diff options
Diffstat (limited to 'ide')
108 files changed, 19518 insertions, 0 deletions
diff --git a/ide/.merlin.in b/ide/.merlin.in new file mode 100644 index 0000000000..4dc6f45550 --- /dev/null +++ b/ide/.merlin.in @@ -0,0 +1,8 @@ +PKG unix laglgtk2 lablgtk2.sourceview2 + +S utils +B utils +S protocol +B protocol + +REC diff --git a/ide/FAQ b/ide/FAQ new file mode 100644 index 0000000000..c8b0a5d328 --- /dev/null +++ b/ide/FAQ @@ -0,0 +1,54 @@ + CoqIde FAQ + +Q0) What is CoqIde? +R0: A powerful graphical interface for Coq. See http://coq.inria.fr. for more informations. + +Q1) How to enable Emacs keybindings? +R1: Insert + gtk-key-theme-name = "Emacs" +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. + If some of your fonts are not available, set GDK_USE_XFT to 0. + +Q4) How to use those Forall and Exists pretty symbols? +R4) Thanks to the Notation features in Coq, you just need to insert these + lines in your Coq Buffer : +====================================================================== +Notation "∀ x : t, P" := (forall x:t, P) (at level 200, x ident). +Notation "∃ x : t, P" := (exists x:t, P) (at level 200, x ident). +====================================================================== +Copy/Paste of these lines from this file will not work outside of CoqIde. +You need to load a file containing these lines or to enter the "∀" +using an input method (see Q5). To try it just use "Require utf8" from inside +CoqIde. +To enable these notations automatically start coqide with + coqide -l utf8 +In the ide subdir of Coq library, you will find a sample utf8.v with some +pretty simple notations. + +Q5) How to define an input method for non ASCII symbols? +R5)-First solution : type "<CONTROL><SHIFT>2200" to enter a forall in the script widow. + 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 : 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 + - 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. + Keep it as UTF-8 until it becomes important for you to exchange files + with non UTF-8 aware applications. + If you choose something else than UTF-8, then missing characters will + be encoded by \x{....} or \x{........} where each dot is an hex. digit. + The number between braces is the hexadecimal UNICODE index for the + missing character. + diff --git a/ide/MacOS/Info.plist.template b/ide/MacOS/Info.plist.template new file mode 100644 index 0000000000..fbe7773dd4 --- /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-2016, 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 Binary files differnew file mode 100644 index 0000000000..107e70431d --- /dev/null +++ b/ide/MacOS/coqfile.icns diff --git a/ide/MacOS/coqide.icns b/ide/MacOS/coqide.icns Binary files differnew file mode 100644 index 0000000000..92bdfe773f --- /dev/null +++ b/ide/MacOS/coqide.icns diff --git a/ide/MacOS/default_accel_map b/ide/MacOS/default_accel_map new file mode 100644 index 0000000000..54a592a04d --- /dev/null +++ b/ide/MacOS/default_accel_map @@ -0,0 +1,376 @@ +; coqide GtkAccelMap rc-file -*- scheme -*- +; this file is an automated accelerator map dump +; +; (gtk_accel_path "<Actions>/Templates/Template Read Module" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic pattern" "") +(gtk_accel_path "<Actions>/Templates/Definition" "<Shift><Primary>d") +; (gtk_accel_path "<Actions>/Templates/Template Program Lemma" "") +(gtk_accel_path "<Actions>/Templates/Lemma" "<Shift><Primary>l") +; (gtk_accel_path "<Actions>/Templates/Template Fact" "") +(gtk_accel_path "<Actions>/Tactics/auto" "<Primary><Control>a") +; (gtk_accel_path "<Actions>/Tactics/Tactic fold" "") +; (gtk_accel_path "<Actions>/Help/About Coq" "") +; (gtk_accel_path "<Actions>/Templates/Template Add Ring A Aplus Amult Aone Azero Ainv Aeq T [ c1 ... cn ]. " "") +; (gtk_accel_path "<Actions>/Templates/Template Hypothesis" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic repeat" "") +; (gtk_accel_path "<Actions>/Templates/Template Unset Extraction Optimize" "") +; (gtk_accel_path "<Actions>/Templates/Template Add Printing Constructor" "") +; (gtk_accel_path "<Actions>/Windows/Detach View" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic inversion" "") +; (gtk_accel_path "<Actions>/Templates/Template Write State" "") +; (gtk_accel_path "<Actions>/Export/Export to" "") +(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/Copy" "<Primary>c") +; (gtk_accel_path "<Actions>/Tactics/Tactic inversion -- using" "") +; (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" "") +; (gtk_accel_path "<Actions>/Templates/Template Coercion" "") +; (gtk_accel_path "<Actions>/Templates/Template CoFixpoint" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic intros until" "") +; (gtk_accel_path "<Actions>/Templates/Template Derive Dependent Inversion" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic eapply" "") +; (gtk_accel_path "<Actions>/View/View" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic change" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic firstorder using" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic decompose sum" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic cut" "") +; (gtk_accel_path "<Actions>/Templates/Template Remove Printing Let" "") +; (gtk_accel_path "<Actions>/Templates/Template Structure" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic compute in" "") +; (gtk_accel_path "<Actions>/Queries/Locate" "") +; (gtk_accel_path "<Actions>/Templates/Template Save." "") +; (gtk_accel_path "<Actions>/Templates/Template Canonical Structure" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic compare" "") +; (gtk_accel_path "<Actions>/Templates/Template Next Obligation" "") +(gtk_accel_path "<Actions>/View/Display notations" "<Shift><Control>n") +; (gtk_accel_path "<Actions>/Tactics/Tactic fail" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic left" "") +(gtk_accel_path "<Actions>/Edit/Undo" "<Primary>u") +(gtk_accel_path "<Actions>/Tactics/eauto with *" "<Primary><Control>ampersand") +; (gtk_accel_path "<Actions>/Templates/Template Infix" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic functional induction" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic clear" "") +; (gtk_accel_path "<Actions>/Templates/Template End Silent." "") +; (gtk_accel_path "<Actions>/Tactics/Tactic intros" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic constructor -- with" "") +; (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 Extract Constant" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic assert (--:--)" "") +; (gtk_accel_path "<Actions>/Templates/Template Add Rec LoadPath" "") +; (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 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 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 Set Hyps--limit" "") +; (gtk_accel_path "<Actions>/Templates/Template Global Variable" "") +; (gtk_accel_path "<Actions>/Templates/Template Remove Printing Constructor" "") +; (gtk_accel_path "<Actions>/Templates/Template Add Setoid" "") +; (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 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" "<Control>Escape") +; (gtk_accel_path "<Actions>/Tactics/Tactic cbv" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic inversion--clear -- in" "") +; (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>/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>/Tactics/Tactic d" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic u" "") +; (gtk_accel_path "<Actions>/Templates/Templates" "") +; (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 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") +; (gtk_accel_path "<Actions>/Tactics/Tactic omega" "") +; (gtk_accel_path "<Actions>/File/New" "<Primary>n") +; (gtk_accel_path "<Actions>/Tactics/Tactic l" "") +; (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>/Templates/Template Definition" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic g" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic f" "") +; (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" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic a" "") +; (gtk_accel_path "<Actions>/Templates/Template Mutual Inductive" "") +; (gtk_accel_path "<Actions>/Templates/Template Extraction NoInline" "") +(gtk_accel_path "<Actions>/Templates/Theorem" "<Shift><Primary>t") +; (gtk_accel_path "<Actions>/Templates/Template Derive Dependent Inversion--clear" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic unfold" "") +; (gtk_accel_path "<Actions>/Tactics/Try Tactics" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic red in" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic rewrite <- -- in" "") +; (gtk_accel_path "<Actions>/Templates/Template Hint Extern" "") +; (gtk_accel_path "<Actions>/Templates/Template Unfocus" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic dependent inversion--clear" "") +; (gtk_accel_path "<Actions>/Help/Browse Coq Library" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic lazy" "") +; (gtk_accel_path "<Actions>/Templates/Template Scheme" "") +(gtk_accel_path "<Actions>/Tactics/tauto" "<Primary><Control>p") +; (gtk_accel_path "<Actions>/Tactics/Tactic cutrewrite" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic contradiction" "") +; (gtk_accel_path "<Actions>/Templates/Template Set Printing Wildcard" "") +; (gtk_accel_path "<Actions>/Templates/Template Add LoadPath" "") +(gtk_accel_path "<Actions>/Navigation/Previous" "<Primary><Control>less") +; (gtk_accel_path "<Actions>/Templates/Template Require" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic simpl" "") +; (gtk_accel_path "<Actions>/Templates/Template Require Import" "") +; (gtk_accel_path "<Actions>/Templates/Template Add Abstract Semi Ring A Aplus Amult Aone Azero Aeq T." "") +(gtk_accel_path "<Actions>/Navigation/Forward" "<Primary><Control>Down") +; (gtk_accel_path "<Actions>/Tactics/Tactic rename -- into" "") +; (gtk_accel_path "<Actions>/Compile/Compile" "") +; (gtk_accel_path "<Actions>/File/Save all" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic fix" "") +; (gtk_accel_path "<Actions>/Templates/Template Parameter" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic assert" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic do" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic ring" "") +; (gtk_accel_path "<Actions>/Export/Pdf" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic quote" "") +; (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>/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") +; (gtk_accel_path "<Actions>/Templates/Template Hint Resolve" "") +; (gtk_accel_path "<Actions>/Templates/Template Set Extraction Optimize" "") +; (gtk_accel_path "<Actions>/File/Revert all buffers" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic subst" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic autorewrite" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic pose" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic simplify--eq" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic clearbody" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic eauto" "") +; (gtk_accel_path "<Actions>/Templates/Template Grammar" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic exact" "") +; (gtk_accel_path "<Actions>/Templates/Template Unset Implicit Arguments" "") +; (gtk_accel_path "<Actions>/Templates/Template Extract Inductive" "") +(gtk_accel_path "<Actions>/View/Display implicit arguments" "<Shift><Control>i") +; (gtk_accel_path "<Actions>/Tactics/Tactic symmetry" "") +; (gtk_accel_path "<Actions>/Templates/Template Add Printing Let" "") +; (gtk_accel_path "<Actions>/Help/Help for keyword" "<Primary>h") +; (gtk_accel_path "<Actions>/File/Save" "<Primary>s") +; (gtk_accel_path "<Actions>/Compile/Make makefile" "") +; (gtk_accel_path "<Actions>/Templates/Template Remove LoadPath" "") +(gtk_accel_path "<Actions>/Navigation/Interrupt" "<Primary><Control>Break") +(gtk_accel_path "<Actions>/Navigation/End" "<Primary><Control>End") +; (gtk_accel_path "<Actions>/Templates/Template Add Morphism" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic field" "") +; (gtk_accel_path "<Actions>/Templates/Template Axiom" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic solve" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic casetype" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic cbv in" "") +; (gtk_accel_path "<Actions>/Templates/Template Load" "") +; (gtk_accel_path "<Actions>/Templates/Template Goal" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic exists" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic decompose record" "") +(gtk_accel_path "<Actions>/Navigation/Go to" "<Primary><Control>Right") +; (gtk_accel_path "<Actions>/Templates/Template Remark" "") +; (gtk_accel_path "<Actions>/Templates/Template Set Undo" "") +; (gtk_accel_path "<Actions>/Templates/Template Inductive" "") +(gtk_accel_path "<Actions>/Edit/Preferences" "<Primary>VoidSymbol") +; (gtk_accel_path "<Actions>/Export/Html" "") +; (gtk_accel_path "<Actions>/Templates/Template Extraction Inline" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic absurd" "") +(gtk_accel_path "<Actions>/Tactics/intuition" "<Primary><Control>i") +; (gtk_accel_path "<Actions>/Tactics/Tactic simple induction" "") +; (gtk_accel_path "<Actions>/Queries/Queries" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic rewrite -- in" "") +; (gtk_accel_path "<Actions>/Templates/Template Hint Rewrite" "") +; (gtk_accel_path "<Actions>/Templates/Template Add Semi Ring A Aplus Amult Aone Azero Aeq T [ c1 ... cn ]." "") +; (gtk_accel_path "<Actions>/Navigation/Navigation" "") +; (gtk_accel_path "<Actions>/Help/Browse Coq Manual" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic transitivity" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic auto" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic dependent inversion -- with" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic assumption" "") +; (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>/Tactics/Tactic constructor" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic elim -- with" "") +; (gtk_accel_path "<Actions>/Templates/Template Identity Coercion" "") +(gtk_accel_path "<Actions>/View/Display all low-level contents" "<Shift><Control>l") +; (gtk_accel_path "<Actions>/Tactics/Tactic right" "") +; (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>/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" "") +(gtk_accel_path "<Actions>/File/Print..." "<Primary>p") +; (gtk_accel_path "<Actions>/Templates/Template Record" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic info" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic firstorder with" "") +; (gtk_accel_path "<Actions>/Templates/Template Hint Unfold" "") +; (gtk_accel_path "<Actions>/Templates/Template Set Silent." "") +; (gtk_accel_path "<Actions>/Templates/Template Program Theorem" "") +; (gtk_accel_path "<Actions>/Templates/Template Declare ML Module" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic lazy in" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic unfold -- in" "") +; (gtk_accel_path "<Actions>/Edit/Paste" "<Primary>v") +; (gtk_accel_path "<Actions>/Templates/Template Remove Printing If" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic intuition" "") +; (gtk_accel_path "<Actions>/Queries/SearchAbout" "F2") +; (gtk_accel_path "<Actions>/Tactics/Tactic dependent rewrite ->" "") +; (gtk_accel_path "<Actions>/Templates/Template Module" "") +; (gtk_accel_path "<Actions>/Templates/Template Unset Extraction AutoInline" "") +(gtk_accel_path "<Actions>/Templates/Scheme" "<Shift><Primary>s") +; (gtk_accel_path "<Actions>/Templates/Template V" "") +; (gtk_accel_path "<Actions>/Templates/Template Variable" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic decide equality" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic instantiate (--:=--)" "") +; (gtk_accel_path "<Actions>/Templates/Template Syntactic Definition" "") +; (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>/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") +; (gtk_accel_path "<Actions>/Tactics/Tactic split" "") +; (gtk_accel_path "<Actions>/File/Quit" "<Primary>q") +(gtk_accel_path "<Actions>/View/Display existential variable instances" "<Shift><Control>e") +(gtk_accel_path "<Actions>/Navigation/Start" "<Primary><Control>Home") +; (gtk_accel_path "<Actions>/Tactics/Tactic dependent rewrite <-" "") +; (gtk_accel_path "<Actions>/Templates/Template U" "") +; (gtk_accel_path "<Actions>/Templates/Template Variables" "") +; (gtk_accel_path "<Actions>/Templates/Template S" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic move -- after" "") +; (gtk_accel_path "<Actions>/Templates/Template Unset Silent." "") +; (gtk_accel_path "<Actions>/Templates/Template Local" "") +; (gtk_accel_path "<Actions>/Templates/Template T" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic reflexivity" "") +; (gtk_accel_path "<Actions>/Templates/Template R" "") +; (gtk_accel_path "<Actions>/Templates/Template Time" "") +; (gtk_accel_path "<Actions>/Templates/Template P" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic decompose" "") +; (gtk_accel_path "<Actions>/Templates/Template N" "") +; (gtk_accel_path "<Actions>/Templates/Template Eval" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic congruence" "") +; (gtk_accel_path "<Actions>/Templates/Template O" "") +; (gtk_accel_path "<Actions>/Templates/Template E" "") +; (gtk_accel_path "<Actions>/Templates/Template I" "") +; (gtk_accel_path "<Actions>/Templates/Template H" "") +; (gtk_accel_path "<Actions>/Templates/Template Extraction Language" "") +; (gtk_accel_path "<Actions>/Templates/Template M" "") +; (gtk_accel_path "<Actions>/Templates/Template Derive Inversion" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic double induction" "") +; (gtk_accel_path "<Actions>/Templates/Template L" "") +; (gtk_accel_path "<Actions>/Templates/Template Derive Inversion--clear" "") +(gtk_accel_path "<Actions>/View/Display universe levels" "<Shift><Control>u") +; (gtk_accel_path "<Actions>/Templates/Template G" "") +; (gtk_accel_path "<Actions>/Templates/Template F" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic dependent inversion--clear -- with" "") +; (gtk_accel_path "<Actions>/Templates/Template D" "") +; (gtk_accel_path "<Actions>/Edit/Edit" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic firstorder" "") +; (gtk_accel_path "<Actions>/Templates/Template C" "") +(gtk_accel_path "<Actions>/Tactics/simpl" "<Primary><Control>s") +; (gtk_accel_path "<Actions>/Tactics/Tactic replace -- with" "") +; (gtk_accel_path "<Actions>/Templates/Template A" "") +; (gtk_accel_path "<Actions>/Templates/Template Remove Printing Record" "") +; (gtk_accel_path "<Actions>/Templates/Template Qed." "") +; (gtk_accel_path "<Actions>/Templates/Template Program Fixpoint" "") +(gtk_accel_path "<Actions>/View/Display coercions" "<Shift><Control>c") +; (gtk_accel_path "<Actions>/Tactics/Tactic hnf" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic injection" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic rewrite" "") +; (gtk_accel_path "<Actions>/Templates/Template Opaque" "") +; (gtk_accel_path "<Actions>/Templates/Template Focus" "") +; (gtk_accel_path "<Actions>/Templates/Template Ltac" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic simple destruct" "") +(gtk_accel_path "<Actions>/View/Display all basic low-level contents" "<Shift><Control>a") +; (gtk_accel_path "<Actions>/Tactics/Tactic jp <n>" "") +; (gtk_accel_path "<Actions>/Templates/Template Test Printing Synth" "") +; (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>/Tactics/Tactic try" "") +; (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" "<Shift>Right") +; (gtk_accel_path "<Actions>/File/File" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic setoid--replace" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic generalize dependent" "") +(gtk_accel_path "<Actions>/Tactics/trivial" "<Primary><Control>v") +; (gtk_accel_path "<Actions>/Tactics/Tactic fix -- with" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic pose --:=--)" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic auto with" "") +; (gtk_accel_path "<Actions>/Templates/Template Add Printing Record" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic inversion -- in" "") +(gtk_accel_path "<Actions>/Tactics/eauto" "<Primary><Control>e") +; (gtk_accel_path "<Actions>/File/Open" "<Primary>o") +; (gtk_accel_path "<Actions>/Tactics/Tactic elim -- using" "") +; (gtk_accel_path "<Actions>/Templates/Template Hint" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic tauto" "") +; (gtk_accel_path "<Actions>/Export/Dvi" "") +; (gtk_accel_path "<Actions>/Tactics/Tactic simpl -- in" "") +; (gtk_accel_path "<Actions>/Templates/Template Hint Immediate" "") diff --git a/ide/Make b/ide/Make new file mode 100644 index 0000000000..c0881ca392 --- /dev/null +++ b/ide/Make @@ -0,0 +1,6 @@ +interface.mli +xmlprotocol.mli +xmlprotocol.ml +ide_slave.ml + +coqidetop.mllib diff --git a/ide/config_lexer.mli b/ide/config_lexer.mli new file mode 100644 index 0000000000..4719612cda --- /dev/null +++ b/ide/config_lexer.mli @@ -0,0 +1,12 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val print_file : string -> string list Util.String.Map.t -> unit +val load_file : string -> string list Util.String.Map.t diff --git a/ide/config_lexer.mll b/ide/config_lexer.mll new file mode 100644 index 0000000000..55d8d96980 --- /dev/null +++ b/ide/config_lexer.mll @@ -0,0 +1,68 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +{ + + open Lexing + open Format + + let string_buffer = Buffer.create 1024 + +} + +let space = [' ' '\010' '\013' '\009' '\012'] +let char = ['A'-'Z' 'a'-'z' '_' '0'-'9'] +let ident = (char | '.')+ +let ignore = space | ('#' [^ '\n']*) + +rule prefs m = parse + |ignore* (ident as id) ignore* '=' { let conf = str_list [] lexbuf in + 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 } + | eof { m } + +and str_list l = parse + | ignore* '"' { Buffer.reset string_buffer; + Buffer.add_char string_buffer '"'; + string lexbuf; + let s = Buffer.contents string_buffer in + str_list ((Scanf.sscanf s "%S" (fun s -> s))::l) lexbuf } + |ignore+ { List.rev l} + +and string = parse + | '"' { Buffer.add_char string_buffer '"' } + | '\\' '"' | _ + { Buffer.add_string string_buffer (lexeme lexbuf); string lexbuf } + | eof { eprintf "coqiderc: unterminated string\n@." } + +{ + + let load_file f = + let c = open_in f in + let lb = from_channel c in + let m = prefs Util.String.Map.empty lb in + close_in c; + m + + let print_file f m = + let c = open_out f in + let fmt = formatter_of_out_channel c in + let rec print_list fmt = function + | [] -> () + | s :: sl -> fprintf fmt "%S@ %a" s print_list sl + in + 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/configwin.ml b/ide/configwin.ml new file mode 100644 index 0000000000..79a1eae880 --- /dev/null +++ b/ide/configwin.ml @@ -0,0 +1,53 @@ +(*********************************************************************************) +(* Cameleon *) +(* *) +(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. *) +(* *) +(* This program is free software; you can redistribute it and/or modify *) +(* it under the terms of the GNU Library General Public License as *) +(* published by the Free Software Foundation; either version 2 of the *) +(* License, or any later version. *) +(* *) +(* This program is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU Library General Public License for more details. *) +(* *) +(* You should have received a copy of the GNU Library General Public *) +(* License along with this program; if not, write to the Free Software *) +(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) +(* 02111-1307 USA *) +(* *) +(* Contact: Maxence.Guesdon@inria.fr *) +(* *) +(*********************************************************************************) + +type parameter_kind = Configwin_types.parameter_kind + +type configuration_structure = + Configwin_types.configuration_structure = + Section of string * GtkStock.id option * parameter_kind list + | Section_list of string * GtkStock.id option * configuration_structure list + +type return_button = + Configwin_types.return_button = + Return_apply + | Return_ok + | Return_cancel + +let string = Configwin_ihm.string +(* +let strings = Configwin_ihm.strings +let list = Configwin_ihm.list +*) +let bool = Configwin_ihm.bool +let combo = Configwin_ihm.combo +let custom = Configwin_ihm.custom +let modifiers = Configwin_ihm.modifiers + +let edit + ?(apply=(fun () -> ())) + title ?parent ?width ?height + conf_struct_list = + Configwin_ihm.edit ~with_apply: true ~apply title ?parent ?width ?height conf_struct_list diff --git a/ide/configwin.mli b/ide/configwin.mli new file mode 100644 index 0000000000..fa22846d19 --- /dev/null +++ b/ide/configwin.mli @@ -0,0 +1,167 @@ +(*********************************************************************************) +(* Cameleon *) +(* *) +(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. *) +(* *) +(* This program is free software; you can redistribute it and/or modify *) +(* it under the terms of the GNU Library General Public License as *) +(* published by the Free Software Foundation; either version 2 of the *) +(* License, or any later version. *) +(* *) +(* This program is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU Library General Public License for more details. *) +(* *) +(* You should have received a copy of the GNU Library General Public *) +(* License along with this program; if not, write to the Free Software *) +(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) +(* 02111-1307 USA *) +(* *) +(* Contact: Maxence.Guesdon@inria.fr *) +(* *) +(*********************************************************************************) + +(** This module is the interface of the Configwin library. *) + +(** {2 Types} *) + +(** This type represents the different kinds of parameters. *) +type parameter_kind;; + +(** This type represents the structure of the configuration window. *) +type configuration_structure = + | Section of string * GtkStock.id option * parameter_kind list + (** label of the section, icon, parameters *) + | Section_list of string * GtkStock.id option * configuration_structure list + (** label of the section, icon, list of the sub sections *) +;; + +(** To indicate what button pushed the user when the window is closed. *) +type return_button = + Return_apply + (** The user clicked on Apply at least once before + closing the window with Cancel or the window manager. *) + | Return_ok + (** The user closed the window with the ok button. *) + | Return_cancel + (** The user closed the window with the cancel + button or the window manager but never clicked + on the apply button.*) + +(** {2 Functions to create parameters} *) + +(** [string label value] creates a string parameter. + @param editable indicate if the value is editable (default is [true]). + @param expand indicate if the entry widget must expand or not (default is [true]). + @param help an optional help message. + @param f the function called to apply the value (default function does nothing). +*) +val string : ?editable: bool -> ?expand: bool -> ?help: string -> + ?f: (string -> unit) -> string -> string -> parameter_kind + +(** [bool label value] creates a boolean parameter. + @param editable indicate if the value is editable (default is [true]). + @param help an optional help message. + @param f the function called to apply the value (default function does nothing). +*) +val bool : ?editable: bool -> ?help: string -> + ?f: (bool -> unit) -> string -> bool -> parameter_kind + +(* +(** [strings label value] creates a string list parameter. + @param editable indicate if the value is editable (default is [true]). + @param help an optional help message. + @param f the function called to apply the value (default function does nothing). + @param add the function returning a list of strings when the user wants to add strings + (default returns an empty list). + @param eq the comparison function, used not to have doubles in list. Default + is [Pervasives.(=)]. If you want to allow doubles in the list, give a function + always returning false. +*) +val strings : ?editable: bool -> ?help: string -> + ?f: (string list -> unit) -> + ?eq: (string -> string -> bool) -> + ?add: (unit -> string list) -> + string -> string list -> parameter_kind + +(** [list label f_strings value] creates a list parameter. + [f_strings] is a function taking a value and returning a list + of strings to display it. The list length should be the same for + any value, and the same as the titles list length. The [value] + is the initial list. + @param editable indicate if the value is editable (default is [true]). + @param help an optional help message. + @param f the function called to apply the value (default function does nothing). + @param eq the comparison function, used not to have doubles in list. Default + is [Pervasives.(=)]. If you want to allow doubles in the list, give a function + always returning false. + @param edit an optional function to use to edit an element of the list. + The function returns an element, no matter if element was changed or not. + When this function is given, a "Edit" button appears next to the list. + @param add the function returning a list of values when the user wants to add values + (default returns an empty list). + @param titles an optional list of titles for the list. If the [f_strings] + function returns a list with more than one element, then you must give + a list of titles. + @param color an optional function returning the optional color for a given element. + This color is used to display the element in the list. The default function returns + no color for any element. +*) +val list : ?editable: bool -> ?help: string -> + ?f: ('a list -> unit) -> + ?eq: ('a -> 'a -> bool) -> + ?edit: ('a -> 'a) -> + ?add: (unit -> 'a list) -> + ?titles: string list -> + ?color: ('a -> string option) -> + string -> + ('a -> string list) -> + 'a list -> + parameter_kind +*) + +(** [combo label choices value] creates a combo parameter. + @param editable indicate if the value is editable (default is [true]). + @param expand indicate if the entry widget must expand or not (default is [true]). + @param help an optional help message. + @param f the function called to apply the value (default function does nothing). + @param new_allowed indicate if a entry not in the list of choices is accepted + (default is [false]). + @param blank_allowed indicate if the empty selection [""] is accepted + (default is [false]). +*) +val combo : ?editable: bool -> ?expand: bool -> ?help: string -> + ?f: (string -> unit) -> + ?new_allowed: bool -> ?blank_allowed: bool -> + string -> string list -> string -> parameter_kind + +val modifiers : ?editable: bool -> ?expand: bool -> ?help: string -> + ?allow:(Gdk.Tags.modifier list) -> + ?f: (Gdk.Tags.modifier list -> unit) -> + string -> Gdk.Tags.modifier list -> parameter_kind + +(** [custom box f expand] creates a custom parameter, with + the given [box], the [f] function is called when the user + wants to apply his changes, and [expand] indicates if the box + must expand in its father. + @param label if a value is specified, a the box is packed into a frame. +*) +val custom : ?label: string -> GPack.box -> (unit -> unit) -> bool -> parameter_kind + +(** {2 Functions creating configuration windows and boxes} *) + +(** This function takes a configuration structure and creates a window + to configure the various parameters. + @param apply this function is called when the apply button is clicked, after + giving new values to parameters. +*) +val edit : + ?apply: (unit -> unit) -> + string -> + ?parent:GWindow.window -> + ?width:int -> + ?height:int -> + configuration_structure list -> + return_button diff --git a/ide/configwin_ihm.ml b/ide/configwin_ihm.ml new file mode 100644 index 0000000000..0f3fd38a7a --- /dev/null +++ b/ide/configwin_ihm.ml @@ -0,0 +1,834 @@ +(*********************************************************************************) +(* Cameleon *) +(* *) +(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. *) +(* *) +(* This program is free software; you can redistribute it and/or modify *) +(* it under the terms of the GNU Library General Public License as *) +(* published by the Free Software Foundation; either version 2 of the *) +(* License, or any later version. *) +(* *) +(* This program is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU Library General Public License for more details. *) +(* *) +(* You should have received a copy of the GNU Library General Public *) +(* License along with this program; if not, write to the Free Software *) +(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) +(* 02111-1307 USA *) +(* *) +(* Contact: Maxence.Guesdon@inria.fr *) +(* *) +(*********************************************************************************) + +(** This module contains the gui functions of Configwin.*) + +open Configwin_types + +let set_help_tip wev = function + | None -> () + | Some help -> GtkBase.Widget.Tooltip.set_text wev#as_widget help + +let modifiers_to_string m = + let rec iter m s = + match m with + [] -> s + | c :: m -> + iter m (( + match c with + `CONTROL -> "<ctrl>" + | `SHIFT -> "<shft>" + | `LOCK -> "<lock>" + | `MOD1 -> "<alt>" + | `MOD2 -> "<mod2>" + | `MOD3 -> "<mod3>" + | `MOD4 -> "<mod4>" + | `MOD5 -> "<mod5>" + | _ -> raise Not_found + ) ^ s) + in + iter m "" + +class type widget = + object + method box : GObj.widget + method apply : unit -> unit + end + +let debug = false +let dbg s = if debug then Minilib.log s else () +(* +(** This class builds a frame with a clist and two buttons : + one to add items and one to remove the selected items. + The class takes in parameter a function used to add items and + a string list ref which is used to store the content of the clist. + At last, a title for the frame is also in parameter, so that + each instance of the class creates a frame. *) +class ['a] list_selection_box + (listref : 'a list ref) + titles_opt + help_opt + f_edit_opt + f_strings + f_color + (eq : 'a -> 'a -> bool) + add_function title editable + = + let _ = dbg "list_selection_box" in + let wev = GBin.event_box () in + let wf = GBin.frame ~label: title ~packing: wev#add () in + let hbox = GPack.hbox ~packing: wf#add () in + (* the scroll window and the clist *) + let wscroll = GBin.scrolled_window + ~vpolicy: `AUTOMATIC + ~hpolicy: `AUTOMATIC + ~packing: (hbox#pack ~expand: true) () + in + let wlist = match titles_opt with + None -> + GList.clist ~selection_mode: `MULTIPLE + ~titles_show: false + ~packing: wscroll#add () + | Some l -> + GList.clist ~selection_mode: `MULTIPLE + ~titles: l + ~titles_show: true + ~packing: wscroll#add () + in + let _ = set_help_tip wev help_opt in + (* the vbox for the buttons *) + let vbox_buttons = GPack.vbox () in + let _ = + if editable then + let _ = hbox#pack ~expand: false vbox_buttons#coerce in + () + else + () + in + let _ = dbg "list_selection_box: wb_add" in + let wb_add = GButton.button + ~label: Configwin_messages.mAdd + ~packing: (vbox_buttons#pack ~expand:false ~padding:2) + () + in + let wb_edit = GButton.button + ~label: Configwin_messages.mEdit + () + in + let _ = match f_edit_opt with + None -> () + | Some _ -> vbox_buttons#pack ~expand:false ~padding:2 wb_edit#coerce + in + let wb_up = GButton.button + ~label: Configwin_messages.mUp + ~packing: (vbox_buttons#pack ~expand:false ~padding:2) + () + in + let wb_remove = GButton.button + ~label: Configwin_messages.mRemove + ~packing: (vbox_buttons#pack ~expand:false ~padding:2) + () + in + let _ = dbg "list_selection_box: object(self)" in + object (self) + (** the list of selected rows *) + val mutable list_select = [] + + (** This method returns the frame created. *) + method box = wev + + method update l = + (* set the new list in the provided listref *) + listref := l; + (* insert the elements in the clist *) + wlist#freeze (); + wlist#clear (); + List.iter + (fun ele -> + ignore (wlist#append (f_strings ele)); + match f_color ele with + None -> () + | Some c -> + try wlist#set_row ~foreground: (`NAME c) (wlist#rows - 1) + with _ -> () + ) + !listref; + + (match titles_opt with + None -> wlist#columns_autosize () + | Some _ -> GToolbox.autosize_clist wlist); + wlist#thaw (); + (* the list of selectd elements is now empty *) + list_select <- [] + + (** Move up the selected rows. *) + method up_selected = + let rec iter n selrows l = + match selrows with + [] -> (l, []) + | m :: qrows -> + match l with + [] -> ([],[]) + | [_] -> (l,[]) + | e1 :: e2 :: q when m = n + 1 -> + let newl, newrows = iter (n+1) qrows (e1 :: q) in + (e2 :: newl, n :: newrows) + | e1 :: q -> + let newl, newrows = iter (n+1) selrows q in + (e1 :: newl, newrows) + in + let sorted_select = List.sort compare list_select in + let new_list, new_rows = iter 0 sorted_select !listref in + self#update new_list; + List.iter (fun n -> wlist#select n 0) new_rows + + (** Make the user edit the first selected row. *) + method edit_selected f_edit = + let sorted_select = List.sort compare list_select in + match sorted_select with + [] -> () + | n :: _ -> + try + let ele = List.nth !listref n in + let ele2 = f_edit ele in + let rec iter m = function + [] -> [] + | e :: q -> + if n = m then + ele2 :: q + else + e :: (iter (m+1) q) + in + self#update (iter 0 !listref); + wlist#select n 0 + with + Not_found -> + () + + initializer + + (* create the functions called when the buttons are clicked *) + let f_add () = + (* get the files to add with the function provided *) + let l = add_function () in + (* remove from the list the ones which are already in + the listref, using the eq predicate *) + let l2 = List.fold_left + (fun acc -> fun ele -> + if List.exists (eq ele) acc then + acc + else + acc @ [ele]) + !listref + l + in + self#update l2 + in + let f_remove () = + (* remove the selected items from the listref and the clist *) + let rec iter n = function + [] -> [] + | h :: q -> + if List.mem n list_select then + iter (n+1) q + else + h :: (iter (n+1) q) + in + let new_list = iter 0 !listref in + self#update new_list + in + let _ = dbg "list_selection_box: connecting wb_add" in + (* connect the functions to the buttons *) + ignore (wb_add#connect#clicked ~callback:f_add); + let _ = dbg "list_selection_box: connecting wb_remove" in + ignore (wb_remove#connect#clicked ~callback:f_remove); + let _ = dbg "list_selection_box: connecting wb_up" in + ignore (wb_up#connect#clicked ~callback:(fun () -> self#up_selected)); + ( + match f_edit_opt with + None -> () + | Some f -> + let _ = dbg "list_selection_box: connecting wb_edit" in + ignore (wb_edit#connect#clicked ~callback:(fun () -> self#edit_selected f)) + ); + (* connect the selection and deselection of items in the clist *) + let f_select ~row ~column ~event = + try + list_select <- row :: list_select + with + Failure _ -> + () + in + let f_unselect ~row ~column ~event = + try + let new_list_select = List.filter (fun n -> n <> row) list_select in + list_select <- new_list_select + with + Failure _ -> + () + in + (* connect the select and deselect events *) + let _ = dbg "list_selection_box: connecting select_row" in + ignore(wlist#connect#select_row ~callback:f_select); + let _ = dbg "list_selection_box: connecting unselect_row" in + ignore(wlist#connect#unselect_row ~callback:f_unselect); + + (* initialize the clist with the listref *) + self#update !listref + end;; +*) + +(** This class is used to build a box for a string parameter.*) +class string_param_box param = + let _ = dbg "string_param_box" in + let hbox = GPack.hbox () in + let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in + let _wl = GMisc.label ~text: param.string_label ~packing: wev#add () in + let we = GEdit.entry + ~editable: param.string_editable + ~packing: (hbox#pack ~expand: param.string_expand ~padding: 2) + () + in + let _ = set_help_tip wev param.string_help in + let _ = we#set_text (param.string_to_string param.string_value) in + + object (self) + + (** This method returns the main box ready to be packed. *) + method box = hbox#coerce + + (** This method applies the new value of the parameter. *) + method apply = + let new_value = param.string_of_string we#text in + if new_value <> param.string_value then + let _ = param.string_f_apply new_value in + param.string_value <- new_value + else + () + end ;; + +(** This class is used to build a box for a combo parameter.*) +class combo_param_box param = + let _ = dbg "combo_param_box" in + let hbox = GPack.hbox () in + let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in + let _wl = GMisc.label ~text: param.combo_label ~packing: wev#add () in + let _ = set_help_tip wev param.combo_help in + let get_value = if not param.combo_new_allowed then + let wc = GEdit.combo_box_text + ~strings: param.combo_choices + ?active:(let rec aux i = function + |[] -> None + |h::_ when h = param.combo_value -> Some i + |_::t -> aux (succ i) t + in aux 0 param.combo_choices) + ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2) + () + in + fun () -> match GEdit.text_combo_get_active wc with |None -> "" |Some s -> s + else + let (wc,_) = GEdit.combo_box_entry_text + ~strings: param.combo_choices + ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2) + () + in + let _ = wc#entry#set_editable param.combo_editable in + let _ = wc#entry#set_text param.combo_value in + fun () -> wc#entry#text + in +object (self) + + (** This method returns the main box ready to be packed. *) + method box = hbox#coerce + + (** This method applies the new value of the parameter. *) + method apply = + let new_value = get_value () in + if new_value <> param.combo_value then + let _ = param.combo_f_apply new_value in + param.combo_value <- new_value + else + () +end ;; + +(** Class used to pack a custom box. *) +class custom_param_box param = + let _ = dbg "custom_param_box" in + let top = + match param.custom_framed with + None -> param.custom_box#coerce + | Some l -> + let wf = GBin.frame ~label: l () in + wf#add param.custom_box#coerce; + wf#coerce + in + object (self) + method box = top + method apply = param.custom_f_apply () + end + +(** This class is used to build a box for a text parameter.*) +class text_param_box param = + let _ = dbg "text_param_box" in + let wf = GBin.frame ~label: param.string_label ~height: 100 () in + let wev = GBin.event_box ~packing: wf#add () in + let wscroll = GBin.scrolled_window + ~vpolicy: `AUTOMATIC + ~hpolicy: `AUTOMATIC + ~packing: wev#add () + in + let wview = GText.view + ~editable: param.string_editable + ~packing: wscroll#add + () + in + let _ = set_help_tip wev param.string_help in + let _ = dbg "text_param_box: buffer creation" in + let buffer = GText.buffer () in + + let _ = wview#set_buffer buffer in + let _ = buffer#insert (param.string_to_string param.string_value) in + let _ = dbg "text_param_box: object(self)" in + object (self) + val wview = wview + + (** This method returns the main box ready to be packed. *) + method box = wf#coerce + + (** This method applies the new value of the parameter. *) + method apply = + let v = param.string_of_string (buffer#get_text ()) in + if v <> param.string_value then + ( + dbg "apply new value!"; + let _ = param.string_f_apply v in + param.string_value <- v + ) + else + () + end ;; + +(** This class is used to build a box for a boolean parameter.*) +class bool_param_box param = + let _ = dbg "bool_param_box" in + let wchk = GButton.check_button + ~label: param.bool_label + () + in + let _ = set_help_tip wchk param.bool_help in + let _ = wchk#set_active param.bool_value in + let _ = wchk#misc#set_sensitive param.bool_editable in + + object (self) + + (** This method returns the check button ready to be packed. *) + method box = wchk#coerce + + (** This method applies the new value of the parameter. *) + method apply = + let new_value = wchk#active in + if new_value <> param.bool_value then + let _ = param.bool_f_apply new_value in + param.bool_value <- new_value + else + () + end ;; + +class modifiers_param_box param = + let hbox = GPack.hbox () in + let wev = GBin.event_box ~packing: (hbox#pack ~expand:true ~fill:true ~padding: 2) () in + let _wl = GMisc.label ~text: param.md_label ~packing: wev#add () in + let value = ref param.md_value in + let _ = List.map (fun modifier -> + let but = GButton.toggle_button + ~label:(modifiers_to_string [modifier]) + ~active:(List.mem modifier param.md_value) + ~packing:(hbox#pack ~expand:false) () in + ignore (but#connect#toggled + ~callback:(fun _ -> if but#active then value := modifier::!value + else value := List.filter ((<>) modifier) !value))) + param.md_allow + in + let _ = set_help_tip wev param.md_help in + object (self) + + (** This method returns the main box ready to be packed. *) + method box = hbox#coerce + + (** This method applies the new value of the parameter. *) + method apply = + let new_value = !value in + if new_value <> param.md_value then + let _ = param.md_f_apply new_value in + param.md_value <- new_value + else + () + end ;; +(* +(** This class is used to build a box for a parameter whose values are a list.*) +class ['a] list_param_box (param : 'a list_param) = + let _ = dbg "list_param_box" in + let listref = ref param.list_value in + let frame_selection = new list_selection_box + listref + param.list_titles + param.list_help + param.list_f_edit + param.list_strings + param.list_color + param.list_eq + param.list_f_add param.list_label param.list_editable + tt + in + + object (self) + + (** This method returns the main box ready to be packed. *) + method box = frame_selection#box#coerce + + (** This method applies the new value of the parameter. *) + method apply = + param.list_f_apply !listref ; + param.list_value <- !listref + end ;; +*) + +(** This class creates a configuration box from a configuration structure *) +class configuration_box conf_struct = + + let main_box = GPack.hbox () in + + let columns = new GTree.column_list in + let icon_col = columns#add GtkStock.conv in + let label_col = columns#add Gobject.Data.string in + let box_col = columns#add Gobject.Data.caml in + let () = columns#lock () in + + let pane = GPack.paned `HORIZONTAL ~packing:main_box#add () in + + (* Tree view part *) + let scroll = GBin.scrolled_window ~hpolicy:`NEVER ~packing:pane#pack1 () in + let tree = GTree.tree_store columns in + let view = GTree.view ~model:tree ~headers_visible:false ~packing:scroll#add_with_viewport () in + let selection = view#selection in + let _ = selection#set_mode `SINGLE in + + let menu_box = GPack.vbox ~packing:pane#pack2 () in + + let renderer = (GTree.cell_renderer_pixbuf [], ["stock-id", icon_col]) in + let col = GTree.view_column ~renderer () in + let _ = view#append_column col in + + let renderer = (GTree.cell_renderer_text [], ["text", label_col]) in + let col = GTree.view_column ~renderer () in + let _ = view#append_column col in + + let make_param (main_box : #GPack.box) = function + | String_param p -> + let box = new string_param_box p in + let _ = main_box#pack ~expand: false ~padding: 2 box#box in + box + | Combo_param p -> + let box = new combo_param_box p in + let _ = main_box#pack ~expand: false ~padding: 2 box#box in + box + | Text_param p -> + let box = new text_param_box p in + let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in + box + | Bool_param p -> + let box = new bool_param_box p in + let _ = main_box#pack ~expand: false ~padding: 2 box#box in + box + | List_param f -> + let box = f () in + let _ = main_box#pack ~expand: true ~padding: 2 box#box in + box + | Custom_param p -> + let box = new custom_param_box p in + let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in + box + | Modifiers_param p -> + let box = new modifiers_param_box p in + let _ = main_box#pack ~expand: false ~padding: 2 box#box in + box + in + + let set_icon iter = function + | None -> () + | Some icon -> tree#set ~row:iter ~column:icon_col icon + in + + (* Populate the tree *) + + let rec make_tree iter conf_struct = + (* box is not shown at first *) + let box = GPack.vbox ~packing:(menu_box#pack ~expand:true) ~show:false () in + let new_iter = match iter with + | None -> tree#append () + | Some parent -> tree#append ~parent () + in + match conf_struct with + | Section (label, icon, param_list) -> + let params = List.map (make_param box) param_list in + let widget = + object + method box = box#coerce + method apply () = List.iter (fun param -> param#apply) params + end + in + let () = tree#set ~row:new_iter ~column:label_col label in + let () = set_icon new_iter icon in + let () = tree#set ~row:new_iter ~column:box_col widget in + () + | Section_list (label, icon, struct_list) -> + let widget = + object + (* Section_list does not contain any effect widget, so we do not have to + apply anything. *) + method apply () = () + method box = box#coerce + end + in + let () = tree#set ~row:new_iter ~column:label_col label in + let () = set_icon new_iter icon in + let () = tree#set ~row:new_iter ~column:box_col widget in + List.iter (make_tree (Some new_iter)) struct_list + in + + let () = List.iter (make_tree None) conf_struct in + + (* Dealing with signals *) + + let current_prop : widget option ref = ref None in + + let select_iter iter = + let () = match !current_prop with + | None -> () + | Some box -> box#box#misc#hide () + in + let box = tree#get ~row:iter ~column:box_col in + let () = box#box#misc#show () in + current_prop := Some box + in + + let when_selected () = + let rows = selection#get_selected_rows in + match rows with + | [] -> () + | row :: _ -> + let iter = tree#get_iter row in + select_iter iter + in + + (* Focus on a box when selected *) + + let _ = selection#connect#changed ~callback:when_selected in + + let _ = match tree#get_iter_first with + | None -> () + | Some iter -> select_iter iter + in + + object + + method box = main_box + + method apply = + let foreach _ iter = + let widget = tree#get ~row:iter ~column:box_col in + widget#apply(); false + in + tree#foreach foreach + + end + +(** This function takes a configuration structure list and creates a window + to configure the various parameters. *) +let edit ?(with_apply=true) + ?(apply=(fun () -> ())) + title ?parent ?width ?height + conf_struct = + let dialog = GWindow.dialog + ~position:`CENTER + ~modal: true ~title: title + ~type_hint:`DIALOG + ?parent ?height ?width + () + in + let config_box = new configuration_box conf_struct in + + let _ = dialog#vbox#pack ~expand:true config_box#box#coerce in + + if with_apply then + dialog#add_button Configwin_messages.mApply `APPLY; + + dialog#add_button Configwin_messages.mOk `OK; + dialog#add_button Configwin_messages.mCancel `CANCEL; + + let destroy () = + dialog#destroy (); + in + let rec iter rep = + try + match dialog#run () with + | `APPLY -> config_box#apply; iter Return_apply + | `OK -> config_box#apply; destroy (); Return_ok + | _ -> destroy (); rep + with + Failure s -> + GToolbox.message_box ~title:"Error" s; iter rep + | e -> + GToolbox.message_box ~title:"Error" (Printexc.to_string e); iter rep + in + iter Return_cancel + +(* +let edit_string l s = + match GToolbox.input_string ~title: l ~text: s Configwin_messages.mValue with + None -> s + | Some s2 -> s2 +*) + +(** Create a string param. *) +let string ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = + String_param + { + string_label = label ; + string_help = help ; + string_value = v ; + string_editable = editable ; + string_f_apply = f ; + string_expand = expand ; + string_to_string = (fun x -> x) ; + string_of_string = (fun x -> x) ; + } + +(** Create a bool param. *) +let bool ?(editable=true) ?help ?(f=(fun _ -> ())) label v = + Bool_param + { + bool_label = label ; + bool_help = help ; + bool_value = v ; + bool_editable = editable ; + bool_f_apply = f ; + } + +(* +(** Create a list param. *) +let list ?(editable=true) ?help + ?(f=(fun (_:'a list) -> ())) + ?(eq=Pervasives.(=)) + ?(edit:('a -> 'a) option) + ?(add=(fun () -> ([] : 'a list))) + ?titles ?(color=(fun (_:'a) -> (None : string option))) + label (f_strings : 'a -> string list) v = + List_param + (fun () -> + new list_param_box + { + list_label = label ; + list_help = help ; + list_value = v ; + list_editable = editable ; + list_titles = titles; + list_eq = eq ; + list_strings = f_strings ; + list_color = color ; + list_f_edit = edit ; + list_f_add = add ; + list_f_apply = f ; + } + ) + +(** Create a strings param. *) +let strings ?(editable=true) ?help + ?(f=(fun _ -> ())) + ?(eq=Pervasives.(=)) + ?(add=(fun () -> [])) label v = + list ~editable ?help ~f ~eq ~edit: (edit_string label) ~add label (fun s -> [s]) v +*) + +(** Create a combo param. *) +let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) + ?(new_allowed=false) + ?(blank_allowed=false) label choices v = + Combo_param + { + combo_label = label ; + combo_help = help ; + combo_value = v ; + combo_editable = editable ; + combo_choices = choices ; + combo_new_allowed = new_allowed ; + combo_blank_allowed = blank_allowed ; + combo_f_apply = f ; + combo_expand = expand ; + } + +let modifiers + ?(editable=true) + ?(expand=true) + ?help + ?(allow=[`CONTROL;`SHIFT;`LOCK;`MOD1;`MOD2;`MOD3;`MOD4;`MOD5]) + ?(f=(fun _ -> ())) label v = + Modifiers_param + { + md_label = label ; + md_help = help ; + md_value = v ; + md_editable = editable ; + md_f_apply = f ; + md_expand = expand ; + md_allow = allow ; + } + +(** Create a custom param.*) +let custom ?label box f expand = + Custom_param + { + custom_box = box ; + custom_f_apply = f ; + custom_expand = expand ; + custom_framed = label ; + } + +(* Copying lablgtk question_box + forbidding hiding *) + +let question_box ~title ~buttons ?(default=1) ?icon ?parent message = + let button_nb = ref 0 in + let window = GWindow.dialog ~position:`CENTER ~modal:true ?parent ~type_hint:`DIALOG ~title () in + let hbox = GPack.hbox ~border_width:10 ~packing:window#vbox#add () in + let bbox = window#action_area in + begin match icon with + None -> () + | Some i -> hbox#pack i#coerce ~padding:4 + end; + ignore (GMisc.label ~text: message ~packing: hbox#add ()); + (* the function called to create each button by iterating *) + let rec iter_buttons n = function + [] -> + () + | button_label :: q -> + let b = GButton.button ~label: button_label + ~packing:(bbox#pack ~expand:true ~padding:4) () + in + ignore (b#connect#clicked ~callback: + (fun () -> button_nb := n; window#destroy ())); + (* If it's the first button then give it the focus *) + if n = default then b#grab_default () else (); + + iter_buttons (n+1) q + in + iter_buttons 1 buttons; + ignore (window#connect#destroy ~callback: GMain.Main.quit); + window#set_position `CENTER; + window#show (); + GMain.Main.main (); + !button_nb + +let message_box ~title ?icon ?parent ?(ok="Ok") message = + ignore (question_box ?icon ?parent ~title message ~buttons:[ ok ]) diff --git a/ide/configwin_ihm.mli b/ide/configwin_ihm.mli new file mode 100644 index 0000000000..ce6cd4d7c1 --- /dev/null +++ b/ide/configwin_ihm.mli @@ -0,0 +1,78 @@ +(*********************************************************************************) +(* Cameleon *) +(* *) +(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. *) +(* *) +(* This program is free software; you can redistribute it and/or modify *) +(* it under the terms of the GNU Library General Public License as *) +(* published by the Free Software Foundation; either version 2 of the *) +(* License, or any later version. *) +(* *) +(* This program is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU Library General Public License for more details. *) +(* *) +(* You should have received a copy of the GNU Library General Public *) +(* License along with this program; if not, write to the Free Software *) +(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) +(* 02111-1307 USA *) +(* *) +(* Contact: Maxence.Guesdon@inria.fr *) +(* *) +(*********************************************************************************) + +open Configwin_types + +val string : ?editable: bool -> ?expand: bool -> ?help: string -> + ?f: (string -> unit) -> string -> string -> parameter_kind +val bool : ?editable: bool -> ?help: string -> + ?f: (bool -> unit) -> string -> bool -> parameter_kind +(* +val strings : ?editable: bool -> ?help: string -> + ?f: (string list -> unit) -> + ?eq: (string -> string -> bool) -> + ?add: (unit -> string list) -> + string -> string list -> parameter_kind +val list : ?editable: bool -> ?help: string -> + ?f: ('a list -> unit) -> + ?eq: ('a -> 'a -> bool) -> + ?edit: ('a -> 'a) -> + ?add: (unit -> 'a list) -> + ?titles: string list -> + ?color: ('a -> string option) -> + string -> + ('a -> string list) -> + 'a list -> + parameter_kind +*) +val combo : ?editable: bool -> ?expand: bool -> ?help: string -> + ?f: (string -> unit) -> + ?new_allowed: bool -> ?blank_allowed: bool -> + string -> string list -> string -> parameter_kind + +val modifiers : ?editable: bool -> ?expand: bool -> ?help: string -> + ?allow:(Gdk.Tags.modifier list) -> + ?f: (Gdk.Tags.modifier list -> unit) -> + string -> Gdk.Tags.modifier list -> parameter_kind +val custom : ?label: string -> GPack.box -> (unit -> unit) -> bool -> parameter_kind + +val edit : + ?with_apply:bool -> + ?apply:(unit -> unit) -> + string -> + ?parent:GWindow.window -> + ?width:int -> + ?height:int -> + configuration_structure list -> + return_button + +val question_box : title:string -> + buttons:string list -> + ?default:int -> ?icon:#GObj.widget -> + ?parent:GWindow.window -> string -> int + +val message_box : + title:string -> ?icon:#GObj.widget -> + ?parent:GWindow.window -> ?ok:string -> string -> unit diff --git a/ide/configwin_messages.ml b/ide/configwin_messages.ml new file mode 100644 index 0000000000..de1b4721d0 --- /dev/null +++ b/ide/configwin_messages.ml @@ -0,0 +1,50 @@ +(*********************************************************************************) +(* Cameleon *) +(* *) +(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. *) +(* *) +(* This program is free software; you can redistribute it and/or modify *) +(* it under the terms of the GNU Library General Public License as *) +(* published by the Free Software Foundation; either version 2 of the *) +(* License, or any later version. *) +(* *) +(* This program is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU Library General Public License for more details. *) +(* *) +(* You should have received a copy of the GNU Library General Public *) +(* License along with this program; if not, write to the Free Software *) +(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) +(* 02111-1307 USA *) +(* *) +(* Contact: Maxence.Guesdon@inria.fr *) +(* *) +(*********************************************************************************) + +(** Module containing the messages of Configwin.*) + +let software = "Configwin";; +let version = "1.2";; + +let html_config = "Configwin bindings configurator for html parameters" + +let home = Option.default "" (Glib.get_home_dir ()) + +let mCapture = "Capture";; +let mType_key = "Type key" ;; +let mAdd = "Add";; +let mRemove = "Remove";; +let mUp = "Up";; +let mEdit = "Edit";; +let mOk = "Ok";; +let mCancel = "Cancel";; +let mApply = "Apply";; +let mValue = "Value" +let mKey = "Key" + +let shortcuts = "Shortcuts" +let html_end = "End with" +let html_begin = "Begin with" + diff --git a/ide/configwin_types.ml b/ide/configwin_types.ml new file mode 100644 index 0000000000..251e3dded3 --- /dev/null +++ b/ide/configwin_types.ml @@ -0,0 +1,121 @@ +(*********************************************************************************) +(* Cameleon *) +(* *) +(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. *) +(* *) +(* This program is free software; you can redistribute it and/or modify *) +(* it under the terms of the GNU Library General Public License as *) +(* published by the Free Software Foundation; either version 2 of the *) +(* License, or any later version. *) +(* *) +(* This program is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU Library General Public License for more details. *) +(* *) +(* You should have received a copy of the GNU Library General Public *) +(* License along with this program; if not, write to the Free Software *) +(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) +(* 02111-1307 USA *) +(* *) +(* Contact: Maxence.Guesdon@inria.fr *) +(* *) +(*********************************************************************************) + +(** This module contains the types used in Configwin. *) + +(** This type represents a string or filename parameter, or + any other type, depending on the given conversion functions. *) +type 'a string_param = { + string_label : string; (** the label of the parameter *) + mutable string_value : 'a; (** the current value of the parameter *) + string_editable : bool ; (** indicates if the value can be changed *) + string_f_apply : ('a -> unit) ; (** the function to call to apply the new value of the parameter *) + string_help : string option ; (** optional help string *) + string_expand : bool ; (** expand or not *) + string_to_string : 'a -> string ; + string_of_string : string -> 'a ; + } ;; + +(** This type represents a boolean parameter. *) +type bool_param = { + bool_label : string; (** the label of the parameter *) + mutable bool_value : bool; (** the current value of the parameter *) + bool_editable : bool ; (** indicates if the value can be changed *) + bool_f_apply : (bool -> unit) ; (** the function to call to apply the new value of the parameter *) + bool_help : string option ; (** optional help string *) + } ;; + +(** This type represents a parameter whose value is a list of ['a]. *) +type 'a list_param = { + list_label : string; (** the label of the parameter *) + mutable list_value : 'a list; (** the current value of the parameter *) + list_titles : string list option; (** the titles of columns, if they must be displayed *) + list_f_edit : ('a -> 'a) option; (** optional edition function *) + list_eq : ('a -> 'a -> bool) ; (** the comparison function used to get list without doubles *) + list_strings : ('a -> string list); (** the function to get a string list from a ['a]. *) + list_color : ('a -> string option) ; (** a function to get the optional color of an element *) + list_editable : bool ; (** indicates if the value can be changed *) + list_f_add : unit -> 'a list ; (** the function to call to add list *) + list_f_apply : ('a list -> unit) ; (** the function to call to apply the new value of the parameter *) + list_help : string option ; (** optional help string *) + } ;; + +type combo_param = { + combo_label : string ; + mutable combo_value : string ; + combo_choices : string list ; + combo_editable : bool ; + combo_blank_allowed : bool ; + combo_new_allowed : bool ; + combo_f_apply : (string -> unit); + combo_help : string option ; (** optional help string *) + combo_expand : bool ; (** expand the entry widget or not *) + } ;; + +type custom_param = { + custom_box : GPack.box ; + custom_f_apply : (unit -> unit) ; + custom_expand : bool ; + custom_framed : string option ; (** optional label for an optional frame *) + } ;; + +type modifiers_param = { + md_label : string ; (** the label of the parameter *) + mutable md_value : Gdk.Tags.modifier list ; + (** The value, as a list of modifiers and a key code *) + md_editable : bool ; (** indicates if the value can be changed *) + md_f_apply : Gdk.Tags.modifier list -> unit ; + (** the function to call to apply the new value of the paramter *) + md_help : string option ; (** optional help string *) + md_expand : bool ; (** expand or not *) + md_allow : Gdk.Tags.modifier list + } + + +(** This type represents the different kinds of parameters. *) +type parameter_kind = + String_param of string string_param + | List_param of (unit -> <box: GObj.widget ; apply : unit>) + | Bool_param of bool_param + | Text_param of string string_param + | Combo_param of combo_param + | Custom_param of custom_param + | Modifiers_param of modifiers_param +;; + +(** This type represents the structure of the configuration window. *) +type configuration_structure = + | Section of string * GtkStock.id option * parameter_kind list (** label of the section, icon, parameters *) + | Section_list of string * GtkStock.id option * configuration_structure list (** label of the section, list of the sub sections *) +;; + +(** To indicate what button was pushed by the user when the window is closed. *) +type return_button = + Return_apply (** The user clicked on Apply at least once before + closing the window with Cancel or the window manager. *) + | Return_ok (** The user closed the window with the ok button. *) + | Return_cancel (** The user closed the window with the cancel + button or the window manager but never clicked + on the apply button.*) diff --git a/ide/coq-ssreflect.lang b/ide/coq-ssreflect.lang new file mode 100644 index 0000000000..bd9cb4bfa2 --- /dev/null +++ b/ide/coq-ssreflect.lang @@ -0,0 +1,247 @@ +<?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>Restart</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.ico b/ide/coq.ico Binary files differnew file mode 100644 index 0000000000..94ce897d17 --- /dev/null +++ b/ide/coq.ico diff --git a/ide/coq.lang b/ide/coq.lang new file mode 100644 index 0000000000..e9eab48de7 --- /dev/null +++ b/ide/coq.lang @@ -0,0 +1,249 @@ +<?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="dot_sep">\.(\s|\z)</define-regex> + <define-regex id="bullet">([-+*]+|{)(\s|\z)|}(\s*})*</define-regex> + <define-regex id="single_decl">Definition|Let|Example|SubClass|(Co)?Fixpoint|Function|Conjecture|(Co)?Inductive|Record|Structure|Ltac|Instance|Class|Existing\%{space}Instance|Canonical\%{space}Structure|Coercion|Universe</define-regex> + <define-regex id="mult_decl">Hypothes[ie]s|Axiom(s)?|Variable(s)?|Parameter(s)?|Context|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|Save</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> + + <!-- Strings, with '""' an escape sequence --> + <context id="string" style-ref="string" class="string"> + <start>"</start> + <end>"</end> + <include> + <context id="string-escape" style-ref="escape"> + <match>""</match> + </context> + </include> + </context> + + <!-- Coqdoc comments --> + <context id="coqdoc" style-ref="coqdoc" class="comment" class-disabled="no-spell-check"> + <start>\(\*\*(\s|\z)</start> + <end>\*\)</end> + <include> + <context ref="comment"/> + <context ref="string"/> + <context ref="def:in-comment"/> + </include> + </context> + + <!-- Regular comments, possibly nested --> + <context id="comment" style-ref="comment" class="comment" class-disabled="no-spell-check"> + <start>\(\*</start> + <end>\*\)</end> + <include> + <context ref="comment"/> + <context ref="string"/> + <context ref="def:in-comment"/> + </include> + </context> + + <!-- Keywords for constr --> + <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> + </context> + + <!-- Sort keywords --> + <context id="constr-sort" style-ref="constr-sort"> + <keyword>Prop</keyword> + <keyword>Set</keyword> + <keyword>Type</keyword> + </context> + + <!-- Terms --> + <context id="constr"> + <include> + <context ref="string"/> + <context ref="coqdoc"/> + <context ref="comment"/> + <context ref="constr-sort"/> + <context ref="constr-keyword"/> + <context id="dot-nosep"> + <match>\.\.</match> + </context> + </include> + </context> + + <context id="coq" class="no-spell-check"> + <include> + <context ref="coqdoc"/> + <context ref="comment"/> + + <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 ref="constr"/> + </include> + </context> + + <context id="proof"> + <start>(Proof(\%{dot_sep}|\%{space}using|\%{space}with))|Next Obligation</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="coqdoc"/> + <context ref="comment"/> + <context id="bullet" style-ref="vernac-keyword" extend-parent="false"> + <match>\%{bullet}</match> + </context> + <context extend-parent="false"> + <start>\%[</start> + <end>\%{dot_sep}</end> + <include> + <context ref="command-in-proof"/> + <context ref="constr"/> + </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"/> + </include> + </context> + + <context ref="command"/> + </include> + </context> + + <!-- Toplevel commands --> + <context id="command" extend-parent="false"> + <start>\%[</start> + <end>\%{dot_sep}</end> + <include> + <context id="command-in-proof" style-ref="vernac-keyword"> + <keyword>About</keyword> + <keyword>Check</keyword> + <keyword>Print</keyword> + <keyword>Eval</keyword> + <keyword>Undo</keyword> + <keyword>Restart</keyword> + <keyword>Opaque</keyword> + <keyword>Transparent</keyword> + </context> + + <context id="toplevel-command" style-ref="vernac-keyword"> + <keyword>Add</keyword> + <keyword>Load</keyword> + <keyword>(Print|Reset)\%{space}+Extraction\%{space}+(Inline|Blacklist)</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>Declare\%{space}ML\%{space}Module</keyword> + <keyword>Extraction\%{space}Language\%{space}(OCaml|Haskell|Scheme|JSON)</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>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>Scheme\%{space}(Induction|Minimality|Elimination|Case|Equality)\%{space}for</keyword> + <keyword>End</keyword> + <keyword>Section</keyword> + <keyword>Module(\%{space}Type)?</keyword> + <keyword>Declare\%{space}Module(\%{space}(Import|Export))?</keyword> + <keyword>Arguments</keyword> + <keyword>Implicit\%{space}Arguments</keyword> + <keyword>Include</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"> + <suffix>(?'qua_list'(\%{space}\%{qualit})+)</suffix> + <keyword>Typeclasses (Transparent|Opaque)</keyword> + <keyword>Require(\%{space}(Import|Export))?</keyword> + <keyword>Import</keyword> + <keyword>Export</keyword> + <keyword>((Recursive|Separate)\%{space})?Extraction(\%{space}(Library|(No)?Inline|Blacklist))?</keyword> + <include> + <context sub-pattern="1" style-ref="vernac-keyword"/> + <context sub-pattern="qua_list" style-ref="identifier"/> + </include> + </context> + + <context ref="constr"/> + </include> + </context> + + </definitions> +</language> diff --git a/ide/coq.ml b/ide/coq.ml new file mode 100644 index 0000000000..a420a3cbf5 --- /dev/null +++ b/ide/coq.ml @@ -0,0 +1,609 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Ideutils +open Preferences + +let ideslave_coqtop_flags = ref None + +(** * Version and date *) + +let get_version_date () = + let date = + if Glib.Utf8.validate Coq_config.date + then Coq_config.date + else "<date not printable>" in + try + (* the following makes sense only when running with local layout *) + let coqroot = Filename.concat + (Filename.dirname Sys.executable_name) + Filename.parent_dir_name + in + let ch = open_in (Filename.concat coqroot "revision") in + let ver = input_line ch in + let rev = input_line ch in + (ver,rev) + with _ -> (Coq_config.version,date) + +let short_version () = + let (ver,date) = get_version_date () in + Printf.sprintf "The Coq Proof Assistant, version %s (%s)\n" ver date + +let version () = + let (ver,date) = get_version_date () in + Printf.sprintf + "The Coq Proof Assistant, version %s (%s)\ + \nArchitecture %s running %s operating system\ + \nGtk version is %s\ + \nThis is %s \n" + ver date + Coq_config.arch Sys.os_type + (let x,y,z = GMain.Main.version in Printf.sprintf "%d.%d.%d" x y z) + (Filename.basename Sys.executable_name) + +(** * Initial checks by launching test coqtop processes *) + +let rec read_all_lines in_chan = + try + let arg = input_line in_chan in + let len = String.length arg in + let arg = + if len > 0 && arg.[len - 1] = '\r' then + String.sub arg 0 (len - 1) + else arg + in + arg::(read_all_lines in_chan) + with End_of_file -> [] + +let fatal_error_popup msg = + let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok + ~message_type:`ERROR ~message:msg () + in ignore (popup#run ()); exit 1 + +let final_info_popup small msg = + if small then + let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok + ~message_type:`INFO ~message:msg () + in + let _ = popup#run () in + exit 0 + else + let popup = GWindow.dialog () in + let button = GButton.button ~label:"ok" ~packing:popup#action_area#add () + in + let scroll = GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC + ~packing:popup#vbox#add ~height:500 () + in + let _ = GMisc.label ~text:msg ~packing:scroll#add_with_viewport () in + let _ = popup#connect#destroy ~callback:(fun _ -> exit 0) in + let _ = button#connect#clicked ~callback:(fun _ -> exit 0) in + let _ = popup#run () in + exit 0 + +let connection_error cmd lines exn = + fatal_error_popup + ("Connection with coqtop failed!\n"^ + "Command was: "^cmd^"\n"^ + "Answer was: "^(String.concat "\n " lines)^"\n"^ + "Exception was: "^Printexc.to_string exn) + +let display_coqtop_answer cmd lines = + final_info_popup (List.length lines < 30) + ("Coqtop exited\n"^ + "Command was: "^cmd^"\n"^ + "Answer was: "^(String.concat "\n " lines)) + +let rec filter_coq_opts args = + let argstr = String.concat " " (List.map Filename.quote args) in + let cmd = Filename.quote (coqtop_path ()) ^" -nois -filteropts " ^ argstr in + let cmd = requote cmd in + let filtered_args = ref [] in + let errlines = ref [] in + try + let oc,ic,ec = Unix.open_process_full cmd (Unix.environment ()) in + filtered_args := read_all_lines oc; + errlines := read_all_lines ec; + match Unix.close_process_full (oc,ic,ec) with + | 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 + | e -> connection_error cmd (!filtered_args @ !errlines) e + +and asks_for_coqtop args = + let pb_mes = GWindow.message_dialog + ~message:"Failed to load coqidetop. Reset the preference to default ?" + ~message_type:`QUESTION ~buttons:GWindow.Buttons.yes_no () in + match pb_mes#run () with + | `YES -> + let () = cmd_coqtop#set None in + let () = custom_coqtop := None in + let () = pb_mes#destroy () in + filter_coq_opts args + | `DELETE_EVENT | `NO -> + let file = select_file_for_open + ~title:"coqidetop to execute (edit your preference then)" + ~filter:false + ~filename:(coqtop_path ()) () in + match file with + | Some _ -> + let () = custom_coqtop := file in + filter_coq_opts args + | None -> exit 0 + +exception WrongExitStatus of string + +let print_status = function + | Unix.WEXITED n -> "WEXITED "^string_of_int n + | Unix.WSIGNALED n -> "WSIGNALED "^string_of_int n + | Unix.WSTOPPED n -> "WSTOPPED "^string_of_int n + +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 = requote cmd in + try + 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 *) + +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 +end + +module CoqTop = Spawn.Async(GlibMainLoop) + +type handle = { + proc : CoqTop.process; + xml_oc : Xml_printer.t; + mutable alive : bool; + mutable waiting_for : ccb option; (* last call + callback *) +} + +(** 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. +*) + +type status = New | Ready | Busy | Closed + +type 'a task = handle -> ('a -> void) -> void + +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 : 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 *) + +(** We simulate a Unix.open_process that also returns the pid of + the created process. Note: this uses Unix.create_process, which + doesn't call bin/sh, so args shouldn't be quoted. The process + cannot be terminated by a Unix.close_process, but rather by a + kill of the pid. + + >--ide2top_w--[pipe]--ide2top_r--> + coqide coqtop + <--top2ide_r--[pipe]--top2ide_w--< + + Note: we use Unix.stderr in Unix.create_process to get debug + messages from the coqtop's Ide_slave loop. + + NB: it's important to close coqide's descriptors (ide2top_w and top2ide_r) + in coqtop. We do this indirectly via [Unix.set_close_on_exec]. + This way, coqide has the only remaining copies of these descriptors, + and closing them later will have visible effects in coqtop. Cf man 7 pipe : + + - If all file descriptors referring to the write end of a pipe have been + closed, then an attempt to read(2) from the pipe will see end-of-file + (read(2) will return 0). + - If all file descriptors referring to the read end of a pipe have been + closed, then a write(2) will cause a SIGPIPE signal to be generated for + the calling process. If the calling process is ignoring this signal, + then write(2) fails with the error EPIPE. + + Symmetrically, coqtop's descriptors (ide2top_r and top2ide_w) should be + closed in coqide. +*) + +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_feedback feedback_processor xml = + let feedback = Xmlprotocol.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 ~do_not_canonicalize:true 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 Xmlprotocol.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(expected,actual) -> + "Protocol violation. Expected: " ^ expected ^ " Actual: " + ^ Xml_printer.to_string actual + | 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 async_default = + (* disable async processing by default in Windows *) + if List.mem Sys.os_type ["Win32"; "Cygwin"] then + "off" + else + "on" + in + let args = Array.of_list ("--xml_format=Ppcmds" :: "-async-proofs" :: async_default :: args) in + let env = + match !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 save_all = ref (fun () -> assert false) + +let rec respawn_coqtop ?(why=Unexpected) coqtop = + let () = match why with + | Unexpected -> + let title = "Warning" in + let icon = (warn_image ())#coerce in + let buttons = ["Reset"; "Save all and quit"; "Quit without saving"] in + let ans = GToolbox.question_box ~title ~buttons ~icon "coqidetop died badly." in + if ans = 2 then (!save_all (); GtkMain.Main.quit ()) + else if ans = 3 then GtkMain.Main.quit () + | Planned -> () + in + 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 coqtop.handle (mkready coqtop)) + +let spawn_coqtop sup_args = + 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 set_reset_handler coqtop hook = coqtop.reset_handler <- hook + +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 get_arguments coqtop = coqtop.sup_args + +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 try_grab coqtop task abort = + match coqtop.status with + |Closed -> () + |Busy|New -> abort () + |Ready -> process_task coqtop task + +let init_coqtop coqtop task = + assert (coqtop.status = New); + process_task coqtop task + +(** * Calls to coqtop *) + +(** Cf [Ide_intf] for more details *) + +type 'a query = 'a Interface.value task + +let eval_call 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)); + Xml_printer.print handle.xml_oc (Xmlprotocol.of_call call); + Minilib.log "End eval_call"; + Void + +let add x = eval_call (Xmlprotocol.add x) +let edit_at i = eval_call (Xmlprotocol.edit_at i) +let query x = eval_call (Xmlprotocol.query x) +let mkcases s = eval_call (Xmlprotocol.mkcases s) +let status force = eval_call (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) + +let break_coqtop coqtop workers = + if coqtop.status = Busy then + try !interrupter (CoqTop.unixpid coqtop.handle.proc) + with _ -> Minilib.log "Error while sending Ctrl-C" + else + let rec aux = function + | [] -> Void + | w :: ws -> stop_worker w coqtop.handle (fun _ -> aux ws) + in + let Void = aux workers in () + +module PrintOpt = +struct + type _ t = + | BoolOpt : string list -> bool t + | StringOpt : string list -> string t + + let opt_name (type a) : a t -> string list = function + | BoolOpt l -> l + | StringOpt l -> l + + let opt_data (type a) (key : a t) (v : a) = match key with + | BoolOpt l -> Interface.BoolValue v + | StringOpt l -> Interface.StringValue v + + (* Boolean options *) + + let implicit = BoolOpt ["Printing"; "Implicit"] + let coercions = BoolOpt ["Printing"; "Coercions"] + let raw_matching = BoolOpt ["Printing"; "Matching"] + let notations = BoolOpt ["Printing"; "Notations"] + let all_basic = BoolOpt ["Printing"; "All"] + let existential = BoolOpt ["Printing"; "Existential"; "Instances"] + let universes = BoolOpt ["Printing"; "Universes"] + let unfocused = BoolOpt ["Printing"; "Unfocused"] + let diff = StringOpt ["Diffs"] + + type 'a descr = { opts : 'a t list; init : 'a; 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" }; + { opts = [unfocused]; init = false; label = "Display _unfocused goals" } + ] + + let diff_item = { opts = [diff]; init = "off"; label = "Display _proof diffs" } + + (** The current status of the boolean options *) + + let current_state = Hashtbl.create 11 + + let set (type a) (opt : a t) (v : a) = + Hashtbl.replace current_state (opt_name opt) (opt_data 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; + List.iter (fun o -> set o diff_item.init) diff_item.opts + + let _ = reset () + + let printing_unfocused () = + let BoolOpt unfocused = unfocused in + match Hashtbl.find current_state unfocused with + | Interface.BoolValue b -> b + | _ -> assert false + + (** Transmitting options to coqtop *) + + let enforce h k = + let mkopt o v acc = (o, v) :: acc in + let opts = Hashtbl.fold mkopt current_state [] in + eval_call (Xmlprotocol.set_options opts) h + (function + | Interface.Good () -> k () + | _ -> failwith "Cannot set options. Resetting coqtop") + +end + +let goals x h k = + PrintOpt.enforce h (fun () -> eval_call (Xmlprotocol.goals x) h k) + +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 new file mode 100644 index 0000000000..3af0aa697e --- /dev/null +++ b/ide/coq.mli @@ -0,0 +1,180 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Coq : Interaction with the Coq toplevel *) + +(** {5 General structures} *) + +type coqtop +(** The structure describing a coqtop sub-process . + + 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 explicitly requesting coqtop to + reset. *) + +type 'a task +(** Coqtop tasks. + + A task is a group of sequential calls to be performed on a coqtop process, + that ultimately return some content. + + 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]. + + Any exception occurring within the task will trigger a coqtop reset. + + 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. +*) + +val return : 'a -> 'a task +(** Monadic return of values as tasks. *) + +val bind : 'a task -> ('a -> 'b task) -> 'b task +(** Monadic binding of tasks *) + +val lift : (unit -> 'a) -> 'a task +(** Return the imperative computation waiting to be processed. *) + +val seq : unit task -> 'a task -> 'a task +(** Sequential composition *) + +(** {5 Coqtop process management} *) + +type reset_kind = Planned | Unexpected +(** A reset may occur accidentally or voluntarily, so we discriminate between + these. *) + +val is_computing : coqtop -> bool +(** Check if coqtop is computing, i.e. already has a current task *) + +val spawn_coqtop : string list -> coqtop +(** Create a coqtop process with some command-line arguments. *) + +val set_reset_handler : coqtop -> 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 -> string list -> unit +(** Interrupt the current computation of coqtop or the worker if coqtop it not running. *) + +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 : Interface.add_sty -> Interface.add_rty query +val edit_at : Interface.edit_at_sty -> Interface.edit_at_rty query +val query : Interface.query_sty -> Interface.query_rty query +val status : Interface.status_sty -> Interface.status_rty query +val goals : 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 'a t (** Representation of an option *) + + type 'a descr = { opts : 'a t list; init : 'a; label : string } + + val bool_items : bool descr list + + val diff_item : string descr + + val set : 'a t -> 'a -> unit + + val printing_unfocused: unit -> bool + + (** [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 +val save_all : (unit -> unit) ref + +(* Flags to be used for ideslave *) +val ideslave_coqtop_flags : string option ref diff --git a/ide/coq.png b/ide/coq.png Binary files differnew file mode 100644 index 0000000000..136bfdd5fe --- /dev/null +++ b/ide/coq.png diff --git a/ide/coq2.ico b/ide/coq2.ico Binary files differnew file mode 100755 index 0000000000..bc1732fd99 --- /dev/null +++ b/ide/coq2.ico diff --git a/ide/coqOps.ml b/ide/coqOps.ml new file mode 100644 index 0000000000..8da9900724 --- /dev/null +++ b/ide/coqOps.ml @@ -0,0 +1,889 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Coq +open Ideutils +open Interface +open Feedback + +let b2c = byte_offset_to_char_offset + +type flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR of string Loc.located | `WARNING of string Loc.located ] +type mem_flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR | `WARNING ] +let mem_flag_of_flag : flag -> mem_flag = function + | `ERROR _ -> `ERROR + | `WARNING _ -> `WARNING + | (`INCOMPLETE | `UNSAFE | `PROCESSING) as mem_flag -> mem_flag +let str_of_flag = function + | `UNSAFE -> "U" + | `PROCESSING -> "P" + | `ERROR _ -> "E" + | `WARNING _ -> "W" + | `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 add_flag : sentence -> flag -> unit + val has_flag : sentence -> mem_flag -> bool + val remove_flag : sentence -> mem_flag -> unit + 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.t + +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 changed s = + s.changed_sig#call (s.index, List.map mem_flag_of_flag s.flags) + + 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 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 ~stop:(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 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 : unit task + method raw_coq_query : + route_id:int -> next:(query_rty value -> unit task) -> 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 = + 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 `NAME Preferences.processed_color#get + +module Doc = Document + +let segment_model (doc : sentence Doc.document) : Wg_Segment.model = +object (self) + + val mutable cbs = [] + + val mutable document_length = 0 + + method length = document_length + + method changed ~callback = cbs <- callback :: cbs + + method fold : 'a. ('a -> Wg_Segment.color -> 'a) -> 'a -> 'a = fun f accu -> + let fold accu _ _ s = + let flags = List.map mem_flag_of_flag s.flags in + f accu (flags_to_color flags) + in + Doc.fold_all doc accu fold + + method private on_changed (i, f) = + let data = (i, flags_to_color f) in + List.iter (fun f -> f (`SET data)) cbs + + method private on_push s ctx = + let after = match ctx with + | None -> [] + | Some (l, _) -> l + in + List.iter (fun s -> set_index s (s.index + 1)) after; + set_index s (document_length - List.length after); + ignore ((SentenceId.connect s)#changed ~callback:self#on_changed); + document_length <- document_length + 1; + List.iter (fun f -> f `INSERT) cbs + + method private on_pop s ctx = + let () = match ctx with + | None -> () + | Some (l, _) -> List.iter (fun s -> set_index s (s.index - 1)) l + in + set_index s (-1); + document_length <- document_length - 1; + List.iter (fun f -> f `REMOVE) cbs + + initializer + let _ = (Doc.connect doc)#pushed ~callback:self#on_push in + let _ = (Doc.connect doc)#popped ~callback:self#on_pop in + () + +end + +class coqops + (_script:Wg_ScriptView.script_view) + (_pv:Wg_ProofView.proof_view) + (_mv:Wg_RoutedMessageViews.message_views_router) + (_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 md = segment_model document in + segment#set_model md; + let on_click id = + let find _ _ s = Int.equal s.index id in + let sentence = Doc.find document find in + let mark = sentence.start in + let iter = script#buffer#get_iter_at_mark mark in + (* Sentence starts tend to be at the end of a line, so we rather choose + the first non-line-ending position. *) + let rec sentence_start iter = + if iter#ends_line then sentence_start iter#forward_line + else iter + in + let iter = sentence_start iter in + script#buffer#place_cursor ~where:iter; + ignore (script#scroll_to_iter ~use_align:true ~yalign:0. iter) + in + let _ = segment#connect#clicked ~callback:on_click in + () + + method private tooltip_callback ~x ~y ~kbd tooltip = + let x, y = script#window_to_buffer_coords ~tag:`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 (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#move_mark ~where:(buffer#get_iter_at_mark qed_s.stop) + (`NAME "stop_of_input") + + method private exit_focus = + Minilib.log "Unfocusing"; + 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) () = + if move_insert then begin + let dest = self#get_start_of_input in + if (buffer#get_iter_at_mark `INSERT)#compare dest <= 0 then begin + buffer#place_cursor ~where:dest; + script#recenter_insert + end + end; + Coq.bind (Coq.goals ()) (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 ~force:true; + Coq.return () + ) + ) + method show_goals = self#show_goals_aux () + + (* This method is intended to perform stateless commands *) + method raw_coq_query ~route_id ~next phrase : unit Coq.task = + let sid = try Document.tip document + with Document.Empty -> Stateid.initial + in + let action = log "raw_coq_query starting now" in + let query = Coq.query (route_id,(phrase,sid)) in + Coq.bind (Coq.seq action query) next + + method private still_valid { edit_id = id } = + try ignore(Doc.find_id document (fun _ { edit_id = id1 } -> id = id1)); true + with Not_found -> false + + method private mark_as_needed sentence = + if self#still_valid sentence then begin + Minilib.log_pp Pp.(str "Marking " ++ 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 has_flag sentence `UNSAFE 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 + end + + method private attach_tooltip ?loc sentence text = + let start_sentence, stop_sentence, phrase = self#get_sentence sentence in + let pre_chars, post_chars = Option.cata Loc.unloc (0, String.length phrase) loc in + let pre = b2c phrase pre_chars in + let post = b2c phrase 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 enqueue_feedback msg = + (* Minilib.log ("Feedback received: " ^ Xml_printer.to_string_fmt Xmlprotocol.(of_feedback Ppcmds msg)); *) + 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.span_id in + let sentence = + let finder _ state_id s = + match state_id, id with + | Some id', id when Stateid.equal id id' -> Some (state_id, s) + | _ -> None in + try Some (Doc.find_map document finder) + with Not_found -> None in + let log_pp ?id s= + Minilib.log_pp Pp.(seq + [str "Feedback "; s; pr_opt (fun id -> str " on " ++ str (Stateid.to_string id)) id]) + in + let log ?id s = log_pp ?id (Pp.str s) in + begin match msg.contents, sentence with + | AddedAxiom, Some (id,sentence) -> + log ?id "AddedAxiom"; + remove_flag sentence `PROCESSING; + remove_flag sentence `ERROR; + add_flag sentence `UNSAFE; + self#mark_as_needed sentence + | Processed, Some (id,sentence) -> + log ?id "Processed" ; + remove_flag sentence `PROCESSING; + self#mark_as_needed sentence + | ProcessingIn _, Some (id,sentence) -> + log ?id "ProcessingIn"; + add_flag sentence `PROCESSING; + self#mark_as_needed sentence + | Incomplete, Some (id, sentence) -> + log ?id "Incomplete"; + add_flag sentence `INCOMPLETE; + self#mark_as_needed sentence + | Complete, Some (id, sentence) -> + log ?id "Complete"; + remove_flag sentence `INCOMPLETE; + self#mark_as_needed sentence + | GlobRef(loc, filepath, modpath, ident, ty), Some (id,sentence) -> + log ?id "GlobRef"; + self#attach_tooltip ~loc sentence + (Printf.sprintf "%s %s %s" filepath ident ty) + | Message(Error, loc, msg), Some (id,sentence) -> + log_pp ?id Pp.(str "ErrorMsg " ++ msg); + remove_flag sentence `PROCESSING; + let rmsg = Pp.string_of_ppcmds msg in + add_flag sentence (`ERROR (loc, rmsg)); + self#mark_as_needed sentence; + self#attach_tooltip ?loc sentence rmsg; + self#position_tag_at_sentence ?loc Tags.Script.error sentence + | Message(Warning, loc, message), Some (id,sentence) -> + log_pp ?id Pp.(str "WarningMsg " ++ message); + let rmsg = Pp.string_of_ppcmds message in + add_flag sentence (`WARNING (loc, rmsg)); + self#attach_tooltip ?loc sentence rmsg; + self#position_tag_at_sentence ?loc Tags.Script.warning sentence; + (messages#route msg.route)#push Warning message + | Message(lvl, loc, message), Some (id,sentence) -> + log_pp ?id Pp.(str "Msg " ++ message); + (messages#route msg.route)#push lvl message + (* We do nothing here as for BZ#5583 *) + | Message(Error, loc, msg), None -> + log_pp Pp.(str "Error Msg without a sentence" ++ msg) + | Message(lvl, loc, message), None -> + log_pp Pp.(str "Msg without a sentence " ++ message); + (messages#route msg.route)#push lvl message + | InProgress n, _ -> + if n < 0 then processed <- processed + abs n + else to_process <- to_process + n + | WorkerStatus(id,status), _ -> + log "WorkerStatus"; + 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 + | 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_tag_at_iter ?loc iter_start iter_stop tag phrase = match loc with + | None -> + buffer#apply_tag tag ~start:iter_start ~stop:iter_stop + | Some loc -> + let start, stop = Loc.unloc loc in + buffer#apply_tag tag + ~start:(iter_start#forward_chars (b2c phrase start)) + ~stop:(iter_start#forward_chars (b2c phrase stop)) + + method private position_tag_at_sentence ?loc tag sentence = + let start, stop, phrase = self#get_sentence sentence in + self#position_tag_at_iter ?loc start stop tag phrase + + method private process_interp_error ?loc queue sentence 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_tag_at_iter ?loc start stop Tags.Script.error phrase; + buffer#place_cursor ~where:stop; + messages#default_route#clear; + messages#default_route#push Feedback.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 topstack = + if Doc.focused document then fst (Doc.context document) else [] in + 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 + List.exists (fun (_, s) -> + start#equal (buffer#get_iter_at_mark s.start) && + stop#equal (buffer#get_iter_at_mark s.stop)) topstack + 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#default_route#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#default_route#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), [] -> + logger Feedback.Error (Pp.str "You must close the proof with Qed or Admitted"); + self#discard_command_queue queue; + conclude [] + | `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 ((phrase,edit_id),(tip,verbose)) in + let handle_answer = function + | Good (id, (Util.Inl (* NewTip *) (), msg)) -> + Doc.assign_tip_id document id; + logger Feedback.Notice (Pp.str 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 Feedback.Notice (Pp.str 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 loc = Option.map Loc.make_loc loc in + let sentence = Doc.pop document in + self#process_interp_error ?loc queue sentence 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#default_route#clear; + messages#default_route#push + Feedback.Info (Pp.str "All proof terms checked by the kernel"); + Coq.return () + | Fail x -> self#handle_failure x in + Coq.bind (Coq.status 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 (loc, msg) -> + let iter = begin match loc with + | None -> buffer#get_iter_at_mark s.start + | Some loc -> + let (iter, _, phrase) = self#get_sentence s in + let (start, _) = Loc.unloc loc in + iter#forward_chars (b2c phrase start) + end in iter#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 Preferences.stop_before#get 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; + self#print_stack + + (** 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 begin + buffer#place_cursor ~where:self#get_start_of_input; + script#recenter_insert; + end; + 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 Feedback.Error (Richpp.richpp_of_string "Fixme LOC"); *) + messages#default_route#push Feedback.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#default_route#push Feedback.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#default_route#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#default_route#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#default_route#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#default_route#clear; + self#show_goals + in + let display_error (loc, s) = + messages#default_route#add (Ideutils.validate s) in + let try_phrase phrase stop more = + let action = log "Sending to coq now" in + let route_id = 0 in + let query = Coq.query (route_id,(phrase,Stateid.dummy)) in + let next = function + | Fail (_, l, str) -> (* FIXME: check *) + display_error (l, str); + messages#default_route#add (Pp.str ("Unsuccessfully tried: "^phrase)); + more + | Good () -> 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 = + let action () = + (* 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#default_route#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 (_, _, message) -> + let message = "Couldn't initialize coqtop\n\n" ^ (Pp.string_of_ppcmds message) in + let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok ~message_type:`ERROR ~message () in + ignore (popup#run ()); exit 1 + | 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 0000000000..3685fea92e --- /dev/null +++ b/ide/coqOps.mli @@ -0,0 +1,47 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Coq +open Interface + +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 : unit task + method raw_coq_query : + route_id:int -> next:(query_rty value -> unit task) -> 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 + +class coqops : + Wg_ScriptView.script_view -> + Wg_ProofView.proof_view -> + Wg_RoutedMessageViews.message_views_router -> + Wg_Segment.segment -> + coqtop -> + (unit -> string option) -> + ops diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml new file mode 100644 index 0000000000..b0bafb7930 --- /dev/null +++ b/ide/coq_commands.ml @@ -0,0 +1,427 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +let commands = [ + [(* "Abort"; *) + "Add Abstract Ring A Aplus Amult Aone Azero Ainv Aeq T."; + "Add Abstract Semi Ring A Aplus Amult Aone Azero Aeq T."; + "Add Field"; + "Add LoadPath"; + "Add ML Path"; + "Add Morphism"; + "Add Printing Constructor"; + "Add Printing If"; + "Add Printing Let"; + "Add Printing Record"; + "Add Rec LoadPath"; + "Add Rec ML Path"; + "Add Ring A Aplus Amult Aone Azero Ainv Aeq T [ c1 ... cn ]. "; + "Add Semi Ring A Aplus Amult Aone Azero Aeq T [ c1 ... cn ]."; + "Add Relation"; + "Add Setoid"; + "Axiom";]; + [(* "Back"; *) ]; + ["Canonical Structure"; + "Chapter"; + "Coercion"; + "Coercion Local"; + "CoFixpoint"; + "CoInductive"; + ]; + ["Declare ML Module"; + "Defined."; + "Definition"; + "Derive Dependent Inversion"; + "Derive Dependent Inversion__clear"; + "Derive Inversion"; + "Derive Inversion__clear"; + ]; + ["End"; + "End Silent."; + "Eval"; + "Extract Constant"; + "Extract Inductive"; + "Extraction Inline"; + "Extraction Language"; + "Extraction NoInline";]; + ["Fact"; + "Fixpoint"; + "Focus";]; + ["Global Variable"; + "Goal"; + "Grammar";]; + ["Hint"; + "Hint Constructors"; + "Hint Extern"; + "Hint Immediate"; + "Hint Resolve"; + "Hint Rewrite"; + "Hint Unfold"; + "Hypothesis";]; + ["Identity Coercion"; + "Implicit Arguments"; + "Inductive"; + "Infix"; + ]; + ["Lemma"; + "Load"; + "Load Verbose"; + "Local"; + "Ltac"; + ]; + ["Module"; + "Module Type"; + "Mutual Inductive";]; + ["Notation"; + "Next Obligation";]; + ["Opaque"; + "Obligations Tactic";]; + ["Parameter"; + "Proof."; + "Program Definition"; + "Program Fixpoint"; + "Program Lemma"; + "Program Theorem"; + ]; + ["Qed."; + ]; + ["Read Module"; + "Record"; + "Variant"; + "Remark"; + "Remove LoadPath"; + "Remove Printing Constructor"; + "Remove Printing If"; + "Remove Printing Let"; + "Remove Printing Record"; + "Require"; + "Require Export"; + "Require Import"; + "Reset Extraction Inline"; + "Restore State"; + ]; + [ "Scheme"; + "Section"; + "Set Extraction AutoInline"; + "Set Extraction Optimize"; + "Set Hyps__limit"; + "Set Implicit Arguments"; + (*"Set Printing Coercion"; + "Set Printing Coercions"; + "Set Printing Synth";*) + "Set Printing Wildcard"; + "Set Silent."; + "Set Undo"; + (*"Show"; + "Show Conjectures"; + "Show Implicits"; + "Show Intro"; + "Show Intros"; + "Show Programs"; + "Show Proof"; + "Show Script"; + "Show Tree";*) + "Structure"; + "Syntactic Definition"; + "Syntax";]; + [ + "Test Printing If"; + "Test Printing Let"; + "Test Printing Synth"; + "Test Printing Wildcard"; + "Theorem"; + "Time"; + "Transparent";]; + [(* "Undo"; *) + "Unfocus"; + "Unset Extraction AutoInline"; + "Unset Extraction Optimize"; + "Unset Hyps__limit"; + "Unset Implicit Arguments"; + (* + "Unset Printing Coercion"; + "Unset Printing Coercions"; + "Unset Printing Synth"; *) + "Unset Printing Wildcard"; + "Unset Silent."; + "Unset Undo";]; + ["Variable"; + "Variables";]; + ["Write State";]; +] + +let state_preserving = [ + "About"; + "Check"; + "Eval"; + "Eval lazy in"; + "Eval vm_compute in"; + "Eval compute in"; + "Extraction"; + "Extraction Library"; + "Extraction Module"; + "Inspect"; + "Locate"; + + "Obligations"; + "Print"; + "Print All."; + "Print Classes"; + "Print Coercion Paths"; + "Print Coercions"; + "Print Extraction Inline"; + "Print Grammar"; + "Print Graph"; + "Print Hint"; + "Print Hint *"; + "Print HintDb"; + "Print Implicit"; + "Print LoadPath"; + "Print ML Modules"; + "Print ML Path"; + "Print Module"; + "Print Module Type"; + "Print Modules"; + "Print Proof"; + "Print Rewrite HintDb"; + "Print Setoids"; + "Print Scope"; + "Print Scopes."; + "Print Section"; + + "Print Table Printing If."; + "Print Table Printing Let."; + "Print Tables."; + "Print Term"; + + "Print Visibility"; + + "Pwd."; + + "Recursive Extraction"; + "Recursive Extraction Library"; + + "Search"; + "SearchAbout (* deprecated *)"; + "SearchHead"; + "SearchPattern"; + "SearchRewrite"; + + "Show"; + "Show Conjectures"; + "Show Existentials"; + "Show Implicits"; + "Show Intro"; + "Show Intros"; + "Show Proof"; + "Show Script"; + "Show Tree"; + + "Test Printing If"; + "Test Printing Let"; + "Test Printing Synth"; + "Test Printing Wildcard"; + +] + + +let tactics = + [ + [ + "abstract"; + "absurd"; + "apply"; + "apply __ with"; + "assert"; + "assert (__:__)"; + "assert (__:=__)"; + "assumption"; + "auto"; + "auto with"; + "autorewrite"; + ]; + + [ + "case"; + "case __ with"; + "casetype"; + "cbv"; + "cbv in"; + "change"; + "change __ in"; + "clear"; + "clearbody"; + "cofix"; + "compare"; + "compute"; + "compute in"; + "congruence"; + "constructor"; + "constructor __ with"; + "contradiction"; + "cut"; + "cutrewrite"; + ]; + + [ + "decide equality"; + "decompose"; + "decompose record"; + "decompose sum"; + "dependent inversion"; + "dependent inversion __ with"; + "dependent inversion__clear"; + "dependent inversion__clear __ with"; + "dependent rewrite ->"; + "dependent rewrite <-"; + "destruct"; + "discriminate"; + "do"; + "double induction"; + ]; + + [ + "eapply"; + "eauto"; + "eauto with"; + "eexact"; + "elim"; + "elim __ using"; + "elim __ with"; + "elimtype"; + "exact"; + "exists"; + ]; + + [ + "fail"; + "field"; + "first"; + "firstorder"; + "firstorder using"; + "firstorder with"; + "fix"; + "fix __ with"; + "fold"; + "fold __ in"; + "functional induction"; + ]; + + [ + "generalize"; + "generalize dependent"; + ]; + + [ + "hnf"; + ]; + + [ + "idtac"; + "induction"; + "info"; + "injection"; + "instantiate (__:=__)"; + "intro"; + "intro after"; + "intro __ after"; + "intros"; + "intros until"; + "intuition"; + "inversion"; + "inversion __ in"; + "inversion __ using"; + "inversion __ using __ in"; + "inversion__clear"; + "inversion__clear __ in"; + ]; + + [ + "jp <n>"; + "jp"; + ]; + + [ + "lapply"; + "lazy"; + "lazy in"; + "left"; + ]; + + [ + "move __ after"; + ]; + + [ + "omega"; + ]; + + [ + "pattern"; + "pose"; + "pose __:=__)"; + "progress"; + ]; + + [ + "quote"; + ]; + + [ + "red"; + "red in"; + "refine"; + "reflexivity"; + "rename __ into"; + "repeat"; + "replace __ with"; + "rewrite"; + "rewrite __ in"; + "rewrite <-"; + "rewrite <- __ in"; + "right"; + "ring"; + ]; + + [ + "set"; + "set (__:=__)"; + "setoid__replace"; + "setoid__rewrite"; + "simpl"; + "simpl __ in"; + "simple destruct"; + "simple induction"; + "simple inversion"; + "simplify__eq"; + "solve"; + "split"; +(* "split__Rabs"; + "split__Rmult"; +*) + "subst"; + "symmetry"; + "symmetry in"; + ]; + + [ + "tauto"; + "transitivity"; + "trivial"; + "try"; + ]; + + [ + "unfold"; + "unfold __ in"; + ]; +] + + diff --git a/ide/coq_commands.mli b/ide/coq_commands.mli new file mode 100644 index 0000000000..259d790e0c --- /dev/null +++ b/ide/coq_commands.mli @@ -0,0 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val tactics : string list list +val commands : string list list +val state_preserving : string list diff --git a/ide/coq_icon.rc b/ide/coq_icon.rc new file mode 100644 index 0000000000..f873e7de11 --- /dev/null +++ b/ide/coq_icon.rc @@ -0,0 +1 @@ +large ICON ide/coq.ico diff --git a/ide/coq_lex.mli b/ide/coq_lex.mli new file mode 100644 index 0000000000..100411933a --- /dev/null +++ b/ide/coq_lex.mli @@ -0,0 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val delimit_sentences : (int -> GText.tag -> unit) -> string -> unit + +exception Unterminated diff --git a/ide/coq_lex.mll b/ide/coq_lex.mll new file mode 100644 index 0000000000..b6654f6d7a --- /dev/null +++ b/ide/coq_lex.mll @@ -0,0 +1,109 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +{ + exception Unterminated + + 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 number = [ '0'-'9' ]+ + +let string = "\"" _+ "\"" + +let alpha = ['a'-'z' 'A'-'Z'] + +let ident = alpha (alpha | number | '_' | "'")* + +let undotted_sep = ((number | '[' ident ']') space* ':' space*)? '{' | '}' | '-'+ | '+'+ | '*'+ + +let vernac_control = "Fail" | "Time" | "Redirect" space+ string | "Timeout" space+ number + +let dot_sep = '.' (space | eof) + +let utf8_extra_byte = [ '\x80' - '\xBF' ] + +rule coq_string = parse + | "\"\"" { coq_string lexbuf } + | "\"" { () } + | eof { () } + | utf8_extra_byte { incr utf8_adjust; coq_string lexbuf } + | _ { coq_string lexbuf } + +and comment = parse + | "(*" { 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 + | "(*" { + match comment lexbuf with + | None -> raise Unterminated + | Some comm_last -> + stamp comm_last Tags.Script.comment; + sentence initial stamp lexbuf + } + | "\"" { + let () = coq_string lexbuf in + 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 + (cf. for instance the syntax for recursive notation). + This rule and the following one also allow to treat the "..." + special case, where the third dot is a terminator. *) + sentence false stamp lexbuf + } + | dot_sep { + (* The usual "." terminator *) + stamp (utf8_lexeme_start lexbuf) Tags.Script.sentence; + sentence true stamp lexbuf + } + | (vernac_control space+)* undotted_sep { + (* Separators like { or } and bullets * - + are only active + at the start of a sentence *) + 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 + } + +{ + + (** 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_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 0000000000..67631d3462 --- /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.ml b/ide/coqide.ml new file mode 100644 index 0000000000..aa9e150fd5 --- /dev/null +++ b/ide/coqide.ml @@ -0,0 +1,1408 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Preferences +open Gtk_parsing +open Ideutils +open Session + +(** 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) + + 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 + + insert_text : #insert (and variants) + delete_range : #delete (and variants) + + apply_tag : #apply_tag, (and some #insert) + remove_tag : #remove_tag + + mark_deleted : #delete_mark + mark_set : #create_mark, #move_mark + + 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. +*) + +(** {2 Some static elements } *) + +(** 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_file = ref None +let sup_args = ref [] + +let logfile = ref None + +(** {2 Notebook of sessions } *) + +(** The main element of coqide is a notebook of session views *) + +let notebook = + Wg_Notebook.create Session.build_layout Session.kill + ~border_width:2 ~show_border:false ~scrollable:true () + + +(** {2 Callback functions for the user interface } *) + +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 cb_on_current_term f _ = on_current_term f + +(** 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 local_cd file = + "cd " ^ Filename.quote (Filename.dirname file) ^ " && " + +let pr_exit_status = function + | Unix.WEXITED 0 -> " succeeded" + | _ -> " failed" + +let make_coqtop_args fname = + let open CoqProject_file in + let base_args = match read_project#get with + | Ignore_args -> !sup_args + | Append_args -> !sup_args + | Subst_args -> [] in + let proj, args = + if read_project#get = Ignore_args then "", base_args + else + match !custom_project_file, fname with + | Some (d,proj), _ -> d, coqtop_args_from_project proj @ base_args + | None, None -> "", base_args + | None, Some the_file -> + match + CoqProject_file.find_project_file + ~from:(Filename.dirname the_file) + ~projfile_name:project_file_name#get + with + | None -> "", base_args + | Some proj -> + let warning_fn x = Feedback.msg_warning Pp.(str x) in + proj, coqtop_args_from_project (read_project_file ~warning_fn proj) @ base_args + in + let args = match fname with + | None -> args + | Some fname -> + if List.exists (String.equal "-top") args then args + else "-topfile"::fname::args + in + proj, args + +(** 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} +] + +let set_drag (w : GObj.drag_ops) = + w#dest_set drop_targets ~actions:[`COPY;`MOVE]; + w#connect#data_received ~callback:drop_received + +(** Session management *) + +let create_session f = + let project_file, args = make_coqtop_args f in + if project_file <> "" then + flash_info (Printf.sprintf "Reading options from %s" project_file); + let ans = Session.create f args in + let _ = set_drag ans.script#drag in + ans + +(** Auxiliary functions for the File operations *) + +module FileAux = struct + +let load_file ?(maycreate=false) f = + let f = CUnix.correct_path f (Sys.getcwd ()) in + try + 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 (); + 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 ?parent ~saveas ?filename sn = + let do_save = if saveas then sn.fileops#saveas ?parent else sn.fileops#save in + let title = if saveas then "Save file as" else "Save file" in + match select_file_for_save ~title ?parent ?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 ?parent ~saveas sn = + try match sn.fileops#filename with + |None -> select_and_save ?parent ~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 ?parent saveall = + (try save_pref () + with e -> flash_info ("Cannot save preferences (" ^ Printexc.to_string e ^ ")")); + let is_modified sn = sn.buffer#modified in + if List.exists is_modified notebook#pages then begin + let answ = Configwin_ihm.question_box ~title:"Quit" + ~buttons:["Save Named Buffers and Quit"; + "Quit without Saving"; + "Don't Quit"] + ~default:0 + ~icon:(warn_image ())#coerce + ?parent + "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 + +end + +let () = load_file_cb := (fun s -> FileAux.load_file s) + +(** Callbacks for the File menu *) + +module File = struct + +let newfile _ = + let session = create_session None in + let index = notebook#append_term session in + notebook#goto_page index + +let load ?parent _ = + let filename = + try notebook#current_term.fileops#filename + with Invalid_argument _ -> None in + match select_file_for_open ~title:"Load file" ?parent ?filename () with + | None -> () + | Some f -> FileAux.load_file f + +let save ?parent _ = on_current_term (FileAux.check_save ?parent ~saveas:false) + +let saveas ?parent sn = + try + let filename = sn.fileops#filename in + ignore (FileAux.select_and_save ?parent ~saveas:true ?filename sn) + with _ -> warning "Save Failed" + +let saveas ?parent = cb_on_current_term (saveas ?parent) + +let saveall _ = + List.iter + (fun sn -> match sn.fileops#filename with + | None -> () + | Some f -> ignore (sn.fileops#save f)) + notebook#pages + +let () = Coq.save_all := saveall + +let revert_all ?parent _ = + List.iter + (fun sn -> if sn.fileops#changed_on_disk then sn.fileops#revert ?parent ()) + notebook#pages + +let quit ?parent _ = + try FileAux.check_quit ?parent saveall; exit 0 + with FileAux.DontQuit -> () + +let close_buffer ?parent sn = + let do_remove () = notebook#remove_page notebook#current_page in + if not sn.buffer#modified then do_remove () + else + let answ = Configwin_ihm.question_box ~title:"Close" + ~buttons:["Save Buffer and Close"; + "Close without Saving"; + "Don't Close"] + ~default:0 + ~icon:(warn_image ())#coerce + ?parent + "This buffer has unsaved modifications" + in + match answ with + | 1 when FileAux.check_save ?parent ~saveas:true sn -> do_remove () + | 2 -> do_remove () + | _ -> () + +let close_buffer ?parent = cb_on_current_term (close_buffer ?parent) + +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 + let cmd = + local_cd f ^ cmd_coqdoc#get ^ " --" ^ kind ^ " -o " ^ + (Filename.quote output) ^ " " ^ (Filename.quote basef) ^ " 2>&1" + in + sn.messages#default_route#set (Pp.str ("Running: "^cmd)); + let finally st = flash_info (cmd ^ pr_exit_status st) + in + run_command (fun msg -> sn.messages#default_route#add_string msg) finally cmd + +let export kind = cb_on_current_term (export kind) + +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 ^ cmd_coqdoc#get ^ " -ps " ^ + Filename.quote (Filename.basename f_name) ^ " | " ^ cmd_print#get + in + let w = GWindow.window ~title:"Print" ~modal:true + ~position:`CENTER ~wmclass:("CoqIDE","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 () + +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 + +end + +(** Timers *) + +let reset_revert_timer () = + FileOps.revert_timer.kill (); + if global_auto_revert#get then + FileOps.revert_timer.run + ~ms:global_auto_revert_delay#get + ~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 auto_save#get then + FileOps.autosave_timer.run ~ms:auto_save_delay#get ~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 ^ cmd_coqmakefile#get in + let finally st = flash_info (cmd_coqmakefile#get ^ pr_exit_status st) + in + run_command ignore finally cmd + +let coq_makefile = cb_on_current_term coq_makefile + +let editor ?parent 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 cmd_editor#get f in + run_command ignore (fun _ -> sn.fileops#revert ?parent ()) cmd + +let editor ?parent = cb_on_current_term (editor ?parent) + +let compile sn = + File.save (); + match sn.fileops#filename with + |None -> flash_info "Active buffer has no name" + |Some f -> + let args = Coq.get_arguments sn.coqtop in + let cmd = cmd_coqc#get + ^ " " ^ String.concat " " args + ^ " " ^ (Filename.quote f) ^ " 2>&1" + in + let buf = Buffer.create 1024 in + sn.messages#default_route#set (Pp.str ("Running: "^cmd)); + let display s = + sn.messages#default_route#add_string 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#default_route#set (Pp.str "Compilation output:\n"); + sn.messages#default_route#add (Pp.str (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 ^ cmd_make#get ^ " 2>&1" in + sn.messages#default_route#set (Pp.str "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#default_route#add_string s; + Buffer.add_string last_make_buf s + in + let finally st = flash_info (cmd_make#get ^ 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]+\\)" + +let search_next_error () = + 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) + and e = int_of_string (Str.matched_group 4 !last_make) + and msg_index = Str.match_beginning () + in + last_make_index := Str.group_end 4; + (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#default_route#set (Pp.str error_msg); + sn.script#misc#grab_focus () + with Not_found -> + last_make_index := 0; + sn.messages#default_route#set (Pp.str "No more errors.\n") + +let next_error = cb_on_current_term next_error + +end + +(** 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 nanoPG#get then ", [μPG]" else "") ^ path ^ name); + Coq.return () + in + Coq.bind (Coq.status 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 CString.(Set.elements (Map.domain sn.jobpage#data)) + 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 *) + let buf1 = term.script#buffer in + let buf2 = term.proof#buffer in + if buf1#has_selection then + let (start, stop) = buf1#selection_bounds in + buf1#get_text ~slice:true ~start ~stop () + else if buf2#has_selection then + let (start, stop) = buf2#selection_bounds in + buf2#get_text ~slice:true ~start ~stop () + else if term.messages#has_selection then + term.messages#get_selected_text + (* Otherwise try to find the word around the cursor *) + else + let it = term.script#buffer#get_iter_at_mark `INSERT in + let start = find_word_start it in + let stop = find_word_end start in + term.script#buffer#get_text ~slice:true ~start ~stop () + +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 doquery query sn = + sn.messages#default_route#clear; + Coq.try_grab sn.coqtop (sn.coqops#raw_coq_query query ~route_id:0 + ~next:(function + | Interface.Fail (_, _, err) -> + let err = Ideutils.validate err in + sn.messages#default_route#add err; + Coq.return () + | Interface.Good () -> Coq.return ())) + ignore + +let queryif command sn = + Option.iter (fun query -> doquery (query ^ ".") sn) + begin try + let i = CString.string_index_from command 0 "..." in + let word = get_current_word sn in + if word = "" then None + else Some (CString.sub command 0 i ^ " " ^ word) + with Not_found -> Some command end + +let query command _ = cb_on_current_term (queryif command) () + +end + +(** Misc *) + +module MiscMenu = struct + +let detach_view sn = sn.control#detach () + +let detach_view = cb_on_current_term detach_view + +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 initial_about () = + let initial_string = + "Welcome to CoqIDE, an Integrated Development Environment for Coq" + in + 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#default_route#add_string 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 _ = + try dialog#set_logo (GdkPixbuf.from_file (coq_icon ())) + with _ -> () + in + let copyright = + "Coq is developed by the Coq Development Team\n\ + (INRIA - CNRS - LIX - LRI - PPS)" + in + let authors = [ + "Benjamin Monate"; + "Jean-Christophe Filliâtre"; + "Pierre Letouzey"; + "Claude Marché"; + "Bruno Barras"; + "Pierre Corbineau"; + "Julien Narboux"; + "Hugo Herbelin"; + "Enrico Tassi"; + ] + in + 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 apply_unicode_binding = + cb_on_current_term (fun t -> + t.script#apply_unicode_binding()) + +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 = String.split_on_char ' ' 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#default_route#clear in + sn.messages#default_route#push Feedback.Error (Pp.str msg) + else dialog#destroy () + in + let _ = entry#connect#activate ~callback:ok_cb in + let _ = ok#connect#clicked ~callback:ok_cb in + let cancel = GButton.button ~stock:`CANCEL ~packing:box#add () in + let cancel_cb () = dialog#destroy () in + let _ = cancel#connect#clicked ~callback: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#as_layout in + let fsize = Pango.Font.get_size (Pango.Font.from_string text_font#get) in + Pango.Layout.set_text layout (String.make cols 'X'); + let tlen = fst (Pango.Layout.get_pixel_size layout) in + Pango.Font.set_size (Pango.Font.from_string text_font#get) + (fsize * space / tlen / Pango.scale * Pango.scale); + save_pref () + +end + +(** Refresh functions *) + +let refresh_notebook_pos () = + let pos = match vertical_tabs#get, opposite_tabs#get with + | false, false -> `TOP + | false, true -> `BOTTOM + | true , false -> `LEFT + | true , true -> `RIGHT + in + notebook#set_tab_pos pos + +(** Wrappers around GAction functions for creating menus *) + +let menu = GAction.add_actions +let item = GAction.add_action +let radio = GAction.add_radio_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 ((^) modifier_for_display#get) k in + toggle_item name ~label ?accel ~active:d.Opt.init + ~callback:(printopts_callback d.Opt.opts) + menu_name + in + List.iter f l + +let no_under = Util.String.map (fun x -> if x = '_' then '-' else x) + +(** 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 mk_item text = + let text' = + let last = String.length text - 1 in + if text.[last] = '.' + then text ^"\n" + else text ^" " + in + let callback _ = + on_current_term (fun sn -> sn.buffer#insert_interactive text') + in + item (item_name^" "^(no_under text)) ~label:text ~callback menu_name + in + let mk_items = function + | [] -> () + | [s] -> mk_item s + | s::_ as ll -> + let name = Printf.sprintf "%s %c" item_name s.[0] in + let label = Printf.sprintf "_%c..." s.[0] in + item name ~label menu_name; + List.iter mk_item ll + in + 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 = modifier_for_templates#get 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) + +(** Create menu items for pairs (query, shortcut key). *) +let user_queries_items menu_name item_name l = + let mk_item (query, key) = + let callback = Query.query query in + let accel = if not (CString.is_empty key) then + Some (modifier_for_queries#get^key) else None in + item (item_name^" "^(no_under query)) ~label:query ?accel ~callback menu_name + in + List.iter mk_item l + +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 + ~wmclass:("CoqIde","CoqIde") + ~width:window_width#get ~height:window_height#get + ~title:"CoqIde" () + in + let () = + try w#set_icon (Some (GdkPixbuf.from_file (MiscMenu.coq_icon ()))) + with _ -> () + in + let _ = w#event#connect#delete ~callback:(fun _ -> File.quit ~parent:w (); 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 ~parent:w) ~stock:`OPEN; + item "Save" ~callback:(File.save ~parent:w) ~stock:`SAVE ~tooltip:"Save current buffer"; + item "Save as" ~label:"S_ave as" ~stock:`SAVE_AS ~callback:(File.saveas ~parent:w); + item "Save all" ~label:"Sa_ve all" ~callback:File.saveall; + item "Revert all buffers" ~label:"_Revert all buffers" + ~callback:(File.revert_all ~parent:w) ~stock:`REVERT_TO_SAVED; + item "Close buffer" ~label:"_Close buffer" ~stock:`CLOSE + ~callback:(File.close_buffer ~parent:w) ~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 ~parent:w); + ]; + + 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 "External editor" ~label:"External editor" ~stock:`EDIT + ~callback:(External.editor ~parent:w); + item "Preferences" ~accel:"<Ctrl>comma" ~stock:`PREFERENCES + ~callback:(fun _ -> + begin + try Preferences.configure ~apply:refresh_notebook_pos w + with e -> + flash_info ("Editing preferences failed (" ^ Printexc.to_string e ^ ")") + 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 _ -> + let ft = Pango.Font.from_string text_font#get in + Pango.Font.set_size ft (Pango.Font.get_size ft + Pango.scale); + text_font#set (Pango.Font.to_string ft); + save_pref ()); + item "Zoom out" ~label:"_Zoom out" ~accel:("<Control>minus") + ~stock:`ZOOM_OUT ~callback:(fun _ -> + let ft = Pango.Font.from_string text_font#get in + Pango.Font.set_size ft (Pango.Font.get_size ft - Pango.scale); + text_font#set (Pango.Font.to_string ft); + save_pref ()); + 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:(show_toolbar#get) + ~callback:(fun _ -> show_toolbar#set (not show_toolbar#get)); + item "Query Pane" ~label:"_Query Pane" + ~accel:"F1" + ~callback:(cb_on_current_term MiscMenu.show_hide_query_pane); + GAction.group_radio_actions + ~init_value:( + let v = diffs#get in + List.iter (fun o -> Opt.set o v) Opt.diff_item.Opt.opts; + if v = "on" then 1 + else if v = "removed" then 2 + else 0) + ~callback:begin fun n -> + (match n with + | 0 -> List.iter (fun o -> Opt.set o "off"; diffs#set "off") Opt.diff_item.Opt.opts + | 1 -> List.iter (fun o -> Opt.set o "on"; diffs#set "on") Opt.diff_item.Opt.opts + | 2 -> List.iter (fun o -> Opt.set o "removed"; diffs#set "removed") Opt.diff_item.Opt.opts + | _ -> assert false); + send_to_coq (fun sn -> sn.coqops#show_goals) + end + [ + radio "Unset diff" 0 ~label:"_Don't show diffs"; + radio "Set diff" 1 ~label:"Show diffs: only _added"; + radio "Set removed diff" 2 ~label:"Show diffs: added and _removed"; + ]; + ]; + toggle_items view_menu Coq.PrintOpt.bool_items; + + let navitem (text, label, stock, callback, tooltip, accel) = + let accel = modifier_for_navigation#get ^ accel in + item text ~label ~stock ~callback ~tooltip ~accel + in + menu navigation_menu begin + [ + (fun e -> item "Navigation" ~label:"_Navigation" e); + ] @ List.map navitem [ + ("Forward", "_Forward", `GO_DOWN, Nav.forward_one, "Forward one command", "Down"); + ("Backward", "_Backward", `GO_UP, Nav.backward_one, "Backward one command", "Up"); + ("Go to", "_Go to", `JUMP_TO, Nav.goto, "Go to cursor", "Right"); + ("Start", "_Start", `GOTO_TOP, Nav.restart, "Restart coq", "Home"); + ("End", "_End", `GOTO_BOTTOM, Nav.goto_end, "Go to end", "End"); + ("Interrupt", "_Interrupt", `STOP, Nav.interrupt, "Interrupt computations", "Break"); + (* wait for this available in GtkSourceView ! + ("Hide", "_Hide", `MISSING_IMAGE, + ~callback:(fun _ -> let sess = notebook#current_term in + toggle_proof_visibility sess.buffer sess.analyzed_view#get_insert), "Hide proof", "h"); *) + ("Previous", "_Previous", `GO_BACK, Nav.previous_occ, "Previous occurrence", "less"); + ("Next", "_Next", `GO_FORWARD, Nav.next_occ, "Next occurrence", "greater"); + ("Force", "_Force", `EXECUTE, Nav.join_document, "Fully check the document", "f"); + ] end; + + let tacitem s sc = + item s ~label:("_"^s) + ~accel:(modifier_for_tactics#get^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:(modifier_for_tactics#get^"dollar") + ~callback:(tactic_wizard_callback automatic_tactics#get); + 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\nQed.\n", 6,9, "J"); + template_item ("Theorem new_theorem : .\nProof.\n\nQed.\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:(modifier_for_templates#get^"M") + ~callback:match_callback + ]; + alpha_items templates_menu "Template" Coq_commands.commands; + + let qitem s sc = + let query = s ^ "..." in + item s ~label:("_"^s) + ~accel:(modifier_for_queries#get^sc) + ~callback:(Query.query query) + in + menu queries_menu [ + item "Queries" ~label:"_Queries"; + qitem "Search" "K"; + qitem "Check" "C"; + qitem "Print" "P"; + qitem "About" "A"; + qitem "Locate" "L"; + qitem "Print Assumptions" "N"; + ]; + user_queries_items queries_menu "User-Query" user_queries#get; + + 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; + item "LaTeX-to-unicode" ~label:"_LaTeX-to-unicode" ~accel:"<Shift>space" + ~callback:MiscMenu.apply_unicode_binding; + ]; + + 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#default_route#add_string Coq_config.wwwrefman); + item "Browse Coq Library" ~label:"Browse Coq _Library" + ~callback:(fun _ -> + browse notebook#current_term.messages#default_route#add_string Coq_config.wwwstdlib); + item "Help for keyword" ~label:"Help for _keyword" ~stock:`HELP + ~callback:(fun _ -> on_current_term (fun sn -> + browse_keyword sn.messages#default_route#add_string (get_current_word sn))); + item "Help for μPG mode" ~label:"Help for μPG mode" + ~callback:(fun _ -> on_current_term (fun sn -> + sn.messages#default_route#clear; + sn.messages#default_route#add_string (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 () = GtkButton.Toolbar.set + ~orientation:`HORIZONTAL ~style:`ICONS tbar + in + let toolbar = new GButton.toolbar tbar in + let () = vbox#pack toolbar#coerce in + + (* Emacs/PG mode *) + NanoPG.init w notebook all_menus; + + (* On tab switch, reset, update location *) + let _ = notebook#connect#switch_page ~callback:(fun n -> + let _ = if reset_on_tab_switch#get then Nav.restart () in + try + let session = notebook#get_nth_term n in + let ins = session.buffer#get_iter_at_mark `INSERT in + Ideutils.display_location ins + with _ -> ()) + in + + (* 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 nanoPG#get then ", [μPG]" else "") in + + (* Location display *) + let l = GMisc.label + ~text:"Line: 1 Char: 1" + ~packing:lower_hbox#pack () + in + let () = l#coerce#misc#set_name "location" in + let () = set_location := l#set_text in + + (* Progress Bar *) + 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 *) + let refresh_style style = + let style = style_manager#style_scheme style in + let iter_session v = v.script#source_buffer#set_style_scheme style in + List.iter iter_session notebook#pages + in + let refresh_language lang = + let lang = lang_manager#language lang in + let iter_session v = v.script#source_buffer#set_language lang in + List.iter iter_session notebook#pages + in + let refresh_toolbar b = + if b then toolbar#misc#show () else toolbar#misc#hide () + in + stick show_toolbar toolbar refresh_toolbar; + let _ = source_style#connect#changed ~callback:refresh_style in + let _ = source_language#connect#changed ~callback:refresh_language in + + (* Showtime ! *) + w#show (); + w + + +(** {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 + () + +let main files = + let w = build_ui () in + 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"; + w + +(** {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 overrides + this default coqtop path *) + +let read_coqide_args argv = + let rec filter_coqtop coqtop project_files bindings_files out = function + |"-unicode-bindings" :: sfilenames :: args -> + let filenames = Str.split (Str.regexp ",") sfilenames in + filter_coqtop coqtop project_files (filenames @ bindings_files) out args + |"-coqtop" :: prog :: args -> + if coqtop = None then filter_coqtop (Some prog) project_files bindings_files out args + else (output_string stderr "Error: multiple -coqtop options"; exit 1) + |"-f" :: file :: args -> + if project_files <> None then + (output_string stderr "Error: multiple -f options"; exit 1); + let d = CUnix.canonical_path_name (Filename.dirname file) in + let warning_fn x = Format.eprintf "%s@\n%!" x in + let p = CoqProject_file.read_project_file ~warning_fn file in + filter_coqtop coqtop (Some (d,p)) out bindings_files 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 bindings_files ("-debug"::out) args + |"-coqtop-flags" :: flags :: args-> + Coq.ideslave_coqtop_flags := Some flags; + filter_coqtop coqtop project_files bindings_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 bindings_files out args + |arg::args -> filter_coqtop coqtop project_files bindings_files (arg::out) args + |[] -> (coqtop,project_files,bindings_files,List.rev out) + in + let coqtop,project_files,bindings_files,argv = filter_coqtop None None [] [] argv in + Ideutils.custom_coqtop := coqtop; + custom_project_file := project_files; + Unicode_bindings.load_files bindings_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 ?parent () = + try + Sys.set_signal Sys.sigint (Sys.Signal_handle (File.quit ?parent)); + 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 new file mode 100644 index 0000000000..1d438ec381 --- /dev/null +++ b/ide/coqide.mli @@ -0,0 +1,44 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** * The CoqIde main module *) + +(** The arguments that will be passed to coqtop. No quoting here, since + no /bin/sh when using create_process instead of open_process. *) +val sup_args : string list ref + +(** In debug mode under win32, messages are written to a log file *) +val logfile : string option ref + +(** Filter the argv from coqide specific options, and set + Minilib.coqtop_path accordingly *) +val read_coqide_args : string list -> string list + +(** Prepare the widgets, load the given files in tabs *) +val main : string list -> GWindow.window + +(** Function to save anything and kill all coqtops + @return [false] if you're allowed to quit. *) +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 perform a clean quit at Ctrl-C, while launching + [crash_save] and exiting for others received signals *) +val set_signal_handlers : ?parent:GWindow.window -> unit -> unit + +(** Emergency saving of opened files as "foo.v.crashcoqide", + and exit (if the integer isn't 127). *) +val crash_save : int -> unit diff --git a/ide/coqide_QUARTZ.ml.in b/ide/coqide_QUARTZ.ml.in new file mode 100644 index 0000000000..a08bac5772 --- /dev/null +++ b/ide/coqide_QUARTZ.ml.in @@ -0,0 +1,37 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +let osx = GosxApplication.osxapplication () + +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 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 () diff --git a/ide/coqide_WIN32.ml.in b/ide/coqide_WIN32.ml.in new file mode 100644 index 0000000000..0793a1cc1c --- /dev/null +++ b/ide/coqide_WIN32.ml.in @@ -0,0 +1,49 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* On win32, we add the directory of coqide to the PATH at launch-time + (this used to be done in a .bat script). *) + +let set_win32_path () = + Unix.putenv "PATH" + (Filename.dirname Sys.executable_name ^ ";" ^ + (try Sys.getenv "PATH" with _ -> "")) + +(* 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 + +(* We also provide a specific interrupt function. *) + +external win32_interrupt : int -> unit = "win32_interrupt" +let () = + Coq.gio_channel_of_descr_socket := Glib.Io.channel_of_descr_socket; + set_win32_path (); + Coq.interrupter := win32_interrupt; + reroute_stdout_stderr () + +let init () = () diff --git a/ide/coqide_X11.ml.in b/ide/coqide_X11.ml.in new file mode 100644 index 0000000000..6a5784eac3 --- /dev/null +++ b/ide/coqide_X11.ml.in @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +let init () = () diff --git a/ide/coqide_main.ml b/ide/coqide_main.ml new file mode 100644 index 0000000000..79420b3857 --- /dev/null +++ b/ide/coqide_main.ml @@ -0,0 +1,72 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +let _ = Coqide.set_signal_handlers () + +(* We handle Gtk warning messages ourselves : + - on win32, we don't want them to end on a non-existing console + - we display critical messages via pop-ups *) + +let catch_gtk_messages () = + let all_levels = + [`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 + 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) + in + List.iter catch ["GLib";"Gtk";"Gdk";"Pango"] + +let () = catch_gtk_messages () + +let load_prefs () = + try Preferences.load_pref () + with e -> Ideutils.flash_info + ("Could not load preferences ("^Printexc.to_string e^").") + +let () = + 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 argl in + let args = List.filter (fun x -> not (List.mem x files)) argl in + Coq.check_connection args; + Coqide.sup_args := args; + let w = Coqide.main files in + Coqide.set_signal_handlers ~parent:w (); + Coqide_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_main.mli b/ide/coqide_main.mli new file mode 100644 index 0000000000..9db9ecd12e --- /dev/null +++ b/ide/coqide_main.mli @@ -0,0 +1,12 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This empty file avoids a race condition that occurs when compiling a .ml file + that does not have a corresponding .mli file *) diff --git a/ide/coqide_os_specific.mli b/ide/coqide_os_specific.mli new file mode 100644 index 0000000000..ebd09099f0 --- /dev/null +++ b/ide/coqide_os_specific.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val init : unit -> unit diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml new file mode 100644 index 0000000000..d4a339f4f5 --- /dev/null +++ b/ide/coqide_ui.ml @@ -0,0 +1,184 @@ +let ui_m = GAction.ui_manager ();; + +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 + let tactic_item = function + |[] -> Buffer.create 1 + |[s] -> let b = Buffer.create 16 in + let () = Buffer.add_string b ("<menuitem action='"^menu^" "^(no_under s)^"' />\n") in + b + |s::_ as l -> let b = Buffer.create 50 in + let () = (Buffer.add_string b ("<menu action='"^menu^" "^(String.make 1 s.[0])^"'>\n")) in + let () = (List.iter + (fun x -> Buffer.add_string b ("<menuitem action='"^menu^" "^(no_under x)^"' />\n")) l) in + let () = Buffer.add_string b"</menu>\n" in + b in + let () = List.iter (fun b -> Buffer.add_buffer res_buf (tactic_item b)) li in + res_buf + +let list_queries menu li = + let res_buf = Buffer.create 500 in + let query_item (q, _) = + let s = "<menuitem action='"^menu^" "^(no_under q)^"' />\n" in + Buffer.add_string res_buf s + in + let () = List.iter query_item li in + res_buf + +let init () = + let theui = Printf.sprintf "<ui>\ +\n<menubar name='CoqIde MenuBar'>\ +\n <menu action='File'>\ +\n <menuitem action='New' />\ +\n <menuitem action='Open' />\ +\n <menuitem action='Save' />\ +\n <menuitem action='Save as' />\ +\n <menuitem action='Save all' />\ +\n <menuitem action='Revert all buffers' />\ +\n <menuitem action='Close buffer' />\ +\n <menuitem action='Print...' />\ +\n <menu action='Export to'>\ +\n <menuitem action='Html' />\ +\n <menuitem action='Latex' />\ +\n <menuitem action='Dvi' />\ +\n <menuitem action='Pdf' />\ +\n <menuitem action='Ps' />\ +\n </menu>\ +\n <menuitem action='Rehighlight' />\ +\n %s\ +\n </menu>\ +\n <menu name='Edit' action='Edit'>\ +\n <menuitem action='Undo' />\ +\n <menuitem action='Redo' />\ +\n <separator />\ +\n <menuitem action='Cut' />\ +\n <menuitem action='Copy' />\ +\n <menuitem action='Paste' />\ +\n <separator />\ +\n <menuitem action='Find' />\ +\n <menuitem action='Find Next' />\ +\n <menuitem action='Find Previous' />\ +\n <separator />\ +\n <menuitem action='External editor' />\ +\n <separator />\ +\n <menuitem name='Prefs' action='Preferences' />\ +\n </menu>\ +\n <menu name='View' action='View'>\ +\n <menuitem action='Previous tab' />\ +\n <menuitem action='Next tab' />\ +\n <separator/>\ +\n <menuitem action='Zoom in' />\ +\n <menuitem action='Zoom out' />\ +\n <menuitem action='Zoom fit' />\ +\n <separator/>\ +\n <menuitem action='Show Toolbar' />\ +\n <menuitem action='Query Pane' />\ +\n <separator/>\ +\n <menuitem action='Display implicit arguments' />\ +\n <menuitem action='Display coercions' />\ +\n <menuitem action='Display raw matching expressions' />\ +\n <menuitem action='Display notations' />\ +\n <menuitem action='Display all basic low-level contents' />\ +\n <menuitem action='Display existential variable instances' />\ +\n <menuitem action='Display universe levels' />\ +\n <menuitem action='Display all low-level contents' />\ +\n <menuitem action='Display unfocused goals' />\ +\n <separator/>\ +\n <menuitem action='Unset diff' />\ +\n <menuitem action='Set diff' />\ +\n <menuitem action='Set removed diff' />\ +\n </menu>\ +\n <menu action='Navigation'>\ +\n <menuitem action='Forward' />\ +\n <menuitem action='Backward' />\ +\n <menuitem action='Go to' />\ +\n <menuitem action='Start' />\ +\n <menuitem action='End' />\ +\n <menuitem action='Interrupt' />\ +\n <menuitem action='Previous' />\ +\n <menuitem action='Next' />\ +\n </menu>\ +\n <menu action='Try Tactics'>\ +\n <menuitem action='auto' />\ +\n <menuitem action='auto with *' />\ +\n <menuitem action='eauto' />\ +\n <menuitem action='eauto with *' />\ +\n <menuitem action='intuition' />\ +\n <menuitem action='omega' />\ +\n <menuitem action='simpl' />\ +\n <menuitem action='tauto' />\ +\n <menuitem action='trivial' />\ +\n <menuitem action='Wizard' />\ +\n <separator />\ +\n %s\ +\n </menu>\ +\n <menu action='Templates'>\ +\n <menuitem action='Lemma' />\ +\n <menuitem action='Theorem' />\ +\n <menuitem action='Definition' />\ +\n <menuitem action='Inductive' />\ +\n <menuitem action='Fixpoint' />\ +\n <menuitem action='Scheme' />\ +\n <menuitem action='match' />\ +\n <separator />\ +\n %s\ +\n </menu>\ +\n <menu action='Queries'>\ +\n <menuitem action='Search' />\ +\n <menuitem action='Check' />\ +\n <menuitem action='Print' />\ +\n <menuitem action='About' />\ +\n <menuitem action='Locate' />\ +\n <menuitem action='Print Assumptions' />\ +\n <separator />\ +\n %s\ +\n </menu>\ +\n <menu name='Tools' action='Tools'>\ +\n <menuitem action='Comment' />\ +\n <menuitem action='Uncomment' />\ +\n <separator />\ +\n <menuitem action='Coqtop arguments' />\ +\n <separator />\ +\n <menuitem action='LaTeX-to-unicode' />\ +\n </menu>\ +\n <menu action='Compile'>\ +\n <menuitem action='Compile buffer' />\ +\n <menuitem action='Make' />\ +\n <menuitem action='Next error' />\ +\n <menuitem action='Make makefile' />\ +\n </menu>\ +\n <menu action='Windows'>\ +\n <menuitem action='Detach View' />\ +\n </menu>\ +\n <menu name='Help' action='Help'>\ +\n <menuitem action='Browse Coq Manual' />\ +\n <menuitem action='Browse Coq Library' />\ +\n <menuitem action='Help for keyword' />\ +\n <menuitem action='Help for μPG mode' />\ +\n <separator />\ +\n <menuitem name='Abt' action='About Coq' />\ +\n </menu>\ +\n</menubar>\ +\n<toolbar name='CoqIde ToolBar'>\ +\n <toolitem action='Save' />\ +\n <toolitem action='Close buffer' />\ +\n <toolitem action='Forward' />\ +\n <toolitem action='Backward' />\ +\n <toolitem action='Go to' />\ +\n <toolitem action='Start' />\ +\n <toolitem action='End' />\ +\n <toolitem action='Force' />\ +\n <toolitem action='Interrupt' />\ +\n <toolitem action='Previous' />\ +\n <toolitem action='Next' />\ +\n <toolitem action='Wizard' />\ +\n</toolbar>\ +\n</ui>" + (if Coq_config.gtk_platform <> `QUARTZ then "<menuitem action='Quit' />" else "") + (Buffer.contents (list_items "Tactic" Coq_commands.tactics)) + (Buffer.contents (list_items "Template" Coq_commands.commands)) + (Buffer.contents (list_queries "User-Query" Preferences.user_queries#get)) + in + ignore (ui_m#add_ui_from_string theui); diff --git a/ide/coqide_ui.mli b/ide/coqide_ui.mli new file mode 100644 index 0000000000..afc5447aba --- /dev/null +++ b/ide/coqide_ui.mli @@ -0,0 +1,12 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val init : unit -> unit +val ui_m : GAction.ui_manager diff --git a/ide/default_bindings_src.ml b/ide/default_bindings_src.ml new file mode 100644 index 0000000000..85a635a50f --- /dev/null +++ b/ide/default_bindings_src.ml @@ -0,0 +1,2899 @@ +(** Usage + ocamlc default_bindings_src.ml -o generator.out + ./generator.out output_filename +*) + +(** **************************************************************************) +(** * Classifiers *) + +(** Note: for future use *) + +let logic = "logic" +let symbol = "symbols" +let fraction = "fractions" +let letter = "letters" +let greek_letter = "greek letter" +let asciiart = "ASCII art" +let equivalence = "equivalence relations" +let order = "order relations" +let circle = "circles" +let square = "squares" +let triangle = "triangles" +let arrow = "arrows" +let set = "set theory" +let math = "mathematics" +let space = "spaces" +let delimiter = "parentheses and delimiters" +let miscellanea = "miscellanea" + + +(** **************************************************************************) +(** * Bindings set 1 *) + +let bindings_set_1 = [ + +(* {{{ logics *) + ["\\not"; "\\neg"; "\\lnot" ], "¬", [logic]; + ["\\ForAll"; "\\forall" ], "∀", [logic]; + ["\\exist"; "\\Exists"; "\\exists" ], "∃", [logic]; + ["\\nexist"; "\\nexists"; "\\NotExists" ], "∄", [logic]; + ["\\and"; "\\land"; "\\wedge" ], "∧", [logic]; + ["\\or"; "\\vee"; "\\lor" ], "∨", [logic]; + ["\\vdash"; "\\RightTee" ], "⊢", [logic]; + ["\\dashv"; "\\LeftTee" ], "⊣", [logic]; + ["\\top"; "\\DownTee" ], "⊤", [logic]; + ["\\bot"; "\\perp"; "\\UpTee"; "\\bottom" ], "⊥", [logic]; + ["\\models" ], "⊧", [logic]; + ["\\vDash"; "\\DoubleRightTee" ], "⊨", [logic]; + ["\\Vdash" ], "⊩", [logic]; + ["\\Vvdash" ], "⊪", [logic]; + ["\\VDash" ], "⊫", [logic]; + ["\\nvdash" ], "⊬", [logic]; + ["\\nvDash" ], "⊭", [logic]; + ["\\nVdash" ], "⊮", [logic]; + ["\\nVDash" ], "⊯", [logic]; + ["\\Wedge"; "\\xwedge"; "\\bigwedge" ], "⋀", [logic]; + ["\\Vee"; "\\xvee"; "\\bigvee" ], "⋁", [logic]; +(* }}} *) + +(* {{{ symbols *) + ["\\cent" ], "¢", [symbol]; + ["\\pound" ], "£", [symbol]; + ["\\curren" ], "¤", [symbol]; + ["\\yen" ], "¥", [symbol]; + ["\\brvbar" ], "¦", [symbol]; + ["\\sect" ], "§", [symbol]; + ["\\uml"; "\\die"; "\\Dot"; "\\DoubleDot" ], "¨", [symbol]; + ["\\macr"; "\\OverBar" ], "¯", [symbol]; + ["\\sup" ], "^", [symbol]; + ["\\sup2" ], "²", [symbol]; + ["\\sup3" ], "³", [symbol]; + ["\\acute"; "\\DiacriticalAcute" ], "´", [symbol]; + ["\\para" ], "¶", [symbol]; + ["\\middot"; "\\centerdot"; "\\CenterDot" ], "·", [symbol]; + ["\\cedil"; "\\Cedilla" ], "¸", [symbol]; + ["\\sup1" ], "¹", [symbol]; + ["\\iquest" ], "¿", [symbol]; + ["\\thorn" ], "þ", [symbol]; + ["\\imath"; "\\inodot" ], "ı", [symbol]; + ["\\Hacek"; "\\caron" ], "ˇ", [symbol]; + ["\\Breve"; "\\breve" ], "˘", [symbol]; + ["\\dot"; "\\DiacriticalDot" ], "˙", [symbol]; + ["\\ogon" ], "˛", [symbol]; + ["\\tilde"; "\\DiacriticalTilde" ], "˜", [symbol]; + ["\\dblac"; "\\DiacriticalDoubleAcute" ], "˝", [symbol]; + ["\\Hat" ], "̂", [symbol]; + ["\\DownBreve" ], "̑", [symbol]; + ["\\UnderBar" ], "̲", [symbol]; + ["\\dash"; "\\hyphen" ], "‐", [symbol]; + ["\\ndash" ], "–", [symbol]; + ["\\mdash" ], "—", [symbol]; + ["\\horbar" ], "―", [symbol]; + ["\\Vert"; "\\Verbar" ], "‖", [symbol]; + ["\\lsquo"; "\\OpenCurlyQuote" ], "‘", [symbol]; + ["\\rsquo"; "\\rsquor"; "\\CloseCurlyQuote" ], "’", [symbol]; + ["\\lsquor" ], "‚", [symbol]; + ["\\ldquo"; "\\OpenCurlyDoubleQuote" ], "“", [symbol]; + ["\\rdquo"; "\\rdquor"; "\\CloseCurlyDoubleQuote" ], "”", [symbol]; + ["\\ldquor" ], "„", [symbol]; + ["\\dagger" ], "†", [symbol]; + ["\\Dagger"; "\\ddagger" ], "‡", [symbol]; + ["\\nldr" ], "‥", [symbol]; + ["\\mldr"; "\\dots"; "\\ldots"; "\\hellip" ], "…", [symbol]; + ["\\prime" ], "′", [symbol]; + ["\\Prime" ], "″", [symbol]; + ["\\tprime" ], "‴", [symbol]; + ["\\bprime"; "\\backprime" ], "‵", [symbol]; + ["\\caret" ], "⁁", [symbol]; + ["\\hybull" ], "⁃", [symbol]; + ["\\bsemi" ], "⁏", [symbol]; + ["\\qprime" ], "⁗", [symbol]; + ["\\MediumSpace" ], " ", [symbol]; + ["\\tdot"; "\\TripleDot" ], "⃛", [symbol]; + ["\\DotDot" ], "⃜", [symbol]; + ["\\minus" ], "−", [symbol]; + ["\\angrt" ], "∟", [symbol]; + ["\\ang"; "\\angle" ], "∠", [symbol]; + ["\\nang" ], "∠̸", [symbol]; + ["\\angmsd"; "\\measuredangle" ], "∡", [symbol]; + ["\\angsph" ], "∢", [symbol]; + ["\\par"; "\\parallel"; "\\DoubleVerticalBar" ], "∥", [symbol]; + ["\\there4"; "\\Therefore"; "\\therefore" ], "∴", [symbol]; + ["\\becaus"; "\\because"; "\\Because" ], "∵", [symbol]; + ["\\ratio" ], "∶", [symbol]; + ["\\Colon"; "\\Proportion" ], "∷", [symbol]; + ["\\minusd"; "\\dotminus" ], "∸", [symbol]; + ["\\mDDot" ], "∺", [symbol]; + ["\\homtht" ], "∻", [symbol]; + ["\\sim"; "\\Tilde" ], "∼", [symbol]; + ["\\mstpos" ], "∾", [symbol]; + ["\\acd" ], "∿", [symbol]; + ["\\wr"; "\\wreath"; "\\VerticalTilde" ], "≀", [symbol]; + ["\\origof" ], "⊶", [symbol]; + ["\\imof" ], "⊷", [symbol]; + ["\\mumap"; "\\multimap" ], "⊸", [symbol]; + ["\\hercon" ], "⊹", [symbol]; + ["\\intcal"; "\\intercal" ], "⊺", [symbol]; + ["\\veebar" ], "⊻", [symbol]; + ["\\barwed"; "\\barwedge" ], "⊼", [symbol]; + ["\\barvee" ], "⊽", [symbol]; + ["\\vangrt" ], "⊾", [symbol]; + ["\\lrtri" ], "⊿", [symbol]; + ["\\diam"; "\\Diamond"; "\\diamond" ], "⋄", [symbol]; + ["\\sdot" ], "⋅", [symbol]; + ["\\Star"; "\\star"; "\\sstarf" ], "⋆", [symbol]; + ["\\divonx"; "\\divideontimes" ], "⋇", [symbol]; + ["\\bowtie" ], "⋈", [symbol]; + ["\\ltimes" ], "⋉", [symbol]; + ["\\rtimes" ], "⋊", [symbol]; + ["\\lthree"; "\\leftthreetimes" ], "⋋", [symbol]; + ["\\rthree"; "\\rightthreetimes" ], "⋌", [symbol]; + ["\\cuvee"; "\\curlyvee" ], "⋎", [symbol]; + ["\\cuwed"; "\\curlywedge" ], "⋏", [symbol]; + ["\\fork"; "\\pitchfork" ], "⋔", [symbol]; + ["\\epar" ], "⋕", [symbol]; + ["\\vdots"; "\\vellip" ], "⋮", [symbol]; + ["\\cdots"; "\\ctdot" ], "⋯", [symbol]; + ["\\utdot" ], "⋰", [symbol]; + ["\\ddots"; "\\dtdot" ], "⋱", [symbol]; + ["\\Barwed"; "\\doublebarwedge" ], "⌆", [symbol]; + ["\\bnot" ], "⌐", [symbol]; + ["\\profline" ], "⌒", [symbol]; + ["\\profsurf" ], "⌓", [symbol]; + ["\\telrec" ], "⌕", [symbol]; + ["\\frown" ], "⌢", [symbol]; + ["\\smile" ], "⌣", [symbol]; + ["\\blank" ], "␣", [symbol]; + ["\\HorizontalLine" ], "─", [symbol]; + ["\\loz"; "\\lozenge" ], "◊", [symbol]; + ["\\starf"; "\\bigstar" ], "★", [symbol]; + ["\\phone" ], "☎", [symbol]; + ["\\female" ], "♀", [symbol]; + ["\\male" ], "♂", [symbol]; + ["\\spades"; "\\spadesuit" ], "♠", [symbol]; + ["\\heartsuit" ], "♡", [symbol]; + ["\\diamondsuit" ], "♢", [symbol]; + ["\\clubs"; "\\clubsuit" ], "♣", [symbol]; + ["\\diams" ], "♦", [symbol]; + ["\\sung" ], "♪", [symbol]; + ["\\flat" ], "♭", [symbol]; + ["\\natur"; "\\natural" ], "♮", [symbol]; + ["\\sharp" ], "♯", [symbol]; + ["\\check"; "\\checkmark" ], "✓", [symbol]; + ["\\cross" ], "✗", [symbol]; + ["\\malt"; "\\maltese" ], "✠", [symbol]; + ["\\sext" ], "✶", [symbol]; + ["\\VerticalSeparator" ], "❘", [symbol]; + ["\\lozf"; "\\blacklozenge" ], "⧫", [symbol]; + ["\\OverParenthesis" ], "︵", [symbol]; + ["\\UnderParenthesis" ], "︶", [symbol]; + ["\\OverBrace" ], "︷", [symbol]; + ["\\UnderBrace" ], "︸", [symbol]; + ["\\Yang" ], "⚊", [symbol]; +(* }}} *) + +(* {{{ fraction *) + ["\\frac14" ], "¼", [fraction]; + ["\\half"; "\\frac" ], "½", [fraction]; + ["\\frac34" ], "¾", [fraction]; + ["\\permil" ], "‰", [fraction]; + ["\\pertenk" ], "‱", [fraction]; + ["\\incare" ], "℅", [fraction]; + ["\\frac13" ], "⅓", [fraction]; + ["\\frac23" ], "⅔", [fraction]; + ["\\frac15" ], "⅕", [fraction]; + ["\\frac25" ], "⅖", [fraction]; + ["\\frac35" ], "⅗", [fraction]; + ["\\frac45" ], "⅘", [fraction]; + ["\\frac16" ], "⅙", [fraction]; + ["\\frac56" ], "⅚", [fraction]; + ["\\frac18" ], "⅛", [fraction]; + ["\\frac38" ], "⅜", [fraction]; + ["\\frac58" ], "⅝", [fraction]; + ["\\frac78" ], "⅞", [fraction]; +(* }}} *) + +(* {{{ greek letters *) + ["\\alpha" ], "α", [greek_letter]; + ["\\beta" ], "β", [greek_letter]; + ["\\gamma" ], "γ", [greek_letter]; + ["\\delta" ], "δ", [greek_letter]; + ["\\epsilon" ], "ϵ", [greek_letter]; + ["\\varepsilon"; "\\straightepsilon" ], "ε", [greek_letter]; + ["\\epsiv" ], "ɛ", [greek_letter]; + ["\\bepsi"; "\\backepsilon" ], "϶", [greek_letter]; + ["\\zeta" ], "ζ", [greek_letter]; + ["\\eta" ], "η", [greek_letter]; + ["\\theta" ], "θ", [greek_letter]; + ["\\vartheta" ], "ϑ", [greek_letter]; + ["\\iota" ], "ι", [greek_letter]; + ["\\kappa" ], "κ", [greek_letter]; + ["\\varkappa" ], "ϰ", [greek_letter]; + ["\\lambda" ], "λ", [greek_letter]; + ["\\mu" ], "μ", [greek_letter]; + ["\\nu" ], "ν", [greek_letter]; + ["\\xi" ], "ξ", [greek_letter]; + ["\\o" ], "ο", [greek_letter]; + ["\\pi" ], "π", [greek_letter]; + ["\\varpi" ], "ϖ", [greek_letter]; + ["\\rho" ], "ρ", [greek_letter]; + ["\\varrho" ], "ϱ", [greek_letter]; + ["\\sigma" ], "σ", [greek_letter]; + ["\\varsigma" ], "ς", [greek_letter]; + ["\\tau" ], "τ", [greek_letter]; + ["\\upsilon" ], "υ", [greek_letter]; + ["\\phi" ], "ϕ", [greek_letter]; + ["\\varphi"; "\\straightphi" ], "φ", [greek_letter]; + ["\\chi" ], "χ", [greek_letter]; + ["\\psi" ], "ψ", [greek_letter]; + ["\\omega" ], "ω", [greek_letter]; + ["\\Gamma" ], "Γ", [greek_letter]; + ["\\Gammad"; "\\gammad"; "\\digamma" ], "Ϝ", [greek_letter]; + ["\\Delta" ], "Δ", [greek_letter]; + ["\\Theta" ], "Θ", [greek_letter]; + ["\\Lambda" ], "Λ", [greek_letter]; + ["\\Xi" ], "Ξ", [greek_letter]; + ["\\Pi" ], "Π", [greek_letter]; + ["\\Sigma" ], "Σ", [greek_letter]; + ["\\Upsilon" ], "ϒ", [greek_letter]; + ["\\Phi" ], "Φ", [greek_letter]; + ["\\Psi" ], "Ψ", [greek_letter]; + ["\\Omega" ], "Ω", [greek_letter]; +(* }}} *) + +(* {{{ letters *) + ["\\iexcl" ], "¡", [letter]; + ["\\ordf" ], "ª", [letter]; + ["\\micro" ], "µ", [letter]; + ["\\Agrave" ], "À", [letter]; + ["\\Aacute" ], "Á", [letter]; + ["\\Acirc" ], "Â", [letter]; + ["\\Atilde" ], "Ã", [letter]; + ["\\Auml" ], "Ä", [letter]; + ["\\Aring" ], "Å", [letter]; + ["\\AElig" ], "Æ", [letter]; + ["\\Ccedil" ], "Ç", [letter]; + ["\\Egrave" ], "È", [letter]; + ["\\Eacute" ], "É", [letter]; + ["\\Ecirc" ], "Ê", [letter]; + ["\\Euml" ], "Ë", [letter]; + ["\\Igrave" ], "Ì", [letter]; + ["\\Iacute" ], "Í", [letter]; + ["\\Icirc" ], "Î", [letter]; + ["\\Iuml" ], "Ï", [letter]; + ["\\ETH" ], "Ð", [letter]; + ["\\Ntilde" ], "Ñ", [letter]; + ["\\Ograve" ], "Ò", [letter]; + ["\\Oacute" ], "Ó", [letter]; + ["\\Ocirc" ], "Ô", [letter]; + ["\\Otilde" ], "Õ", [letter]; + ["\\Ouml" ], "Ö", [letter]; + ["\\Oslash" ], "Ø", [letter]; + ["\\Ugrave" ], "Ù", [letter]; + ["\\Uacute" ], "Ú", [letter]; + ["\\Ucirc" ], "Û", [letter]; + ["\\Uuml" ], "Ü", [letter]; + ["\\Yacute" ], "Ý", [letter]; + ["\\THORN" ], "Þ", [letter]; + ["\\szlig" ], "ß", [letter]; + ["\\agrave" ], "à", [letter]; + ["\\aacute" ], "á", [letter]; + ["\\acirc" ], "â", [letter]; + ["\\atilde" ], "ã", [letter]; + ["\\auml" ], "ä", [letter]; + ["\\aring" ], "å", [letter]; + ["\\aelig" ], "æ", [letter]; + ["\\ccedil" ], "ç", [letter]; + ["\\egrave" ], "è", [letter]; + ["\\eacute" ], "é", [letter]; + ["\\ecirc" ], "ê", [letter]; + ["\\euml" ], "ë", [letter]; + ["\\igrave" ], "ì", [letter]; + ["\\iacute" ], "í", [letter]; + ["\\icirc" ], "î", [letter]; + ["\\iuml" ], "ï", [letter]; + ["\\eth" ], "ð", [letter]; + ["\\ntilde" ], "ñ", [letter]; + ["\\ograve" ], "ò", [letter]; + ["\\oacute" ], "ó", [letter]; + ["\\ocirc" ], "ô", [letter]; + ["\\otilde" ], "õ", [letter]; + ["\\ouml" ], "ö", [letter]; + ["\\ugrave" ], "ù", [letter]; + ["\\uacute" ], "ú", [letter]; + ["\\ucirc" ], "û", [letter]; + ["\\uuml" ], "ü", [letter]; + ["\\yacute" ], "ý", [letter]; + ["\\yuml" ], "ÿ", [letter]; + ["\\Amacr" ], "Ā", [letter]; + ["\\amacr" ], "ā", [letter]; + ["\\Abreve" ], "Ă", [letter]; + ["\\abreve" ], "ă", [letter]; + ["\\Aogon" ], "Ą", [letter]; + ["\\aogon" ], "ą", [letter]; + ["\\Cacute" ], "Ć", [letter]; + ["\\cacute" ], "ć", [letter]; + ["\\Ccirc" ], "Ĉ", [letter]; + ["\\ccirc" ], "ĉ", [letter]; + ["\\Cdot" ], "Ċ", [letter]; + ["\\cdot" ], "ċ", [letter]; + ["\\Ccaron" ], "Č", [letter]; + ["\\ccaron" ], "č", [letter]; + ["\\Dcaron" ], "Ď", [letter]; + ["\\dcaron" ], "ď", [letter]; + ["\\Dstrok" ], "Đ", [letter]; + ["\\dstrok" ], "đ", [letter]; + ["\\Emacr" ], "Ē", [letter]; + ["\\emacr" ], "ē", [letter]; + ["\\Edot" ], "Ė", [letter]; + ["\\edot" ], "ė", [letter]; + ["\\Eogon" ], "Ę", [letter]; + ["\\eogon" ], "ę", [letter]; + ["\\Ecaron" ], "Ě", [letter]; + ["\\ecaron" ], "ě", [letter]; + ["\\Gcirc" ], "Ĝ", [letter]; + ["\\gcirc" ], "ĝ", [letter]; + ["\\Gbreve" ], "Ğ", [letter]; + ["\\gbreve" ], "ğ", [letter]; + ["\\Gdot" ], "Ġ", [letter]; + ["\\gdot" ], "ġ", [letter]; + ["\\Gcedil" ], "Ģ", [letter]; + ["\\Hcirc" ], "Ĥ", [letter]; + ["\\hcirc" ], "ĥ", [letter]; + ["\\Hstrok" ], "Ħ", [letter]; + ["\\hstrok" ], "ħ", [letter]; + ["\\Itilde" ], "Ĩ", [letter]; + ["\\itilde" ], "ĩ", [letter]; + ["\\Imacr" ], "Ī", [letter]; + ["\\imacr" ], "ī", [letter]; + ["\\Iogon" ], "Į", [letter]; + ["\\iogon" ], "į", [letter]; + ["\\Idot" ], "İ", [letter]; + ["\\IJlig" ], "IJ", [letter]; + ["\\ijlig" ], "ij", [letter]; + ["\\Jcirc" ], "Ĵ", [letter]; + ["\\jcirc" ], "ĵ", [letter]; + ["\\Kcedil" ], "Ķ", [letter]; + ["\\kcedil" ], "ķ", [letter]; + ["\\kgreen" ], "ĸ", [letter]; + ["\\Lacute" ], "Ĺ", [letter]; + ["\\lacute" ], "ĺ", [letter]; + ["\\Lcedil" ], "Ļ", [letter]; + ["\\lcedil" ], "ļ", [letter]; + ["\\Lcaron" ], "Ľ", [letter]; + ["\\lcaron" ], "ľ", [letter]; + ["\\Lmidot" ], "Ŀ", [letter]; + ["\\lmidot" ], "ŀ", [letter]; + ["\\Lstrok" ], "Ł", [letter]; + ["\\lstrok" ], "ł", [letter]; + ["\\Nacute" ], "Ń", [letter]; + ["\\nacute" ], "ń", [letter]; + ["\\Ncedil" ], "Ņ", [letter]; + ["\\ncedil" ], "ņ", [letter]; + ["\\Ncaron" ], "Ň", [letter]; + ["\\ncaron" ], "ň", [letter]; + ["\\napos" ], "ʼn", [letter]; + ["\\ENG" ], "Ŋ", [letter]; + ["\\eng" ], "ŋ", [letter]; + ["\\Omacr" ], "Ō", [letter]; + ["\\omacr" ], "ō", [letter]; + ["\\Odblac" ], "Ő", [letter]; + ["\\odblac" ], "ő", [letter]; + ["\\OElig" ], "Œ", [letter]; + ["\\oelig" ], "œ", [letter]; + ["\\Racute" ], "Ŕ", [letter]; + ["\\racute" ], "ŕ", [letter]; + ["\\Rcedil" ], "Ŗ", [letter]; + ["\\rcedil" ], "ŗ", [letter]; + ["\\Rcaron" ], "Ř", [letter]; + ["\\rcaron" ], "ř", [letter]; + ["\\Sacute" ], "Ś", [letter]; + ["\\sacute" ], "ś", [letter]; + ["\\Scirc" ], "Ŝ", [letter]; + ["\\scirc" ], "ŝ", [letter]; + ["\\Scedil" ], "Ş", [letter]; + ["\\scedil" ], "ş", [letter]; + ["\\Scaron" ], "Š", [letter]; + ["\\scaron" ], "š", [letter]; + ["\\Tcedil" ], "Ţ", [letter]; + ["\\tcedil" ], "ţ", [letter]; + ["\\Tcaron" ], "Ť", [letter]; + ["\\tcaron" ], "ť", [letter]; + ["\\Tstrok" ], "Ŧ", [letter]; + ["\\tstrok" ], "ŧ", [letter]; + ["\\Utilde" ], "Ũ", [letter]; + ["\\utilde" ], "ũ", [letter]; + ["\\Umacr" ], "Ū", [letter]; + ["\\umacr" ], "ū", [letter]; + ["\\Ubreve" ], "Ŭ", [letter]; + ["\\ubreve" ], "ŭ", [letter]; + ["\\Uring" ], "Ů", [letter]; + ["\\uring" ], "ů", [letter]; + ["\\Udblac" ], "Ű", [letter]; + ["\\udblac" ], "ű", [letter]; + ["\\Uogon" ], "Ų", [letter]; + ["\\uogon" ], "ų", [letter]; + ["\\Wcirc" ], "Ŵ", [letter]; + ["\\wcirc" ], "ŵ", [letter]; + ["\\Ycirc" ], "Ŷ", [letter]; + ["\\ycirc" ], "ŷ", [letter]; + ["\\Yuml" ], "Ÿ", [letter]; + ["\\Zacute" ], "Ź", [letter]; + ["\\zacute" ], "ź", [letter]; + ["\\Zdot" ], "Ż", [letter]; + ["\\zdot" ], "ż", [letter]; + ["\\Zcaron" ], "Ž", [letter]; + ["\\zcaron" ], "ž", [letter]; + ["\\fnof" ], "ƒ", [letter]; + ["\\gacute" ], "ǵ", [letter]; + ["\\IOcy" ], "Ё", [letter]; + ["\\DJcy" ], "Ђ", [letter]; + ["\\GJcy" ], "Ѓ", [letter]; + ["\\Jukcy" ], "Є", [letter]; + ["\\DScy" ], "Ѕ", [letter]; + ["\\Iukcy" ], "І", [letter]; + ["\\YIcy" ], "Ї", [letter]; + ["\\Jsercy" ], "Ј", [letter]; + ["\\LJcy" ], "Љ", [letter]; + ["\\NJcy" ], "Њ", [letter]; + ["\\TSHcy" ], "Ћ", [letter]; + ["\\KJcy" ], "Ќ", [letter]; + ["\\Ubrcy" ], "Ў", [letter]; + ["\\DZcy" ], "Џ", [letter]; + ["\\Acy" ], "А", [letter]; + ["\\Bcy" ], "Б", [letter]; + ["\\Vcy" ], "В", [letter]; + ["\\Gcy" ], "Г", [letter]; + ["\\Dcy" ], "Д", [letter]; + ["\\IEcy" ], "Е", [letter]; + ["\\ZHcy" ], "Ж", [letter]; + ["\\Zcy" ], "З", [letter]; + ["\\Icy" ], "И", [letter]; + ["\\Jcy" ], "Й", [letter]; + ["\\Kcy" ], "К", [letter]; + ["\\Lcy" ], "Л", [letter]; + ["\\Mcy" ], "М", [letter]; + ["\\Ncy" ], "Н", [letter]; + ["\\Ocy" ], "О", [letter]; + ["\\Pcy" ], "П", [letter]; + ["\\Rcy" ], "Р", [letter]; + ["\\Scy" ], "С", [letter]; + ["\\Tcy" ], "Т", [letter]; + ["\\Ucy" ], "У", [letter]; + ["\\Fcy" ], "Ф", [letter]; + ["\\KHcy" ], "Х", [letter]; + ["\\TScy" ], "Ц", [letter]; + ["\\CHcy" ], "Ч", [letter]; + ["\\SHcy" ], "Ш", [letter]; + ["\\SHCHcy" ], "Щ", [letter]; + ["\\HARDcy" ], "Ъ", [letter]; + ["\\Ycy" ], "Ы", [letter]; + ["\\SOFTcy" ], "Ь", [letter]; + ["\\Ecy" ], "Э", [letter]; + ["\\YUcy" ], "Ю", [letter]; + ["\\YAcy" ], "Я", [letter]; + ["\\acy" ], "а", [letter]; + ["\\bcy" ], "б", [letter]; + ["\\vcy" ], "в", [letter]; + ["\\gcy" ], "г", [letter]; + ["\\dcy" ], "д", [letter]; + ["\\iecy" ], "е", [letter]; + ["\\zhcy" ], "ж", [letter]; + ["\\zcy" ], "з", [letter]; + ["\\icy" ], "и", [letter]; + ["\\jcy" ], "й", [letter]; + ["\\kcy" ], "к", [letter]; + ["\\lcy" ], "л", [letter]; + ["\\mcy" ], "м", [letter]; + ["\\ncy" ], "н", [letter]; + ["\\ocy" ], "о", [letter]; + ["\\pcy" ], "п", [letter]; + ["\\rcy" ], "р", [letter]; + ["\\scy" ], "с", [letter]; + ["\\tcy" ], "т", [letter]; + ["\\ucy" ], "у", [letter]; + ["\\fcy" ], "ф", [letter]; + ["\\khcy" ], "х", [letter]; + ["\\tscy" ], "ц", [letter]; + ["\\chcy" ], "ч", [letter]; + ["\\shcy" ], "ш", [letter]; + ["\\shchcy" ], "щ", [letter]; + ["\\hardcy" ], "ъ", [letter]; + ["\\ycy" ], "ы", [letter]; + ["\\softcy" ], "ь", [letter]; + ["\\ecy" ], "э", [letter]; + ["\\yucy" ], "ю", [letter]; + ["\\yacy" ], "я", [letter]; + ["\\iocy" ], "ё", [letter]; + ["\\djcy" ], "ђ", [letter]; + ["\\gjcy" ], "ѓ", [letter]; + ["\\jukcy" ], "є", [letter]; + ["\\dscy" ], "ѕ", [letter]; + ["\\iukcy" ], "і", [letter]; + ["\\yicy" ], "ї", [letter]; + ["\\jsercy" ], "ј", [letter]; + ["\\ljcy" ], "љ", [letter]; + ["\\njcy" ], "њ", [letter]; + ["\\tshcy" ], "ћ", [letter]; + ["\\kjcy" ], "ќ", [letter]; + ["\\ubrcy" ], "ў", [letter]; + ["\\dzcy" ], "џ", [letter]; + ["\\Copf"; "\\complexes" ], "ℂ", [letter]; + ["\\gscr" ], "ℊ", [letter]; + ["\\Hscr"; "\\hamilt"; "\\HilbertSpace" ], "ℋ", [letter]; + ["\\Hfr"; "\\Poincareplane" ], "ℌ", [letter]; + ["\\Hopf"; "\\quaternions" ], "ℍ", [letter]; + ["\\planckh" ], "ℎ", [letter]; + ["\\hslash"; "\\plankv" ], "ℏ", [letter]; + ["\\hbar"; "\\planck" ], "ℏ︀", [letter]; + ["\\Iscr"; "\\imagline" ], "ℐ", [letter]; + ["\\Im"; "\\Ifr"; "\\image"; "\\imagpart" ], "ℑ", [letter]; + ["\\Lscr"; "\\lagran"; "\\Laplacetrf" ], "ℒ", [letter]; + ["\\ell"; "\\lscr" ], "ℓ", [letter]; + ["\\Nopf"; "\\naturals" ], "ℕ", [letter]; + ["\\numero" ], "№", [letter]; + ["\\copysr" ], "℗", [letter]; + ["\\wp"; "\\weierp" ], "℘", [letter]; + ["\\Popf"; "\\primes" ], "ℙ", [letter]; + ["\\Qopf"; "\\rationals" ], "ℚ", [letter]; + ["\\Rscr"; "\\realine" ], "ℛ", [letter]; + ["\\Re"; "\\Rfr"; "\\real"; "\\realpart" ], "ℜ", [letter]; + ["\\Ropf"; "\\reals" ], "ℝ", [letter]; + ["\\rx" ], "℞", [letter]; + ["\\trade" ], "™", [letter]; + ["\\Zopf"; "\\integers" ], "ℤ", [letter]; + ["\\ohm" ], "Ω", [letter]; + ["\\mho" ], "℧", [letter]; + ["\\Zfr"; "\\zeetrf" ], "ℨ", [letter]; + ["\\iiota" ], "℩", [letter]; + ["\\angst" ], "Å", [letter]; + ["\\Bscr"; "\\bernou"; "\\Bernoullis" ], "ℬ", [letter]; + ["\\Cfr"; "\\Cayleys" ], "ℭ", [letter]; + ["\\escr" ], "ℯ", [letter]; + ["\\Escr"; "\\expectation" ], "ℰ", [letter]; + ["\\Fscr"; "\\Fouriertrf" ], "ℱ", [letter]; + ["\\Mscr"; "\\phmmat"; "\\Mellintrf" ], "ℳ", [letter]; + ["\\oscr"; "\\order"; "\\orderof" ], "ℴ", [letter]; + ["\\aleph" ], "ℵ", [letter]; + ["\\beth" ], "ℶ", [letter]; + ["\\gimel" ], "ℷ", [letter]; + ["\\daleth" ], "ℸ", [letter]; + ["\\DD"; "\\CapitalDifferentialD" ], "ⅅ", [letter]; + ["\\dd"; "\\DifferentialD" ], "ⅆ", [letter]; + ["\\ee"; "\\exponentiale"; "\\ExponentialE" ], "ⅇ", [letter]; + ["\\ii"; "\\ImaginaryI" ], "ⅈ", [letter]; + ["\\comp"; "\\complement" ], "∁", [letter]; + ["\\part"; "\\partial"; "\\PartialD" ], "∂", [letter]; + ["\\npart" ], "∂̸", [letter]; + ["\\easter" ], "≛", [letter]; + ["\\fpartint" ], "⨍", [letter]; + ["\\fflig" ], "ff", [letter]; + ["\\filig" ], "fi", [letter]; + ["\\fllig" ], "fl", [letter]; + ["\\ffilig" ], "ffi", [letter]; + ["\\ffllig" ], "ffl", [letter]; + ["\\Aopf" ], "𝔸", [letter]; + ["\\Bopf" ], "𝔹", [letter]; + ["\\Dopf" ], "𝔻", [letter]; + ["\\Eopf" ], "𝔼", [letter]; + ["\\Fopf" ], "𝔽", [letter]; + ["\\Gopf" ], "𝔾", [letter]; + ["\\Iopf" ], "𝕀", [letter]; + ["\\Jopf" ], "𝕁", [letter]; + ["\\Kopf" ], "𝕂", [letter]; + ["\\Lopf"; "\\imped" ], "𝕃", [letter]; + ["\\Mopf" ], "𝕄", [letter]; + ["\\Oopf" ], "𝕆", [letter]; + ["\\Sopf" ], "𝕊", [letter]; + ["\\Topf" ], "𝕋", [letter]; + ["\\Uopf" ], "𝕌", [letter]; + ["\\Vopf" ], "𝕍", [letter]; + ["\\Wopf" ], "𝕎", [letter]; + ["\\Xopf" ], "𝕏", [letter]; + ["\\Yopf" ], "𝕐", [letter]; + ["\\aopf" ], "𝕒", [letter]; + ["\\bopf" ], "𝕓", [letter]; + ["\\copf" ], "𝕔", [letter]; + ["\\dopf" ], "𝕕", [letter]; + ["\\eopf" ], "𝕖", [letter]; + ["\\fopf" ], "𝕗", [letter]; + ["\\gopf" ], "𝕘", [letter]; + ["\\hopf" ], "𝕙", [letter]; + ["\\iopf" ], "𝕚", [letter]; + ["\\jopf" ], "𝕛", [letter]; + ["\\kopf" ], "𝕜", [letter]; + ["\\lopf" ], "𝕝", [letter]; + ["\\mopf" ], "𝕞", [letter]; + ["\\nopf" ], "𝕟", [letter]; + ["\\oopf" ], "𝕠", [letter]; + ["\\popf" ], "𝕡", [letter]; + ["\\qopf" ], "𝕢", [letter]; + ["\\ropf" ], "𝕣", [letter]; + ["\\sopf" ], "𝕤", [letter]; + ["\\topf" ], "𝕥", [letter]; + ["\\uopf" ], "𝕦", [letter]; + ["\\vopf" ], "𝕧", [letter]; + ["\\wopf" ], "𝕨", [letter]; + ["\\xopf" ], "𝕩", [letter]; + ["\\yopf" ], "𝕪", [letter]; + ["\\zopf" ], "𝕫", [letter]; +(* }}} *) + +(* {{{ ASCII art *) + ["\\lceil"; "\\LeftCeiling" ], "⌈", [asciiart]; + ["\\rceil"; "\\RightCeiling" ], "⌉", [asciiart]; + ["\\lfloor"; "\\LeftFloor" ], "⌊", [asciiart]; + ["\\rfloor"; "\\RightFloor" ], "⌋", [asciiart]; + ["\\drcrop" ], "⌌", [asciiart]; + ["\\dlcrop" ], "⌍", [asciiart]; + ["\\urcrop" ], "⌎", [asciiart]; + ["\\ulcrop" ], "⌏", [asciiart]; + ["\\ulcorn"; "\\ulcorner" ], "⌜", [asciiart]; + ["\\urcorn"; "\\urcorner" ], "⌝", [asciiart]; + ["\\dlcorn"; "\\llcorner" ], "⌞", [asciiart]; + ["\\drcorn"; "\\lrcorner" ], "⌟", [asciiart]; + ["\\boxh" ], "─", [asciiart]; + ["\\boxv" ], "│", [asciiart]; + ["\\boxdr" ], "┌", [asciiart]; + ["\\boxdl" ], "┐", [asciiart]; + ["\\boxur" ], "└", [asciiart]; + ["\\boxul" ], "┘", [asciiart]; + ["\\boxvr" ], "├", [asciiart]; + ["\\boxvl" ], "┤", [asciiart]; + ["\\boxhd" ], "┬", [asciiart]; + ["\\boxhu" ], "┴", [asciiart]; + ["\\boxvh" ], "┼", [asciiart]; + ["\\boxH" ], "═", [asciiart]; + ["\\boxV" ], "║", [asciiart]; + ["\\boxdR" ], "╒", [asciiart]; + ["\\boxDr" ], "╓", [asciiart]; + ["\\boxDR" ], "╔", [asciiart]; + ["\\boxdL" ], "╕", [asciiart]; + ["\\boxDl" ], "╖", [asciiart]; + ["\\boxDL" ], "╗", [asciiart]; + ["\\boxuR" ], "╘", [asciiart]; + ["\\boxUr" ], "╙", [asciiart]; + ["\\boxUR" ], "╚", [asciiart]; + ["\\boxuL" ], "╛", [asciiart]; + ["\\boxUl" ], "╜", [asciiart]; + ["\\boxUL" ], "╝", [asciiart]; + ["\\boxvR" ], "╞", [asciiart]; + ["\\boxVr" ], "╟", [asciiart]; + ["\\boxVR" ], "╠", [asciiart]; + ["\\boxvL" ], "╡", [asciiart]; + ["\\boxVl" ], "╢", [asciiart]; + ["\\boxVL" ], "╣", [asciiart]; + ["\\boxHd" ], "╤", [asciiart]; + ["\\boxhD" ], "╥", [asciiart]; + ["\\boxHD" ], "╦", [asciiart]; + ["\\boxHu" ], "╧", [asciiart]; + ["\\boxhU" ], "╨", [asciiart]; + ["\\boxHU" ], "╩", [asciiart]; + ["\\boxvH" ], "╪", [asciiart]; + ["\\boxVh" ], "╫", [asciiart]; + ["\\boxVH" ], "╬", [asciiart]; + ["\\block" ], "█", [asciiart]; + ["\\blk14" ], "░", [asciiart]; + ["\\blk12" ], "▒", [asciiart]; + ["\\blk34" ], "▓", [asciiart]; +(* }}} *) + +(* {{{ equivalence *) + ["\\bsim"; "\\backsim" ], "∽", [equivalence]; + ["\\nsim"; "\\NotTilde" ], "≁", [equivalence]; + ["\\nvsim" ], "≁̸", [equivalence]; + ["\\esim"; "\\eqsim"; "\\EqualTilde" ], "≂", [equivalence]; + ["\\nesim"; "\\NotEqualTilde" ], "≂̸", [equivalence]; + ["\\sime"; "\\simeq"; "\\TildeEqual" ], "≃", [equivalence]; + ["\\nsime"; "\\nsimeq"; "\\NotTildeEqual" ], "≄", [equivalence]; + ["\\cong"; "\\TildeFullEqual" ], "≅", [equivalence]; + ["\\simne" ], "≆", [equivalence]; + ["\\ncong"; "\\NotTildeFullEqual" ], "≇", [equivalence]; + ["\\ap"; "\\approx"; "\\TildeTilde" ], "≈", [equivalence]; + ["\\nap"; "\\napprox"; "\\NotTildeTilde" ], "≉", [equivalence]; + ["\\nvap" ], "≉̸", [equivalence]; + ["\\apE"; "\\ape"; "\\approxeq" ], "≊", [equivalence]; + ["\\apid" ], "≋", [equivalence]; + ["\\napid" ], "≋̸", [equivalence]; + ["\\bcong"; "\\backcong" ], "≌", [equivalence]; + ["\\asymp"; "\\CupCap" ], "≍", [equivalence]; + ["\\bump"; "\\Bumpeq"; "\\HumpDownHump" ], "≎", [equivalence]; + ["\\nbump"; "\\NotHumpDownHump" ], "≎̸", [equivalence]; + ["\\bumpe"; "\\bumpeq"; "\\HumpEqual" ], "≏", [equivalence]; + ["\\nbumpe"; "\\NotHumpEqual" ], "≏̸", [equivalence]; + ["\\esdot"; "\\doteq"; "\\DotEqual" ], "≐", [equivalence]; + ["\\eDot"; "\\doteqdot" ], "≑", [equivalence]; + ["\\efDot"; "\\fallingdotseq" ], "≒", [equivalence]; + ["\\erDot"; "\\risingdotseq" ], "≓", [equivalence]; + ["\\colone"; "\\Assign"; "\\coloneq" ], "≔", [equivalence]; + ["\\ecolon"; "\\eqcolon" ], "≕", [equivalence]; + ["\\ecir"; "\\eqcirc" ], "≖", [equivalence]; + ["\\cire"; "\\circeq" ], "≗", [equivalence]; + ["\\wedgeq" ], "≙", [equivalence]; + ["\\veeeq" ], "≚", [equivalence]; + ["\\trie"; "\\triangleq" ], "≜", [equivalence]; + ["\\def";"\\:=" ], "≝", [equivalence]; + ["\\equest"; "\\questeq" ], "≟", [equivalence]; + ["\\ne"; "\\neq"; "\\NotEqual" ], "≠", [equivalence]; + ["\\equiv"; "\\Congruent" ], "≡", [equivalence]; + ["\\nequiv"; "\\NotCongruent" ], "≢", [equivalence]; + ["\\NotCupCap" ], "≭", [equivalence]; + ["\\bsime"; "\\backsimeq" ], "⋍", [equivalence]; + ["\\bumpE" ], "⪮", [equivalence]; +(* }}} *) + +(* {{{ order *) + ["\\le"; "\\leq";"\\<=" ], "≤", [order]; + ["\\ge"; "\\geq"; "\\GreaterEqual";"\\>=" ], "≥", [order]; + ["\\lE"; "\\leqq"; "\\LessFullEqual" ], "≦", [order]; + ["\\gE"; "\\geqq"; "\\GreaterFullEqual" ], "≧", [order]; + ["\\lnE"; "\\lne"; "\\lneq"; "\\lneqq" ], "≨", [order]; + ["\\gnE"; "\\gne"; "\\gneq"; "\\gneqq" ], "≩", [order]; + ["\\Lt"; "\\ll"; "\\NestedLessLess" ], "≪", [order]; + ["\\nLt" ], "≪̸", [order]; + ["\\gg"; "\\Gt"; "\\NestedGreaterGreater" ], "≫", [order]; + ["\\nGt" ], "≫̸", [order]; + ["\\nlt"; "\\nvlt"; "\\nless"; "\\NotLess" ], "≮", [order]; + ["\\ngt"; "\\ngtr"; "\\nvgt"; "\\NotGreater" ], "≯", [order]; + ["\\nlE"; "\\nleq"; "\\nvle"; "\\nles"; "\\nleqq"; "\\nleqslant"; "\\NotLessSlantEqual"; "\\NotGreaterFullEqual"], "≰", [order]; + ["\\ngE"; "\\nges"; "\\nvge"; "\\ngeq"; "\\ngeqq"; "\\ngeqslant"; "\\NotGreaterSlantEqual"], "≱", [order]; + ["\\lap"; "\\lsim"; "\\lesssim"; "\\LessTilde"; "\\lessapprox" ], "≲", [order]; + ["\\gap"; "\\gsim"; "\\gtrsim"; "\\gtrapprox"; "\\GreaterTilde" ], "≳", [order]; + ["\\nlsim"; "\\NotLessTilde" ], "≴", [order]; + ["\\ngsim"; "\\NotGreaterTilde" ], "≵", [order]; + ["\\lessgtr"; "\\LessGreater" ], "≶", [order]; + ["\\gl"; "\\gtrless"; "\\GreaterLess" ], "≷", [order]; + ["\\ntlg"; "\\NotLessGreater" ], "≸", [order]; + ["\\ntgl"; "\\NotGreaterLess" ], "≹", [order]; + ["\\pr"; "\\prec"; "\\Precedes" ], "≺", [order]; + ["\\sc"; "\\succ"; "\\Succeeds" ], "≻", [order]; + ["\\prcue"; "\\preccurlyeq"; "\\PrecedesSlantEqual" ], "≼", [order]; + ["\\sce"; "\\sccue"; "\\succeq"; "\\succcurlyeq"; "\\SucceedsEqual"; "\\SucceedsSlantEqual"], "≽", [order]; + ["\\scE"; "\\prap"; "\\prsim"; "\\precsim"; "\\precapprox"; "\\PrecedesTilde"], "≾", [order]; + ["\\scap"; "\\scsim"; "\\succsim"; "\\succapprox"; "\\SucceedsTilde"], "≿", [order]; + ["\\NotSucceedsTilde" ], "≿̸", [order]; + ["\\npr"; "\\nprec"; "\\NotPrecedes" ], "⊀", [order]; + ["\\nsc"; "\\nsucc"; "\\NotSucceeds" ], "⊁", [order]; + ["\\ltdot"; "\\lessdot" ], "⋖", [order]; + ["\\gtdot"; "\\gtrdot" ], "⋗", [order]; + ["\\Ll" ], "⋘", [order]; + ["\\nLl" ], "⋘̸", [order]; + ["\\Gg"; "\\ggg" ], "⋙", [order]; + ["\\nGg" ], "⋙̸", [order]; + ["\\lEg"; "\\leg"; "\\lesseqgtr"; "\\lesseqqgtr"; "\\LessEqualGreater"], "⋚", [order]; + ["\\gEl"; "\\gel"; "\\gtreqless"; "\\gtreqqless"; "\\GreaterEqualLess"], "⋛", [order]; + ["\\els"; "\\eqslantless" ], "⋜", [order]; + ["\\egs"; "\\eqslantgtr" ], "⋝", [order]; + ["\\cuepr"; "\\curlyeqprec" ], "⋞", [order]; + ["\\cuesc"; "\\curlyeqsucc" ], "⋟", [order]; + ["\\nprcue"; "\\NotPrecedesSlantEqual" ], "⋠", [order]; + ["\\nsccue"; "\\NotSucceedsSlantEqual" ], "⋡", [order]; + ["\\lnsim" ], "⋦", [order]; + ["\\gnsim" ], "⋧", [order]; + ["\\prnap"; "\\prnsim"; "\\precnsim"; "\\precnapprox" ], "⋨", [order]; + ["\\scnap"; "\\scnsim"; "\\succnsim"; "\\succnapprox" ], "⋩", [order]; + ["\\gtrarr" ], "⥸", [order]; + ["\\les"; "\\leqslant"; "\\LessSlantEqual" ], "⩽", [order]; + ["\\ges"; "\\geqslant"; "\\GreaterSlantEqual" ], "⩾", [order]; + ["\\lesdot" ], "⩿", [order]; + ["\\gesdot" ], "⪀", [order]; + ["\\lesdoto" ], "⪁", [order]; + ["\\gesdoto" ], "⪂", [order]; + ["\\lesdotor" ], "⪃", [order]; + ["\\gesdotol" ], "⪄", [order]; + ["\\lnap"; "\\lnapprox" ], "⪉", [order]; + ["\\gnap"; "\\gnapprox" ], "⪊", [order]; + ["\\lsime" ], "⪍", [order]; + ["\\gsime" ], "⪎", [order]; + ["\\lsimg" ], "⪏", [order]; + ["\\gsiml" ], "⪐", [order]; + ["\\lgE" ], "⪑", [order]; + ["\\glE" ], "⪒", [order]; + ["\\lesges" ], "⪓", [order]; + ["\\gesles" ], "⪔", [order]; + ["\\elsdot" ], "⪗", [order]; + ["\\egsdot" ], "⪘", [order]; + ["\\el" ], "⪙", [order]; + ["\\eg" ], "⪚", [order]; + ["\\siml" ], "⪝", [order]; + ["\\simg" ], "⪞", [order]; + ["\\simlE" ], "⪟", [order]; + ["\\simgE" ], "⪠", [order]; + ["\\prE"; "\\pre"; "\\preceq"; "\\PrecedesEqual" ], "⪯", [order]; + ["\\npre"; "\\npreceq"; "\\NotPrecedesEqual" ], "⪯̸", [order]; + ["\\nsce"; "\\nsucceq"; "\\NotSucceedsEqual" ], "⪰̸", [order]; + ["\\prnE"; "\\precneqq" ], "⪵", [order]; + ["\\scnE"; "\\succneqq" ], "⪶", [order]; +(* }}} *) + +(* {{{ circles *) + ["\\copy" ], "©", [circle]; + ["\\reg"; "\\circledR" ], "®", [circle]; + ["\\ordm" ], "º", [circle]; + ["\\oslash" ], "ø", [circle]; + ["\\ring" ], "˚", [circle]; + ["\\bull"; "\\bullet" ], "•", [circle]; + ["\\circ"; "\\compfn"; "\\SmallCircle" ], "∘", [circle]; + ["\\oplus"; "\\xoplus"; "\\bigoplus"; "\\CirclePlus" ], "⊕", [circle]; + ["\\ominus"; "\\CircleMinus" ], "⊖", [circle]; + ["\\xotime"; "\\otimes"; "\\bigotimes"; "\\CircleTimes"], "⊗", [circle]; + ["\\osol" ], "⊘", [circle]; + ["\\odot"; "\\xodot"; "\\bigodot"; "\\CircleDot" ], "⊙", [circle]; + ["\\ocir"; "\\circledcirc" ], "⊚", [circle]; + ["\\oast"; "\\circledast" ], "⊛", [circle]; + ["\\odash"; "\\circleddash" ], "⊝", [circle]; + ["\\ovbar" ], "⌽", [circle]; + ["\\NotNestedLessLess" ], "⒡̸", [circle]; + ["\\NotNestedGreaterGreater" ], "⒢̸", [circle]; + ["\\oS"; "\\circledS" ], "Ⓢ", [circle]; + ["\\cir"; ], "○", [circle]; + ["\\xcirc"; "\\bigcirc" ], "◯", [circle]; +(* }}} *) + +(* {{{ squares *) + ["\\plusb"; "\\boxplus" ], "⊞", [square]; + ["\\minusb"; "\\boxminus" ], "⊟", [square]; + ["\\timesb"; "\\boxtimes" ], "⊠", [square]; + ["\\sdotb"; "\\dotsquare" ], "⊡", [square]; + ["\\uhblk" ], "▀", [square]; + ["\\lhblk" ], "▄", [square]; + ["\\squ"; "\\square"; "\\Square" ], "□", [square]; + ["\\squf"; "\\squarf"; "\\blacksquare" ], "▪", [square]; + ["\\rect" ], "▭", [square]; + ["\\marker" ], "▮", [square]; + ["\\EmptySmallSquare" ], "◽", [square]; + ["\\FilledSmallSquare" ], "◾", [square]; +(* }}} *) + +(* {{{ triangles *) + ["\\Del"; "\\nabla" ], "∇", [triangle]; + ["\\vltri"; "\\LeftTriangle"; "\\vartriangleleft" ], "⊲", [triangle]; + ["\\vrtri"; "\\RightTriangle"; "\\vartriangleright" ], "⊳", [triangle]; + ["\\ltrie"; "\\trianglelefteq"; "\\LeftTriangleEqual" ], "⊴", [triangle]; + ["\\rtrie"; "\\trianglerighteq"; "\\RightTriangleEqual" ], "⊵", [triangle]; + ["\\nltri"; "\\ntriangleleft"; "\\NotLeftTriangle" ], "⋪", [triangle]; + ["\\nrtri"; "\\ntriangleright"; "\\NotRightTriangle" ], "⋫", [triangle]; + ["\\nltrie"; "\\ntrianglelefteq"; "\\NotLeftTriangleEqual" ], "⋬", [triangle]; + ["\\nvltrie" ], "⋬̸", [triangle]; + ["\\nrtrie"; "\\ntrianglerighteq"; "\\NotRightTriangleEqual" ], "⋭", [triangle]; + ["\\nvrtrie" ], "⋭̸", [triangle]; + ["\\xutri"; "\\bigtriangleup" ], "△", [triangle]; + ["\\utrif"; "\\blacktriangle" ], "▴", [triangle]; + ["\\utri"; "\\triangle" ], "▵", [triangle]; + ["\\rtrif"; "\\blacktriangleright" ], "▸", [triangle]; + ["\\rtri"; "\\triangleright" ], "▹", [triangle]; + ["\\xdtri"; "\\bigtriangledown" ], "▽", [triangle]; + ["\\dtrif"; "\\blacktriangledown" ], "▾", [triangle]; + ["\\dtri"; "\\triangledown" ], "▿", [triangle]; + ["\\ltrif"; "\\blacktriangleleft" ], "◂", [triangle]; + ["\\ltri"; "\\triangleleft" ], "◃", [triangle]; + ["\\tridot" ], "◬", [triangle]; + ["\\ultri" ], "◸", [triangle]; + ["\\urtri" ], "◹", [triangle]; + ["\\lltri" ], "◺", [triangle]; + ["\\rtriltri" ], "⧎", [triangle]; + ["\\LeftTriangleBar" ], "⧏", [triangle]; + ["\\NotLeftTriangleBar" ], "⧏̸", [triangle]; + ["\\RightTriangleBar" ], "⧐", [triangle]; + ["\\NotRightTriangleBar" ], "⧐̸", [triangle]; +(* }}} *) + +(* {{{ arrows *) + ["\\larr"; "\\gets"; "\\leftarrow"; "\\LeftArrow";"\\<-" ], "←", [arrow]; + ["\\uarr"; "\\UpArrow"; "\\uparrow" ], "↑", [arrow]; + ["\\to"; "\\rarr"; "\\RightArrow"; "\\rightarrow";"\\->"], "→", [arrow]; + ["\\darr"; "\\downarrow"; "\\DownArrow" ], "↓", [arrow]; + ["\\harr"; "\\LeftRightArrow"; "\\leftrightarrow" ], "↔", [arrow]; + ["\\varr"; "\\updownarrow"; "\\UpDownArrow" ], "↕", [arrow]; + ["\\nwarr"; "\\nwarrow"; "\\UpperLeftArrow" ], "↖", [arrow]; + ["\\nearr"; "\\nearrow"; "\\UpperRightArrow" ], "↗", [arrow]; + ["\\searr"; "\\searrow"; "\\LowerRightArrow" ], "↘", [arrow]; + ["\\swarr"; "\\swarrow"; "\\LowerLeftArrow" ], "↙", [arrow]; + ["\\nlarr"; "\\nleftarrow" ], "↚", [arrow]; + ["\\nrarr"; "\\nrightarrow" ], "↛", [arrow]; + ["\\rarrw"; "\\rightsquigarrow" ], "↝", [arrow]; + ["\\nrarrw" ], "↝̸", [arrow]; + ["\\Larr"; "\\twoheadleftarrow" ], "↞", [arrow]; + ["\\Uarr" ], "↟", [arrow]; + ["\\Rarr"; "\\twoheadrightarrow" ], "↠", [arrow]; + ["\\Darr" ], "↡", [arrow]; + ["\\larrtl"; "\\leftarrowtail" ], "↢", [arrow]; + ["\\ratail"; "\\rarrtl"; "\\rightarrowtail" ], "↣", [arrow]; + ["\\mapstoleft"; "\\LeftTeeArrow" ], "↤", [arrow]; + ["\\mapstoup"; "\\UpTeeArrow" ], "↥", [arrow]; + ["\\map"; "\\mapsto"; "\\RightTeeArrow" ], "↦", [arrow]; + ["\\mapstodown"; "\\DownTeeArrow" ], "↧", [arrow]; + ["\\larrhk"; "\\hookleftarrow" ], "↩", [arrow]; + ["\\rarrhk"; "\\hookrightarrow" ], "↪", [arrow]; + ["\\larrlp"; "\\looparrowleft" ], "↫", [arrow]; + ["\\rarrlp"; "\\looparrowright" ], "↬", [arrow]; + ["\\harrw"; "\\leftrightsquigarrow" ], "↭", [arrow]; + ["\\nharr"; "\\nleftrightarrow" ], "↮", [arrow]; + ["\\Lsh"; "\\lsh" ], "↰", [arrow]; + ["\\Rsh"; "\\rsh" ], "↱", [arrow]; + ["\\ldsh" ], "↲", [arrow]; + ["\\rdsh" ], "↳", [arrow]; + ["\\cularr"; "\\curvearrowleft" ], "↶", [arrow]; + ["\\curarr"; "\\curvearrowright" ], "↷", [arrow]; + ["\\olarr"; "\\circlearrowleft" ], "↺", [arrow]; + ["\\orarr"; "\\circlearrowright" ], "↻", [arrow]; + ["\\lharu"; "\\LeftVector"; "\\leftharpoonup" ], "↼", [arrow]; + ["\\lhard"; "\\DownLeftVector"; "\\leftharpoondown" ], "↽", [arrow]; + ["\\uharr"; "\\RightUpVector"; "\\upharpoonright" ], "↾", [arrow]; + ["\\uharl"; "\\LeftUpVector"; "\\upharpoonleft" ], "↿", [arrow]; + ["\\rharu"; "\\RightVector"; "\\rightharpoonup" ], "⇀", [arrow]; + ["\\rhard"; "\\DownRightVector"; "\\rightharpoondown" ], "⇁", [arrow]; + ["\\dharr"; "\\RightDownVector"; "\\downharpoonright" ], "⇂", [arrow]; + ["\\dharl"; "\\LeftDownVector"; "\\downharpoonleft" ], "⇃", [arrow]; + ["\\rlarr"; "\\rightleftarrows"; "\\RightArrowLeftArrow" ], "⇄", [arrow]; + ["\\udarr"; "\\UpArrowDownArrow" ], "⇅", [arrow]; + ["\\lrarr"; "\\leftrightarrows"; "\\LeftArrowRightArrow" ], "⇆", [arrow]; + ["\\llarr"; "\\leftleftarrows" ], "⇇", [arrow]; + ["\\uuarr"; "\\upuparrows" ], "⇈", [arrow]; + ["\\rrarr"; "\\rightrightarrows" ], "⇉", [arrow]; + ["\\ddarr"; "\\downdownarrows" ], "⇊", [arrow]; + ["\\lrhar"; "\\leftrightharpoons"; "\\ReverseEquilibrium" ], "⇋", [arrow]; + ["\\rlhar"; "\\Equilibrium"; "\\rightleftharpoons" ], "⇌", [arrow]; + ["\\nlArr"; "\\nvlArr"; "\\nLeftarrow" ], "⇍", [arrow]; + ["\\nhArr"; "\\nvHarr"; "\\nLeftrightarrow" ], "⇎", [arrow]; + ["\\nrArr"; "\\nvrArr"; "\\nRightarrow" ], "⇏", [arrow]; + ["\\lArr"; "\\Leftarrow"; "\\DoubleLeftArrow";"\\<==" ], "⇐", [arrow]; + ["\\uArr"; "\\Uparrow"; "\\DoubleUpArrow" ], "⇑", [arrow]; + ["\\rArr"; "\\Implies"; "\\Rightarrow"; "\\Longrightarrow"; "\\DoubleRightArrow"; "\\==>"], "⇒", [arrow]; + ["\\dArr"; "\\Downarrow"; "\\DoubleDownArrow" ], "⇓", [arrow]; + ["\\iff"; "\\hArr"; "\\Leftrightarrow"; "\\DoubleLeftRightArrow";"\\<==>" ], "⇔", [arrow]; + ["\\vArr"; "\\Updownarrow"; "\\DoubleUpDownArrow" ], "⇕", [arrow]; + ["\\nwArr" ], "⇖", [arrow]; + ["\\neArr" ], "⇗", [arrow]; + ["\\seArr" ], "⇘", [arrow]; + ["\\swArr" ], "⇙", [arrow]; + ["\\lAarr"; "\\Lleftarrow" ], "⇚", [arrow]; + ["\\rAarr"; "\\Rrightarrow" ], "⇛", [arrow]; + ["\\zigrarr" ], "⇝", [arrow]; + ["\\larrb"; "\\LeftArrowBar" ], "⇤", [arrow]; + ["\\rarrb"; "\\RightArrowBar" ], "⇥", [arrow]; + ["\\duarr"; "\\DownArrowUpArrow" ], "⇵", [arrow]; + ["\\loarr" ], "⇽", [arrow]; + ["\\roarr" ], "⇾", [arrow]; + ["\\hoarr" ], "⇿", [arrow]; + ["\\Map" ], "⤅", [arrow]; + ["\\lbarr" ], "⤌", [arrow]; + ["\\rbarr"; "\\bkarow" ], "⤍", [arrow]; + ["\\lBarr" ], "⤎", [arrow]; + ["\\ac"; "\\rBarr"; "\\dbkarow" ], "⤏", [arrow]; + ["\\RBarr"; "\\drbkarow" ], "⤐", [arrow]; + ["\\DDotrahd" ], "⤑", [arrow]; + ["\\UpArrowBar" ], "⤒", [arrow]; + ["\\DownArrowBar" ], "⤓", [arrow]; + ["\\Rarrtl" ], "⤖", [arrow]; + ["\\latail" ], "⤙", [arrow]; + ["\\lAtail" ], "⤛", [arrow]; + ["\\rAtail" ], "⤜", [arrow]; + ["\\larrfs" ], "⤝", [arrow]; + ["\\rarrfs" ], "⤞", [arrow]; + ["\\larrbfs" ], "⤟", [arrow]; + ["\\rarrbfs" ], "⤠", [arrow]; + ["\\nwarhk" ], "⤣", [arrow]; + ["\\nearhk" ], "⤤", [arrow]; + ["\\searhk"; "\\hksearow" ], "⤥", [arrow]; + ["\\swarhk"; "\\hkswarow" ], "⤦", [arrow]; + ["\\nwnear" ], "⤧", [arrow]; + ["\\toea"; "\\nesear" ], "⤨", [arrow]; + ["\\tosa"; "\\seswar" ], "⤩", [arrow]; + ["\\swnwar" ], "⤪", [arrow]; + ["\\rarrc" ], "⤳", [arrow]; + ["\\nrarrc" ], "⤳̸", [arrow]; + ["\\cudarrr" ], "⤵", [arrow]; + ["\\ldca" ], "⤶", [arrow]; + ["\\rdca" ], "⤷", [arrow]; + ["\\cudarrl" ], "⤸", [arrow]; + ["\\larrpl" ], "⤹", [arrow]; + ["\\curarrm" ], "⤼", [arrow]; + ["\\cularrp" ], "⤽", [arrow]; + ["\\rarrpl" ], "⥅", [arrow]; + ["\\harrcir" ], "⥈", [arrow]; + ["\\Uarrocir" ], "⥉", [arrow]; + ["\\lurdshar" ], "⥊", [arrow]; + ["\\ldrushar" ], "⥋", [arrow]; + ["\\LeftRightVector" ], "⥎", [arrow]; + ["\\RightUpDownVector" ], "⥏", [arrow]; + ["\\DownLeftRightVector" ], "⥐", [arrow]; + ["\\LeftUpDownVector" ], "⥑", [arrow]; + ["\\LeftVectorBar" ], "⥒", [arrow]; + ["\\RightVectorBar" ], "⥓", [arrow]; + ["\\RightUpVectorBar" ], "⥔", [arrow]; + ["\\RightDownVectorBar" ], "⥕", [arrow]; + ["\\DownLeftVectorBar" ], "⥖", [arrow]; + ["\\DownRightVectorBar" ], "⥗", [arrow]; + ["\\LeftUpVectorBar" ], "⥘", [arrow]; + ["\\LeftDownVectorBar" ], "⥙", [arrow]; + ["\\LeftTeeVector" ], "⥚", [arrow]; + ["\\RightTeeVector" ], "⥛", [arrow]; + ["\\RightUpTeeVector" ], "⥜", [arrow]; + ["\\RightDownTeeVector" ], "⥝", [arrow]; + ["\\DownLeftTeeVector" ], "⥞", [arrow]; + ["\\DownRightTeeVector" ], "⥟", [arrow]; + ["\\LeftUpTeeVector" ], "⥠", [arrow]; + ["\\LeftDownTeeVector" ], "⥡", [arrow]; + ["\\lHar" ], "⥢", [arrow]; + ["\\uHar" ], "⥣", [arrow]; + ["\\rHar" ], "⥤", [arrow]; + ["\\dHar" ], "⥥", [arrow]; + ["\\luruhar" ], "⥦", [arrow]; + ["\\ldrdhar" ], "⥧", [arrow]; + ["\\ruluhar" ], "⥨", [arrow]; + ["\\rdldhar" ], "⥩", [arrow]; + ["\\lharul" ], "⥪", [arrow]; + ["\\llhard" ], "⥫", [arrow]; + ["\\rharul" ], "⥬", [arrow]; + ["\\lrhard" ], "⥭", [arrow]; + ["\\udhar"; "\\UpEquilibrium" ], "⥮", [arrow]; + ["\\duhar"; "\\ReverseUpEquilibrium" ], "⥯", [arrow]; + ["\\RoundImplies" ], "⥰", [arrow]; + ["\\erarr" ], "⥱", [arrow]; + ["\\simrarr" ], "⥲", [arrow]; + ["\\larrsim" ], "⥳", [arrow]; + ["\\rarrsim" ], "⥴", [arrow]; + ["\\rarrap" ], "⥵", [arrow]; + ["\\ltlarr" ], "⥶", [arrow]; + ["\\suplarr" ], "⥻", [arrow]; + ["\\lfisht" ], "⥼", [arrow]; + ["\\rfisht" ], "⥽", [arrow]; + ["\\ufisht" ], "⥾", [arrow]; + ["\\dfisht" ], "⥿", [arrow]; +(* }}} *) + +(* {{{ set operations *) + ["\\emptyv"; "\\varnothing" ], "∅", [set]; + ["\\in"; "\\isin"; "\\isinv"; "\\Element" ], "∈", [set]; + ["\\notin"; "\\NotElement" ], "∉", [set]; + ["\\notinva" ], "∉̸", [set]; + ["\\ni"; "\\niv"; "\\owns"; "\\SuchThat"; "\\ReverseElement" ], "∋", [set]; + ["\\notni"; "\\notniva"; "\\NotReverseElement" ], "∌", [set]; + ["\\coprod"; "\\Coproduct" ], "∐", [set]; + ["\\cap" ], "∩", [set]; + ["\\cup" ], "∪", [set]; + ["\\twixt"; "\\between" ], "≬", [set]; + ["\\subset" ], "⊂", [set]; + ["\\supset"; "\\Superset" ], "⊃", [set]; + ["\\suphsol" ], "⊃/", [set]; + ["\\nsub"; "\\vnsub"; "\\nsubset"; "\\NotSubset" ], "⊄", [set]; + ["\\nsup"; "\\vnsup"; "\\nsupset"; "\\NotSuperset" ], "⊅", [set]; + ["\\subE"; "\\sube"; "\\subseteq"; "\\subseteqq"; "\\SubsetEqual" ], "⊆", [set]; + ["\\supe"; "\\supE"; "\\supseteq"; "\\supseteqq"; "\\SupersetEqual"], "⊇", [set]; + ["\\nsube"; "\\nsubE"; "\\nsubseteq"; "\\nsubseteqq"; "\\NotSubsetEqual"], "⊈", [set]; + ["\\nsupe"; "\\nsupE"; "\\nsupseteq"; "\\nsupseteqq"; "\\NotSupersetEqual"], "⊉", [set]; + ["\\subne"; "\\subnE"; "\\subsetneq"; "\\subsetneqq" ], "⊊", [set]; + ["\\supne"; "\\supnE"; "\\supsetneq"; "\\supsetneqq" ], "⊋", [set]; + ["\\cupdot" ], "⊍", [set]; + ["\\uplus"; "\\xuplus"; "\\biguplus"; "\\UnionPlus" ], "⊎", [set]; + ["\\sqsub"; "\\sqsubset"; "\\SquareSubset" ], "⊏", [set]; + ["\\NotSquareSubset" ], "⊏̸", [set]; + ["\\sqsup"; "\\sqsupset"; "\\SquareSuperset" ], "⊐", [set]; + ["\\NotSquareSuperset" ], "⊐̸", [set]; + ["\\sqsube"; "\\sqsubseteq"; "\\SquareSubsetEqual" ], "⊑", [set]; + ["\\sqsupe"; "\\sqsupseteq"; "\\SquareSupersetEqual" ], "⊒", [set]; + ["\\sqcap"; "\\SquareIntersection" ], "⊓", [set]; + ["\\sqcup"; "\\xsqcup"; "\\bigsqcup"; "\\SquareUnion" ], "⊔", [set]; + ["\\xcap"; "\\bigcap"; "\\Intersection" ], "⋂", [set]; + ["\\xcup"; "\\Union"; "\\bigcup" ], "⋃", [set]; + ["\\Sub"; "\\Subset" ], "⋐", [set]; + ["\\Sup"; "\\Supset" ], "⋑", [set]; + ["\\Cap" ], "⋒", [set]; + ["\\Cup" ], "⋓", [set]; + ["\\nsqsube"; "\\NotSquareSubsetEqual" ], "⋢", [set]; + ["\\nsqsupe"; "\\NotSquareSupersetEqual" ], "⋣", [set]; + ["\\disin" ], "⋲", [set]; + ["\\isinsv" ], "⋳", [set]; + ["\\isins" ], "⋴", [set]; + ["\\isindot" ], "⋵", [set]; + ["\\notinvc" ], "⋶", [set]; + ["\\notindot" ], "⋶︀", [set]; + ["\\notinvb" ], "⋷", [set]; + ["\\isinE" ], "⋹", [set]; + ["\\nisd" ], "⋺", [set]; + ["\\xnis" ], "⋻", [set]; + ["\\nis" ], "⋼", [set]; + ["\\notnivc" ], "⋽", [set]; + ["\\notnivb" ], "⋾", [set]; + ["\\subrarr" ], "⥹", [set]; +(* }}} *) + +(* {{{ math *) + ["\\pm"; "\\plusmn"; "\\PlusMinus" ], "±", [math]; + ["\\times" ], "×", [math]; + ["\\div"; "\\divide" ], "÷", [math]; + ["\\prod"; "\\Product" ], "∏", [math]; + ["\\sum"; "\\Sum" ], "∑", [math]; + ["\\mp"; "\\mnplus"; "\\MinusPlus" ], "∓", [math]; + ["\\plusdo"; "\\dotplus" ], "∔", [math]; + ["\\setmn"; "\\setminus"; "\\Backslash" ], "∖", [math]; + ["\\lowast" ], "∗", [math]; + ["\\Sqrt"; "\\radic" ], "√", [math]; + ["\\prop"; "\\vprop"; "\\propto"; "\\varpropto"; "\\Proportional" ], "∝", [math]; + ["\\infty"; "\\infin" ], "∞", [math]; + ["\\mid"; "\\divides"; "\\VerticalBar" ], "∣", [math]; + ["\\nmid"; "\\ndivides"; "\\NotVerticalBar" ], "∤", [math]; + ["\\npar"; "\\nparallel"; "\\NotDoubleVerticalBar" ], "∦", [math]; + ["\\int"; "\\Integral" ], "∫", [math]; + ["\\Int" ], "∬", [math]; + ["\\tint"; "\\iiint" ], "∭", [math]; + ["\\oint"; "\\conint"; "\\ContourIntegral" ], "∮", [math]; + ["\\Conint"; "\\DoubleContourIntegral" ], "∯", [math]; + ["\\Cconint" ], "∰", [math]; + ["\\cwint" ], "∱", [math]; + ["\\cwconint"; "\\ClockwiseContourIntegral" ], "∲", [math]; + ["\\awconint"; "\\CounterClockwiseContourIntegral" ], "∳", [math]; + ["\\qint"; "\\iiiint" ], "⨌", [math]; + ["\\cirfnint" ], "⨐", [math]; + ["\\awint" ], "⨑", [math]; + ["\\rppolint" ], "⨒", [math]; + ["\\scpolint" ], "⨓", [math]; + ["\\npolint" ], "⨔", [math]; + ["\\pointint" ], "⨕", [math]; + ["\\quatint" ], "⨖", [math]; + ["\\intlarhk" ], "⨗", [math]; + ["\\Cross" ], "⨯", [math]; +(* }}} *) + +(* {{{ spaces *) + ["\\nbsp"; "\\NonBreakingSpace" ], " ", [space]; + ["\\shy" ], "", [space]; + ["\\ensp" ], " ", [space]; + ["\\emsp" ], " ", [space]; + ["\\emsp13" ], " ", [space]; + ["\\emsp14" ], " ", [space]; + ["\\numsp" ], " ", [space]; + ["\\puncsp" ], " ", [space]; + ["\\thinsp"; "\\ThinSpace" ], " ", [space]; + ["\\ThickSpace" ], " ", [space]; + ["\\hairsp"; "\\VeryThinSpace" ], " ", [space]; + ["\\ic"; "\\ZeroWidthSpace"; "\\InvisibleComma" ], "", [space]; + ["\\af"; "\\ApplyFunction" ], "", [space]; + ["\\it"; "\\InvisibleTimes" ], "", [space]; + ["\\NoBreak" ], "", [space]; +(* }}} *) + +(* {{{ parenteses *) + ["\\laquo" ], "«", [delimiter] ; + ["\\raquo" ], "»", [delimiter] ; + ["\\lang"; "\\langle"; "\\LeftAngleBracket" ], "〈", [delimiter] ; + ["\\rang"; "\\rangle"; "\\RightAngleBracket" ], "〉", [delimiter] ; + ["\\lmoust"; "\\lmoustache" ], "⎰", [delimiter] ; + ["\\rmoust"; "\\rmoustache" ], "⎱", [delimiter] ; + ["\\Lang" ], "《", [delimiter] ; + ["\\Rang" ], "》", [delimiter] ; + ["\\lbbrk" ], "〔", [delimiter] ; + ["\\rbbrk" ], "〕", [delimiter] ; + ["\\lopar" ], "〘", [delimiter] ; + ["\\ropar" ], "〙", [delimiter] ; + ["\\lobrk"; "\\LeftDoubleBracket" ], "〚", [delimiter] ; + ["\\robrk"; "\\RightDoubleBracket" ], "〛", [delimiter] ; +(* }}} *) + +(* {{{ Missing font *) + ["\\NegativeThickSpace" ], " ︀", [miscellanea]; + ["\\NegativeThinSpace" ], " ︀", [miscellanea]; + ["\\NegativeVeryThinSpace" ], " ︀", [miscellanea]; + ["\\NegativeMediumSpace" ], " ︀", [miscellanea]; + ["\\slarr"; "\\ShortLeftArrow" ], "←︀", [miscellanea]; + ["\\srarr"; "\\ShortRightArrow" ], "→︀", [miscellanea]; + ["\\empty"; "\\emptyset" ], "∅︀", [miscellanea]; + ["\\ssetmn"; "\\smallsetminus" ], "∖︀", [miscellanea]; + ["\\smid"; "\\shortmid" ], "∣︀", [miscellanea]; + ["\\nsmid"; "\\nshortmid" ], "∤︀", [miscellanea]; + ["\\spar"; "\\parsl"; "\\shortparallel" ], "∥︀", [miscellanea]; + ["\\nparsl" ], "∥︀⃥", [miscellanea]; + ["\\nspar"; "\\nshortparallel" ], "∦︀", [miscellanea]; + ["\\caps" ], "∩︀", [miscellanea]; + ["\\cups" ], "∪︀", [miscellanea]; + ["\\thksim"; "\\thicksim" ], "∼︀", [miscellanea]; + ["\\thkap"; "\\thickapprox" ], "≈︀", [miscellanea]; + ["\\nedot" ], "≠︀", [miscellanea]; + ["\\bnequiv" ], "≡⃥", [miscellanea]; + ["\\lvnE"; "\\lvertneqq" ], "≨︀", [miscellanea]; + ["\\gvnE"; "\\gvertneqq" ], "≩︀", [miscellanea]; + ["\\nLtv"; "\\NotLessLess" ], "≪̸︀", [miscellanea]; + ["\\nGtv"; "\\NotGreaterGreater" ], "≫̸︀", [miscellanea]; + ["\\nle"; "\\NotLessEqual" ], "≰⃥", [miscellanea]; + ["\\nge"; "\\NotGreaterEqual" ], "≱⃥", [miscellanea]; + ["\\vsubnE"; "\\vsubne"; "\\varsubsetneq"; "\\varsubsetneqq" ], "⊊︀", [miscellanea]; + ["\\vsupne"; "\\vsupnE"; "\\varsupsetneq"; "\\varsupsetneqq" ], "⊋︀", [miscellanea]; + ["\\sqcaps" ], "⊓︀", [miscellanea]; + ["\\sqcups" ], "⊔︀", [miscellanea]; + ["\\prurel" ], "⊰", [miscellanea]; + ["\\lesg" ], "⋚︀", [miscellanea]; + ["\\gesl" ], "⋛︀", [miscellanea]; + ["\\ShortUpArrow" ], "⌃︀", [miscellanea]; + ["\\ShortDownArrow" ], "⌄︀", [miscellanea]; + ["\\target" ], "⌖", [miscellanea]; + ["\\cylcty" ], "⌭", [miscellanea]; + ["\\profalar" ], "⌮", [miscellanea]; + ["\\topbot" ], "⌶", [miscellanea]; + ["\\solbar" ], "⌿", [miscellanea]; + ["\\angzarr" ], "⍼", [miscellanea]; + ["\\tbrk"; "\\OverBracket" ], "⎴", [miscellanea]; + ["\\bbrk"; "\\UnderBracket" ], "⎵", [miscellanea]; + ["\\lbrke" ], "⦋", [miscellanea]; + ["\\rbrke" ], "⦌", [miscellanea]; + ["\\lbrkslu" ], "⦍", [miscellanea]; + ["\\rbrksld" ], "⦎", [miscellanea]; + ["\\lbrksld" ], "⦏", [miscellanea]; + ["\\rbrkslu" ], "⦐", [miscellanea]; + ["\\langd" ], "⦑", [miscellanea]; + ["\\rangd" ], "⦒", [miscellanea]; + ["\\lparlt" ], "⦓", [miscellanea]; + ["\\rpargt" ], "⦔", [miscellanea]; + ["\\gtlPar" ], "⦕", [miscellanea]; + ["\\ltrPar" ], "⦖", [miscellanea]; + ["\\vzigzag" ], "⦚", [miscellanea]; + ["\\angrtvbd" ], "⦝", [miscellanea]; + ["\\angrtvb" ], "⦝︀", [miscellanea]; + ["\\ange" ], "⦤", [miscellanea]; + ["\\range" ], "⦥", [miscellanea]; + ["\\dwangle" ], "⦦", [miscellanea]; + ["\\uwangle" ], "⦧", [miscellanea]; + ["\\angmsdaa" ], "⦨", [miscellanea]; + ["\\angmsdab" ], "⦩", [miscellanea]; + ["\\angmsdac" ], "⦪", [miscellanea]; + ["\\angmsdad" ], "⦫", [miscellanea]; + ["\\angmsdae" ], "⦬", [miscellanea]; + ["\\angmsdaf" ], "⦭", [miscellanea]; + ["\\angmsdag" ], "⦮", [miscellanea]; + ["\\angmsdah" ], "⦯", [miscellanea]; + ["\\bemptyv" ], "⦰", [miscellanea]; + ["\\demptyv" ], "⦱", [miscellanea]; + ["\\cemptyv" ], "⦲", [miscellanea]; + ["\\raemptyv" ], "⦳", [miscellanea]; + ["\\laemptyv" ], "⦴", [miscellanea]; + ["\\ohbar" ], "⦵", [miscellanea]; + ["\\omid" ], "⦶", [miscellanea]; + ["\\opar" ], "⦷", [miscellanea]; + ["\\operp" ], "⦹", [miscellanea]; + ["\\olcross" ], "⦻", [miscellanea]; + ["\\odsold" ], "⦼", [miscellanea]; + ["\\olcir" ], "⦾", [miscellanea]; + ["\\ofcir" ], "⦿", [miscellanea]; + ["\\olt" ], "⧀", [miscellanea]; + ["\\ogt" ], "⧁", [miscellanea]; + ["\\cirscir" ], "⧂", [miscellanea]; + ["\\cirE" ], "⧃", [miscellanea]; + ["\\solb" ], "⧄", [miscellanea]; + ["\\bsolb" ], "⧅", [miscellanea]; + ["\\boxbox" ], "⧉", [miscellanea]; + ["\\trisb" ], "⧍", [miscellanea]; + ["\\race" ], "⧚", [miscellanea]; + ["\\acE" ], "⧛", [miscellanea]; + ["\\iinfin" ], "⧜", [miscellanea]; + ["\\nvinfin" ], "⧞", [miscellanea]; + ["\\eparsl" ], "⧣", [miscellanea]; + ["\\smeparsl" ], "⧤", [miscellanea]; + ["\\eqvparsl" ], "⧥", [miscellanea]; + ["\\RuleDelayed" ], "⧴", [miscellanea]; + ["\\dsol" ], "⧶", [miscellanea]; + ["\\pluscir" ], "⨢", [miscellanea]; + ["\\plusacir" ], "⨣", [miscellanea]; + ["\\simplus" ], "⨤", [miscellanea]; + ["\\plusdu" ], "⨥", [miscellanea]; + ["\\plussim" ], "⨦", [miscellanea]; + ["\\plustwo" ], "⨧", [miscellanea]; + ["\\mcomma" ], "⨩", [miscellanea]; + ["\\minusdu" ], "⨪", [miscellanea]; + ["\\loplus" ], "⨭", [miscellanea]; + ["\\roplus" ], "⨮", [miscellanea]; + ["\\timesd" ], "⨰", [miscellanea]; + ["\\timesbar" ], "⨱", [miscellanea]; + ["\\smashp" ], "⨳", [miscellanea]; + ["\\lotimes" ], "⨴", [miscellanea]; + ["\\rotimes" ], "⨵", [miscellanea]; + ["\\otimesas" ], "⨶", [miscellanea]; + ["\\Otimes" ], "⨷", [miscellanea]; + ["\\odiv" ], "⨸", [miscellanea]; + ["\\triplus" ], "⨹", [miscellanea]; + ["\\triminus" ], "⨺", [miscellanea]; + ["\\tritime" ], "⨻", [miscellanea]; + ["\\iprod"; "\\intprod" ], "⨼", [miscellanea]; + ["\\amalg" ], "⨿", [miscellanea]; + ["\\capdot" ], "⩀", [miscellanea]; + ["\\ncup" ], "⩂", [miscellanea]; + ["\\ncap" ], "⩃", [miscellanea]; + ["\\capand" ], "⩄", [miscellanea]; + ["\\cupor" ], "⩅", [miscellanea]; + ["\\cupcap" ], "⩆", [miscellanea]; + ["\\capcup" ], "⩇", [miscellanea]; + ["\\cupbrcap" ], "⩈", [miscellanea]; + ["\\capbrcup" ], "⩉", [miscellanea]; + ["\\cupcup" ], "⩊", [miscellanea]; + ["\\capcap" ], "⩋", [miscellanea]; + ["\\ccups" ], "⩌", [miscellanea]; + ["\\ccaps" ], "⩍", [miscellanea]; + ["\\ccupssm" ], "⩐", [miscellanea]; + ["\\And" ], "⩓", [miscellanea]; + ["\\Or" ], "⩔", [miscellanea]; + ["\\andand" ], "⩕", [miscellanea]; + ["\\oror" ], "⩖", [miscellanea]; + ["\\orslope" ], "⩗", [miscellanea]; + ["\\andslope" ], "⩘", [miscellanea]; + ["\\andv" ], "⩚", [miscellanea]; + ["\\orv" ], "⩛", [miscellanea]; + ["\\andd" ], "⩜", [miscellanea]; + ["\\ord" ], "⩝", [miscellanea]; + ["\\wedbar" ], "⩟", [miscellanea]; + ["\\sdote" ], "⩦", [miscellanea]; + ["\\simdot" ], "⩪", [miscellanea]; + ["\\congdot" ], "⩭", [miscellanea]; + ["\\ncongdot" ], "⩭̸", [miscellanea]; + ["\\apacir" ], "⩯", [miscellanea]; + ["\\napE" ], "⩰̸", [miscellanea]; + ["\\eplus" ], "⩱", [miscellanea]; + ["\\pluse" ], "⩲", [miscellanea]; + ["\\Esim" ], "⩳", [miscellanea]; + ["\\Colone" ], "⩴", [miscellanea]; + ["\\Equal" ], "⩵", [miscellanea]; + ["\\eDDot"; "\\ddotseq" ], "⩷", [miscellanea]; + ["\\equivDD" ], "⩸", [miscellanea]; + ["\\ltcir" ], "⩹", [miscellanea]; + ["\\gtcir" ], "⩺", [miscellanea]; + ["\\ltquest" ], "⩻", [miscellanea]; + ["\\gtquest" ], "⩼", [miscellanea]; + ["\\LessLess" ], "⪡", [miscellanea]; + ["\\GreaterGreater" ], "⪢", [miscellanea]; + ["\\glj" ], "⪤", [miscellanea]; + ["\\gla" ], "⪥", [miscellanea]; + ["\\ltcc" ], "⪦", [miscellanea]; + ["\\gtcc" ], "⪧", [miscellanea]; + ["\\lescc" ], "⪨", [miscellanea]; + ["\\gescc" ], "⪩", [miscellanea]; + ["\\smt" ], "⪪", [miscellanea]; + ["\\lat" ], "⪫", [miscellanea]; + ["\\smte" ], "⪬", [miscellanea]; + ["\\smtes" ], "⪬︀", [miscellanea]; + ["\\late" ], "⪭", [miscellanea]; + ["\\lates" ], "⪭︀", [miscellanea]; + ["\\Sc" ], "⪼", [miscellanea]; + ["\\subdot" ], "⪽", [miscellanea]; + ["\\supdot" ], "⪾", [miscellanea]; + ["\\subplus" ], "⪿", [miscellanea]; + ["\\supplus" ], "⫀", [miscellanea]; + ["\\submult" ], "⫁", [miscellanea]; + ["\\supmult" ], "⫂", [miscellanea]; + ["\\subedot" ], "⫃", [miscellanea]; + ["\\supedot" ], "⫄", [miscellanea]; + ["\\subsim" ], "⫇", [miscellanea]; + ["\\supsim" ], "⫈", [miscellanea]; + ["\\csub" ], "⫏", [miscellanea]; + ["\\csup" ], "⫐", [miscellanea]; + ["\\csube" ], "⫑", [miscellanea]; + ["\\csupe" ], "⫒", [miscellanea]; + ["\\subsup" ], "⫓", [miscellanea]; + ["\\supsub" ], "⫔", [miscellanea]; + ["\\subsub" ], "⫕", [miscellanea]; + ["\\supsup" ], "⫖", [miscellanea]; + ["\\suphsub" ], "⫗", [miscellanea]; + ["\\supdsub" ], "⫘", [miscellanea]; + ["\\forkv" ], "⫙", [miscellanea]; + ["\\topfork" ], "⫚", [miscellanea]; + ["\\mlcp" ], "⫛", [miscellanea]; + ["\\Dashv"; "\\DoubleLeftTee" ], "⫤", [miscellanea]; + ["\\Vdashl" ], "⫦", [miscellanea]; + ["\\Barv" ], "⫧", [miscellanea]; + ["\\vBar" ], "⫨", [miscellanea]; + ["\\vBarv" ], "⫩", [miscellanea]; + ["\\Vbar" ], "⫫", [miscellanea]; + ["\\Not" ], "⫬", [miscellanea]; + ["\\bNot" ], "⫭", [miscellanea]; + ["\\rnmid" ], "⫮", [miscellanea]; + ["\\cirmid" ], "⫯", [miscellanea]; + ["\\midcir" ], "⫰", [miscellanea]; + ["\\topcir" ], "⫱", [miscellanea]; + ["\\nhpar" ], "⫲", [miscellanea]; + ["\\parsim" ], "⫳", [miscellanea]; + ["\\loang" ], "", [miscellanea]; + ["\\roang" ], "", [miscellanea]; + ["\\xlarr"; "\\LongLeftArrow" ], "", [miscellanea]; + ["\\xrarr"; "\\LongRightArrow" ], "", [miscellanea]; + ["\\xharr"; "\\LongLeftRightArrow" ], "", [miscellanea]; + ["\\xlArr"; "\\DoubleLongLeftArrow" ], "", [miscellanea]; + ["\\xrArr"; "\\DoubleLongRightArrow" ], "", [miscellanea]; + ["\\xhArr"; "\\DoubleLongLeftRightArrow" ], "", [miscellanea]; + ["\\xmap" ], "", [miscellanea]; + ["\\FilledVerySmallSquare" ], "", [miscellanea]; + ["\\EmptyVerySmallSquare" ], "", [miscellanea]; + ["\\dzigrarr" ], "", [miscellanea]; + ["\\Ascr" ], "𝒜", [miscellanea]; + ["\\Cscr" ], "𝒞", [miscellanea]; + ["\\Dscr" ], "𝒟", [miscellanea]; + ["\\Gscr" ], "𝒢", [miscellanea]; + ["\\Jscr" ], "𝒥", [miscellanea]; + ["\\Kscr" ], "𝒦", [miscellanea]; + ["\\Nscr" ], "𝒩", [miscellanea]; + ["\\Oscr" ], "𝒪", [miscellanea]; + ["\\Pscr" ], "𝒫", [miscellanea]; + ["\\Qscr" ], "𝒬", [miscellanea]; + ["\\Sscr" ], "𝒮", [miscellanea]; + ["\\Tscr" ], "𝒯", [miscellanea]; + ["\\Uscr" ], "𝒰", [miscellanea]; + ["\\Vscr" ], "𝒱", [miscellanea]; + ["\\Wscr" ], "𝒲", [miscellanea]; + ["\\Xscr" ], "𝒳", [miscellanea]; + ["\\Yscr" ], "𝒴", [miscellanea]; + ["\\Zscr" ], "𝒵", [miscellanea]; + ["\\ascr" ], "𝒶", [miscellanea]; + ["\\bscr" ], "𝒷", [miscellanea]; + ["\\cscr" ], "𝒸", [miscellanea]; + ["\\dscr" ], "𝒹", [miscellanea]; + ["\\fscr" ], "𝒻", [miscellanea]; + ["\\hscr" ], "𝒽", [miscellanea]; + ["\\iscr" ], "𝒾", [miscellanea]; + ["\\jscr" ], "𝒿", [miscellanea]; + ["\\kscr" ], "𝓀", [miscellanea]; + ["\\mscr" ], "𝓂", [miscellanea]; + ["\\nscr" ], "𝓃", [miscellanea]; + ["\\pscr" ], "𝓅", [miscellanea]; + ["\\qscr" ], "𝓆", [miscellanea]; + ["\\rscr" ], "𝓇", [miscellanea]; + ["\\sscr" ], "𝓈", [miscellanea]; + ["\\tscr" ], "𝓉", [miscellanea]; + ["\\uscr" ], "𝓊", [miscellanea]; + ["\\vscr" ], "𝓋", [miscellanea]; + ["\\wscr" ], "𝓌", [miscellanea]; + ["\\xscr" ], "𝓍", [miscellanea]; + ["\\yscr" ], "𝓎", [miscellanea]; + ["\\zscr" ], "𝓏", [miscellanea]; + ["\\Afr" ], "𝔄", [miscellanea]; + ["\\Bfr" ], "𝔅", [miscellanea]; + ["\\Dfr" ], "𝔇", [miscellanea]; + ["\\Efr" ], "𝔈", [miscellanea]; + ["\\Ffr" ], "𝔉", [miscellanea]; + ["\\Gfr" ], "𝔊", [miscellanea]; + ["\\Jfr" ], "𝔍", [miscellanea]; + ["\\Kfr" ], "𝔎", [miscellanea]; + ["\\Lfr" ], "𝔏", [miscellanea]; + ["\\Mfr" ], "𝔐", [miscellanea]; + ["\\Nfr" ], "𝔑", [miscellanea]; + ["\\Ofr" ], "𝔒", [miscellanea]; + ["\\Pfr" ], "𝔓", [miscellanea]; + ["\\Qfr" ], "𝔔", [miscellanea]; + ["\\Sfr" ], "𝔖", [miscellanea]; + ["\\Tfr" ], "𝔗", [miscellanea]; + ["\\Ufr" ], "𝔘", [miscellanea]; + ["\\Vfr" ], "𝔙", [miscellanea]; + ["\\Wfr" ], "𝔚", [miscellanea]; + ["\\Xfr" ], "𝔛", [miscellanea]; + ["\\Yfr" ], "𝔜", [miscellanea]; + ["\\afr" ], "𝔞", [miscellanea]; + ["\\bfr" ], "𝔟", [miscellanea]; + ["\\cfr" ], "𝔠", [miscellanea]; + ["\\dfr" ], "𝔡", [miscellanea]; + ["\\efr" ], "𝔢", [miscellanea]; + ["\\ffr" ], "𝔣", [miscellanea]; + ["\\gfr" ], "𝔤", [miscellanea]; + ["\\hfr" ], "𝔥", [miscellanea]; + ["\\ifr" ], "𝔦", [miscellanea]; + ["\\jfr" ], "𝔧", [miscellanea]; + ["\\kfr" ], "𝔨", [miscellanea]; + ["\\lfr" ], "𝔩", [miscellanea]; + ["\\mfr" ], "𝔪", [miscellanea]; + ["\\nfr" ], "𝔫", [miscellanea]; + ["\\ofr" ], "𝔬", [miscellanea]; + ["\\pfr" ], "𝔭", [miscellanea]; + ["\\qfr" ], "𝔮", [miscellanea]; + ["\\rfr" ], "𝔯", [miscellanea]; + ["\\sfr" ], "𝔰", [miscellanea]; + ["\\tfr" ], "𝔱", [miscellanea]; + ["\\ufr" ], "𝔲", [miscellanea]; + ["\\vfr" ], "𝔳", [miscellanea]; + ["\\wfr" ], "𝔴", [miscellanea]; + ["\\xfr" ], "𝔵", [miscellanea]; + ["\\yfr" ], "𝔶", [miscellanea]; + ["\\zfr" ], "𝔷", [miscellanea]; +(* }}} *) + +] + + +(** **************************************************************************) +(** * Bindings set 2 *) + +let bindings_set_2 = [ + + (* Symbols *) + "\\!'", "¡"; + "\\`", "‘"; + "\\``", "“"; + "\\'", "′"; + "\\''", "″"; + "\\'''", "‴"; + "\\mbox''", "”"; + "\\mbox'", "’"; + "\\--", "–"; + "\\---", "—"; + "\\Alpha", "Α"; + "\\Beta", "Β"; + "\\Box", "□"; + "\\Bumpeq", "≎"; + "\\Cap", "⋒"; + "\\Chi", "Χ"; + "\\Cup", "⋓"; + "\\DH", "Ð"; + "\\Delta", "Δ "; + "\\Diamond", "◇"; + "\\Downarrow", "⇓"; + "\\Epsilon", "Ε "; + "\\Eta", "Η"; + "\\Finv", "Ⅎ"; + "\\Gamma", "Γ "; + "\\Im", "ℑ"; + "\\Join", "⋈"; + "\\Kappa", "Κ"; + "\\L", "Ł"; + "\\Lambda", "Λ"; + "\\Leftarrow", "⇐"; + "\\Leftrightarrow", "⇔"; + "\\Lleftarrow", "⇚"; + "\\Longleftarrow", "⇐"; + "\\Longleftrightarrow", "⇔"; + "\\Longrightarrow", "⇒"; + "\\Lsh", "↰"; + "\\Mu", "Μ"; + "\\Nu", "Ν"; + "\\O", "Ø"; + "\\OE", "Œ"; + "\\Omega", "Ω"; + "\\W", "Ω"; + "\\Omicron", "Ο"; + "\\P", "¶"; + "\\Phi", "Φ"; + "\\F", "Φ"; + "\\Pi", "Π"; + "\\Psi", "Ψ"; + "\\Re", "ℜ"; + "\\Rho", "Ρ"; + "\\Rightarrow", "⇒"; + "\\Rrightarrow", "⇛"; + "\\Rsh", "↱"; + "\\S", "§"; + "\\Sigma", "Σ"; + "\\Subset", "⋐"; + "\\Supset", "⋑"; + "\\TH", "Þ"; + "\\Tau", "Τ"; + "\\Theta", "Θ"; + "\\Uparrow", "⇑"; + "\\Updownarrow", "⇕"; + "\\Upsilon", "Υ"; + "\\Vdash", "⊩"; + "\\Vvdash", "⊪"; + "\\Xi", "Ξ"; + "\\Zeta", "Ζ"; + "\\aa", "å"; + "\\ae", "æ"; + "\\aleph", "ℵ"; + "\\alpha", "α"; + "\\angle", "∠"; + "\\approx", "≈"; + "\\approxeq", "≊"; + "\\aquarius", "♒"; + "\\aries", "♈"; + "\\ascnode", "☊"; + "\\ast", "∗"; + "\\astrosun", "☉"; + "\\asymp", "≍"; + "\\backepsilon", "∍"; + "\\backprime", "‵"; + "\\backsim", "∽"; + "\\barwedge", "⊼"; + "\\because", "∵"; + "\\beta", "β"; + "\\beth", "ℶ"; + "\\between", "≬"; + "\\bigcap", "⋂"; + "\\bigcirc", "○"; + "\\bigcup", "⋃"; + "\\bigodot", "⊙"; + "\\bigoplus", "⊕"; + "\\bigotimes", "⊗"; + "\\bigsqcup", "⊔"; + "\\bigstar", "★"; + "\\bigtriangledown", "▽"; + "\\bigtriangleup", "△"; + "\\biguplus", "⊎"; + "\\bigvee", "⋁"; + "\\bigwedge", "⋀"; + "\\blackbishop", "♝"; + "\\blackking", "♚"; + "\\blackknight", "♞"; + "\\blacklozenge", "◆"; + "\\blackpawn", "♟"; + "\\blackqueen", "♛"; + "\\blackrook", "♜"; + "\\blacksquare", "■"; + "\\blacktriangle", "▲"; + "\\blacktriangledown", "▼"; + "\\blacktriangleleft", "◀"; + "\\blacktriangleright", "▷"; + "\\bot", "⊥"; + "\\bowtie", "⋈"; + "\\boxdot", "⊡"; + "\\boxminus", "⊟"; + "\\boxplus", "⊞"; + "\\boxtimes", "⊠"; + "\\bullet", "∙"; + "\\bumpeq", "≏"; + "\\cancer", "♋"; + "\\cap", "∩"; + "\\capricornus", "♑"; + "\\capslockkey", "⇪"; + "\\cdot", "⋅"; + "\\cdots", "⋯"; + "\\centerdot", "⋅"; + "\\cents", "¢"; + "\\chi", "χ"; + "\\circ", "∘"; + "\\circeq", "≗"; + "\\circlearrowleft", "↺"; + "\\circlearrowright", "↻"; + "\\circledS", "Ⓢ"; + "\\circledast", "⊛"; + "\\circledcirc", "⊚"; + "\\circleddash", "⊝"; + "\\clubsuit", "♣"; + "\\cmdkey", "⌘"; + "\\complement", "∁"; + "\\cong", "≅"; + "\\conjunction", "☌"; + "\\coprod", "∐"; + "\\copyright", "©"; + "\\cup", "∪"; + "\\curlyeqprec", "⋞"; + "\\curlyeqsucc", "⋟"; + "\\curlyvee", "⋎"; + "\\curlywedge", "⋏"; + "\\curvearrowleft", "↶"; + "\\curvearrowright", "↷"; + "\\cC", "Ç"; + "\\cc", "ç"; + "\\dag", "†"; + "\\dagger", "†"; + "\\daleth", "ℸ"; + "\\dashleftarrow", "⇠"; + "\\dashrightarrow", "⇢"; + "\\dashv", "⊣"; + "\\ddag", "‡"; + "\\ddagger", "‡"; + "\\degree", "°"; + "\\delkey", "⌫"; + "\\delta", "δ "; + "\\descnode", "☋"; + "\\dh", "ð"; + "\\diamond", "⋄"; + "\\diamondsuit", "♢"; + "\\digamma", "Ϝ"; + "\\div", "÷"; + "\\divideontimes", "⋇"; + "\\downarrow", "↓"; + "\\downdownarrows", "⇊"; + "\\downharpoonleft", "⇃"; + "\\downharpoonright", "⇂"; + "\\earth", "⊕"; + "\\ejectkey", "⏏"; + "\\ell", "ℓ"; + "\\emptyset", "∅"; + "\\enterkey", "⌤"; + "\\epsdice1", "⚀"; + "\\epsdice2", "⚁"; + "\\epsdice3", "⚂"; + "\\epsdice4", "⚃"; + "\\epsdice5", "⚄"; + "\\epsdice6", "⚅"; + "\\epsilon", "∊"; + "\\eqcirc", "≖"; + "\\equiv", "≡"; + "\\esckey", "⎋"; + "\\eta", "η"; + "\\eth", "ð"; + "\\euro", "€"; + "\\exists", "∃"; + "\\fallingdotseq", "≒"; + "\\flat", "♭"; + "\\forall", "∀"; + "\\frown", "⌢"; + "\\gamma", "γ"; + "\\ge", "≥"; + "\\gemini", "♊"; + "\\geq", "≥"; + "\\geqq", "≧"; + "\\gg", "≫"; + "\\ggg", "⋙"; + "\\gimel", "ℷ"; + "\\gtrdot", "⋗"; + "\\gtreqless", "⋛"; + "\\gtrless", "≷"; + "\\gtrsim", "≳"; + "\\hbar", "ℏ"; + "\\heartsuit", "♡"; + "\\hookleftarrow", "↩"; + "\\hookrightarrow", "↪"; + "\\hslash", "ℏ"; + "\\iiiint", "⨌"; + "\\iiint", "∭"; + "\\iint", "∬"; + "\\implies", "⇒"; + "\\in", "∈"; + "\\infty", "∞"; + "\\int", "∫"; + "\\intercal", "⊺"; + "\\iota", "ι"; + "\\jupiter", "♃"; + "\\kappa", "κ"; + "\\l{}", "ł"; + "\\lambda", "λ"; + "\\langle", "⟨"; + "\\lceil", "⌈"; + "\\ldots", "…"; + "\\le", "≤"; + "\\leadsto", "↝"; + "\\leftarrow", "←"; + "\\leftarrowtail", "↢"; + "\\leftharpoondown", "↽"; + "\\leftharpoonup", "↼"; + "\\leftleftarrows", "⇇"; + "\\leftmoon", "☾"; + "\\leftrightarrow", "↔"; + "\\leftrightarrows", "⇆"; + "\\leftrightharpoons", "⇋"; + "\\leftrightsquigarrow", "↭"; + "\\leftthreetimes", "⋋"; + "\\leo", "♌"; + "\\leq", "≤"; + "\\leqq", "≦"; + "\\leqslant", "≤"; + "\\lessdot", "⋖"; + "\\lesseqgtr", "⋚"; + "\\lessgtr", "≶"; + "\\lesssim", "≲"; + "\\lfloor", "⌊"; + "\\lhd", "⊲"; + "\\libra", "♎"; + "\\ll", "≪"; + "\\lll", "⋘"; + "\\longleftarrow", "←"; + "\\longleftrightarrow", "↔"; + "\\longmapsto", "⇖"; + "\\longrightarrow", "→"; + "\\looparrowleft", "↫"; + "\\looparrowright", "↬"; + "\\lozenge", "◊"; + "\\ltimes", "⋉"; + "\\mapsto", "↦"; + "\\mars", "♂"; + "\\measuredangle", "∡"; + "\\mercury", "☿"; + "\\mho", "℧"; + "\\mid", "∣"; + "\\models", "⊨"; + "\\mp", "∓"; + "\\mu", "μ"; + "\\multimap", "⊸"; + "\\nabla", "∇"; + "\\natural", "♮"; + "\\nearrow", "↗"; + "\\neg", "¬"; + "\\neptune", "♆"; + "\\neq", "≠"; + "\\nexists", "∄"; + "\\ng", "ŋ"; + "\\ni", "∋"; + "\\not<", "≮"; + "\\not>", "≯"; + "\\not\\Vdash", "⊮"; + "\\not\\approx", "≉"; + "\\not\\cong", "≇"; + "\\not\\equiv", "≢"; + "\\not\\ge", "≱"; + "\\not\\gtrless", "≹"; + "\\not\\in", "∉"; + "\\not\\le", "≰"; + "\\not\\models", "⊭"; + "\\not\\ni", "∌"; + "\\not\\sim", "≄"; + "\\not\\sqsubseteq", "⋢"; + "\\not\\sqsupseteq", "⋣"; + "\\not\\subset", "⊄"; + "\\not\\subseteq", "⊈"; + "\\not\\supset", "⊅"; + "\\not\\supseteq", "⊉"; + "\\not\\vdash", "⊬"; + "\\notin", "∉"; + "\\nu", "ν"; + "\\v", "ν"; + "\\nwarrow", "↖"; + "\\o{}", "ø"; + "\\odot", "⊙"; + "\\oe", "œ"; + "\\oint", "∮"; + "\\omega", "ω"; + "\\w", "ω"; + "\\omicron", "ο"; + "\\ominus", "⊖"; + "\\oplus", "⊕"; + "\\opposition", "☍"; + "\\optkey", "⌥"; + "\\oslash", "⊘"; + "\\otimes", "⊗"; + "\\parallel", "∥"; + "\\partial", "∂"; + "\\perp", "⊥"; + "\\phi", "φ"; + "\\f", "φ"; + "\\pi", "π"; + "\\pilcrow", "¶"; + "\\pisces", "♓"; + "\\pitchfork", "⋔"; + "\\pluto", "♇"; + "\\pm", "±"; + "\\pound", "£"; + "\\pounds", "£"; + "\\prec", "≺"; + "\\preccurlyeq", "≼"; + "\\preceq", "≼"; + "\\precsim", "≾"; + "\\prime", "′"; + "\\prod", "∏"; + "\\propto", "∝"; + "\\psi", "ψ"; + "\\rangle", "⟩"; + "\\rceil", "⌉"; + "\\registered", "®"; + "\\returnkey", "⏎"; + "\\revtabkey", "⇤"; + "\\rfloor", "⌋"; + "\\rhd", "⊳"; + "\\rho", "ρ"; + "\\rightarrow", "→"; + "\\rightarrowtail", "↣"; + "\\rightdelkey", "⌦"; + "\\rightharpoondown", "⇁"; + "\\rightharpoonup", "⇀"; + "\\rightleftarrows", "⇄"; + "\\rightleftharpoons", "⇌"; + "\\rightmoon", "☽"; + "\\rightrightarrows", "⇉"; + "\\rightsquigarrow", "⇝"; + "\\rightthreetimes", "⋌"; + "\\risingdotseq", "≓"; + "\\rtimes", "⋊"; + "\\sagittarius", "♐"; + "\\saturn", "♄"; + "\\scorpio", "♏"; + "\\searrow", "↘"; + "\\section", "§"; + "\\setminus", "∖"; + "\\sharp", "♯"; + "\\shiftkey", "⇧"; + "\\shortparallel", "∥"; + "\\sigma", "σ"; + "\\sim", "∼"; + "\\simeq", "≃"; + "\\smallfrown", "⌢"; + "\\smallsetminus", "∖"; + "\\smallsmile", "⌣"; + "\\smile", "⌣"; + "\\space", "␣"; + "\\spadesuit", "♠"; + "\\sphericalangle", "∢"; + "\\sqcap", "⊓"; + "\\sqcup", "⊔"; + "\\sqsubset", "⊏"; + "\\sqsubseteq", "⊑"; + "\\sqsupset", "⊐"; + "\\sqsupseteq", "⊒"; + "\\square", "□"; + "\\ss", "ß"; + "\\star", "⋆"; + "\\subset", "⊂"; + "\\subseteq", "⊆"; + "\\subsetneq", "⊊"; + "\\succ", "≻"; + "\\succcurlyeq", "≽"; + "\\succeq", "≽"; + "\\succsim", "≿"; + "\\sum", "∑"; + "\\supset", "⊃"; + "\\supseteq", "⊇"; + "\\supsetneq", "⊋"; + "\\surd", "√"; + "\\swarrow", "↙"; + "\\tabkey", "⇥"; + "\\tau", "τ"; + "\\taurus", "♉"; + "\\textbabygamma", "ɤ"; + "\\textbarglotstop", "ʡ"; + "\\textbari", "ɨ"; + "\\textbaro", "ɵ"; + "\\textbarrevglotstop", "ʢ"; + "\\textbaru", "ʉ"; + "\\textbeltl", "ɬ"; + "\\textbeta", "β"; + "\\textbullseye", "ʘ"; + "\\textchi", "χ"; + "\\textcloserevepsilon", "ɞ"; + "\\textcrh", "ħ"; + "\\textctc", "ɕ"; + "\\textctj", "ʝ"; + "\\textctz", "ʑ"; + "\\textdoublepipe", "ǁ"; + "\\textdyoghlig", "ʤ"; + "\\textepsilon", "ɛ"; + "\\textesh", "ʃ"; + "\\textfishhookr", "ɾ"; + "\\textgamma", "ɣ"; + "\\textglotstop", "ʔ"; + "\\textgrgamma", "γ"; + "\\texthtb", "ɓ"; + "\\texthtd", "ɗ"; + "\\texthtg", "ɠ"; + "\\texthth", "ɦ"; + "\\texththeng", "ɧ"; + "\\texthtscg", "ʛ"; + "\\textinvscr", "ʁ"; + "\\textiota", "ι"; + "\\textltailm", "ɱ"; + "\\textltailn", "ɲ"; + "\\textltilde", "ɫ"; + "\\textlyoghlig", "ɮ"; + "\\textopeno", "ɔ"; + "\\textphi", "ɸ"; + "\\textpipe", "ǀ"; + "\\textregistered", "®"; + "\\textreve", "ɘ"; + "\\textrevepsilon", "ɜ"; + "\\textrevglotstop", "ʕ"; + "\\textrhookrevepsilon", "ɝ"; + "\\textrighthookschwa", "ɚ"; + "\\textteshlig", "ʧ"; + "\\texttheta", "θ"; + "\\texttrademark", "™"; + "\\textturna", "ɐ"; + "\\textturnh", "ɥ"; + "\\textturnlonglegr", "ɺ"; + "\\textturnm", "ɯ"; + "\\textturnmrleg", "ɰ"; + "\\textturnr", "ɹ"; + "\\textturnrrtail", "ɻ"; + "\\textturnscripta", "ɒ"; + "\\textturnv", "ʌ"; + "\\textturnw", "ʍ"; + "\\textturny", "ʎ"; + "\\textupsilon", "ʊ"; + "\\textyogh", "ʒ"; + "\\th", "þ"; + "\\therefore", "∴"; + "\\theta", "θ"; + "\\h", "θ"; + "\\thickapprox", "≈"; + "\\thicksim", "∼"; + "\\times", "×"; + "\\top", "⊤"; + "\\trademark", "™"; + "\\triangle", "△"; + "\\triangledown", "▽"; + "\\triangleleft", "◁"; + "\\trianglelefteq", "⊴"; + "\\triangleq", "≜"; + "\\triangleright", "▷"; + "\\trianglerighteq", "⊵"; + "\\twoheadleftarrow", "↞"; + "\\twoheadrightarrow", "↠"; + "\\unlhd", "⊴"; + "\\unrhd", "⊵"; + "\\uparrow", "↑"; + "\\updownarrow", "↕"; + "\\upharpoonleft", "↿"; + "\\upharpoonright", "↾"; + "\\uplus", "⊎"; + "\\upsilon", "υ"; + "\\upuparrows", "⇈"; + "\\uranus", "⛢"; + "\\vDash", "⊨"; + "\\varepsilon", "ε"; + "\\varkappa", "ϰ"; + "\\varnothing", "∅"; + "\\varphi", "ϕ"; + "\\varpi", "ϖ"; + "\\varpropto", "∝"; + "\\varrho", "ϱ"; + "\\varsigma", "ς"; + "\\vartheta", "ϑ"; + "\\vartriangle", "△"; + "\\vartriangleleft", "⊲"; + "\\vartriangleright", "⊳"; + "\\vdash", "⊢"; + "\\vdots", "⋮"; + "\\vee", "∨"; + "\\veebar", "⊻"; + "\\venus", "♀"; + "\\virgo", "♍"; + "\\wedge", "∧"; + "\\whitebishop", "♗"; + "\\whiteking", "♔"; + "\\whiteknight", "♘"; + "\\whitepawn", "♙"; + "\\whitequeen", "♕"; + "\\whiterook", "♖"; + "\\wp", "℘"; + "\\wr", "≀"; + "\\xi", "ξ"; + "\\zeta", "ζ"; + + (* Double accent *) + "\\\"A", "Ä"; + "\\\"E", "Ë"; + "\\\"H", "Ḧ"; + "\\\"I", "Ï"; + "\\\"O", "Ö"; + "\\\"U", "Ü"; + "\\\"W", "Ẅ"; + "\\\"X", "Ẍ"; + "\\\"Y", "Ÿ"; + "\\\"a", "ä"; + "\\\"e", "ë"; + "\\\"h", "ḧ"; + "\\\"i", "ï"; + "\\\"o", "ö"; + "\\\"t", "ẗ"; + "\\\"u", "ü"; + "\\\"w", "ẅ"; + "\\\"x", "ẍ"; + "\\\"y", "ÿ"; + + (* Acute accent *) + "\\'A", "Á"; + "\\'C", "Ć"; + "\\'E", "É"; + "\\'G", "Ǵ"; + "\\'I", "Í"; + "\\'K", "Ḱ"; + "\\'L", "Ĺ"; + "\\'M", "Ḿ"; + "\\'N", "Ń"; + "\\'O", "Ó"; + "\\'P", "Ṕ"; + "\\'R", "Ŕ"; + "\\'S", "Ś"; + "\\'U", "Ú"; + "\\'W", "Ẃ"; + "\\'Y", "Ý"; + "\\'Z", "Ź"; + "\\'a", "á"; + "\\'c", "ć"; + "\\'e", "é"; + "\\'g", "ǵ"; + "\\'i", "í"; + "\\'k", "ḱ"; + "\\'l", "ĺ"; + "\\'m", "ḿ"; + "\\'n", "ń"; + "\\'o", "ó"; + "\\'p", "ṕ"; + "\\'r", "ŕ"; + "\\'s", "ś"; + "\\'u", "ú"; + "\\'w", "ẃ"; + "\\'y", "ý"; + "\\'z", "ź"; + + (* Doted accent *) + "\\.A", "Ȧ"; + "\\.B", "Ḃ"; + "\\.C", "Ċ"; + "\\.D", "Ḋ"; + "\\.E", "Ė"; + "\\.F", "Ḟ"; + "\\.G", "Ġ"; + "\\.H", "Ḣ"; + "\\.I", "İ"; + "\\.M", "Ṁ"; + "\\.N", "Ṅ"; + "\\.O", "Ȯ"; + "\\.P", "Ṗ"; + "\\.R", "Ṙ"; + "\\.S", "Ṡ"; + "\\.T", "Ṫ"; + "\\.W", "Ẇ"; + "\\.X", "Ẋ"; + "\\.Y", "Ẏ"; + "\\.Z", "Ż"; + "\\.a", "ȧ"; + "\\.b", "ḃ"; + "\\.c", "ċ"; + "\\.d", "ḋ"; + "\\.e", "ė"; + "\\.f", "ḟ"; + "\\.g", "ġ"; + "\\.h", "ḣ"; + "\\.m", "ṁ"; + "\\.n", "ṅ"; + "\\.o", "ȯ"; + "\\.p", "ṗ"; + "\\.r", "ṙ"; + "\\.s", "ṡ"; + "\\.t", "ṫ"; + "\\.w", "ẇ"; + "\\.x", "ẋ"; + "\\.y", "ẏ"; + "\\.z", "ż"; + "\\doteq", "≐"; + "\\doteqdot", "≑"; + "\\dotplus", "∔"; + "\\dotA", "Ȧ"; + "\\dotB", "Ḃ"; + "\\dotC", "Ċ"; + "\\dotD", "Ḋ"; + "\\dotE", "Ė"; + "\\dotF", "Ḟ"; + "\\dotG", "Ġ"; + "\\dotH", "Ḣ"; + "\\dotI", "İ"; + "\\dotM", "Ṁ"; + "\\dotN", "Ṅ"; + "\\dotO", "Ȯ"; + "\\dotP", "Ṗ"; + "\\dotR", "Ṙ"; + "\\dotS", "Ṡ"; + "\\dotT", "Ṫ"; + "\\dotW", "Ẇ"; + "\\dotX", "Ẋ"; + "\\dotY", "Ẏ"; + "\\dotZ", "Ż"; + "\\dota", "ȧ"; + "\\dotb", "ḃ"; + "\\dotc", "ċ"; + "\\dotd", "ḋ"; + "\\dote", "ė"; + "\\dotf", "ḟ"; + "\\dotg", "ġ"; + "\\doth", "ḣ"; + "\\dotm", "ṁ"; + "\\dotn", "ṅ"; + "\\doto", "ȯ"; + "\\dotp", "ṗ"; + "\\dotr", "ṙ"; + "\\dots", "ṡ"; + "\\dott", "ṫ"; + "\\dotw", "ẇ"; + "\\dotx", "ẋ"; + "\\doty", "ẏ"; + "\\dotz", "ż"; + "\\dA", "Ạ"; + "\\dB", "Ḅ"; + "\\dD", "Ḍ"; + "\\dE", "Ẹ"; + "\\dH", "Ḥ"; + "\\dI", "Ị"; + "\\dK", "Ḳ"; + "\\dL", "Ḷ"; + "\\dM", "Ṃ"; + "\\dN", "Ṇ"; + "\\dO", "Ọ"; + "\\dR", "Ṛ"; + "\\dS", "Ṣ"; + "\\dT", "Ṭ"; + "\\dU", "Ụ"; + "\\dV", "Ṿ"; + "\\dW", "Ẉ"; + "\\dY", "Ỵ"; + "\\dZ", "Ẓ"; + "\\da", "ạ"; + "\\db", "ḅ"; + "\\dd", "ḍ"; + "\\de", "ẹ"; + "\\dh", "ḥ"; + "\\di", "ị"; + "\\dk", "ḳ"; + "\\dl", "ḷ"; + "\\dm", "ṃ"; + "\\dn", "ṇ"; + "\\do", "ọ"; + "\\dr", "ṛ"; + "\\ds", "ṣ"; + "\\dt", "ṭ"; + "\\du", "ụ"; + "\\dv", "ṿ"; + "\\dw", "ẉ"; + "\\dy", "ỵ"; + "\\dz", "ẓ"; + + (* Double dot accent *) + "\\ddots", "⋱"; + "\\ddotA", "Ä"; + "\\ddotE", "Ë"; + "\\ddotH", "Ḧ"; + "\\ddotI", "Ï"; + "\\ddotO", "Ö"; + "\\ddotU", "Ü"; + "\\ddotW", "Ẅ"; + "\\ddotX", "Ẍ"; + "\\ddotY", "Ÿ"; + "\\ddota", "ä"; + "\\ddote", "ë"; + "\\ddoth", "ḧ"; + "\\ddoti", "ï"; + "\\ddoto", "ö"; + "\\ddott", "ẗ"; + "\\ddotu", "ü"; + "\\ddotw", "ẅ"; + "\\ddotx", "ẍ"; + "\\ddoty", "ÿ"; + + (* Breve accent *) + "\\breveA", "Ă"; + "\\breveE", "Ĕ"; + "\\breveG", "Ğ"; + "\\breveI", "Ĭ"; + "\\breveO", "Ŏ"; + "\\breveU", "Ŭ"; + "\\brevea", "ă"; + "\\brevee", "ĕ"; + "\\breveg", "ğ"; + "\\brevei", "ĭ"; + "\\breveo", "ŏ"; + "\\breveu", "ŭ"; + "\\uA", "Ă"; + "\\uE", "Ĕ"; + "\\uG", "Ğ"; + "\\uI", "Ĭ"; + "\\uO", "Ŏ"; + "\\uU", "Ŭ"; + "\\ua", "ă"; + "\\ue", "ĕ"; + "\\ug", "ğ"; + "\\ui", "ĭ"; + "\\uo", "ŏ"; + "\\uu", "ŭ"; + + (* Check accent *) + "\\checkA", "Ǎ"; + "\\checkC", "Č"; + "\\checkD", "Ď"; + "\\checkE", "Ě"; + "\\checkN", "Ň"; + "\\checkR", "Ř"; + "\\checkS", "Š"; + "\\checkT", "Ť"; + "\\checkZ", "Ž"; + "\\checka", "ǎ"; + "\\checkc", "č"; + "\\checkd", "ď"; + "\\checke", "ě"; + "\\checkn", "ň"; + "\\checkr", "ř"; + "\\checks", "š"; + "\\checkt", "ť"; + "\\checkz", "ž"; + "\\vA", "Ǎ"; + "\\vC", "Č"; + "\\vD", "Ď"; + "\\vE", "Ě"; + "\\vN", "Ň"; + "\\vR", "Ř"; + "\\vS", "Š"; + "\\vT", "Ť"; + "\\vZ", "Ž"; + "\\va", "ǎ"; + "\\vc", "č"; + "\\vd", "ď"; + "\\ve", "ě"; + "\\vn", "ň"; + "\\vr", "ř"; + "\\vs", "š"; + "\\vt", "ť"; + "\\vz", "ž"; + + (* Bar accent *) + "\\=A", "Ā"; + "\\=E", "Ē"; + "\\=G", "Ḡ"; + "\\=I", "Ī"; + "\\=O", "Ō"; + "\\=U", "Ū"; + "\\=Y", "Ȳ"; + "\\=a", "ā"; + "\\=e", "ē"; + "\\=g", "ḡ"; + "\\=i", "ī"; + "\\=o", "ō"; + "\\=u", "ū"; + "\\=y", "ȳ"; + "\\AA", "Å"; + "\\AE", "Æ"; + "\\barA", "Ā"; + "\\barE", "Ē"; + "\\barG", "Ḡ"; + "\\barI", "Ī"; + "\\barO", "Ō"; + "\\barU", "Ū"; + "\\barY", "Ȳ"; + "\\bara", "ā"; + "\\bare", "ē"; + "\\barg", "ḡ"; + "\\bari", "ī"; + "\\baro", "ō"; + "\\baru", "ū"; + "\\bary", "ȳ"; + + (* Hat acccent *) + "\\^A", "Â"; + "\\^C", "Ĉ"; + "\\^E", "Ê"; + "\\^G", "Ĝ"; + "\\^H", "Ĥ"; + "\\^I", "Î"; + "\\^J", "Ĵ"; + "\\^O", "Ô"; + "\\^S", "Ŝ"; + "\\^U", "Û"; + "\\^W", "Ŵ"; + "\\^Y", "Ŷ"; + "\\^Z", "Ẑ"; + "\\^a", "â"; + "\\^c", "ĉ"; + "\\^e", "ê"; + "\\^g", "ĝ"; + "\\^h", "ĥ"; + "\\^i", "î"; + "\\^j", "ĵ"; + "\\^o", "ô"; + "\\^s", "ŝ"; + "\\^u", "û"; + "\\^w", "ŵ"; + "\\^y", "ŷ"; + "\\^z", "ẑ"; + + (* Backquote acccent *) + "\\`A", "À"; + "\\`E", "È"; + "\\`I", "Ì"; + "\\`N", "Ǹ"; + "\\`O", "Ò"; + "\\`U", "Ù"; + "\\`W", "Ẁ"; + "\\`Y", "Ỳ"; + "\\`a", "à"; + "\\`e", "è"; + "\\`i", "ì"; + "\\`n", "ǹ"; + "\\`o", "ò"; + "\\`u", "ù"; + "\\`w", "ẁ"; + "\\`y", "ỳ"; + + (* Tiled acccent *) + "\\~A", "Ā"; + "\\~E", "Ẽ"; + "\\~I", "Ĩ"; + "\\~N", "Ñ"; + "\\~O", "Õ"; + "\\~U", "Ũ"; + "\\~Y", "Ỹ"; + "\\~a", "ã"; + "\\~e", "ẽ"; + "\\~i", "ĩ"; + "\\~n", "ñ"; + "\\~o", "õ"; + "\\~u", "ũ"; + "\\~y", "ỹ"; + + (* textrt font *) + "\\textrtaild", "ɖ"; + "\\textrtaill", "ɭ"; + "\\textrtailn", "ɳ"; + "\\textrtailr", "ɽ"; + "\\textrtails", "ʂ"; + "\\textrtailt", "ʈ"; + "\\textrtailz", "ʐ"; + + (* textsc font *) + "\\textscb", "ʙ"; + "\\textscg", "ɢ"; + "\\textsch", "ʜ"; + "\\textschwa", "ə"; + "\\textsci", "ɪ"; + "\\textscl", "ʟ"; + "\\textscn", "ɴ"; + "\\textscoelig", "ɶ"; + "\\textscr", "ʀ"; + "\\textscripta", "ɑ"; + "\\textscriptv", "ʋ"; + "\\textscy", "ʏ"; + + (* bb font *) + "\\bb0", "𝟘"; + "\\bb1", "𝟙"; + "\\bb2", "𝟚"; + "\\bb3", "𝟛"; + "\\bb4", "𝟜"; + "\\bb5", "𝟝"; + "\\bb6", "𝟞"; + "\\bb7", "𝟟"; + "\\bb8", "𝟠"; + "\\bb9", "𝟡"; + "\\bbA", "𝔸"; + "\\bbB", "𝔹"; + "\\bbC", "ℂ"; + "\\bbD", "𝔻"; + "\\bbE", "𝔼"; + "\\bbF", "𝔽"; + "\\bbG", "𝔾"; + "\\bbH", "ℍ"; + "\\bbI", "𝕀"; + "\\bbJ", "𝕁"; + "\\bbK", "𝕂"; + "\\bbL", "𝕃"; + "\\bbM", "𝕄"; + "\\bbN", "ℕ"; + "\\bbO", "𝕆"; + "\\bbP", "ℙ"; + "\\bbQ", "ℚ"; + "\\bbR", "ℝ"; + "\\bbS", "𝕊"; + "\\bbT", "𝕋"; + "\\bbU", "𝕌"; + "\\bbV", "𝕍"; + "\\bbW", "𝕎"; + "\\bbX", "𝕏"; + "\\bbY", "𝕐"; + "\\bbZ", "ℤ"; + "\\bba", "𝕒"; + "\\bbb", "𝕓"; + "\\bbc", "𝕔"; + "\\bbd", "𝕕"; + "\\bbe", "𝕖"; + "\\bbf", "𝕗"; + "\\bbg", "𝕘"; + "\\bbh", "𝕙"; + "\\bbi", "𝕚"; + "\\bbj", "𝕛"; + "\\bbk", "𝕜"; + "\\bbl", "𝕝"; + "\\bbm", "𝕞"; + "\\bbn", "𝕟"; + "\\bbo", "𝕠"; + "\\bbp", "𝕡"; + "\\bbq", "𝕢"; + "\\bbr", "𝕣"; + "\\bbs", "𝕤"; + "\\bbt", "𝕥"; + "\\bbu", "𝕦"; + "\\bbv", "𝕧"; + "\\bbw", "𝕨"; + "\\bbx", "𝕩"; + "\\bby", "𝕪"; + "\\bbz", "𝕫"; + + (* cal font *) + "\\calA", "𝒜"; + "\\calB", "ℬ"; + "\\calC", "𝒞"; + "\\calD", "𝒟"; + "\\calE", "ℰ"; + "\\calF", "ℱ"; + "\\calG", "𝒢"; + "\\calH", "ℋ"; + "\\calI", "ℐ"; + "\\calJ", "𝒥"; + "\\calK", "𝒦"; + "\\calL", "ℒ"; + "\\calM", "ℳ"; + "\\calN", "𝒩"; + "\\calO", "𝒪"; + "\\calP", "𝒫"; + "\\calQ", "𝒬"; + "\\calR", "ℛ"; + "\\calS", "𝒮"; + "\\calT", "𝒯"; + "\\calU", "𝒰"; + "\\calV", "𝒱"; + "\\calW", "𝒲"; + "\\calX", "𝒳"; + "\\calY", "𝒴"; + "\\calZ", "𝒵"; + "\\cala", "𝒶"; + "\\calb", "𝒷"; + "\\calc", "𝒸"; + "\\cald", "𝒹"; + "\\cale", "ℯ"; + "\\calf", "𝒻"; + "\\calg", "ℊ"; + "\\calh", "𝒽"; + "\\cali", "𝒾"; + "\\calj", "𝒿"; + "\\calk", "𝓀"; + "\\call", "𝓁"; + "\\calm", "𝓂"; + "\\caln", "𝓃"; + "\\calo", "ℴ"; + "\\calp", "𝓅"; + "\\calq", "𝓆"; + "\\calr", "𝓇"; + "\\cals", "𝓈"; + "\\calt", "𝓉"; + "\\calu", "𝓊"; + "\\calv", "𝓋"; + "\\calw", "𝓌"; + "\\calx", "𝓍"; + "\\caly", "𝓎"; + "\\calz", "𝓏"; + + (* frak font *) + "\\frakA", "𝔄"; + "\\frakB", "𝔅"; + "\\frakC", "ℭ"; + "\\frakD", "𝔇"; + "\\frakE", "𝔈"; + "\\frakF", "𝔉"; + "\\frakG", "𝔊"; + "\\frakH", "ℌ"; + "\\frakI", "ℑ"; + "\\frakJ", "𝔍"; + "\\frakK", "𝔎"; + "\\frakL", "𝔏"; + "\\frakM", "𝔐"; + "\\frakN", "𝔑"; + "\\frakO", "𝔒"; + "\\frakP", "𝔓"; + "\\frakQ", "𝔔"; + "\\frakR", "ℜ"; + "\\frakS", "𝔖"; + "\\frakT", "𝔗"; + "\\frakU", "𝔘"; + "\\frakV", "𝔙"; + "\\frakW", "𝔚"; + "\\frakX", "𝔛"; + "\\frakY", "𝔜"; + "\\frakZ", "ℨ"; + "\\fraka", "𝔞"; + "\\frakb", "𝔟"; + "\\frakc", "𝔠"; + "\\frakd", "𝔡"; + "\\frake", "𝔢"; + "\\frakf", "𝔣"; + "\\frakg", "𝔤"; + "\\frakh", "𝔥"; + "\\fraki", "𝔦"; + "\\frakj", "𝔧"; + "\\frakk", "𝔨"; + "\\frakl", "𝔩"; + "\\frakm", "𝔪"; + "\\frakn", "𝔫"; + "\\frako", "𝔬"; + "\\frakp", "𝔭"; + "\\frakq", "𝔮"; + "\\frakr", "𝔯"; + "\\fraks", "𝔰"; + "\\frakt", "𝔱"; + "\\fraku", "𝔲"; + "\\frakv", "𝔳"; + "\\frakw", "𝔴"; + "\\frakx", "𝔵"; + "\\fraky", "𝔶"; + "\\frakz", "𝔷"; + + (* Exponent *) + "\\^(", "⁽"; + "\\^)", "⁾"; + "\\^+", "⁺"; + "\\^-", "⁻"; + "\\^0", "⁰"; + "\\^1", "¹"; + "\\^2", "²"; + "\\^3", "³"; + "\\^4", "⁴"; + "\\^5", "⁵"; + "\\^6", "⁶"; + "\\^7", "⁷"; + "\\^8", "⁸"; + "\\^9", "⁹"; + "\\^=", "⁼"; + "\\^A", "ᴬ"; + "\\^B", "ᴮ"; + "\\^D", "ᴰ"; + "\\^E", "ᴱ"; + "\\^G", "ᴳ"; + "\\^H", "ᴴ"; + "\\^I", "ᴵ"; + "\\^J", "ᴶ"; + "\\^K", "ᴷ"; + "\\^L", "ᴸ"; + "\\^M", "ᴹ"; + "\\^N", "ᴺ"; + "\\^O", "ᴼ"; + "\\^P", "ᴾ"; + "\\^R", "ᴿ"; + "\\^T", "ᵀ"; + "\\^U", "ᵁ"; + "\\^V", "ⱽ"; + "\\^W", "ᵂ"; + "\\^alpha", "ᵅ"; + "\\^beta", "ᵝ"; + "\\^chi", "ᵡ"; + "\\^delta", "ᵟ"; + "\\^epsilon", "ᵋ"; + "\\^gamma", "ᵞ"; + "\\^iota", "ᶥ"; + "\\^phi", "ᶲ"; + "\\^theta", "ᶿ"; + "\\^varphi", "ᵠ"; + "\\^a", "ᵃ"; + "\\^b", "ᵇ"; + "\\^c", "ᶜ"; + "\\^d", "ᵈ"; + "\\^e", "ᵉ"; + "\\^f", "ᶠ"; + "\\^g", "ᵍ"; + "\\^h", "ʰ"; + "\\^i", "ⁱ"; + "\\^j", "ʲ"; + "\\^k", "ᵏ"; + "\\^l", "ˡ"; + "\\^m", "ᵐ"; + "\\^n", "ⁿ"; + "\\^o", "ᵒ"; + "\\^p", "ᵖ"; + "\\^r", "ʳ"; + "\\^s", "ˢ"; + "\\^t", "ᵗ"; + "\\^u", "ᵘ"; + "\\^v", "ᵛ"; + "\\^w", "ʷ"; + "\\^x", "ˣ"; + "\\^y", "ʸ"; + "\\^z", "ᶻ"; + + (* Subscript *) + "\\_(", "₍"; + "\\_)", "₎"; + "\\_+", "₊"; + "\\_-", "₋"; + "\\_0", "₀"; + "\\_1", "₁"; + "\\_2", "₂"; + "\\_3", "₃"; + "\\_4", "₄"; + "\\_5", "₅"; + "\\_6", "₆"; + "\\_7", "₇"; + "\\_8", "₈"; + "\\_9", "₉"; + "\\_=", "₌"; + "\\_beta", "ᵦ"; + "\\_chi", "ᵪ"; + "\\_gamma", "ᵧ"; + "\\_rho", "ᵨ"; + "\\_varphi", "ᵩ"; + "\\_a", "ₐ"; + "\\_e", "ₑ"; + "\\_h", "ₕ"; + "\\_i", "ᵢ"; + "\\_j", "ⱼ"; + "\\_k", "ₖ"; + "\\_l", "ₗ"; + "\\_m", "ₘ"; + "\\_n", "ₙ"; + "\\_o", "ₒ"; + "\\_p", "ₚ"; + "\\_r", "ᵣ"; + "\\_s", "ₛ"; + "\\_t", "ₜ"; + "\\_u", "ᵤ"; + "\\_v", "ᵥ"; + "\\_x", "ₓ"; + +] + + +(** **************************************************************************) +(** * Priorities *) + +(** Set priorities, at the moment only for greek letters *) + +let priorities = [ +(* {{{ greek letters *) + "\\alpha", 1; + "\\beta", 1; + "\\gamma", 1; + "\\delta", 1; + "\\epsilon", 1; + "\\zeta", 1; + "\\eta", 2; + "\\theta", 2; + "\\iota", 1; + "\\kappa", 1; + "\\lambda", 1; + "\\mu", 1; + "\\nu", 1; + "\\xi", 1; + "\\o", 1; + "\\pi", 1; + "\\rho", 1; + "\\sigma", 1; + "\\tau", 1; + "\\upsilon", 1; + "\\phi", 2; + "\\chi", 1; + "\\psi", 2; + "\\omega", 2; + "\\Gamma", 1; + "\\Delta", 1; + "\\Theta", 2; + "\\Lambda", 1; + "\\Xi", 1; + "\\Pi", 1; + "\\Sigma", 1; + "\\Upsilon", 1; + "\\Phi", 2; + "\\Psi", 2; + "\\Omega", 1; +(* }}} *) +] + + +(** **************************************************************************) +(** * Binding generator *) + +let filename = + let args = Sys.argv in + if Array.length args < 2 + then failwith "please provide output filename as argument"; + Sys.argv.(1) + +let _ = (* generate output file *) + let bindings = ref [] in + let add (key,value) = + bindings := (key,value)::!bindings in + (* add bindings from set 1 *) + List.iter (fun (keys,value,_group) -> + List.iter (fun key -> add (key,value)) keys) bindings_set_1; + (* add bindings from set 2 *) + List.iter add bindings_set_2; + (* create table for priorities lookup *) + let priotable = Hashtbl.create 20 in + List.iter (fun (key,prio) -> Hashtbl.add priotable key prio) priorities; + (* remove duplicates and sort *) + let outbindings = List.sort_uniq (fun (key1,_) (key2,_) -> String.compare key1 key2) !bindings in + (* print bindings into file, including optional priorities *) + let file = open_out filename in + let print_binding (key,value) = + Printf.fprintf file "%s %s" key value; + begin match Hashtbl.find_opt priotable key with + | Some prio -> Printf.fprintf file " %d" prio + | None -> () + end; + Printf.fprintf file "\n" + in + List.iter print_binding outbindings; + close_out file + + +(** **************************************************************************) +(** * Groups of similar shapes *) + +(* For future use. + +let predefined_classes = [ + ["&"; "⅋"; ]; + ["|"; "∥"; ]; + ["!"; "¡"; "⫯"; "⫰"; "⟟"; "⫱"; ]; + ["?"; "¿"; "⸮"; ]; + [":"; "⁝"; ]; + ["."; "•"; "◦"; ]; + ["#"; "♯"; "⋕"; "⧣"; "⧤"; "⌘"; ]; + ["+"; "⊞"; ]; + ["-"; "÷"; "⊢"; "⊩"; "⊟"; ]; + ["="; "≝"; "≡"; "⩬"; "≂"; "≃"; "≈"; "≅"; "≗"; "≐"; "≑"; "≚"; "≙"; "⌆"; "⊜"; ]; + ["→"; "↦"; "⇝"; "⤞"; "⇾"; "⤍"; "⤏"; "⤳"; ] ; + ["⇒"; "⤇"; "➾"; "⇨"; "➡"; "⬈"; "➤"; "➸"; "⇉"; "⥰"; ] ; + ["^"; "↑"; ] ; + ["⇑"; "⇧"; "⬆"; ] ; + ["⇓"; "⇩"; "⬇"; "⬊"; "➷"; ] ; + ["⇕"; "⇳"; "⬍"; ]; + ["↔"; "⇔"; "⬄"; "⬌"; ] ; + ["≤"; "≲"; "≼"; "≰"; "≴"; "⋠"; "⊆"; "⫃"; "⊑"; ] ; + ["_"; "↓"; "↙"; "⎽"; "⎼"; "⎻"; "⎺"; ]; + ["<"; "≺"; "≮"; "⊀"; "〈"; "«"; "❬"; "❮"; "❰"; ] ; + ["("; "❨"; "❪"; "❲"; "（"; ]; + [")"; "❩"; "❫"; "❳"; "）"; ]; + ["["; "⦋"; "〚"; ] ; + ["]"; "⦌"; "〛"; ] ; + ["{"; "❴"; "⦃" ] ; + ["}"; "❵"; "⦄" ] ; + ["□"; "◽"; "▪"; "◾"; ]; + ["◊"; "♢"; "⧫"; "♦"; "⟐"; "⟠"; ] ; + [">"; "⭃"; "⧁"; "〉"; "»"; "❭"; "❯"; "❱"; "▸"; "►"; "▶"; "⊃"; "⊐"; ] ; + ["≥"; "⪀"; "≽"; "⪴"; "⥸"; "⊒"; ]; + ["∨"; "⩖"; "∪"; "∩"; "⋓"; "⋒" ] ; + ["a"; "α"; "𝕒"; "𝐚"; "𝛂"; "ⓐ"; ] ; + ["A"; "ℵ"; "𝔸"; "𝐀"; "Ⓐ"; ] ; + ["b"; "β"; "ß"; "𝕓"; "𝐛"; "𝛃"; "ⓑ"; ] ; + ["B"; "ℶ"; "ℬ"; "𝔹"; "𝐁"; "Ⓑ"; ] ; + ["c"; "𝕔"; "𝐜"; "ⓒ"; ] ; + ["C"; "ℭ"; "∁"; "𝐂"; "Ⓒ"; ] ; + ["d"; "δ"; "∂"; "𝕕"; "ⅆ"; "𝐝"; "𝛅"; "ⓓ"; ] ; + ["D"; "Δ"; "𝔻"; "ⅅ"; "𝐃"; "𝚫"; "Ⓓ"; ] ; + ["e"; "ɛ"; "ε"; "ϵ"; "Є"; "ℯ"; "𝕖"; "ⅇ"; "𝐞"; "𝛆"; "𝛜"; "ⓔ"; ] ; + ["E"; "ℰ"; "𝔼"; "𝐄"; "Ⓔ"; ] ; + ["f"; "φ"; "ψ"; "ϕ"; "⨍"; "𝕗"; "𝐟"; "𝛟"; "𝛙"; "ⓕ"; ] ; + ["F"; "Φ"; "Ψ"; "ℱ"; "𝔽"; "𝐅"; "𝚽"; "𝚿"; "Ⓕ"; ] ; + ["g"; "γ"; "ℊ"; "𝕘"; "𝐠"; "𝛄"; "ⓖ"; ] ; + ["G"; "Γ"; "𝔾"; "𝐆"; "𝚪"; "Ⓖ"; ] ; + ["h"; "η"; "ℌ"; "ℎ"; "𝕙"; "𝐡"; "ⓗ"; ] ; + ["H"; "ℋ"; "ℍ"; "𝐇"; "Ⓗ"; ] ; + ["i"; "ι"; "ℐ"; "𝕚"; "ⅈ"; "𝐢"; "𝛊"; "ⓘ"; ] ; + ["I"; "𝕀"; "𝐈"; "Ⓘ"; ] ; + ["j"; "𝕛"; "𝐣"; "ⓙ"; ] ; + ["J"; "Ј"; "𝕁"; "𝐉"; "Ⓙ"; ] ; + ["k"; "κ"; "𝕜"; "𝐤"; "𝛋"; "ⓚ"; ] ; + ["K"; "𝕂"; "𝐊"; "Ⓚ"; ] ; + ["l"; "λ"; "𝕝"; "𝐥"; "𝛌"; "ⓛ"; ] ; + ["L"; "Λ"; "𝕃"; "𝐋"; "𝚲"; "Ⓛ"; ] ; + ["m"; "μ"; "𝕞"; "𝐦"; "𝛍"; "ⓜ"; ] ; + ["M"; "ℳ"; "𝕄"; "𝐌"; "Ⓜ"; ] ; + ["n"; "𝕟"; "𝐧"; "𝛈"; "ⓝ"; ] ; + ["N"; "ℕ"; "№"; "𝐍"; "Ⓝ"; ] ; + ["o"; "θ"; "ϑ"; "𝕠"; "∘"; "⊚"; "ø"; "○"; "𝐨"; "𝛉"; "ⓞ"; ] ; + ["O"; "Θ"; "𝕆"; "𝐎"; "𝚯"; "𝚹"; "Ⓞ"; ] ; + ["p"; "π"; "𝕡"; "𝐩"; "𝛑"; "ⓟ"; ] ; + ["P"; "Π"; "℘"; "ℙ"; "𝐏"; "𝚷"; "Ⓟ"; ] ; + ["q"; "𝕢"; "𝐪"; "ⓠ"; ] ; + ["Q"; "ℚ"; "𝐐"; "Ⓠ"; ] ; + ["r"; "ρ"; "ϱ"; "𝕣"; "𝐫"; "𝛒"; "𝛠"; "ⓡ"; ] ; + ["R"; "ℛ"; "ℜ"; "ℝ"; "𝐑"; "Ⓡ"; ] ; + ["s"; "σ"; "ς"; "𝕤"; "𝐬"; "𝛔"; "ⓢ"; ] ; + ["S"; "Σ"; "𝕊"; "𝐒"; "𝚺"; "Ⓢ"; ] ; + ["t"; "τ"; "𝕥"; "𝐭"; "𝛕"; "ⓣ"; ] ; + ["T"; "𝕋"; "𝐓"; "Ⓣ"; "⊥"; ] ; + ["u"; "𝕦"; "𝐮"; "ⓤ"; ] ; + ["U"; "𝕌"; "𝐔"; "Ⓤ"; ] ; + ["v"; "ν"; "𝕧"; "𝐯"; "𝛖"; "𝛎"; "ⓥ"; "▼"; ] ; + ["V"; "𝕍"; "𝐕"; "Ⓥ"; ] ; + ["w"; "ω"; "𝕨"; "𝐰"; "𝛚"; "ⓦ"; ] ; + ["W"; "Ω"; "𝕎"; "𝐖"; "𝛀"; "Ⓦ"; ] ; + ["x"; "ξ"; "χ"; "ϰ"; "𝕩"; "𝐱"; "𝛏"; "𝛘"; "𝛞"; "ⓧ"; ] ; + ["X"; "Ξ"; "𝕏";"𝐗"; "𝚵"; "Ⓧ"; "⦻"; ] ; + ["y"; "υ"; "𝕪"; "𝐲"; "ⓨ"; ] ; + ["Y"; "ϒ"; "𝕐"; "𝐘"; "𝚼"; "Ⓨ"; ] ; + ["z"; "ζ"; "𝕫"; "𝐳"; "𝛇"; "ⓩ"; ] ; + ["Z"; "ℨ"; "ℤ"; "𝐙"; "Ⓩ"; ] ; + ["0"; "𝟘"; "⓪"; ] ; + ["1"; "𝟙"; "①"; "⓵"; ] ; + ["2"; "𝟚"; "②"; "⓶"; ] ; + ["3"; "𝟛"; "③"; "⓷"; ] ; + ["4"; "𝟜"; "④"; "⓸"; ] ; + ["5"; "𝟝"; "⑤"; "⓹"; ] ; + ["6"; "𝟞"; "⑥"; "⓺"; ] ; + ["7"; "𝟟"; "⑦"; "⓻"; ] ; + ["8"; "𝟠"; "⑧"; "⓼"; "∞"; ] ; + ["9"; "𝟡"; "⑨"; "⓽"; ] ; + ] + +*) diff --git a/ide/document.ml b/ide/document.ml new file mode 100644 index 0000000000..0d3b36a7fd --- /dev/null +++ b/ide/document.ml @@ -0,0 +1,189 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +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 -> ('a list * 'a list) option -> unit) -> unit + method pushed : callback:('a -> ('a list * 'a list) option -> 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 * ('a list * 'a list) option) signal; + popped_sig : ('a * ('a list * 'a list) option) signal; +} + +let connect d : 'a signals = + object + method pushed ~callback = d.pushed_sig#connect (fun (x, ctx) -> callback x ctx) + method popped ~callback = d.popped_sig#connect (fun (x, ctx) -> callback x ctx) + end + +let create () = { + stack = []; + context = None; + pushed_sig = new signal (); + popped_sig = new signal (); +} + +let repr_context s = match s.context with +| None -> None +| Some (cl, cr) -> + let map s = s.data in + Some (List.map map cl, List.map map cr) + +(* 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, repr_context d) + +let pop = function + | { stack = [] } -> raise Empty + | { stack = { data }::xs } as s -> + s.stack <- xs; s.popped_sig#call (data, repr_context s); 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 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 0000000000..2f460e6d8c --- /dev/null +++ b/ide/document.mli @@ -0,0 +1,117 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* 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.t) -> Pp.t + +(** Callbacks on documents *) + +class type ['a] signals = + object + method popped : callback:('a -> ('a list * 'a list) option -> unit) -> unit + method pushed : callback:('a -> ('a list * 'a list) option -> unit) -> unit + end + +val connect : 'a document -> 'a signals diff --git a/ide/dune b/ide/dune new file mode 100644 index 0000000000..5710fcbec7 --- /dev/null +++ b/ide/dune @@ -0,0 +1,66 @@ +; IDE Server +(ocamllex utf8_convert config_lexer coq_lex) + +(library + (name core) + (public_name coqide-server.core) + (wrapped false) + (modules document) + (libraries coq.lib)) + +(executable + (name fake_ide) + (public_name fake_ide) + (package coqide-server) + (modules fake_ide) + (libraries coqide-server.protocol coqide-server.core)) + +(executable + (name idetop) + (public_name coqidetop.opt) + (package coqide-server) + (modules idetop) + (libraries coq.toplevel coqide-server.protocol) + (link_flags -linkall)) + +; IDE Client +(library + (name coqide_gui) + (wrapped false) + (modules (:standard \ document fake_ide idetop coqide_main default_bindings_src)) + (optional) + (libraries coqide-server.protocol coqide-server.core lablgtk3-sourceview3)) + +(rule + (targets coqide_os_specific.ml) + (deps (:in-file coqide_X11.ml.in)) ; TODO support others + (action (copy# %{in-file} %{targets}))) + +(executable + (name coqide_main) + (public_name coqide) + (package coqide) + (modules coqide_main) + (libraries coqide_gui)) + +; Input-method bindings +(executable + (name default_bindings_src) + (modules default_bindings_src)) + +(rule + (targets default.bindings) + (deps (:gen ./default_bindings_src.exe)) + (action (run %{gen} %{targets}))) + +; FIXME: we should install those in share/coqide. We better do this +; once the make-based system has been phased out. +(install + (section share_root) + (package coqide) + (files + (coq.png as coq/coq.png) + (default.bindings as coq/default.bindings) + (coq_style.xml as coq/coq_style.xml) + (coq.lang as coq/coq.lang) + (coq-ssreflect.lang as coq/coq-ssreflect.lang))) diff --git a/ide/fake_ide.ml b/ide/fake_ide.ml new file mode 100644 index 0000000000..4e26cb6095 --- /dev/null +++ b/ide/fake_ide.ml @@ -0,0 +1,348 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Fake_ide : Simulate a [coqide] talking to a [coqidetop] *) + +let error s = + prerr_endline ("fake_ide: error: "^s); + exit 1 + +let pperr_endline pp = Format.eprintf "@[%a@]\n%!" Pp.pp_with pp + +type coqtop = { + xml_printer : Xml_printer.t; + xml_parser : Xml_parser.t; +} + +let print_error msg = + Format.eprintf "fake_ide: error: @[%a@]\n%!" Pp.pp_with msg + +let base_eval_call ?(print=true) ?(fail=true) call coqtop = + if print then prerr_endline (Xmlprotocol.pr_call call); + let xml_query = Xmlprotocol.of_call call in + Xml_printer.print coqtop.xml_printer xml_query; + let rec loop () = + let xml = Xml_parser.parse coqtop.xml_parser in + if Xmlprotocol.is_feedback xml then + loop () + else Xmlprotocol.to_answer call xml + in + let res = loop () in + if print then prerr_endline (Xmlprotocol.pr_full_value call res); + match res with + | Interface.Fail (_,_,s) when fail -> print_error s; exit 1 + | Interface.Fail (_,_,s) as x -> print_error s; x + | x -> x + +let eval_call c q = ignore(base_eval_call c q) + +module Parser = struct (* {{{ *) + + exception Err of string + exception More + + type token = + | Tok of string * string + | Top of token list + + type grammar = + | Alt of grammar list + | Seq of grammar list + | Opt of grammar + | Item of (string * (string -> token * int)) + + let eat_rex x = x, fun s -> + if Str.string_match (Str.regexp x) s 0 then begin + let m = Str.match_end () in + let w = String.sub s 0 m in + Tok(x,w), m + end else raise (Err ("Regexp "^x^" not found in: "^s)) + + let eat_balanced c = + let c' = match c with + | '{' -> '}' | '(' -> ')' | '[' -> ']' | _ -> assert false in + let sc, sc' = String.make 1 c, String.make 1 c' in + let name = sc ^ "..." ^ sc' in + let unescape s = + Str.global_replace (Str.regexp ("\\\\"^sc)) sc + (Str.global_replace (Str.regexp ("\\\\"^sc')) sc' s) in + name, fun s -> + if s.[0] = c then + let rec find n m = + if String.length s <= m then raise More; + if s.[m] = c' then + if n = 0 then Tok (name, unescape (String.sub s 1 (m-1))), m+1 + else find (n-1) (m+1) + else if s.[m] = c then find (n+1) (m+1) + else if s.[m] = '\\' && String.length s > m+1 && s.[m+1] = c then + find n (m+2) + else if s.[m] = '\\' && String.length s > m+1 && s.[m+1] = c' then + find n (m+2) + else find n (m+1) + in find ~-1 0 + else raise (Err ("Balanced "^String.make 1 c^" not found in: "^s)) + + let eat_blanks s = snd (eat_rex "[ \r\n\t]*") s + + let s = ref "" + + let parse g ic = + let read_more () = s := !s ^ input_line ic ^ "\n" in + let ensure_non_empty n = if n = String.length !s then read_more () in + let cut_after s n = String.sub s n (String.length s - n) in + let rec wrap f n = + try + ensure_non_empty n; + let _, n' = eat_blanks (cut_after !s n) in + ensure_non_empty n'; + let t, m = f (cut_after !s (n+n')) in + let _, m' = eat_blanks (cut_after !s (n+n'+m)) in + t, n+n'+m+m' + with More -> read_more (); wrap f n in + let rec aux n g res : token list * int = + match g with + | Item (_,f) -> + let t, n = wrap f n in + t :: res, n + | Opt g -> + (try let res', n = aux n g [] in Top (List.rev res') :: res, n + with Err _ -> Top [] :: res, n) + | Alt gl -> + let rec fst = function + | [] -> raise (Err ("No more alternatives for: "^cut_after !s n)) + | g :: gl -> + try aux n g res + with Err s -> fst gl in + fst gl + | Seq gl -> + let rec all (res,n) = function + | [] -> res, n + | g :: gl -> all (aux n g res) gl in + all (res,n) gl in + let res, n = aux 0 g [] in + s := cut_after !s n; + List.rev res + + let clean s = Str.global_replace (Str.regexp "\n") "\\n" s + + let rec print g = + match g with + | Item (s,_) -> Printf.sprintf "%s" (clean s) + | Opt g -> Printf.sprintf "[%s]" (print g) + | Alt gs -> Printf.sprintf "( %s )" (String.concat " | " (List.map print gs)) + | Seq gs -> String.concat " " (List.map print gs) + + let rec print_toklist = function + | [] -> "" + | Tok(k,v) :: rest when k = v -> clean k ^ " " ^ print_toklist rest + | Tok(k,v) :: rest -> clean k ^ " = \"" ^ clean v ^ "\" " ^ print_toklist rest + | Top l :: rest -> print_toklist l ^ " " ^ print_toklist rest + +end (* }}} *) + +type sentence = { + name : string; + text : string; + edit_id : int; +} + +let doc : sentence Document.document = Document.create () + +let tip_id () = + try Document.tip doc + with + | Document.Empty -> Stateid.initial + | Invalid_argument _ -> error "add_sentence on top of non assigned tip" + +let add_sentence = + let edit_id = ref 0 in + fun ?(name="") text -> + let tip_id = tip_id () in + decr edit_id; + Document.push doc { name; text; edit_id = !edit_id }; + !edit_id, tip_id + +let print_document () = + let ellipsize s = + Str.global_replace (Str.regexp "^[\n ]*") "" + (if String.length s > 20 then String.sub s 0 17 ^ "..." + else s) in + pperr_endline ( + (Document.print doc + (fun b state_id { name; text } -> + Pp.str (Printf.sprintf "%s[%10s, %3s] %s" + (if b then "*" else " ") + name + (Stateid.to_string (Option.default Stateid.dummy state_id)) + (ellipsize text))))) + +(* This module is the logic a GUI has to implement *) +module GUILogic = struct + + let after_add = function + | Interface.Fail (_,_,s) -> print_error s; exit 1 + | Interface.Good (id, (Util.Inl (), _)) -> + Document.assign_tip_id doc id + | Interface.Good (id, (Util.Inr tip, _)) -> + Document.assign_tip_id doc id; + Document.unfocus doc; + ignore(Document.cut_at doc tip); + print_document () + + let at id id' _ = Stateid.equal id' id + + let after_edit_at (id,need_unfocus) = function + | Interface.Fail (_,_,s) -> print_error s; exit 1 + | Interface.Good (Util.Inl ()) -> + if need_unfocus then Document.unfocus doc; + ignore(Document.cut_at doc id); + print_document () + | Interface.Good (Util.Inr (stop_id,(start_id,tip))) -> + if need_unfocus then Document.unfocus doc; + ignore(Document.cut_at doc tip); + Document.focus doc ~cond_top:(at start_id) ~cond_bot:(at stop_id); + ignore(Document.cut_at doc id); + print_document () + + let get_id_pred pred = + try Document.find_id doc pred + with Not_found -> error "No state found" + + let get_id id = get_id_pred (fun _ { name } -> name = id) + + let after_fail coq = function + | Interface.Fail (safe_id,_,s) -> + prerr_endline "The command failed as expected"; + let to_id, need_unfocus = + get_id_pred (fun id _ -> Stateid.equal id safe_id) in + after_edit_at (to_id, need_unfocus) + (base_eval_call (Xmlprotocol.edit_at to_id) coq) + | Interface.Good _ -> error "The command was expected to fail but did not" + +end + +open GUILogic + +let eval_print l coq = + let open Parser in + let open Xmlprotocol in + (* prerr_endline ("Interpreting: " ^ print_toklist l); *) + match l with + | [ Tok(_,"ADD"); Top []; Tok(_,phrase) ] -> + let eid, tip = add_sentence phrase in + after_add (base_eval_call (add ((phrase,eid),(tip,true))) coq) + | [ Tok(_,"ADD"); Top [Tok(_,name)]; Tok(_,phrase) ] -> + let eid, tip = add_sentence ~name phrase in + after_add (base_eval_call (add ((phrase,eid),(tip,true))) coq) + | [ Tok(_,"FAILADD"); Tok(_,phrase) ] -> + let eid, tip = add_sentence phrase in + after_fail coq (base_eval_call ~fail:false (add ((phrase,eid),(tip,true))) coq) + | [ Tok(_,"GOALS"); ] -> + eval_call (goals ()) coq + | [ Tok(_,"FAILGOALS"); ] -> + after_fail coq (base_eval_call ~fail:false (goals ()) coq) + | [ Tok(_,"EDIT_AT"); Tok(_,id) ] -> + let to_id, need_unfocus = get_id id in + after_edit_at (to_id, need_unfocus) (base_eval_call (edit_at to_id) coq) + | [ Tok(_,"QUERY"); Top []; Tok(_,phrase) ] -> + eval_call (query (0,(phrase,tip_id()))) coq + | [ Tok(_,"QUERY"); Top [Tok(_,id)]; Tok(_,phrase) ] -> + let to_id, _ = get_id id in + eval_call (query (0,(phrase, to_id))) coq + | [ Tok(_,"WAIT") ] -> + eval_call (wait ()) coq + | [ Tok(_,"JOIN") ] -> + eval_call (status true) coq + | [ Tok(_,"FAILJOIN") ] -> + after_fail coq (base_eval_call ~fail:false (status true) coq) + | [ Tok(_,"ASSERT"); Tok(_,"TIP"); Tok(_,id) ] -> + let to_id, _ = get_id id in + if not(Stateid.equal (Document.tip doc) to_id) then error "Wrong tip" + else prerr_endline "Good tip" + | [ Tok(_,"ABORT") ] -> + prerr_endline "Quitting fake_ide"; + exit 0 + | Tok("#[^\n]*",_) :: _ -> () + | Tok(s,_) :: _ -> error ("syntax error at " ^ s) + | _ -> error ("syntax error") + +let grammar = + let open Parser in + let eat_id = eat_rex "[a-zA-Z_][a-zA-Z0-9_]*" in + let eat_phrase = eat_balanced '{' in + Alt + [ Seq [Item (eat_rex "ADD"); Opt (Item eat_id); Item eat_phrase] + ; Seq [Item (eat_rex "FAILADD"); Item eat_phrase] + ; Seq [Item (eat_rex "EDIT_AT"); Item eat_id] + ; Seq [Item (eat_rex "QUERY"); Opt (Item eat_id); Item eat_phrase] + ; Seq [Item (eat_rex "WAIT")] + ; Seq [Item (eat_rex "JOIN")] + ; Seq [Item (eat_rex "GOALS")] + ; Seq [Item (eat_rex "FAILGOALS")] + ; Seq [Item (eat_rex "FAILJOIN")] + ; Seq [Item (eat_rex "ABORT")] + ; Seq [Item (eat_rex "ASSERT"); Item (eat_rex "TIP"); Item eat_id ] + ; Item (eat_rex "#[^\n]*") + ] + +let read_command inc = Parser.parse grammar inc + +let usage () = + error (Printf.sprintf + "A fake coqide process talking to a coqtop -toploop coqidetop.\n\ + Usage: %s (file|-) [<coqtop>]\n\ + Input syntax is the following:\n%s\n" + (Filename.basename Sys.argv.(0)) + (Parser.print grammar)) + +module Coqide = Spawn.Sync () + +let main = + if Sys.os_type = "Unix" then Sys.set_signal Sys.sigpipe + (Sys.Signal_handle + (fun _ -> prerr_endline "Broken Pipe (coqtop died ?)"; exit 1)); + let def_args = ["--xml_format=Ppcmds"] in + let idetop_name = System.get_toplevel_path "coqidetop" in + let coqtop_args, input_file = match Sys.argv with + | [| _; f |] -> Array.of_list def_args, f + | [| _; f; ct |] -> + let ct = Str.split (Str.regexp " ") ct in + Array.of_list (def_args @ ct), f + | _ -> usage () in + let inc = if input_file = "-" then stdin else open_in input_file in + prerr_endline ("Running: "^idetop_name^" "^ + (String.concat " " (Array.to_list coqtop_args))); + let coq = + let _p, cin, cout = Coqide.spawn idetop_name coqtop_args in + let ip = Xml_parser.make (Xml_parser.SChannel cin) in + let op = Xml_printer.make (Xml_printer.TChannel cout) in + Xml_parser.check_eof ip false; + { xml_printer = op; xml_parser = ip } in + let init () = + match base_eval_call ~print:false (Xmlprotocol.init None) coq with + | Interface.Good id -> + let dir = Filename.dirname input_file in + let phrase = Printf.sprintf "Add LoadPath \"%s\". " dir in + let eid, tip = add_sentence ~name:"initial" phrase in + after_add (base_eval_call (Xmlprotocol.add ((phrase,eid),(tip,true))) coq) + | Interface.Fail _ -> error "init call failed" in + let finish () = + match base_eval_call (Xmlprotocol.status true) coq with + | Interface.Good _ -> exit 0 + | Interface.Fail (_,_,s) -> print_error s; exit 1 in + (* The main loop *) + init (); + while true do + let cmd = try read_command inc with End_of_file -> finish () in + try eval_print cmd coq + with e -> error ("Uncaught exception " ^ Printexc.to_string e) + done + +(* vim:set foldmethod=marker: *) diff --git a/ide/fileOps.ml b/ide/fileOps.ml new file mode 100644 index 0000000000..e4c8942cf1 --- /dev/null +++ b/ide/fileOps.ml @@ -0,0 +1,156 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Ideutils + +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 : ?parent:GWindow.window -> unit -> unit + method auto_save : unit + method save : string -> bool + method saveas : ?parent:GWindow.window -> 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 ?parent () = + 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 = Configwin_ihm.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) + ?parent + "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"; + Preferences.global_auto_revert#set 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 ?parent f = + if not (Sys.file_exists f) then self#save f + else + let answ = Configwin_ihm.question_box ~title:"File exists on disk" + ~buttons:["Overwrite"; "Cancel";] + ~default:1 + ~icon:(warn_image ())#coerce + ?parent + ("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 Preferences.auto_save_name#get) ^ + (Filename.basename f) ^ + (snd Preferences.auto_save_name#get) + 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/fileOps.mli b/ide/fileOps.mli new file mode 100644 index 0000000000..44a19f9981 --- /dev/null +++ b/ide/fileOps.mli @@ -0,0 +1,25 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val revert_timer : Ideutils.timer +val autosave_timer : Ideutils.timer + +class type ops = +object + method filename : string option + method update_stats : unit + method changed_on_disk : bool + method revert : ?parent:GWindow.window -> unit -> unit + method auto_save : unit + method save : string -> bool + method saveas : ?parent:GWindow.window -> string -> bool +end + +class fileops : GText.buffer -> string option -> (unit -> unit) -> ops diff --git a/ide/gtk_parsing.ml b/ide/gtk_parsing.ml new file mode 100644 index 0000000000..d554bebdd3 --- /dev/null +++ b/ide/gtk_parsing.ml @@ -0,0 +1,77 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +let underscore = Glib.Utf8.to_unichar "_" ~pos:(ref 0) +let prime = Glib.Utf8.to_unichar "'" ~pos:(ref 0) + + +(* TODO: avoid num and prime at the head of a word *) +let is_word_char c = + Glib.Unichar.isalnum c || c = underscore || c = prime + + +let starts_word (it:GText.iter) = + (it#is_start || + (let c = it#backward_char#char in + not (is_word_char c))) + +let ends_word (it:GText.iter) = + (it#is_end || + let c = it#forward_char#char in + not (is_word_char c) + ) + +let find_word_start (it:GText.iter) = + let rec step_to_start it = + Minilib.log "Find word start"; + if not it#nocopy#backward_char then + (Minilib.log "find_word_start: cannot backward"; it) + else if is_word_char it#char + then step_to_start it + else begin + ignore(it#nocopy#forward_char); + Minilib.log ("Word start at: "^(string_of_int it#offset)); + it + end + in + step_to_start it#copy + +let find_word_end (it:GText.iter) = + let rec step_to_end (it:GText.iter) = + 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 ( + Minilib.log ("Word end at: "^(string_of_int it#offset)); + it) + in + step_to_end it#copy + + +let get_word_around (it:GText.iter) = + let start = find_word_start it in + let stop = find_word_end it in + start,stop + +(** On double-click on a view, select the whole word. This is a workaround for + a deficient word handling in TextView. *) +let fix_double_click self = + let callback ev = match GdkEvent.get_type ev with + | `TWO_BUTTON_PRESS -> + let iter = self#buffer#get_iter `INSERT in + let start, stop = get_word_around iter in + let () = self#buffer#move_mark `INSERT ~where:start in + let () = self#buffer#move_mark `SEL_BOUND ~where:stop in + true + | _ -> false + in + ignore (self#event#connect#button_press ~callback) diff --git a/ide/gtk_parsing.mli b/ide/gtk_parsing.mli new file mode 100644 index 0000000000..a9f3e1222d --- /dev/null +++ b/ide/gtk_parsing.mli @@ -0,0 +1,28 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val fix_double_click : + < buffer : < get_iter : [> `INSERT ] -> GText.iter; + move_mark : [> `INSERT | `SEL_BOUND ] -> + where:GText.iter -> unit; + .. >; + event : < connect : + < button_press : + callback:([> `TWO_BUTTON_PRESS ] Gdk.event -> + bool) -> + 'a; + .. >; + .. >; + .. > -> + unit +val starts_word : GText.iter -> bool +val ends_word : GText.iter -> bool +val find_word_start : GText.iter -> GText.iter +val find_word_end : GText.iter -> GText.iter diff --git a/ide/ide.mllib b/ide/ide.mllib new file mode 100644 index 0000000000..ed6520f29f --- /dev/null +++ b/ide/ide.mllib @@ -0,0 +1,34 @@ +Minilib +Configwin_messages +Configwin_ihm +Configwin +Config_parser +Tags +Wg_Notebook +Config_lexer +Utf8_convert +Preferences +Project_file +Ideutils +Unicode_bindings +Coq +Coq_lex +Sentence +Gtk_parsing +Wg_Segment +Wg_ProofView +Wg_MessageView +Wg_RoutedMessageViews +Wg_Detachable +Wg_Find +Wg_Completion +Wg_ScriptView +Coq_commands +FileOps +Document +CoqOps +Wg_Command +Session +Coqide_ui +NanoPG +Coqide diff --git a/ide/ide_common.mllib b/ide/ide_common.mllib new file mode 100644 index 0000000000..050c282ef6 --- /dev/null +++ b/ide/ide_common.mllib @@ -0,0 +1,7 @@ +Xml_lexer +Xml_parser +Xml_printer +Serialize +Richpp +Xmlprotocol +Document diff --git a/ide/ide_win32_stubs.c b/ide/ide_win32_stubs.c new file mode 100644 index 0000000000..f430c9f2b6 --- /dev/null +++ b/ide/ide_win32_stubs.c @@ -0,0 +1,33 @@ +#define _WIN32_WINNT 0x0501 /* Cf below, we restrict to */ + +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <windows.h> + +/* Win32 emulation of a kill -2 (SIGINT) */ + +/* 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. */ + +/* 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_interrupt(value pseudopid) { + CAMLparam1(pseudopid); + HANDLE h; + DWORD pid; + 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/idetop.ml b/ide/idetop.ml new file mode 100644 index 0000000000..543ff924bd --- /dev/null +++ b/ide/idetop.ml @@ -0,0 +1,551 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Vernacexpr +open Vernacprop +open CErrors +open Util +open Pp +open Printer + +module NamedDecl = Context.Named.Declaration +module CompactedDecl = Context.Compacted.Declaration + +(** Idetop : an implementation of [Interface], i.e. mainly an interp + function and a rewind function. *) + + +(** 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) + +let pr_with_pid s = Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s + +let pr_error s = pr_with_pid 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"]; + ["Printing";"Unfocused"]; + ["Diffs"]] + +let is_known_option cmd = match Vernacprop.under_control cmd with + | VernacSetOption (_, o, OptionSetTrue) + | VernacSetOption (_, o, OptionSetString _) + | VernacSetOption (_, o, OptionUnset) -> coqide_known_option o + | _ -> false + +(** Check whether a command is forbidden in the IDE *) + +let ide_cmd_checks ~last_valid {CAst.loc;v=ast} = + let user_error s = + try CErrors.user_err ?loc ~hdr:"IDE" (str s) + with e -> + let (e, info) = CErrors.push e in + let info = Stateid.add info ~valid:last_valid Stateid.dummy in + Exninfo.raise ~info e + in + if is_debug ast then + user_error "Debug mode not available in the IDE" + +let ide_cmd_warns ~id {CAst.loc;v=ast} = + let warn msg = Feedback.(feedback ~id (Message (Warning, loc, strbrk msg))) in + if is_known_option ast then + warn "Set this option from the IDE menu instead"; + if is_navigation_vernac ast || is_undo ast then + warn "Use IDE navigation instead" + +(** Interpretation (cf. [Ide_intf.interp]) *) + +let ide_doc = ref None +let get_doc () = Option.get !ide_doc +let set_doc doc = ide_doc := Some doc + +let add ((s,eid),(sid,verbose)) = + let doc = get_doc () in + let pa = Pcoq.Parsable.make (Stream.of_string s) in + match Stm.parse_sentence ~doc sid ~entry:Pvernac.main_entry pa with + | None -> assert false (* s is not an empty string *) + | Some ast -> + ide_cmd_checks ~last_valid:sid ast; + let doc, newid, rc = Stm.add ~doc ~ontop:sid verbose ast in + set_doc doc; + let rc = match rc with `NewTip -> CSig.Inl () | `Unfocus id -> CSig.Inr id in + ide_cmd_warns ~id:newid ast; + (* TODO: the "" parameter is a leftover of the times the protocol + * used to include stderr/stdout output. + * + * Currently, we force all the output meant for the to go via the + * feedback mechanism, and we don't manipulate stderr/stdout, which + * are left to the client's discrection. The parameter is still there + * as not to break the core protocol for this minor change, but it should + * be removed in the next version of the protocol. + *) + newid, (rc, "") + +let edit_at id = + let doc = get_doc () in + match Stm.edit_at ~doc id with + | doc, `NewTip -> set_doc doc; CSig.Inl () + | doc, `Focus { Stm.start; stop; tip} -> set_doc doc; CSig.Inr (start, (stop, tip)) + +(* TODO: the "" parameter is a leftover of the times the protocol + * used to include stderr/stdout output. + * + * Currently, we force all the output meant for the to go via the + * feedback mechanism, and we don't manipulate stderr/stdout, which + * are left to the client's discrection. The parameter is still there + * as not to break the core protocol for this minor change, but it should + * be removed in the next version of the protocol. + *) +let query (route, (s,id)) = + let pa = Pcoq.Parsable.make (Stream.of_string s) in + let doc = get_doc () in + Stm.query ~at:id ~doc ~route pa + +let annotate phrase = + let doc = get_doc () in + let pa = Pcoq.Parsable.make (Stream.of_string phrase) in + match Stm.parse_sentence ~doc (Stm.get_current_state ~doc) ~entry:Pvernac.main_entry pa with + | None -> Richpp.richpp_of_pp 78 (Pp.mt ()) + | Some ast -> + (* XXX: Width should be a parameter of annotate... *) + Richpp.richpp_of_pp 78 (Ppvernac.pr_vernac ast.CAst.v) + +(** Goal display *) + +let hyp_next_tac sigma env decl = + let id = NamedDecl.get_id decl in + let ast = NamedDecl.get_type decl in + 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 = + 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 = + pr_goal_concl_style_env env sigma (Goal.V82.concl sigma g) + in + let process_hyp d (env,l) = + let d' = CompactedDecl.to_named_context d in + (List.fold_right Environ.push_named d' env, + (pr_compacted_decl env sigma d) :: l) in + let (_env, hyps) = + Context.Compacted.fold process_hyp + (Termops.compact_named_context (Environ.named_context env)) ~init:(min_env,[]) in + { Interface.goal_hyp = List.rev hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; } + +let process_goal_diffs diff_goal_map oldp nsigma ng = + let open Evd in + let og_s = match oldp with + | Some oldp -> + let Proof.{ sigma=osigma } = Proof.data oldp in + (try Some { it = Evar.Map.find ng diff_goal_map; sigma = osigma } + with Not_found -> None) + | None -> None + in + let (hyps_pp_list, concl_pp) = Proof_diffs.diff_goal_ide og_s ng nsigma in + { Interface.goal_hyp = hyps_pp_list; Interface.goal_ccl = concl_pp; Interface.goal_id = Goal.uid ng } + +let export_pre_goals Proof.{ sigma; goals; stack; shelf; given_up } process = + let process = List.map (process sigma) in + { Interface.fg_goals = process goals + ; Interface.bg_goals = List.(map (fun (lg,rg) -> process lg, process rg)) stack + ; Interface.shelved_goals = process shelf + ; Interface.given_up_goals = process given_up + } + +let goals () = + let doc = get_doc () in + set_doc @@ Stm.finish ~doc; + try + let newp = Vernacstate.Proof_global.give_me_the_proof () in + if Proof_diffs.show_diffs () then begin + let oldp = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in + let diff_goal_map = Proof_diffs.make_goal_map oldp newp in + Some (export_pre_goals Proof.(data newp) (process_goal_diffs diff_goal_map oldp)) + end else + Some (export_pre_goals Proof.(data newp) process_goal) + with Vernacstate.Proof_global.NoCurrentProof -> None;; + +let evars () = + try + let doc = get_doc () in + set_doc @@ Stm.finish ~doc; + let pfts = Vernacstate.Proof_global.give_me_the_proof () in + let Proof.{ sigma } = Proof.data pfts in + let exl = Evar.Map.bindings (Evd.undefined_map 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 Vernacstate.Proof_global.NoCurrentProof -> None + +let hints () = + try + let pfts = Vernacstate.Proof_global.give_me_the_proof () in + let Proof.{ goals; sigma } = Proof.data pfts in + match goals with + | [] -> None + | g :: _ -> + let env = Goal.V82.env 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, concl_next_tac) + with Vernacstate.Proof_global.NoCurrentProof -> None + + +(** Other API calls *) + +let wait () = + let doc = get_doc () in + set_doc (Stm.wait ~doc) + +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) *) + set_doc (Stm.finish ~doc:(get_doc ())); + if force then + set_doc (Stm.join ~doc:(get_doc ())); + 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 (Vernacstate.Proof_global.get_current_proof_name ())) + with Vernacstate.Proof_global.NoCurrentProof -> None + in + let allproofs = + let l = Vernacstate.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 ~doc:(get_doc ()); + } + +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 = + let env = Global.env () in + let sigma = Evd.from_env env in + Pp.string_of_ppcmds (pr_lconstr_env env sigma t.Search.coq_object_object) +} + +let pattern_of_string ?env s = + let env = + match env with + | None -> Global.env () + | Some e -> e + in + let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in + let (_, pat) = Constrintern.intern_constr_pattern env (Evd.from_env env) constr in + pat + +let dirpath_of_string_list s = + let path = String.concat "." s in + let qid = Pcoq.parse_string Pcoq.Constr.global path in + let id = + try Nametab.full_name_module qid + with Not_found -> + CErrors.user_err ~hdr:"Search.interface_search" + (str "Module " ++ str path ++ str " not found.") + in + id + +let import_search_constraint = function + | Interface.Name_Pattern s -> Search.Name_Pattern (Str.regexp s) + | Interface.Type_Pattern s -> Search.Type_Pattern (pattern_of_string s) + | Interface.SubType_Pattern s -> Search.SubType_Pattern (pattern_of_string s) + | Interface.In_Module ms -> Search.In_Module (dirpath_of_string_list ms) + | Interface.Include_Blacklist -> Search.Include_Blacklist + +let search flags = + let pstate = Vernacstate.Proof_global.get () in + List.map export_coq_object (Search.interface_search ?pstate ( + 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 + | Goptions.StringOptValue s -> Interface.StringOptValue s + +let import_option_value = function + | Interface.BoolValue b -> Goptions.BoolValue b + | Interface.IntValue x -> Goptions.IntValue x + | Interface.StringValue s -> Goptions.StringValue s + | Interface.StringOptValue s -> Goptions.StringOptValue s + +let export_option_state s = { + Interface.opt_sync = true; + 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 open Goptions in + let iter (name, value) = match import_option_value value with + | BoolValue b -> set_bool_option_value name b + | IntValue i -> set_int_option_value name i + | StringValue s -> set_string_option_value name s + | StringOptValue (Some s) -> set_string_option_value name s + | StringOptValue None -> unset_option_value_gen name + 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 -> Some (Loc.unloc loc) + | _ -> None in + let mk_msg () = CErrors.print ~info e in + match e with + | e -> + match Stateid.get info with + | Some (valid, _) -> valid, loc_of info, mk_msg () + | None -> dummy, loc_of info, mk_msg () + +let init = + let initialized = ref false in + fun file -> + if !initialized then anomaly (str "Already initialized.") + else begin + let init_sid = Stm.get_current_state ~doc:(get_doc ()) in + initialized := true; + match file with + | None -> init_sid + | Some file -> + let doc, initial_id, _ = + get_doc (), init_sid, `NewTip in + if Filename.check_suffix file ".v" then + Stm.set_compilation_hints file; + set_doc (Stm.finish ~doc); + initial_id + end + +(* Retrocompatibility stuff, disabled since 8.7 *) +let interp ((_raw, verbose), s) = + Stateid.dummy, CSig.Inr "The interp call has been disabled, please use Add." + +(** 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 + +(** Disabled *) +let print_ast id = Xml_datatype.PCData "ERROR" + +(** Grouping all call handlers together + error handling *) +let eval_call c = + let interruptible f x = + catch_break := true; + Control.check_for_interrupt (); + let r = f x in + catch_break := false; + 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.wait = interruptible wait; + Interface.interp = interruptible interp; + Interface.handle_exn = handle_exn; + Interface.stop_worker = Stm.stop_worker; + Interface.print_ast = print_ast; + Interface.annotate = interruptible annotate; + } in + Xmlprotocol.abstract_eval_call handler c + +(** Message dispatching. + Since [coqidetop] 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 Control.protect_sigalrm (Xml_printer.print oc) xml; Mutex.unlock m + with e -> let e = CErrors.push e in Mutex.unlock m; iraise e + +let slave_feeder fmt xml_oc msg = + let xml = Xmlprotocol.(of_feedback fmt 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 msg_format = ref (fun () -> + let margin = Option.default 72 (Topfmt.get_margin ()) in + Xmlprotocol.Richpp margin + ) + +(* The loop ignores the command line arguments as the current model delegates + its handing to the toplevel container. *) +let loop ~opts:_ ~state = + let open Vernac.State in + set_doc state.doc; + 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 + (* SEXP parser make *) + let xml_ic = Xml_parser.make (Xml_parser.SLexbuf in_lb) in + let () = Xml_parser.check_eof xml_ic false in + ignore (Feedback.add_feeder (slave_feeder (!msg_format ()) xml_oc)); + 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 Xmlprotocol.Unknown q = Xmlprotocol.to_call xml_query in + let () = pr_debug_call q in + let r = eval_call 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 (!msg_format ()) 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_error ("XML syntax error: " ^ Xml_parser.error_msg err) + | Serialize.Marshal_error (msg,node) -> + pr_error "Unexpected XML message"; + pr_error ("Expected XML node: " ^ msg); + pr_error ("XML tree received: " ^ Xml_printer.to_string_fmt node) + | 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 + | "--xml_format=Ppcmds" :: rest -> + msg_format := (fun () -> Xmlprotocol.Ppcmds); parse rest + | x :: rest -> x :: parse rest + | [] -> [] + +let () = Usage.add_to_usage "coqidetop" +" --xml_format=Ppcmds serialize pretty printing messages using the std_ppcmds format\ +\n --help-XML-protocol print documentation of the Coq XML protocol\n" + +let islave_init ~opts extra_args = + let args = parse extra_args in + CoqworkmgrApi.(init High); + opts, args + +let () = + let open Coqtop in + let custom = { init = islave_init; run = loop; opts = Coqargs.default } in + start_coq custom diff --git a/ide/ideutils.ml b/ide/ideutils.ml new file mode 100644 index 0000000000..8c5b3fcc5b --- /dev/null +++ b/ide/ideutils.ml @@ -0,0 +1,508 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Preferences + +let _ = GtkMain.Main.init () + +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,clear_info = + let status_context = status#new_context ~name:"Messages" in + 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 + (fun ?(delay=5000) s -> flash_context#flash ~delay s) + +(* Note: Setting the same attribute with two separate tags appears to use +the first value applied and not the second. I saw this trying to set the background +color on Windows. A clean fix, if ever needed, would be to combine the attributes +of the tags into a single composite tag before applying. This is left as an +exercise for the reader. *) +let insert_with_tags (buf : #GText.buffer_skel) mark rmark tags text = + (* FIXME: LablGTK2 does not export the C insert_with_tags function, so that + it has to reimplement its own helper function. Unluckily, it relies on + a slow algorithm, so that we have to have our own quicker version here. + Alas, it is still much slower than the native version... *) + if CList.is_empty tags then buf#insert ~iter:(buf#get_iter_at_mark mark) text + else + let it = buf#get_iter_at_mark mark in + let () = buf#move_mark rmark ~where:it in + let () = buf#insert ~iter:(buf#get_iter_at_mark mark) text in + let start = buf#get_iter_at_mark mark in + let stop = buf#get_iter_at_mark rmark in + let iter tag = buf#apply_tag tag ~start ~stop in + List.iter iter (List.rev tags) + +let nl_white_regex = Str.regexp "^\\( *\n *\\)" +let diff_regex = Str.regexp "^diff." + +let insert_xml ?(mark = `INSERT) ?(tags = []) (buf : #GText.buffer_skel) msg = + let open Xml_datatype in + let dtags = ref [] in + let tag name = + match GtkText.TagTable.lookup buf#tag_table name with + | None -> raise Not_found + | Some tag -> new GText.tag tag + in + let rmark = `MARK (buf#create_mark buf#start_iter) in + (* insert the string, but don't apply diff highlights to white space at the begin/end of line *) + let rec insert_str tags s = + let etags = try List.hd !dtags :: tags with hd -> tags in + try + let start = Str.search_forward nl_white_regex s 0 in + insert_with_tags buf mark rmark etags (String.sub s 0 start); + insert_with_tags buf mark rmark tags (Str.matched_group 1 s); + let mend = Str.match_end () in + insert_str tags (String.sub s mend (String.length s - mend)) + with Not_found -> + insert_with_tags buf mark rmark etags s + in + let rec insert tags = function + | PCData s -> insert_str tags s + | Element (t, _, children) -> + let (pfx, tname) = Pp.split_tag t in + let is_diff = try let _ = Str.search_forward diff_regex tname 0 in true with Not_found -> false in + let (tags, have_tag) = + try + let t = tag tname in + if is_diff && pfx <> Pp.end_pfx then + dtags := t :: !dtags; + if pfx = "" then + ((if is_diff then tags else t :: tags), true) + else + (tags, true) + with Not_found -> (tags, false) + in + List.iter (fun xml -> insert tags xml) children; + if have_tag && is_diff && pfx <> Pp.start_pfx then + dtags := (try List.tl !dtags with tl -> []); + in + let () = try insert tags msg with _ -> () in + buf#delete_mark rmark + +let set_location = ref (function s -> failwith "not ready") + +let display_location ins = + let line = ins#line + 1 in + let off = ins#line_offset + 1 in + let msg = Printf.sprintf "Line: %5d Char: %3d" line off in + !set_location msg + +(** A utf8 char is either a single byte (ascii char, 0xxxxxxx) + or multi-byte (with a leading byte 11xxxxxx and extra bytes 10xxxxxx) *) + +let is_extra_byte c = ((Char.code c) lsr 6 = 2) + +(** 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 = + 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 = + 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 encoding#get 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 + do_convert s + with _ -> + "(* Fatal error: wrong encoding in input. \ +Please choose a correct encoding in the preference panel.*)";; + +let export file_name s = + let oc = open_out_bin file_name in + let ending = line_ending#get in + let is_windows = ref false in + for i = 0 to String.length s - 1 do + match s.[i] with + | '\r' -> is_windows := true + | '\n' -> + begin match ending with + | `DEFAULT -> + if !is_windows then (output_char oc '\r'; output_char oc '\n') + else output_char oc '\n' + | `WINDOWS -> output_char oc '\r'; output_char oc '\n' + | `UNIX -> output_char oc '\n' + end + | c -> output_char oc c + done; + close_out oc + +let try_export file_name s = + let s = + try match encoding#get with + |Eutf8 -> Minilib.log "UTF-8 is enforced" ; s + |Elocale -> + let is_unicode,char_set = Glib.Convert.get_charset () in + if is_unicode then + (Minilib.log "Locale is UTF-8" ; s) + else + (Minilib.log ("Locale is "^char_set); + Glib.Convert.convert_with_fallback + ~from_codeset:"UTF-8" ~to_codeset:char_set s) + |Emanual enc -> + (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 + try export file_name s; 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 filter_all_files () = GFile.filter + ~name:"All" + ~patterns:["*"] () + +let filter_coq_files () = GFile.filter + ~name:"Coq source code" + ~patterns:[ "*.v"] () + +let current_dir () = match project_path#get with +| None -> "" +| Some dir -> dir + +let select_file_for_open ~title ?(filter=true) ?parent ?filename () = + let file_chooser = + GWindow.file_chooser_dialog ~action:`OPEN ~modal:true ~title ?parent () + in + file_chooser#add_button_stock `CANCEL `CANCEL ; + file_chooser#add_select_button_stock `OPEN `OPEN ; + if filter then + begin + file_chooser#add_filter (filter_coq_files ()); + file_chooser#add_filter (filter_all_files ()) + end; + file_chooser#set_default_response `OPEN; + let dir = match filename with + | None -> current_dir () + | Some f -> Filename.dirname f in + ignore (file_chooser#set_current_folder dir); + let file = + match file_chooser#run () with + | `OPEN -> + begin + match file_chooser#filename with + | None -> None + | Some _ as f -> + project_path#set file_chooser#current_folder; f + end + | `DELETE_EVENT | `CANCEL -> None in + file_chooser#destroy (); + file + +let select_file_for_save ~title ?parent ?filename () = + let file = ref None in + let file_chooser = + GWindow.file_chooser_dialog ~action:`SAVE ~modal:true ~title ?parent () + 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 ()); + file_chooser#set_do_overwrite_confirmation true; + file_chooser#set_default_response `SAVE; + let dir,filename = match filename with + |None -> current_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 -> project_path#set file_chooser#current_folder + end + | `DELETE_EVENT | `CANCEL -> () + end ; + file_chooser#destroy (); + !file + +let find_tag_start (tag :GText.tag) (it:GText.iter) = + let it = it#copy in + let tag = Some tag in + while not (it#begins_tag tag) && it#nocopy#backward_char do + () + done; + it +let find_tag_stop (tag :GText.tag) (it:GText.iter) = + let it = it#copy in + let tag = Some tag in + while not (it#ends_tag tag) && it#nocopy#forward_char do + () + done; + it +let find_tag_limits (tag :GText.tag) (it:GText.iter) = + (find_tag_start tag it , find_tag_stop tag it) + +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 + +let coqtop_path () = + let file = match !custom_coqtop with + | Some s -> s + | None -> + match cmd_coqtop#get with + | Some s -> s + | None -> + try + let new_prog = System.get_toplevel_path "coqidetop" in + (* The file exists or it is to be found by path *) + if Sys.file_exists new_prog || + CString.equal Filename.(basename new_prog) new_prog + then new_prog + else + let in_macos_bundle = + Filename.concat + (Filename.dirname new_prog) + (Filename.concat "../Resources/bin" (Filename.basename new_prog)) + in if Sys.file_exists in_macos_bundle then in_macos_bundle + else "coqidetop.opt" + with Not_found -> "coqidetop.opt" + in file + +(* 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 *) + +let requote cmd = if Sys.os_type = "Win32" then "\""^cmd^"\"" else cmd + +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 = Feedback.level -> Pp.t -> unit + +let default_logger level message = + let level = match level with + | Feedback.Debug -> `DEBUG + | Feedback.Info -> `INFO + | Feedback.Notice -> `NOTICE + | Feedback.Warning -> `WARNING + | Feedback.Error -> `ERROR + in + Minilib.log_pp ~level message + + +(** {6 File operations} *) + +(** A customized [stat] function. Exceptions are caught. *) + +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 = Bytes.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 = Util.open_utf8_file_in name in + let len = ref 0 in + try + while len := input ic read_string 0 maxread; !len > 0 do + Buffer.add_subbytes 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_subbytes 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 cmd_browse#get 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 url_for_keyword = + let ht = Hashtbl.create 97 in + lazy ( + begin try + let cin = + try let index_urls = Filename.concat (List.find + (fun x -> Sys.file_exists (Filename.concat x "index_urls.txt")) + (Minilib.coqide_data_dirs ())) "index_urls.txt" in + open_in index_urls + with Not_found -> 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.log "Warning: Cannot find documentation index file." + end; + Hashtbl.find ht : string -> string) + +let browse_keyword prerr text = + try + let u = Lazy.force url_for_keyword text in + browse prerr (Coq_config.wwwrefman ^ u) + with Not_found -> prerr ("No documentation found for \""^text^"\".\n") + +let rec is_valid (s : Pp.t) = match Pp.repr s with + | Pp.Ppcmd_empty + | Pp.Ppcmd_print_break _ + | Pp.Ppcmd_force_newline -> true + | Pp.Ppcmd_glue l -> List.for_all is_valid l + | Pp.Ppcmd_string s -> Glib.Utf8.validate s + | Pp.Ppcmd_box (_,s) + | Pp.Ppcmd_tag (_,s) -> is_valid s + | Pp.Ppcmd_comment s -> List.for_all Glib.Utf8.validate s +let validate s = + if is_valid s then s else Pp.str "This error massage can't be printed." diff --git a/ide/ideutils.mli b/ide/ideutils.mli new file mode 100644 index 0000000000..57f59d19fe --- /dev/null +++ b/ide/ideutils.mli @@ -0,0 +1,104 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val warn_image : unit -> GMisc.image +val warning : string -> unit + +val cb : GData.clipboard + +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 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 select_file_for_open : + title:string -> ?filter:bool -> ?parent:GWindow.window -> ?filename:string -> unit -> string option +val select_file_for_save : + title:string -> ?parent:GWindow.window -> ?filename:string -> unit -> string option +val try_convert : string -> string +val try_export : string -> string -> bool +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 + - custom_coqtop if set + - from the prefs is set + - try to infer it else *) +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 insert_xml : ?mark:GText.mark -> ?tags:GText.tag list -> + #GText.buffer_skel -> Richpp.richpp -> unit + +val set_location : (string -> unit) ref +val display_location : GText.iter -> unit + +(* 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 = Feedback.level -> Pp.t -> unit + +val default_logger : logger +(** Default logger. It logs messages that the casual user should not see. *) + +(** {6 I/O operations} *) + +(** A customized [stat] function. Exceptions are caught. *) + +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 + +(* Checks if an error message is printable, it not replaces it with + * a printable error *) +val validate : Pp.t -> Pp.t diff --git a/ide/macos_prehook.ml b/ide/macos_prehook.ml new file mode 100644 index 0000000000..dc8fd0e85d --- /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 "GTK3_RC_FILES" (Filename.concat etc_dir "gtk-3.0/gtkrc") +let () = + Unix.putenv "GTK_IM_MODULE_FILE" + (Filename.concat etc_dir "gtk-3.0/gtk-immodules.loaders") +let () = + Unix.putenv "GDK_PIXBUF_MODULE_FILE" + (Filename.concat etc_dir "gtk-3.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/macos_prehook.mli b/ide/macos_prehook.mli new file mode 100644 index 0000000000..9db9ecd12e --- /dev/null +++ b/ide/macos_prehook.mli @@ -0,0 +1,12 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This empty file avoids a race condition that occurs when compiling a .ml file + that does not have a corresponding .mli file *) diff --git a/ide/minilib.ml b/ide/minilib.ml new file mode 100644 index 0000000000..39183e000f --- /dev/null +++ b/ide/minilib.ml @@ -0,0 +1,74 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +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 Camlp5) *) + +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. + Ideally, we should re-route message to a log file somewhere, or + print in the response buffer. +*) + +let log_pp ?(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 Format.eprintf "[%s] @[%a@]\n%!" prefix Pp.pp_with msg + with _ -> () + end + +let log ?level str = log_pp ?level (Pp.str str) + +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 ()) + @ [Envars.datadir ()] + +let coqide_config_dirs () = + coqide_config_home () + :: List.map coqify (Glib.get_system_config_dirs ()) + @ [Envars.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 + diff --git a/ide/minilib.mli b/ide/minilib.mli new file mode 100644 index 0000000000..6cc36f5f2a --- /dev/null +++ b/ide/minilib.mli @@ -0,0 +1,33 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Some excerpts of Util and similar files to avoid depending on them + and hence on Compat and Camlp5 *) + +val print_list : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit + +type level = [ + | `DEBUG + | `INFO + | `NOTICE + | `WARNING + | `ERROR + | `FATAL ] + +(** debug printing *) +val debug : bool ref + +val log_pp : ?level:level -> Pp.t -> unit +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 0000000000..d85d87142c --- /dev/null +++ b/ide/nanoPG.ml @@ -0,0 +1,323 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +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 -> GSourceView3.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" (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" (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 until 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 nanoPG#get 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/nanoPG.mli b/ide/nanoPG.mli new file mode 100644 index 0000000000..bc9b39d823 --- /dev/null +++ b/ide/nanoPG.mli @@ -0,0 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val get_documentation : unit -> string +val init : GWindow.window -> Session.session Wg_Notebook.typed_notebook -> + GAction.action_group list -> unit diff --git a/ide/preferences.ml b/ide/preferences.ml new file mode 100644 index 0000000000..47cd4c58b6 --- /dev/null +++ b/ide/preferences.ml @@ -0,0 +1,1031 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Configwin + +let pref_file = Filename.concat (Minilib.coqide_config_home ()) "coqiderc" +let accel_file = Filename.concat (Minilib.coqide_config_home ()) "coqide.keys" +let lang_manager = GSourceView3.source_language_manager ~default:true +let () = lang_manager#set_search_path + ((Minilib.coqide_data_dirs ())@lang_manager#search_path) +let style_manager = GSourceView3.source_style_scheme_manager ~default:true +let () = style_manager#set_search_path + ((Minilib.coqide_data_dirs ())@style_manager#search_path) + +type tag = { + tag_fg_color : string option; + tag_bg_color : string option; + tag_bold : bool; + tag_italic : bool; + tag_underline : bool; + tag_strikethrough : bool; +} + + +(** Generic preferences *) + +type obj = { + set : string list -> unit; + get : unit -> string list; +} + +let preferences : obj Util.String.Map.t ref = ref Util.String.Map.empty +let unknown_preferences : string list Util.String.Map.t ref = ref Util.String.Map.empty + +class type ['a] repr = +object + method into : string list -> 'a option + method from : 'a -> string list +end + +class ['a] preference_signals ~(changed : 'a GUtil.signal) = +object + inherit GUtil.ml_signals [changed#disconnect] + method changed = changed#connect ~after +end + +class ['a] preference ~(name : string list) ~(init : 'a) ~(repr : 'a repr) = +object (self) + initializer + let set v = match repr#into v with None -> () | Some s -> self#set s in + let get () = repr#from self#get in + let obj = { set = set; get = get; } in + let name = String.concat "." name in + if Util.String.Map.mem name !preferences then + invalid_arg ("Preference " ^ name ^ " already exists") + else + preferences := Util.String.Map.add name obj !preferences + + val default = init + val mutable data = init + val changed : 'a GUtil.signal = new GUtil.signal () + val name : string list = name + method connect = new preference_signals ~changed + method get = data + method set (n : 'a) = data <- n; changed#call n + method reset () = self#set default + method default = default +end + +let stick (pref : 'a preference) (obj : < connect : #GObj.widget_signals ; .. >) + (cb : 'a -> unit) = + let _ = cb pref#get in + let p_id = pref#connect#changed ~callback:(fun v -> cb v) in + let _ = obj#connect#destroy ~callback:(fun () -> pref#connect#disconnect p_id) in + () + +(** Useful marshallers *) + +let mod_to_str m = + match m with + | `MOD1 -> "<Alt>" + | `MOD2 -> "<Mod2>" + | `MOD3 -> "<Mod3>" + | `MOD4 -> "<Mod4>" + | `MOD5 -> "<Mod5>" + | `CONTROL -> "<Control>" + | `SHIFT -> "<Shift>" + | `HYPER -> "<Hyper>" + | `META -> "<Meta>" + | `RELEASE -> "" + | `SUPER -> "<Super>" + | `BUTTON1| `BUTTON2| `BUTTON3| `BUTTON4| `BUTTON5| `LOCK -> "" + +let mod_list_to_str l = List.fold_left (fun s m -> (mod_to_str m)^s) "" l + +let str_to_mod_list s = snd (GtkData.AccelGroup.parse s) + +type project_behavior = Ignore_args | Append_args | Subst_args + +let string_of_project_behavior = function + |Ignore_args -> "ignored" + |Append_args -> "appended to arguments" + |Subst_args -> "taken instead of arguments" + +let project_behavior_of_string s = + if s = "taken instead of arguments" then Subst_args + else if s = "appended to arguments" then Append_args + else Ignore_args + +type inputenc = Elocale | Eutf8 | Emanual of string + +let string_of_inputenc = function + |Elocale -> "LOCALE" + |Eutf8 -> "UTF-8" + |Emanual s -> s + +let inputenc_of_string s = + (if s = "UTF-8" then Eutf8 + else if s = "LOCALE" then Elocale + else Emanual s) + +type line_ending = [ `DEFAULT | `WINDOWS | `UNIX ] + +let line_end_of_string = function +| "unix" -> `UNIX +| "windows" -> `WINDOWS +| _ -> `DEFAULT + +let line_end_to_string = function +| `UNIX -> "unix" +| `WINDOWS -> "windows" +| `DEFAULT -> "default" + +let use_default_doc_url = "(automatic)" + +module Repr = +struct + +let string : string repr = +object + method from s = [s] + method into = function [s] -> Some s | _ -> None +end + +let string_pair : (string * string) repr = +object + method from (s1, s2) = [s1; s2] + method into = function [s1; s2] -> Some (s1, s2) | _ -> None +end + +let string_list : string list repr = +object + method from s = s + method into s = Some s +end + +let string_pair_list (sep : char) : (string * string) list repr = +object + val sep' = String.make 1 sep + method from = CList.map (fun (s1, s2) -> CString.concat sep' [s1; s2]) + method into l = + try + Some (CList.map (fun s -> + let split = String.split_on_char sep s in + CList.nth split 0, CList.nth split 1) l) + with Failure _ -> None +end + +let bool : bool repr = +object + method from s = [string_of_bool s] + method into = function + | ["true"] -> Some true + | ["false"] -> Some false + | _ -> None +end + +let int : int repr = +object + method from s = [string_of_int s] + method into = function + | [i] -> (try Some (int_of_string i) with _ -> None) + | _ -> None +end + +let option (r : 'a repr) : 'a option repr = +object + method from = function None -> [] | Some v -> "" :: r#from v + method into = function + | [] -> Some None + | "" :: s -> Some (r#into s) + | _ -> None +end + +let custom (from : 'a -> string) (into : string -> 'a) : 'a repr = +object + method from x = try [from x] with _ -> [] + method into = function + | [s] -> (try Some (into s) with _ -> None) + | _ -> None +end + +let tag : tag repr = +let _to s = if s = "" then None else Some s in +let _of = function None -> "" | Some s -> s in +object + method from tag = [ + _of tag.tag_fg_color; + _of tag.tag_bg_color; + string_of_bool tag.tag_bold; + string_of_bool tag.tag_italic; + string_of_bool tag.tag_underline; + string_of_bool tag.tag_strikethrough; + ] + method into = function + | [fg; bg; bd; it; ul; st] -> + (try Some { + tag_fg_color = _to fg; + tag_bg_color = _to bg; + tag_bold = bool_of_string bd; + tag_italic = bool_of_string it; + tag_underline = bool_of_string ul; + tag_strikethrough = bool_of_string st; + } + with _ -> None) + | _ -> None +end + +end + +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.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 (Option.default "" (Glib.get_home_dir ())) ".coqiderc" + +let loaded_accel_file = + try get_config_file "coqide.keys" + with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqide.keys" + +let get_unicode_bindings_local_file () = + try Some (get_config_file "coqide.bindings") + with Not_found -> None + +let get_unicode_bindings_default_file () = + let name = "default.bindings" in + let chk d = Sys.file_exists (Filename.concat d name) in + try + let dir = List.find chk (Minilib.coqide_data_dirs ()) in + Some (Filename.concat dir name) + with Not_found -> None + +(** Hooks *) + +(** New style preferences *) + +let cmd_coqtop = + new preference ~name:["cmd_coqtop"] ~init:None ~repr:Repr.(option string) + +let cmd_coqc = + new preference ~name:["cmd_coqc"] ~init:"coqc" ~repr:Repr.(string) + +let cmd_make = + new preference ~name:["cmd_make"] ~init:"make" ~repr:Repr.(string) + +let cmd_coqmakefile = + new preference ~name:["cmd_coqmakefile"] ~init:"coq_makefile -o makefile *.v" ~repr:Repr.(string) + +let cmd_coqdoc = + new preference ~name:["cmd_coqdoc"] ~init:"coqdoc -q -g" ~repr:Repr.(string) + +let source_language = + new preference ~name:["source_language"] ~init:"coq" ~repr:Repr.(string) + +let source_style = + new preference ~name:["source_style"] ~init:"coq_style" ~repr:Repr.(string) + +let global_auto_revert = + new preference ~name:["global_auto_revert"] ~init:false ~repr:Repr.(bool) + +let global_auto_revert_delay = + new preference ~name:["global_auto_revert_delay"] ~init:10000 ~repr:Repr.(int) + +let auto_save = + new preference ~name:["auto_save"] ~init:true ~repr:Repr.(bool) + +let auto_save_delay = + new preference ~name:["auto_save_delay"] ~init:10000 ~repr:Repr.(int) + +let auto_save_name = + new preference ~name:["auto_save_name"] ~init:("#","#") ~repr:Repr.(string_pair) + +let read_project = + let repr = Repr.custom string_of_project_behavior project_behavior_of_string in + new preference ~name:["read_project"] ~init:Append_args ~repr + +let project_file_name = + new preference ~name:["project_file_name"] ~init:"_CoqProject" ~repr:Repr.(string) + +let project_path = + new preference ~name:["project_path"] ~init:None ~repr:Repr.(option string) + +let encoding = + let repr = Repr.custom string_of_inputenc inputenc_of_string in + let init = if Sys.os_type = "Win32" then Eutf8 else Elocale in + new preference ~name:["encoding"] ~init ~repr + +let automatic_tactics = + let init = ["trivial"; "tauto"; "auto"; "omega"; "auto with *"; "intuition" ] in + new preference ~name:["automatic_tactics"] ~init ~repr:Repr.(string_list) + +let cmd_print = + new preference ~name:["cmd_print"] ~init:"lpr" ~repr:Repr.(string) + +let attach_modifiers (pref : string preference) prefix = + let cb mds = + let mds = str_to_mod_list mds in + let change ~path ~key ~modi ~changed = + if CString.is_sub prefix path 0 then + ignore (GtkData.AccelMap.change_entry ~key ~modi:mds ~replace:true path) + in + GtkData.AccelMap.foreach change + in + pref#connect#changed ~callback:cb + +let modifier_for_navigation = + new preference ~name:["modifier_for_navigation"] ~init:"<Control>" ~repr:Repr.(string) + +let modifier_for_templates = + new preference ~name:["modifier_for_templates"] ~init:"<Control><Shift>" ~repr:Repr.(string) + +let modifier_for_tactics = + new preference ~name:["modifier_for_tactics"] ~init:"<Control><Alt>" ~repr:Repr.(string) + +let modifier_for_display = + new preference ~name:["modifier_for_display"] ~init:"<Alt><Shift>" ~repr:Repr.(string) + +let modifier_for_queries = + new preference ~name:["modifier_for_queries"] ~init:"<Control><Shift>" ~repr:Repr.(string) + +let _ = attach_modifiers modifier_for_navigation "<Actions>/Navigation/" +let _ = attach_modifiers modifier_for_templates "<Actions>/Templates/" +let _ = attach_modifiers modifier_for_tactics "<Actions>/Tactics/" +let _ = attach_modifiers modifier_for_display "<Actions>/View/" +let _ = attach_modifiers modifier_for_queries "<Actions>/Queries/" + +let modifiers_valid = + new preference ~name:["modifiers_valid"] ~init:"<Alt><Control><Shift>" ~repr:Repr.(string) + +let browser_cmd_fmt = + try + let coq_netscape_remote_var = "COQREMOTEBROWSER" in + Sys.getenv coq_netscape_remote_var + with + Not_found -> Coq_config.browser + +let cmd_browse = + new preference ~name:["cmd_browse"] ~init:browser_cmd_fmt ~repr:Repr.(string) + +let cmd_editor = + let init = if Sys.os_type = "Win32" then "NOTEPAD %s" else "emacs %s" in + new preference ~name:["cmd_editor"] ~init ~repr:Repr.(string) + +let text_font = + let init = match Coq_config.gtk_platform with + | `QUARTZ -> "Arial Unicode MS 11" + | _ -> "Monospace 10" + in + new preference ~name:["text_font"] ~init ~repr:Repr.(string) + +let show_toolbar = + new preference ~name:["show_toolbar"] ~init:true ~repr:Repr.(bool) + +let contextual_menus_on_goal = + new preference ~name:["contextual_menus_on_goal"] ~init:true ~repr:Repr.(bool) + +let window_width = + new preference ~name:["window_width"] ~init:800 ~repr:Repr.(int) + +let window_height = + new preference ~name:["window_height"] ~init:600 ~repr:Repr.(int) + +let auto_complete = + new preference ~name:["auto_complete"] ~init:false ~repr:Repr.(bool) + +let stop_before = + new preference ~name:["stop_before"] ~init:true ~repr:Repr.(bool) + +let reset_on_tab_switch = + new preference ~name:["reset_on_tab_switch"] ~init:false ~repr:Repr.(bool) + +let line_ending = + let repr = Repr.custom line_end_to_string line_end_of_string in + new preference ~name:["line_ending"] ~init:`DEFAULT ~repr + +let vertical_tabs = + new preference ~name:["vertical_tabs"] ~init:false ~repr:Repr.(bool) + +let opposite_tabs = + new preference ~name:["opposite_tabs"] ~init:false ~repr:Repr.(bool) + +(* let background_color = *) +(* new preference ~name:["background_color"] ~init:"cornsilk" ~repr:Repr.(string) *) + +let attach_tag (pref : string preference) (tag : GText.tag) f = + tag#set_property (f pref#get); + pref#connect#changed ~callback:(fun c -> tag#set_property (f c)) + +let attach_bg (pref : string preference) (tag : GText.tag) = + attach_tag pref tag (fun c -> `BACKGROUND c) + +let attach_fg (pref : string preference) (tag : GText.tag) = + attach_tag pref tag (fun c -> `FOREGROUND c) + +let processing_color = + new preference ~name:["processing_color"] ~init:"light blue" ~repr:Repr.(string) + +let incompletely_processed_color = + new preference ~name:["incompletely_processed_color"] ~init:"light sky blue" ~repr:Repr.(string) + +let _ = attach_bg processing_color Tags.Script.to_process +let _ = attach_bg incompletely_processed_color Tags.Script.incomplete + +let tags = ref Util.String.Map.empty + +let list_tags () = !tags + +let make_tag ?fg ?bg ?(bold = false) ?(italic = false) ?(underline = false) ?(strikethrough = false) () = { + tag_fg_color = fg; + tag_bg_color = bg; + tag_bold = bold; + tag_italic = italic; + tag_underline = underline; + tag_strikethrough = strikethrough; +} + +let create_tag name default = + let pref = new preference ~name:[name] ~init:default ~repr:Repr.(tag) in + let set_tag tag = + begin match pref#get.tag_bg_color with + | None -> tag#set_property (`BACKGROUND_SET false) + | Some c -> + tag#set_property (`BACKGROUND_SET true); + tag#set_property (`BACKGROUND c) + end; + begin match pref#get.tag_fg_color with + | None -> tag#set_property (`FOREGROUND_SET false) + | Some c -> + tag#set_property (`FOREGROUND_SET true); + tag#set_property (`FOREGROUND c) + end; + begin match pref#get.tag_bold with + | false -> tag#set_property (`WEIGHT_SET false) + | true -> + tag#set_property (`WEIGHT_SET true); + tag#set_property (`WEIGHT `BOLD) + end; + begin match pref#get.tag_italic with + | false -> tag#set_property (`STYLE_SET false) + | true -> + tag#set_property (`STYLE_SET true); + tag#set_property (`STYLE `ITALIC) + end; + begin match pref#get.tag_underline with + | false -> tag#set_property (`UNDERLINE_SET false) + | true -> + tag#set_property (`UNDERLINE_SET true); + tag#set_property (`UNDERLINE `SINGLE) + end; + begin match pref#get.tag_strikethrough with + | false -> tag#set_property (`STRIKETHROUGH_SET false) + | true -> + tag#set_property (`STRIKETHROUGH_SET true); + tag#set_property (`STRIKETHROUGH true) + end; + in + let iter table = + let tag = GText.tag ~name () in + table#add tag#as_tag; + ignore (pref#connect#changed ~callback:(fun _ -> set_tag tag)); + set_tag tag; + in + List.iter iter [Tags.Script.table; Tags.Proof.table; Tags.Message.table]; + tags := Util.String.Map.add name pref !tags + +(* note these appear to only set the defaults; they don't override +the user selection from the Edit/Preferences/Tags dialog *) +let () = + let iter (name, tag) = create_tag name tag in + List.iter iter [ + ("constr.evar", make_tag ()); + ("constr.keyword", make_tag ~fg:"dark green" ()); + ("constr.notation", make_tag ()); + ("constr.path", make_tag ()); + ("constr.reference", make_tag ~fg:"navy"()); + ("constr.type", make_tag ~fg:"#008080" ()); + ("constr.variable", make_tag ()); + ("message.debug", make_tag ()); + ("message.error", make_tag ()); + ("message.warning", make_tag ()); + ("module.definition", make_tag ~fg:"orange red" ~bold:true ()); + ("module.keyword", make_tag ()); + ("tactic.keyword", make_tag ()); + ("tactic.primitive", make_tag ()); + ("tactic.string", make_tag ()); + ("diff.added", make_tag ~bg:"#b6f1c0" ~underline:true ()); + ("diff.removed", make_tag ~bg:"#f6b9c1" ~strikethrough:true ()); + ("diff.added.bg", make_tag ~bg:"#e9feee" ()); + ("diff.removed.bg", make_tag ~bg:"#fce9eb" ()); + ] + +let processed_color = + new preference ~name:["processed_color"] ~init:"light green" ~repr:Repr.(string) + +let _ = attach_bg processed_color Tags.Script.processed +let _ = attach_bg processed_color Tags.Proof.highlight + +let error_color = + new preference ~name:["error_color"] ~init:"#FFCCCC" ~repr:Repr.(string) + +let _ = attach_bg error_color Tags.Script.error_bg + +let error_fg_color = + new preference ~name:["error_fg_color"] ~init:"red" ~repr:Repr.(string) + +let _ = attach_fg error_fg_color Tags.Script.error + +let dynamic_word_wrap = + new preference ~name:["dynamic_word_wrap"] ~init:false ~repr:Repr.(bool) + +let show_line_number = + new preference ~name:["show_line_number"] ~init:false ~repr:Repr.(bool) + +let auto_indent = + new preference ~name:["auto_indent"] ~init:false ~repr:Repr.(bool) + +let show_spaces = + new preference ~name:["show_spaces"] ~init:true ~repr:Repr.(bool) + +let show_right_margin = + new preference ~name:["show_right_margin"] ~init:false ~repr:Repr.(bool) + +let show_progress_bar = + new preference ~name:["show_progress_bar"] ~init:true ~repr:Repr.(bool) + +let spaces_instead_of_tabs = + new preference ~name:["spaces_instead_of_tabs"] ~init:true ~repr:Repr.(bool) + +let tab_length = + new preference ~name:["tab_length"] ~init:2 ~repr:Repr.(int) + +let highlight_current_line = + new preference ~name:["highlight_current_line"] ~init:false ~repr:Repr.(bool) + +let nanoPG = + new preference ~name:["nanoPG"] ~init:false ~repr:Repr.(bool) + +let user_queries = + new preference ~name:["user_queries"] ~init:[] ~repr:Repr.(string_pair_list '$') + +let diffs = + new preference ~name:["diffs"] ~init:"off" ~repr:Repr.(string) + +class tag_button (box : Gtk.box Gtk.obj) = +object (self) + + inherit GObj.widget box + + val fg_color = GButton.color_button () + val fg_unset = GButton.toggle_button () + val bg_color = GButton.color_button () + val bg_unset = GButton.toggle_button () + val bold = GButton.toggle_button () + val italic = GButton.toggle_button () + val underline = GButton.toggle_button () + val strikethrough = GButton.toggle_button () + + method set_tag tag = + let track c but set = match c with + | None -> set#set_active true + | Some c -> + set#set_active false; + but#set_color (Gdk.Color.color_parse c) + in + track tag.tag_bg_color bg_color bg_unset; + track tag.tag_fg_color fg_color fg_unset; + bold#set_active tag.tag_bold; + italic#set_active tag.tag_italic; + underline#set_active tag.tag_underline; + strikethrough#set_active tag.tag_strikethrough; + + method tag = + let get but set = + if set#active then None + else Some (Gdk.Color.color_to_string but#color) + in + { + tag_bg_color = get bg_color bg_unset; + tag_fg_color = get fg_color fg_unset; + tag_bold = bold#active; + tag_italic = italic#active; + tag_underline = underline#active; + tag_strikethrough = strikethrough#active; + } + + initializer + let box = new GPack.box box in + let set_stock button stock = + let stock = GMisc.image ~stock ~icon_size:`BUTTON () in + button#set_image stock#coerce + in + set_stock fg_unset `CANCEL; + set_stock bg_unset `CANCEL; + set_stock bold `BOLD; + set_stock italic `ITALIC; + set_stock underline `UNDERLINE; + set_stock strikethrough `STRIKETHROUGH; + box#pack fg_color#coerce; + box#pack fg_unset#coerce; + box#pack bg_color#coerce; + box#pack bg_unset#coerce; + box#pack bold#coerce; + box#pack italic#coerce; + box#pack underline#coerce; + box#pack strikethrough#coerce; + let cb but obj = obj#set_sensitive (not but#active) in + let _ = fg_unset#connect#toggled ~callback:(fun () -> cb fg_unset fg_color#misc) in + let _ = bg_unset#connect#toggled ~callback:(fun () -> cb bg_unset bg_color#misc) in + () + +end + +let tag_button () = + let box = GPack.hbox () in + new tag_button (Gobject.unsafe_cast box#as_widget) + +(** Old style preferences *) + +let save_pref () = + 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 add = Util.String.Map.add in + let fold key obj accu = add key (obj.get ()) accu in + let prefs = Util.String.Map.fold fold !preferences Util.String.Map.empty in + let prefs = Util.String.Map.fold Util.String.Map.add !unknown_preferences prefs in + Config_lexer.print_file pref_file prefs + +let load_pref () = + let () = try GtkData.AccelMap.load loaded_accel_file with _ -> () in + + let m = Config_lexer.load_file loaded_pref_file in + let iter name v = + if Util.String.Map.mem name !preferences then + try (Util.String.Map.find name !preferences).set v with _ -> () + else unknown_preferences := Util.String.Map.add name v !unknown_preferences + in + Util.String.Map.iter iter m + +let pstring name p = string ~f:p#set name p#get +let pbool name p = bool ~f:p#set name p#get +let pmodifiers ?(all = false) name p = modifiers + ?allow:(if all then None else Some (str_to_mod_list modifiers_valid#get)) + ~f:(fun l -> p#set (mod_list_to_str l)) + ~help:"restart to apply" + name + (str_to_mod_list p#get) + +let configure ?(apply=(fun () -> ())) parent = + let cmd_coqtop = + string + ~f:(fun s -> cmd_coqtop#set (if s = "AUTO" then None else Some s)) + " coqidetop" (match cmd_coqtop#get with |None -> "AUTO" | Some x -> x) in + let cmd_coqc = pstring " coqc" cmd_coqc in + let cmd_make = pstring " make" cmd_make in + let cmd_coqmakefile = pstring "coqmakefile" cmd_coqmakefile in + let cmd_coqdoc = pstring " coqdoc" cmd_coqdoc in + let cmd_print = pstring " Print ps" cmd_print in + + let config_font = + let box = GPack.hbox () in + let w = GMisc.font_selection () in + w#set_preview_text + "Goal (∃n : nat, n ≤ 0)∧(∀x,y,z, x∈y⋃z↔x∈y∨x∈z)."; + box#pack ~expand:true w#coerce; + ignore (w#misc#connect#realize + ~callback:(fun () -> w#set_font_name text_font#get)); + custom + ~label:"Fonts for text" + box + (fun () -> + let fd = w#font_name in + text_font#set fd) + true + in + + let config_color = + let box = GPack.vbox () in + let grid = GPack.grid + ~row_spacings:5 + ~col_spacings:5 + ~border_width:2 + ~packing:(box#pack ~expand:true) () + in + let reset_button = GButton.button + ~label:"Reset" + ~packing:box#pack () + in + let iter i (text, pref) = + let label = GMisc.label + ~text ~packing:(grid#attach (*~expand:`X*) ~left:0 ~top:i) () + in + let () = label#set_xalign 0. in + let button = GButton.color_button + ~color:(Gdk.Color.color_parse pref#get) + ~packing:(grid#attach ~left:1 ~top:i) () + in + let _ = button#connect#color_set ~callback:begin fun () -> + pref#set (Gdk.Color.color_to_string button#color) + end in + let reset _ = + pref#reset (); + button#set_color (Gdk.Color.color_parse pref#get) + in + let _ = reset_button#connect#clicked ~callback:reset in + () + in + let () = Util.List.iteri iter [ +(* ("Background color", background_color); *) + ("Background color of processed text", processed_color); + ("Background color of text being processed", processing_color); + ("Background color of incompletely processed Qed", incompletely_processed_color); + ("Background color of errors", error_color); + ("Foreground color of errors", error_fg_color); + ] in + let label = "Color configuration" in + let callback () = () in + custom ~label box callback true + in + + let config_tags = + let box = GPack.vbox () in + let scroll = GBin.scrolled_window + ~hpolicy:`NEVER + ~vpolicy:`AUTOMATIC + ~packing:(box#pack ~expand:true) + () + in + let grid = GPack.grid + ~row_spacings:5 + ~col_spacings:5 + ~border_width:2 + ~packing:scroll#add_with_viewport () + in + let i = ref 0 in + let cb = ref [] in + let iter text tag = + let label = GMisc.label + ~text ~packing:(grid#attach (*~expand:`X*) ~left:0 ~top:!i) () + in + let () = label#set_xalign 0. in + let button = tag_button () in + let callback () = tag#set button#tag in + button#set_tag tag#get; + grid#attach ~left:1 ~top:!i button#coerce; + incr i; + cb := callback :: !cb; + in + let () = Util.String.Map.iter iter !tags in + let label = "Tag configuration" in + let callback () = List.iter (fun f -> f ()) !cb in + custom ~label box callback true + in + + let config_editor = + let label = "Editor configuration" in + let box = GPack.vbox () in + let button text (pref : bool preference) = + let active = pref#get in + let but = GButton.check_button ~label:text ~active ~packing:box#pack () in + ignore (but#connect#toggled ~callback:(fun () -> pref#set but#active)) + in + let () = button "Dynamic word wrap" dynamic_word_wrap in + let () = button "Show line number" show_line_number in + let () = button "Auto indentation" auto_indent in + let () = button "Auto completion" auto_complete in + let () = button "Show spaces" show_spaces in + let () = button "Show right margin" show_right_margin in + let () = button "Show progress bar" show_progress_bar in + let () = button "Insert spaces instead of tabs" spaces_instead_of_tabs in + let () = button "Highlight current line" highlight_current_line in + let () = button "Emacs/PG keybindings (μPG mode)" nanoPG in + let callback () = () in + custom ~label box callback true + in + + let window_height = + string + ~f:(fun s -> try window_height#set (int_of_string s) with _ -> ()) + "Default window height at starting time" + (string_of_int window_height#get) + in + + let window_width = + string + ~f:(fun s -> try window_width#set (int_of_string s) with _ -> ()) + "Default window width at starting time" + (string_of_int window_width#get) + in + + let global_auto_revert = pbool "Enable global auto revert" global_auto_revert in + let global_auto_revert_delay = + string + ~f:(fun s -> global_auto_revert_delay#set + (try int_of_string s with _ -> 10000)) + "Global auto revert delay (ms)" + (string_of_int global_auto_revert_delay#get) + in + + let auto_save = pbool "Enable auto save" auto_save in + let auto_save_delay = + string + ~f:(fun s -> auto_save_delay#set + (try int_of_string s with _ -> 10000)) + "Auto save delay (ms)" + (string_of_int auto_save_delay#get) + in + + let stop_before = pbool "Stop interpreting before the current point" stop_before in + + let reset_on_tab_switch = pbool "Reset coqtop on tab switch" reset_on_tab_switch in + + let vertical_tabs = pbool "Vertical tabs" vertical_tabs in + + let opposite_tabs = pbool "Tabs on opposite side" opposite_tabs in + + let encodings = + combo + "File charset encoding " + ~f:(fun s -> encoding#set (inputenc_of_string s)) + ~new_allowed: true + ("UTF-8"::"LOCALE":: match encoding#get with + |Emanual s -> [s] + |_ -> [] + ) + (string_of_inputenc encoding#get) + in + + let line_ending = + combo + "EOL character" + ~f:(fun s -> line_ending#set (line_end_of_string s)) + ~new_allowed:false + ["unix"; "windows"; "default"] + (line_end_to_string line_ending#get) + in + + let source_style = + combo "Highlighting style:" + ~f:source_style#set ~new_allowed:false + style_manager#style_scheme_ids source_style#get + in + + let source_language = + combo "Language:" + ~f:source_language#set ~new_allowed:false + (List.filter + (fun x -> Str.string_match (Str.regexp "^coq") x 0) + lang_manager#language_ids) + source_language#get + in + + let read_project = + combo + "Project file options are" + ~f:(fun s -> read_project#set (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 read_project#get) + in + let project_file_name = pstring "Default name for project file" project_file_name in + let modifier_for_tactics = + pmodifiers "Modifiers for Tactics Menu" modifier_for_tactics + in + let modifier_for_templates = + pmodifiers "Modifiers for Templates Menu" modifier_for_templates + in + let modifier_for_navigation = + pmodifiers "Modifiers for Navigation Menu" modifier_for_navigation + in + let modifier_for_display = + pmodifiers "Modifiers for View Menu" modifier_for_display + in + let modifier_for_queries = + pmodifiers "Modifiers for Queries Menu" modifier_for_queries + in + let modifiers_valid = + pmodifiers ~all:true "Allowed modifiers" modifiers_valid + in + let cmd_editor = + let predefined = [ "emacs %s"; "vi %s"; "NOTEPAD %s" ] in + combo + ~help:"(%s for file name)" + "External editor" + ~f:cmd_editor#set + ~new_allowed: true + (predefined@[if List.mem cmd_editor#get predefined then "" + else cmd_editor#get]) + cmd_editor#get + in + let cmd_browse = + let predefined = [ + Coq_config.browser; + "netscape -remote \"openURL(%s)\""; + "mozilla -remote \"openURL(%s)\""; + "firefox -remote \"openURL(%s,new-windows)\" || firefox %s &"; + "seamonkey -remote \"openURL(%s)\" || seamonkey %s &" + ] in + combo + ~help:"(%s for url)" + "Browser" + ~f:cmd_browse#set + ~new_allowed: true + (predefined@[if List.mem cmd_browse#get predefined then "" + else cmd_browse#get]) + cmd_browse#get + in +(* + let automatic_tactics = + strings + ~f:automatic_tactics#set + ~add:(fun () -> ["<edit me>"]) + "Wizard tactics to try in order" + automatic_tactics#get + + in +*) + + let contextual_menus_on_goal = pbool "Contextual menus on goal" contextual_menus_on_goal in + + let misc = [contextual_menus_on_goal;stop_before;reset_on_tab_switch; + vertical_tabs;opposite_tabs] in + +(* + let add_user_query () = + let input_string l v = + match GToolbox.input_string ~title:l v with + | None -> "" + | Some s -> s + in + let q = input_string "User query" "Your query" in + let k = input_string "Shortcut key" "Shortcut (a single letter)" in + let q = CString.map (fun c -> if c = '$' then ' ' else c) q in + (* Anything that is not a simple letter will be ignored. *) + let k = + if Int.equal (CString.length k) 1 && Util.is_letter k.[0] then k + else "" in + let k = String.uppercase_ascii k in + [q, k] + in + + let user_queries = + list + ~f:user_queries#set + (* Disallow same query, key or empty query. *) + ~eq:(fun (q1, k1) (q2, k2) -> k1 = k2 || q1 = "" || q2 = "" || q1 = q2) + ~add:add_user_query + ~titles:["User query"; "Shortcut key"] + "User queries" + (fun (q, s) -> [q; s]) + user_queries#get + + in +*) + +(* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!! + (shame on Benjamin) *) + let cmds = + [Section("Fonts", Some `SELECT_FONT, + [config_font]); + Section("Colors", Some `SELECT_COLOR, + [config_color; source_language; source_style]); + Section("Tags", Some `SELECT_COLOR, + [config_tags]); + 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*) + encodings; line_ending; + ]); + Section("Project", Some (`STOCK "gtk-page-setup"), + [project_file_name;read_project; + ]); + Section("Appearance", Some `PREFERENCES, [window_width; window_height]); + Section("Externals", None, + [cmd_coqtop;cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; + cmd_print;cmd_editor;cmd_browse]); +(* + Section("Tactics Wizard", None, + [automatic_tactics]); +*) + Section("Shortcuts", Some `PREFERENCES, + [modifiers_valid; modifier_for_tactics; + modifier_for_templates; modifier_for_display; modifier_for_navigation; + modifier_for_queries (*; user_queries *)]); + Section("Misc", Some `ADD, + misc)] + in +(* + Format.printf "before edit: current.text_font = %s@." (Pango.Font.to_string current.text_font); +*) + let x = edit ~apply "Customizations" ~parent cmds in +(* + Format.printf "after edit: current.text_font = %s@." (Pango.Font.to_string current.text_font); +*) + match x with + | Return_apply | Return_ok -> save_pref () + | Return_cancel -> () diff --git a/ide/preferences.mli b/ide/preferences.mli new file mode 100644 index 0000000000..785c191b46 --- /dev/null +++ b/ide/preferences.mli @@ -0,0 +1,117 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val lang_manager : GSourceView3.source_language_manager +val style_manager : GSourceView3.source_style_scheme_manager + +type project_behavior = Ignore_args | Append_args | Subst_args +type inputenc = Elocale | Eutf8 | Emanual of string +type line_ending = [ `DEFAULT | `WINDOWS | `UNIX ] + +type tag = { + tag_fg_color : string option; + tag_bg_color : string option; + tag_bold : bool; + tag_italic : bool; + tag_underline : bool; + tag_strikethrough : bool; +} + +class type ['a] repr = +object + method into : string list -> 'a option + method from : 'a -> string list +end + +class ['a] preference_signals : changed:'a GUtil.signal -> +object + inherit GUtil.ml_signals + method changed : callback:('a -> unit) -> GtkSignal.id +end + +class ['a] preference : name:string list -> init:'a -> repr:'a repr -> +object + method connect : 'a preference_signals + method get : 'a + method set : 'a -> unit + method reset : unit -> unit + method default : 'a +end + +val list_tags : unit -> tag preference Util.String.Map.t + +val get_unicode_bindings_local_file : unit -> string option +val get_unicode_bindings_default_file : unit -> string option + + +val cmd_coqtop : string option preference +val cmd_coqc : string preference +val cmd_make : string preference +val cmd_coqmakefile : string preference +val cmd_coqdoc : string preference +val source_language : string preference +val source_style : string preference +val global_auto_revert : bool preference +val global_auto_revert_delay : int preference +val auto_save : bool preference +val auto_save_delay : int preference +val auto_save_name : (string * string) preference +val read_project : project_behavior preference +val project_file_name : string preference +val project_path : string option preference +val encoding : inputenc preference +val automatic_tactics : string list preference +val cmd_print : string preference +val modifier_for_navigation : string preference +val modifier_for_templates : string preference +val modifier_for_tactics : string preference +val modifier_for_display : string preference +val modifier_for_queries : string preference +val modifiers_valid : string preference +val cmd_browse : string preference +val cmd_editor : string preference +val text_font : string preference +val show_toolbar : bool preference +val contextual_menus_on_goal : bool preference +val window_width : int preference +val window_height : int preference +val auto_complete : bool preference +val stop_before : bool preference +val reset_on_tab_switch : bool preference +val line_ending : line_ending preference +val vertical_tabs : bool preference +val opposite_tabs : bool preference +(* val background_color : string preference *) +val processing_color : string preference +val processed_color : string preference +val error_color : string preference +val error_fg_color : string preference +val dynamic_word_wrap : bool preference +val show_line_number : bool preference +val auto_indent : bool preference +val show_spaces : bool preference +val show_right_margin : bool preference +val show_progress_bar : bool preference +val spaces_instead_of_tabs : bool preference +val tab_length : int preference +val highlight_current_line : bool preference +val nanoPG : bool preference +val user_queries : (string * string) list preference +val diffs : string preference + +val save_pref : unit -> unit +val load_pref : unit -> unit + +val configure : ?apply:(unit -> unit) -> GWindow.window -> unit + +val stick : 'a preference -> + < connect : #GObj.widget_signals ; .. > -> ('a -> unit) -> unit + +val use_default_doc_url : string diff --git a/ide/protocol/dune b/ide/protocol/dune new file mode 100644 index 0000000000..801ceb20ec --- /dev/null +++ b/ide/protocol/dune @@ -0,0 +1,7 @@ +(library + (name protocol) + (public_name coqide-server.protocol) + (wrapped false) + (libraries coq.lib)) + +(ocamllex xml_lexer) diff --git a/ide/protocol/ideprotocol.mllib b/ide/protocol/ideprotocol.mllib new file mode 100644 index 0000000000..8317a08681 --- /dev/null +++ b/ide/protocol/ideprotocol.mllib @@ -0,0 +1,7 @@ +Xml_lexer +Xml_parser +Xml_printer +Serialize +Richpp +Interface +Xmlprotocol diff --git a/ide/protocol/interface.ml b/ide/protocol/interface.ml new file mode 100644 index 0000000000..ccb6bedaf6 --- /dev/null +++ b/ide/protocol/interface.ml @@ -0,0 +1,265 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** * 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 : Pp.t list; + (** List of hypotheses *) + goal_ccl : Pp.t; + (** 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 + | StringOptValue of string option + +(** 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 = +| Name_Pattern of string +(** Whether the name satisfies a regexp (uses Ocaml Str syntax) *) + +| Type_Pattern of string +(** Whether the object type satisfies a pattern *) + +| SubType_Pattern of string +(** Whether some subtype of object type satisfies a pattern *) + +| In_Module of string list +(** Whether the object pertains to a module *) + +| Include_Blacklist +(** Bypass the Search 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 = Stateid.t +type route_id = Feedback.route_id + +(* Obsolete *) +type edit_id = int + +(* 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 * Pp.t) + +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. [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 + + [s] used to contain Coq's console output and has been deprecated + in favor of sending feedback, it will be removed in a future + version of the protocol. *) +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 + performed 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]. + + query used to reply with the contents of Coq's console output, and + has been deprecated in favor of sending the query answers as + feedback. It will be removed in a future version of the protocol. +*) +type query_sty = route_id * (string * state_id) +type query_rty = unit + +(** 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 uninstantiated 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 * Pp.t + +(* 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 wait_sty = unit +type wait_rty = unit + +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; + (* for internal use (fake_id) only, do not use *) + wait : wait_sty -> wait_rty; + (* Retrocompatibility stuff *) + interp : interp_sty -> interp_rty; +} + diff --git a/ide/protocol/richpp.ml b/ide/protocol/richpp.ml new file mode 100644 index 0000000000..b2ce55e89a --- /dev/null +++ b/ide/protocol/richpp.ml @@ -0,0 +1,171 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Xml_datatype + +type 'annotation located = { + annotation : 'annotation option; + startpos : int; + endpos : int +} + +type 'a stack = +| Leaf +| Node of string * 'a located gxml list * int * 'a stack + +type 'a context = { + mutable stack : 'a stack; + (** Pending opened nodes *) + mutable offset : int; + (** Quantity of characters printed so far *) +} + +(** We use Format to introduce tags inside the pretty-printed document. + Each inserted tag is a fresh index that we keep in sync with the contents + of annotations. + + We build an XML tree on the fly, by plugging ourselves in Format tag + marking functions. As those functions are called when actually writing to + the device, the resulting tree is correct. +*) +let rich_pp width ppcmds = + + let context = { + stack = Leaf; + offset = 0; + } in + + let pp_buffer = Buffer.create 180 in + + let push_pcdata () = + (* Push the optional PCData on the above node *) + let len = Buffer.length pp_buffer in + if len = 0 then () + else match context.stack with + | Leaf -> assert false + | Node (node, child, pos, ctx) -> + let data = Buffer.contents pp_buffer in + let () = Buffer.clear pp_buffer in + let () = context.stack <- Node (node, PCData data :: child, pos, ctx) in + context.offset <- context.offset + len + in + + let open_xml_tag tag = + let () = push_pcdata () in + context.stack <- Node (tag, [], context.offset, context.stack) + in + + let close_xml_tag tag = + let () = push_pcdata () in + match context.stack with + | Leaf -> assert false + | Node (node, child, pos, ctx) -> + let () = assert (String.equal tag node) in + let annotation = { + annotation = Some tag; + startpos = pos; + endpos = context.offset; + } in + let xml = Element (node, annotation, List.rev child) in + match ctx with + | Leaf -> + (* Final node: we keep the result in a dummy context *) + context.stack <- Node ("", [xml], 0, Leaf) + | Node (node, child, pos, ctx) -> + context.stack <- Node (node, xml :: child, pos, ctx) + in + + let open Format in + + let ft = formatter_of_buffer pp_buffer in + + let tag_functions = { + mark_open_tag = (fun tag -> let () = open_xml_tag tag in ""); + mark_close_tag = (fun tag -> let () = close_xml_tag tag in ""); + print_open_tag = ignore; + print_close_tag = ignore; + } in + + pp_set_formatter_tag_functions ft tag_functions; + pp_set_mark_tags ft true; + + (* Setting the formatter *) + pp_set_margin ft width; + let m = max (64 * width / 100) (width-30) in + pp_set_max_indent ft m; + pp_set_max_boxes ft 50 ; + pp_set_ellipsis_text ft "..."; + + (* The whole output must be a valid document. To that + end, we nest the document inside <pp> tags. *) + pp_open_box ft 0; + pp_open_tag ft "pp"; + Pp.(pp_with ft ppcmds); + pp_close_tag ft (); + pp_close_box ft (); + + (* Get the resulting XML tree. *) + let () = pp_print_flush ft () in + let () = assert (Buffer.length pp_buffer = 0) in + match context.stack with + | Node ("", [xml], 0, Leaf) -> xml + | _ -> assert false + + +let annotations_positions xml = + let rec node accu = function + | Element (_, { annotation = Some annotation; startpos; endpos }, cs) -> + children ((annotation, (startpos, endpos)) :: accu) cs + | Element (_, _, cs) -> + children accu cs + | _ -> + accu + and children accu cs = + List.fold_left node accu cs + in + node [] xml + +let xml_of_rich_pp tag_of_annotation attributes_of_annotation xml = + let rec node = function + | Element (index, { annotation; startpos; endpos }, cs) -> + let attributes = + [ "startpos", string_of_int startpos; + "endpos", string_of_int endpos + ] + @ (match annotation with + | None -> [] + | Some annotation -> attributes_of_annotation annotation + ) + in + let tag = + match annotation with + | None -> index + | Some annotation -> tag_of_annotation annotation + in + Element (tag, attributes, List.map node cs) + | PCData s -> + PCData s + in + node xml + +type richpp = xml + +let richpp_of_pp width pp = + let rec drop = function + | PCData s -> [PCData s] + | Element (_, annotation, cs) -> + let cs = List.concat (List.map drop cs) in + match annotation.annotation with + | None -> cs + | Some s -> [Element (s, [], cs)] + in + let xml = rich_pp width pp in + Element ("_", [], drop xml) diff --git a/ide/protocol/richpp.mli b/ide/protocol/richpp.mli new file mode 100644 index 0000000000..31fc7b56f1 --- /dev/null +++ b/ide/protocol/richpp.mli @@ -0,0 +1,53 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** This module offers semi-structured pretty-printing. *) + +(** Each annotation of the semi-structured document refers to the + substring it annotates. *) +type 'annotation located = { + annotation : 'annotation option; + startpos : int; + endpos : int +} + +(* XXX: The width parameter should be moved to a `formatter_property` + record shared with Topfmt *) + +(** [rich_pp width ppcmds] returns the interpretation + of [ppcmds] as a semi-structured document + that represents (located) annotations of this string. + The [get_annotations] function is used to convert tags into the desired + annotation. [width] sets the printing witdh of the formatter. *) +val rich_pp : int -> Pp.t -> Pp.pp_tag located Xml_datatype.gxml + +(** [annotations_positions ssdoc] returns a list associating each + annotations with its position in the string from which [ssdoc] is + built. *) +val annotations_positions : + 'annotation located Xml_datatype.gxml -> + ('annotation * (int * int)) list + +(** [xml_of_rich_pp ssdoc] returns an XML representation of the + semi-structured document [ssdoc]. *) +val xml_of_rich_pp : + ('annotation -> string) -> + ('annotation -> (string * string) list) -> + 'annotation located Xml_datatype.gxml -> + Xml_datatype.xml + +(** {5 Enriched text} *) + +type richpp = Xml_datatype.xml + +(** Type of text with style annotations *) + +val richpp_of_pp : int -> Pp.t -> richpp +(** Extract style information from formatted text *) diff --git a/ide/protocol/serialize.ml b/ide/protocol/serialize.ml new file mode 100644 index 0000000000..86074d44d5 --- /dev/null +++ b/ide/protocol/serialize.ml @@ -0,0 +1,123 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Xml_datatype + +exception Marshal_error of string * xml + +(** Utility functions *) + +let rec get_attr attr = function + | [] -> raise Not_found + | (k, v) :: l when CString.equal k attr -> v + | _ :: l -> get_attr attr l + +let massoc x l = + try get_attr x l + with Not_found -> raise (Marshal_error("attribute " ^ x,PCData "not there")) + +let constructor t c args = Element (t, ["val", c], args) +let do_match t mf = function + | Element (s, attrs, args) when CString.equal s t -> + let c = massoc "val" attrs in + mf c args + | x -> raise (Marshal_error (t,x)) + +let singleton = function + | [x] -> x + | l -> raise (Marshal_error + ("singleton",PCData ("list of length " ^ string_of_int (List.length l)))) + +let raw_string = function + | [] -> "" + | [PCData s] -> s + | x::_ -> raise (Marshal_error("raw string",x)) + +(** Base types *) + +let of_unit () = Element ("unit", [], []) +let to_unit : xml -> unit = function + | Element ("unit", [], []) -> () + | x -> raise (Marshal_error ("unit",x)) + +let of_bool (b : bool) : xml = + if b then constructor "bool" "true" [] + else constructor "bool" "false" [] +let to_bool : xml -> bool = do_match "bool" (fun s _ -> match s with + | "true" -> true + | "false" -> false + | x -> raise (Marshal_error("bool",PCData x))) + +let of_list (f : 'a -> xml) (l : 'a list) = + Element ("list", [], List.map f l) +let to_list (f : xml -> 'a) : xml -> 'a list = function + | Element ("list", [], l) -> List.map f l + | x -> raise (Marshal_error("list",x)) + +let of_option (f : 'a -> xml) : 'a option -> xml = function + | None -> Element ("option", ["val", "none"], []) + | Some x -> Element ("option", ["val", "some"], [f x]) +let to_option (f : xml -> 'a) : xml -> 'a option = function + | Element ("option", ["val", "none"], []) -> None + | Element ("option", ["val", "some"], [x]) -> Some (f x) + | x -> raise (Marshal_error("option",x)) + +let of_string (s : string) : xml = Element ("string", [], [PCData s]) +let to_string : xml -> string = function + | Element ("string", [], l) -> raw_string l + | x -> raise (Marshal_error("string",x)) + +let of_int (i : int) : xml = Element ("int", [], [PCData (string_of_int i)]) +let to_int : xml -> int = function + | Element ("int", [], [PCData s]) -> + (try int_of_string s with Failure _ -> raise(Marshal_error("int",PCData s))) + | x -> raise (Marshal_error("int",x)) + +let of_pair (f : 'a -> xml) (g : 'b -> xml) (x : 'a * 'b) : xml = + Element ("pair", [], [f (fst x); g (snd x)]) +let to_pair (f : xml -> 'a) (g : xml -> 'b) : xml -> 'a * 'b = function + | Element ("pair", [], [x; y]) -> (f x, g y) + | x -> raise (Marshal_error("pair",x)) + +let of_union (f : 'a -> xml) (g : 'b -> xml) : ('a,'b) CSig.union -> xml = function + | CSig.Inl x -> Element ("union", ["val","in_l"], [f x]) + | CSig.Inr x -> Element ("union", ["val","in_r"], [g x]) +let to_union (f : xml -> 'a) (g : xml -> 'b) : xml -> ('a,'b) CSig.union = function + | Element ("union", ["val","in_l"], [x]) -> CSig.Inl (f x) + | Element ("union", ["val","in_r"], [x]) -> CSig.Inr (g x) + | x -> raise (Marshal_error("union",x)) + +(** More elaborate types *) + +let of_edit_id i = Element ("edit_id",["val",string_of_int i],[]) +let to_edit_id = function + | Element ("edit_id",["val",i],[]) -> + let id = int_of_string i in + assert (id <= 0 ); + id + | x -> raise (Marshal_error("edit_id",x)) + +let of_loc loc = + let start, stop = Loc.unloc loc in + Element ("loc",[("start",string_of_int start);("stop",string_of_int stop)],[]) +let to_loc xml = + match xml with + | Element ("loc", l,[]) -> + let start = massoc "start" l in + let stop = massoc "stop" l in + (try + Loc.make_loc (int_of_string start, int_of_string stop) + with Not_found | Invalid_argument _ -> raise (Marshal_error("loc",PCData(start^":"^stop)))) + | x -> raise (Marshal_error("loc",x)) + +let of_xml x = Element ("xml", [], [x]) +let to_xml xml = match xml with +| Element ("xml", [], [x]) -> x +| x -> raise (Marshal_error("xml",x)) diff --git a/ide/protocol/serialize.mli b/ide/protocol/serialize.mli new file mode 100644 index 0000000000..af082f25b1 --- /dev/null +++ b/ide/protocol/serialize.mli @@ -0,0 +1,41 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Xml_datatype + +exception Marshal_error of string * xml + +val massoc: string -> (string * string) list -> string +val constructor: string -> string -> xml list -> xml +val do_match: string -> (string -> xml list -> 'b) -> xml -> 'b +val singleton: 'a list -> 'a +val raw_string: xml list -> string +val of_unit: unit -> xml +val to_unit: xml -> unit +val of_bool: bool -> xml +val to_bool: xml -> bool +val of_list: ('a -> xml) -> 'a list -> xml +val to_list: (xml -> 'a) -> xml -> 'a list +val of_option: ('a -> xml) -> 'a option -> xml +val to_option: (xml -> 'a) -> xml -> 'a option +val of_string: string -> xml +val to_string: xml -> string +val of_int: int -> xml +val to_int: xml -> int +val of_pair: ('a -> xml) -> ('b -> xml) -> 'a * 'b -> xml +val to_pair: (xml -> 'a) -> (xml -> 'b) -> xml -> 'a * 'b +val of_union: ('a -> xml) -> ('b -> xml) -> ('a, 'b) CSig.union -> xml +val to_union: (xml -> 'a) -> (xml -> 'b) -> xml -> ('a, 'b) CSig.union +val of_edit_id: int -> xml +val to_edit_id: xml -> int +val of_loc : Loc.t -> xml +val to_loc : xml -> Loc.t +val of_xml : xml -> xml +val to_xml : xml -> xml diff --git a/ide/protocol/xml_lexer.mli b/ide/protocol/xml_lexer.mli new file mode 100644 index 0000000000..e61cb055f7 --- /dev/null +++ b/ide/protocol/xml_lexer.mli @@ -0,0 +1,44 @@ +(* + * Xml Light, an small Xml parser/printer with DTD support. + * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com) + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +type error = + | EUnterminatedComment + | EUnterminatedString + | EIdentExpected + | ECloseExpected + | ENodeExpected + | EAttributeNameExpected + | EAttributeValueExpected + | EUnterminatedEntity + +exception Error of error + +type token = + | Tag of string * (string * string) list * bool + | PCData of string + | Endtag of string + | Eof + +type pos = int * int * int * int + +val init : Lexing.lexbuf -> unit +val close : unit -> unit +val token : Lexing.lexbuf -> token +val pos : Lexing.lexbuf -> pos +val restore : pos -> unit diff --git a/ide/protocol/xml_lexer.mll b/ide/protocol/xml_lexer.mll new file mode 100644 index 0000000000..e8bf7e16ae --- /dev/null +++ b/ide/protocol/xml_lexer.mll @@ -0,0 +1,317 @@ +{(* + * Xml Light, an small Xml parser/printer with DTD support. + * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com) + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +open Lexing + +type error = + | EUnterminatedComment + | EUnterminatedString + | EIdentExpected + | ECloseExpected + | ENodeExpected + | EAttributeNameExpected + | EAttributeValueExpected + | EUnterminatedEntity + +exception Error of error + +type pos = int * int * int * int + +type token = + | Tag of string * (string * string) list * bool + | PCData of string + | Endtag of string + | Eof + +let last_pos = ref 0 +and current_line = ref 0 +and current_line_start = ref 0 + +let tmp = Buffer.create 200 + +let idents = Hashtbl.create 0 + +let _ = begin + Hashtbl.add idents "nbsp;" " "; + Hashtbl.add idents "gt;" ">"; + Hashtbl.add idents "lt;" "<"; + Hashtbl.add idents "amp;" "&"; + Hashtbl.add idents "apos;" "'"; + Hashtbl.add idents "quot;" "\""; +end + +let init lexbuf = + current_line := 1; + current_line_start := lexeme_start lexbuf; + last_pos := !current_line_start + +let close lexbuf = + Buffer.reset tmp + +let pos lexbuf = + !current_line , !current_line_start , + !last_pos , + lexeme_start lexbuf + +let restore (cl,cls,lp,_) = + current_line := cl; + current_line_start := cls; + last_pos := lp + +let newline lexbuf = + incr current_line; + last_pos := lexeme_end lexbuf; + current_line_start := !last_pos + +let error lexbuf e = + last_pos := lexeme_start lexbuf; + raise (Error e) + +} + +let newline = ['\n'] +let break = ['\r'] +let space = [' ' '\t'] +let identchar = ['A'-'Z' 'a'-'z' '_' '0'-'9' ':' '-' '.'] +let ident = ['A'-'Z' 'a'-'z' '_' ':'] identchar* +let entitychar = ['A'-'Z' 'a'-'z'] +let pcchar = [^ '\r' '\n' '<' '>' '&'] + +rule token = parse + | newline | (newline break) | break + { + newline lexbuf; + PCData "\n" + } + | "<!--" + { + last_pos := lexeme_start lexbuf; + comment lexbuf; + token lexbuf + } + | "<?" + { + last_pos := lexeme_start lexbuf; + header lexbuf; + token lexbuf; + } + | '<' space* '/' space* + { + last_pos := lexeme_start lexbuf; + let tag = ident_name lexbuf in + ignore_spaces lexbuf; + close_tag lexbuf; + Endtag tag + } + | '<' space* + { + last_pos := lexeme_start lexbuf; + let tag = ident_name lexbuf in + ignore_spaces lexbuf; + let attribs, closed = attributes lexbuf in + Tag(tag, attribs, closed) + } + | "&#" + { + last_pos := lexeme_start lexbuf; + Buffer.reset tmp; + Buffer.add_string tmp (lexeme lexbuf); + PCData (pcdata lexbuf) + } + | '&' + { + last_pos := lexeme_start lexbuf; + Buffer.reset tmp; + Buffer.add_string tmp (entity lexbuf); + PCData (pcdata lexbuf) + } + | pcchar+ + { + last_pos := lexeme_start lexbuf; + Buffer.reset tmp; + Buffer.add_string tmp (lexeme lexbuf); + PCData (pcdata lexbuf) + } + | eof { Eof } + | _ + { error lexbuf ENodeExpected } + +and ignore_spaces = parse + | newline | (newline break) | break + { + newline lexbuf; + ignore_spaces lexbuf + } + | space + + { ignore_spaces lexbuf } + | "" + { () } + +and comment = parse + | newline | (newline break) | break + { + newline lexbuf; + comment lexbuf + } + | "-->" + { () } + | eof + { raise (Error EUnterminatedComment) } + | _ + { comment lexbuf } + +and header = parse + | newline | (newline break) | break + { + newline lexbuf; + header lexbuf + } + | "?>" + { () } + | eof + { error lexbuf ECloseExpected } + | _ + { header lexbuf } + +and pcdata = parse + | newline | (newline break) | break + { + Buffer.add_char tmp '\n'; + newline lexbuf; + pcdata lexbuf + } + | pcchar+ + { + Buffer.add_string tmp (lexeme lexbuf); + pcdata lexbuf + } + | "&#" + { + Buffer.add_string tmp (lexeme lexbuf); + pcdata lexbuf; + } + | '&' + { + Buffer.add_string tmp (entity lexbuf); + pcdata lexbuf + } + | "" + { Buffer.contents tmp } + +and entity = parse + | entitychar+ ';' + { + let ident = lexeme lexbuf in + try + Hashtbl.find idents (String.lowercase_ascii ident) + with + Not_found -> "&" ^ ident + } + | _ | eof + { raise (Error EUnterminatedEntity) } + +and ident_name = parse + | ident + { lexeme lexbuf } + | _ | eof + { error lexbuf EIdentExpected } + +and close_tag = parse + | '>' + { () } + | _ | eof + { error lexbuf ECloseExpected } + +and attributes = parse + | '>' + { [], false } + | "/>" + { [], true } + | "" (* do not read a char ! *) + { + let key = attribute lexbuf in + let data = attribute_data lexbuf in + ignore_spaces lexbuf; + let others, closed = attributes lexbuf in + (key, data) :: others, closed + } + +and attribute = parse + | ident + { lexeme lexbuf } + | _ | eof + { error lexbuf EAttributeNameExpected } + +and attribute_data = parse + | space* '=' space* '"' + { + Buffer.reset tmp; + last_pos := lexeme_end lexbuf; + dq_string lexbuf + } + | space* '=' space* '\'' + { + Buffer.reset tmp; + last_pos := lexeme_end lexbuf; + q_string lexbuf + } + | _ | eof + { error lexbuf EAttributeValueExpected } + +and dq_string = parse + | '"' + { Buffer.contents tmp } + | '\\' [ '"' '\\' ] + { + Buffer.add_char tmp (lexeme_char lexbuf 1); + dq_string lexbuf + } + | '&' + { + Buffer.add_string tmp (entity lexbuf); + dq_string lexbuf + } + | eof + { raise (Error EUnterminatedString) } + | _ + { + Buffer.add_char tmp (lexeme_char lexbuf 0); + dq_string lexbuf + } + +and q_string = parse + | '\'' + { Buffer.contents tmp } + | '\\' [ '\'' '\\' ] + { + Buffer.add_char tmp (lexeme_char lexbuf 1); + q_string lexbuf + } + | '&' + { + Buffer.add_string tmp (entity lexbuf); + q_string lexbuf + } + | eof + { raise (Error EUnterminatedString) } + | _ + { + Buffer.add_char tmp (lexeme_char lexbuf 0); + q_string lexbuf + } diff --git a/ide/protocol/xml_parser.ml b/ide/protocol/xml_parser.ml new file mode 100644 index 0000000000..8db3f9e8ba --- /dev/null +++ b/ide/protocol/xml_parser.ml @@ -0,0 +1,232 @@ +(* + * Xml Light, an small Xml parser/printer with DTD support. + * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com) + * Copyright (C) 2003 Jacques Garrigue + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +open Printf +open Xml_datatype + +type xml = Xml_datatype.xml + +type error_pos = { + eline : int; + eline_start : int; + emin : int; + emax : int; +} + +type error_msg = + | UnterminatedComment + | UnterminatedString + | UnterminatedEntity + | IdentExpected + | CloseExpected + | NodeExpected + | AttributeNameExpected + | AttributeValueExpected + | EndOfTagExpected of string + | EOFExpected + | Empty + +type error = error_msg * error_pos + +exception Error of error + +exception File_not_found of string + +type t = { + mutable check_eof : bool; + mutable concat_pcdata : bool; + source : Lexing.lexbuf; + stack : Xml_lexer.token Stack.t; +} + +type source = + | SChannel of in_channel + | SString of string + | SLexbuf of Lexing.lexbuf + +exception Internal_error of error_msg +exception NoMoreData + +let xml_error = ref (fun _ -> assert false) +let file_not_found = ref (fun _ -> assert false) + +let is_blank s = + let len = String.length s in + let break = ref true in + let i = ref 0 in + while !break && !i < len do + let c = s.[!i] in + (* no '\r' because we replaced them in the lexer *) + if c = ' ' || c = '\n' || c = '\t' then incr i + else break := false + done; + !i = len + +let _raises e f = + xml_error := e; + file_not_found := f + +let make source = + let source = match source with + | SChannel chan -> Lexing.from_channel chan + | SString s -> Lexing.from_string s + | SLexbuf lexbuf -> lexbuf + in + let () = Xml_lexer.init source in + { + check_eof = false; + concat_pcdata = true; + source = source; + stack = Stack.create (); + } + +let check_eof p v = p.check_eof <- v + +let pop s = + try + Stack.pop s.stack + with + Stack.Empty -> + Xml_lexer.token s.source + +let push t s = + Stack.push t s.stack + +let canonicalize l = + let has_elt = List.exists (function Element _ -> true | _ -> false) l in + if has_elt then List.filter (function PCData s -> not (is_blank s) | _ -> true) l + else l + +let rec read_xml do_not_canonicalize s = + let rec read_node s = + match pop s with + | Xml_lexer.PCData s -> PCData s + | Xml_lexer.Tag (tag, attr, true) -> Element (tag, attr, []) + | Xml_lexer.Tag (tag, attr, false) -> + let elements = read_elems tag s in + let elements = + if do_not_canonicalize then elements else canonicalize elements + in + Element (tag, attr, elements) + | t -> + push t s; + raise NoMoreData + + and read_elems tag s = + let elems = ref [] in + (try + while true do + let node = read_node s in + match node, !elems with + | PCData c , (PCData c2) :: q -> + elems := PCData (c2 ^ c) :: q + | _, l -> + elems := node :: l + done + with + NoMoreData -> ()); + match pop s with + | Xml_lexer.Endtag s when s = tag -> List.rev !elems + | t -> raise (Internal_error (EndOfTagExpected tag)) + in + match read_node s with + | (Element _) as node -> + node + | PCData c -> + if is_blank c then + read_xml do_not_canonicalize s + else + raise (Xml_lexer.Error Xml_lexer.ENodeExpected) + +let convert = function + | Xml_lexer.EUnterminatedComment -> UnterminatedComment + | Xml_lexer.EUnterminatedString -> UnterminatedString + | Xml_lexer.EIdentExpected -> IdentExpected + | Xml_lexer.ECloseExpected -> CloseExpected + | Xml_lexer.ENodeExpected -> NodeExpected + | Xml_lexer.EAttributeNameExpected -> AttributeNameExpected + | Xml_lexer.EAttributeValueExpected -> AttributeValueExpected + | Xml_lexer.EUnterminatedEntity -> UnterminatedEntity + +let error_of_exn xparser = function + | NoMoreData when pop xparser = Xml_lexer.Eof -> Empty + | NoMoreData -> NodeExpected + | Internal_error e -> e + | Xml_lexer.Error e -> convert e + | e -> + (*let e = Errors.push e in: We do not record backtrace here. *) + raise e + +let do_parse do_not_canonicalize xparser = + try + Xml_lexer.init xparser.source; + let x = read_xml do_not_canonicalize xparser in + if xparser.check_eof && pop xparser <> Xml_lexer.Eof then raise (Internal_error EOFExpected); + Xml_lexer.close (); + x + with any -> + Xml_lexer.close (); + raise (!xml_error (error_of_exn xparser any) xparser.source) + +let parse ?(do_not_canonicalize=false) p = + do_parse do_not_canonicalize p + +let error_msg = function + | UnterminatedComment -> "Unterminated comment" + | UnterminatedString -> "Unterminated string" + | UnterminatedEntity -> "Unterminated entity" + | IdentExpected -> "Ident expected" + | CloseExpected -> "Element close expected" + | NodeExpected -> "Xml node expected" + | AttributeNameExpected -> "Attribute name expected" + | AttributeValueExpected -> "Attribute value expected" + | EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag + | EOFExpected -> "End of file expected" + | Empty -> "Empty" + +let error (msg,pos) = + if pos.emin = pos.emax then + sprintf "%s line %d character %d" (error_msg msg) pos.eline + (pos.emin - pos.eline_start) + else + sprintf "%s line %d characters %d-%d" (error_msg msg) pos.eline + (pos.emin - pos.eline_start) (pos.emax - pos.eline_start) + +let line e = e.eline + +let range e = + e.emin - e.eline_start , e.emax - e.eline_start + +let abs_range e = + e.emin , e.emax + +let pos source = + let line, lstart, min, max = Xml_lexer.pos source in + { + eline = line; + eline_start = lstart; + emin = min; + emax = max; + } + +let () = _raises (fun x p -> + (* local cast : Xml.error_msg -> error_msg *) + Error (x, pos p)) + (fun f -> File_not_found f) diff --git a/ide/protocol/xml_parser.mli b/ide/protocol/xml_parser.mli new file mode 100644 index 0000000000..ac2eab352f --- /dev/null +++ b/ide/protocol/xml_parser.mli @@ -0,0 +1,106 @@ +(* + * Xml Light, an small Xml parser/printer with DTD support. + * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com) + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +(** Xml Light Parser + + While basic parsing functions can be used in the {!Xml} module, this module + is providing a way to create, configure and run an Xml parser. + +*) + + +(** An Xml node is either + [Element (tag-name, attributes, children)] or [PCData text] *) +type xml = Xml_datatype.xml + +(** Abstract type for an Xml parser. *) +type t + +(** {6:exc Xml Exceptions} *) + +(** Several exceptions can be raised when parsing an Xml document : {ul + {li {!Xml.Error} is raised when an xml parsing error occurs. the + {!Xml.error_msg} tells you which error occurred during parsing + and the {!Xml.error_pos} can be used to retrieve the document + location where the error occurred at.} + {li {!Xml.File_not_found} is raised when an error occurred while + opening a file with the {!Xml.parse_file} function.} + } + *) + +type error_pos + +type error_msg = + | UnterminatedComment + | UnterminatedString + | UnterminatedEntity + | IdentExpected + | CloseExpected + | NodeExpected + | AttributeNameExpected + | AttributeValueExpected + | EndOfTagExpected of string + | EOFExpected + | Empty + +type error = error_msg * error_pos + +exception Error of error + +exception File_not_found of string + +(** Get a full error message from an Xml error. *) +val error : error -> string + +(** Get the Xml error message as a string. *) +val error_msg : error_msg -> string + +(** Get the line the error occurred at. *) +val line : error_pos -> int + +(** Get the relative character range (in current line) the error occurred at.*) +val range : error_pos -> int * int + +(** Get the absolute character range the error occurred at. *) +val abs_range : error_pos -> int * int + +val pos : Lexing.lexbuf -> error_pos + +(** Several kind of resources can contain Xml documents. *) +type source = +| SChannel of in_channel +| SString of string +| SLexbuf of Lexing.lexbuf + +(** This function returns a new parser with default options. *) +val make : source -> t + +(** When a Xml document is parsed, the parser may check that the end of the + document is reached, so for example parsing ["<A/><B/>"] will fail instead + of returning only the A element. You can turn on this check by setting + [check_eof] to [true] {i (by default, check_eof is false, unlike + in the original Xmllight)}. *) +val check_eof : t -> bool -> unit + +(** Once the parser is configured, you can run the parser on a any kind + of xml document source to parse its contents into an Xml data structure. + + When [do_not_canonicalize] is set, the XML document is given as + is, without trying to remove blank PCDATA elements. *) +val parse : ?do_not_canonicalize:bool -> t -> xml diff --git a/ide/protocol/xml_printer.ml b/ide/protocol/xml_printer.ml new file mode 100644 index 0000000000..488ef7bf57 --- /dev/null +++ b/ide/protocol/xml_printer.ml @@ -0,0 +1,147 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Xml_datatype + +type xml = Xml_datatype.xml + +type target = TChannel of out_channel | TBuffer of Buffer.t + +type t = target + +let make x = x + +let buffer_pcdata tmp text = + let puts = Buffer.add_string tmp in + let putc = Buffer.add_char tmp in + let l = String.length text in + for p = 0 to l-1 do + match text.[p] with + | ' ' -> puts " "; + | '>' -> puts ">" + | '<' -> puts "<" + | '&' -> + if p < l - 1 && text.[p + 1] = '#' then + putc '&' + else + puts "&" + | '\'' -> puts "'" + | '"' -> puts """ + | c -> putc c + done + +let buffer_attr tmp (n,v) = + let puts = Buffer.add_string tmp in + let putc = Buffer.add_char tmp in + putc ' '; + puts n; + puts "=\""; + let l = String.length v in + for p = 0 to l - 1 do + match v.[p] with + | '\\' -> puts "\\\\" + | '"' -> puts "\\\"" + | '<' -> puts "<" + | '&' -> puts "&" + | c -> putc c + done; + putc '"' + +let to_buffer tmp x = + let pcdata = ref false in + let puts = Buffer.add_string tmp in + let putc = Buffer.add_char tmp in + let rec loop = function + | Element (tag,alist,[]) -> + putc '<'; + puts tag; + List.iter (buffer_attr tmp) alist; + puts "/>"; + pcdata := false; + | Element (tag,alist,l) -> + putc '<'; + puts tag; + List.iter (buffer_attr tmp) alist; + putc '>'; + pcdata := false; + List.iter loop l; + puts "</"; + puts tag; + putc '>'; + pcdata := false; + | PCData text -> + if !pcdata then putc ' '; + buffer_pcdata tmp text; + pcdata := true; + in + loop x + +let pcdata_to_string s = + let b = Buffer.create 13 in + buffer_pcdata b s; + Buffer.contents b + +let to_string x = + let b = Buffer.create 200 in + to_buffer b x; + Buffer.contents b + +let to_string_fmt x = + let tmp = Buffer.create 200 in + let puts = Buffer.add_string tmp in + let putc = Buffer.add_char tmp in + let rec loop ?(newl=false) tab = function + | Element (tag, alist, []) -> + puts tab; + putc '<'; + puts tag; + List.iter (buffer_attr tmp) alist; + puts "/>"; + if newl then putc '\n'; + | Element (tag, alist, [PCData text]) -> + puts tab; + putc '<'; + puts tag; + List.iter (buffer_attr tmp) alist; + puts ">"; + buffer_pcdata tmp text; + puts "</"; + puts tag; + putc '>'; + if newl then putc '\n'; + | Element (tag, alist, l) -> + puts tab; + putc '<'; + puts tag; + List.iter (buffer_attr tmp) alist; + puts ">\n"; + List.iter (loop ~newl:true (tab^" ")) l; + puts tab; + puts "</"; + puts tag; + putc '>'; + if newl then putc '\n'; + | PCData text -> + buffer_pcdata tmp text; + if newl then putc '\n'; + in + loop "" x; + Buffer.contents tmp + +let print t xml = + let tmp, flush = match t with + | TChannel oc -> + let b = Buffer.create 200 in + b, (fun () -> Buffer.output_buffer oc b; flush oc) + | TBuffer b -> + b, (fun () -> ()) + in + to_buffer tmp xml; + flush () diff --git a/ide/protocol/xml_printer.mli b/ide/protocol/xml_printer.mli new file mode 100644 index 0000000000..178f7c808f --- /dev/null +++ b/ide/protocol/xml_printer.mli @@ -0,0 +1,31 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +type xml = Xml_datatype.xml + +type t +type target = TChannel of out_channel | TBuffer of Buffer.t + +val make : target -> t + +(** Print the xml data structure to a source into a compact xml string (without + any user-readable formating ). *) +val print : t -> xml -> unit + +(** Print the xml data structure into a compact xml string (without + any user-readable formating ). *) +val to_string : xml -> string + +(** Print the xml data structure into an user-readable string with + tabs and lines break between different nodes. *) +val to_string_fmt : xml -> string + +(** Print PCDATA as a string by escaping XML entities. *) +val pcdata_to_string : string -> string diff --git a/ide/protocol/xmlprotocol.ml b/ide/protocol/xmlprotocol.ml new file mode 100644 index 0000000000..e18219210f --- /dev/null +++ b/ide/protocol/xmlprotocol.ml @@ -0,0 +1,964 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Protocol version of this file. This is the date of the last modification. *) + +(** WARNING: TO BE UPDATED WHEN MODIFIED! *) + +let protocol_version = "20170413" + +type msg_format = Richpp of int | Ppcmds +let msg_format = ref (Richpp 72) + +(** * 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 + | x -> raise (Marshal_error("search",PCData x))) + +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; + } +| x -> raise (Marshal_error("coq_object",x)) + +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] + | StringOptValue s -> constructor "option_value" "stringoptvalue" [of_option 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)) + | "stringoptvalue" -> StringOptValue (to_option to_string (singleton args)) + | x -> raise (Marshal_error("*value",PCData x))) + +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 } + | x -> raise (Marshal_error("option_state",x)) + +let to_stateid = function + | Element ("state_id",["val",i],[]) -> + let id = int_of_string i in + Stateid.of_int id + | _ -> raise (Invalid_argument "to_state_id") + +let of_stateid i = Element ("state_id",["val",string_of_int (Stateid.to_int i)],[]) + +let to_routeid = function + | Element ("route_id",["val",i],[]) -> + let id = int_of_string i in id + | _ -> raise (Invalid_argument "to_route_id") + +let of_routeid i = Element ("route_id",["val",string_of_int i],[]) + +let of_box (ppb : Pp.block_type) = let open Pp in match ppb with + | Pp_hbox i -> constructor "ppbox" "hbox" [of_int i] + | Pp_vbox i -> constructor "ppbox" "vbox" [of_int i] + | Pp_hvbox i -> constructor "ppbox" "hvbox" [of_int i] + | Pp_hovbox i -> constructor "ppbox" "hovbox" [of_int i] + +let to_box = let open Pp in + do_match "ppbox" (fun s args -> match s with + | "hbox" -> Pp_hbox (to_int (singleton args)) + | "vbox" -> Pp_vbox (to_int (singleton args)) + | "hvbox" -> Pp_hvbox (to_int (singleton args)) + | "hovbox" -> Pp_hovbox (to_int (singleton args)) + | x -> raise (Marshal_error("*ppbox",PCData x)) + ) + +let rec of_pp (pp : Pp.t) = let open Pp in match Pp.repr pp with + | Ppcmd_empty -> constructor "ppdoc" "empty" [] + | Ppcmd_string s -> constructor "ppdoc" "string" [of_string s] + | Ppcmd_glue sl -> constructor "ppdoc" "glue" [of_list of_pp sl] + | Ppcmd_box (bt,s) -> constructor "ppdoc" "box" [of_pair of_box of_pp (bt,s)] + | Ppcmd_tag (t,s) -> constructor "ppdoc" "tag" [of_pair of_string of_pp (t,s)] + | Ppcmd_print_break (i,j) + -> constructor "ppdoc" "break" [of_pair of_int of_int (i,j)] + | Ppcmd_force_newline -> constructor "ppdoc" "newline" [] + | Ppcmd_comment cmd -> constructor "ppdoc" "comment" [of_list of_string cmd] + + +let rec to_pp xpp = let open Pp in + Pp.unrepr @@ + do_match "ppdoc" (fun s args -> match s with + | "empty" -> Ppcmd_empty + | "string" -> Ppcmd_string (to_string (singleton args)) + | "glue" -> Ppcmd_glue (to_list to_pp (singleton args)) + | "box" -> let (bt,s) = to_pair to_box to_pp (singleton args) in + Ppcmd_box(bt,s) + | "tag" -> let (tg,s) = to_pair to_string to_pp (singleton args) in + Ppcmd_tag(tg,s) + | "break" -> let (i,j) = to_pair to_int to_int (singleton args) in + Ppcmd_print_break(i, j) + | "newline" -> Ppcmd_force_newline + | "comment" -> Ppcmd_comment (to_list to_string (singleton args)) + | x -> raise (Marshal_error("*ppdoc",PCData x)) + ) xpp + +let of_richpp x = Element ("richpp", [], [x]) + +(* Run-time Selectable *) +let of_pp (pp : Pp.t) = + match !msg_format with + | Richpp margin -> of_richpp (Richpp.richpp_of_pp margin pp) + | Ppcmds -> of_pp pp + +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 = of_stateid id in + Element ("value", ["val", "fail"] @ loc, [id; of_pp 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, msg) = match l with [id; msg] -> (id, msg) | _ -> raise (Marshal_error("val",PCData "no id attribute")) in + let id = to_stateid id in + let msg = to_pp msg in + Fail (id, loc, msg) + else raise (Marshal_error("good or fail",PCData ans)) +| x -> raise (Marshal_error("value",x)) + +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; } + | x -> raise (Marshal_error("status",x)) + +let of_evar s = Element ("evar", [], [PCData s.evar_info]) +let to_evar = function + | Element ("evar", [], data) -> { evar_info = raw_string data; } + | x -> raise (Marshal_error("evar",x)) + +let of_goal g = + let hyp = of_list of_pp g.goal_hyp in + let ccl = of_pp 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_pp hyp in + let ccl = to_pp ccl in + let id = to_string id in + { goal_hyp = hyp; goal_ccl = ccl; goal_id = id; } + | x -> raise (Marshal_error("goal",x)) + +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 } + | x -> raise (Marshal_error("goals",x)) + +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; } + | x -> raise (Marshal_error("coq_info",x)) + +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 route_id_t : route_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 _ val_t = + | Unit : unit val_t + | String : string val_t + | Int : int val_t + | Bool : bool val_t + | Xml : Xml_datatype.xml val_t + + | Option : 'a val_t -> 'a option val_t + | List : 'a val_t -> 'a list val_t + | Pair : 'a val_t * 'b val_t -> ('a * 'b) val_t + | Union : 'a val_t * 'b val_t -> ('a, 'b) union val_t + + | Goals : goals val_t + | Evar : evar val_t + | State : status val_t + | Option_state : option_state val_t + | Option_value : option_value val_t + | Coq_info : coq_info val_t + | Coq_object : 'a val_t -> 'a coq_object val_t + | State_id : state_id val_t + | Route_id : route_id val_t + | Search_cst : search_constraint val_t + + type value_type = Value_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 route_id_t = Route_id + let search_cst_t = Search_cst + + let of_value_type (ty : 'a val_t) : 'a -> xml = + let rec convert : type a. a val_t -> a -> xml = function + | Unit -> of_unit + | Bool -> of_bool + | Xml -> (fun x -> x) + | String -> of_string + | Int -> of_int + | State -> of_status + | Option_state -> of_option_state + | Option_value -> of_option_value + | Coq_info -> of_coq_info + | Goals -> of_goals + | Evar -> of_evar + | List t -> (of_list (convert t)) + | Option t -> (of_option (convert t)) + | Coq_object t -> (of_coq_object (convert t)) + | Pair (t1,t2) -> (of_pair (convert t1) (convert t2)) + | Union (t1,t2) -> (of_union (convert t1) (convert t2)) + | State_id -> of_stateid + | Route_id -> of_routeid + | Search_cst -> of_search_cst + in + convert ty + + let to_value_type (ty : 'a val_t) : xml -> 'a = + let rec convert : type a. a val_t -> xml -> a = function + | Unit -> to_unit + | Bool -> to_bool + | Xml -> (fun x -> x) + | String -> to_string + | Int -> to_int + | State -> to_status + | Option_state -> to_option_state + | Option_value -> to_option_value + | Coq_info -> to_coq_info + | Goals -> to_goals + | Evar -> to_evar + | List t -> (to_list (convert t)) + | Option t -> (to_option (convert t)) + | Coq_object t -> (to_coq_object (convert t)) + | Pair (t1,t2) -> (to_pair (convert t1) (convert t2)) + | Union (t1,t2) -> (to_union (convert t1) (convert t2)) + | State_id -> to_stateid + | Route_id -> to_routeid + | Search_cst -> 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_goal { goal_hyp = hyps; goal_ccl = goal } = + "[" ^ String.concat "; " (List.map Pp.string_of_ppcmds hyps) ^ " |- " ^ + Pp.string_of_ppcmds 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 + | StringOptValue None -> "none" + | StringOptValue (Some 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_state_id = Stateid.to_string + + 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 : type a. a val_t -> a -> string = function + | Unit -> pr_unit + | Bool -> pr_bool + | String -> pr_string + | Xml -> Xml_printer.to_string_fmt + | Int -> pr_int + | State -> pr_status + | Option_state -> pr_option_state + | Option_value -> pr_option_value + | Search_cst -> pr_search_cst + | Coq_info -> pr_coq_info + | Goals -> pr_goal + | Evar -> pr_evar + | List t -> (pr_list (print t)) + | Option t -> (pr_option (print t)) + | Coq_object t -> pr_coq_object + | Pair (t1,t2) -> (pr_pair (print t1) (print t2)) + | Union (t1,t2) -> (pr_union (print t1) (print t2)) + | State_id -> pr_state_id + | Route_id -> pr_int + + (* This is to break if a rename/refactoring makes the strings below outdated *) + type 'a exists = bool + + let rec print_val_t : type a. a val_t -> string = 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_val_t t) + | Option t -> Printf.sprintf "(%s option)" (print_val_t t) + | Coq_object t -> assert(true : 'a coq_object exists); + Printf.sprintf "(%s Interface.coq_object)" (print_val_t t) + | Pair (t1,t2) -> Printf.sprintf "(%s * %s)" (print_val_t t1) (print_val_t t2) + | Union (t1,t2) -> assert(true : ('a,'b) CSig.union exists); + Printf.sprintf "((%s, %s) CSig.union)" (print_val_t t1) (print_val_t t2) + | State_id -> assert(true : Stateid.t exists); "Stateid.t" + | Route_id -> assert(true : route_id exists); "route_id" + + let print_type = function Value_type ty -> print_val_t ty + + let document_type_encoding pr_xml = + Printf.printf "\n=== Data encoding by examples ===\n\n"; + Printf.printf "%s:\n\n%s\n\n" (print_val_t Unit) (pr_xml (of_unit ())); + Printf.printf "%s:\n\n%s\n%s\n\n" (print_val_t Bool) + (pr_xml (of_bool true)) (pr_xml (of_bool false)); + Printf.printf "%s:\n\n%s\n\n" (print_val_t String) (pr_xml (of_string "hello")); + Printf.printf "%s:\n\n%s\n\n" (print_val_t Int) (pr_xml (of_int 256)); + Printf.printf "%s:\n\n%s\n\n" (print_val_t State_id) (pr_xml (of_stateid Stateid.initial)); + Printf.printf "%s:\n\n%s\n\n" (print_val_t (List Int)) (pr_xml (of_list of_int [3;4;5])); + Printf.printf "%s:\n\n%s\n%s\n\n" (print_val_t (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_val_t (Pair (Bool,Int))) + (pr_xml (of_pair of_bool of_int (false,3))); + Printf.printf "%s:\n\n%s\n\n" (print_val_t (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_val_t 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 route_id_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 wait_sty_t : wait_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 = unit_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 wait_rty_t : wait_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; + "Wait", ($)wait_sty_t, ($)wait_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 : add_sty -> add_rty call + | Edit_at : edit_at_sty -> edit_at_rty call + | Query : query_sty -> query_rty call + | Goal : goals_sty -> goals_rty call + | Evars : evars_sty -> evars_rty call + | Hints : hints_sty -> hints_rty call + | Status : status_sty -> status_rty call + | Search : search_sty -> search_rty call + | GetOptions : get_options_sty -> get_options_rty call + | SetOptions : set_options_sty -> set_options_rty call + | MkCases : mkcases_sty -> mkcases_rty call + | Quit : quit_sty -> quit_rty call + | About : about_sty -> about_rty call + | Init : init_sty -> init_rty call + | StopWorker : stop_worker_sty -> stop_worker_rty call + (* internal use (fake_ide) only, do not use *) + | Wait : wait_sty -> wait_rty call + (* retrocompatibility *) + | Interp : interp_sty -> interp_rty call + | PrintAst : print_ast_sty -> print_ast_rty call + | Annotate : annotate_sty -> annotate_rty call + +let id_of_call : type a. a call -> int = 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 + | Wait _ -> 12 + | About _ -> 13 + | Init _ -> 14 + | Interp _ -> 15 + | StopWorker _ -> 16 + | PrintAst _ -> 17 + | Annotate _ -> 18 + +let str_of_call c = pi1 calls.(id_of_call c) + +type unknown_call = Unknown : 'a call -> unknown_call + +(** 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 wait x : wait_rty call = Wait 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 : type a. _ -> a call -> a value = fun handler c -> + let mkGood : type a. a -> a value = fun x -> Good 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) + | Wait x -> mkGood (handler.wait 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 = CErrors.push any in + Fail (handler.handle_exn any) + +(** brain dead code, edit if protocol messages are added/removed *) +let of_answer : type a. a call -> a value -> xml = function + | Add _ -> of_value (of_value_type add_rty_t ) + | Edit_at _ -> of_value (of_value_type edit_at_rty_t ) + | Query _ -> of_value (of_value_type query_rty_t ) + | Goal _ -> of_value (of_value_type goals_rty_t ) + | Evars _ -> of_value (of_value_type evars_rty_t ) + | Hints _ -> of_value (of_value_type hints_rty_t ) + | Status _ -> of_value (of_value_type status_rty_t ) + | Search _ -> of_value (of_value_type search_rty_t ) + | GetOptions _ -> of_value (of_value_type get_options_rty_t) + | SetOptions _ -> of_value (of_value_type set_options_rty_t) + | MkCases _ -> of_value (of_value_type mkcases_rty_t ) + | Quit _ -> of_value (of_value_type quit_rty_t ) + | Wait _ -> of_value (of_value_type wait_rty_t ) + | About _ -> of_value (of_value_type about_rty_t ) + | Init _ -> of_value (of_value_type init_rty_t ) + | Interp _ -> of_value (of_value_type interp_rty_t ) + | StopWorker _ -> of_value (of_value_type stop_worker_rty_t) + | PrintAst _ -> of_value (of_value_type print_ast_rty_t ) + | Annotate _ -> of_value (of_value_type annotate_rty_t ) + +let of_answer msg_fmt = + msg_format := msg_fmt; of_answer + +let to_answer : type a. a call -> xml -> a value = function + | Add _ -> to_value (to_value_type add_rty_t ) + | Edit_at _ -> to_value (to_value_type edit_at_rty_t ) + | Query _ -> to_value (to_value_type query_rty_t ) + | Goal _ -> to_value (to_value_type goals_rty_t ) + | Evars _ -> to_value (to_value_type evars_rty_t ) + | Hints _ -> to_value (to_value_type hints_rty_t ) + | Status _ -> to_value (to_value_type status_rty_t ) + | Search _ -> to_value (to_value_type search_rty_t ) + | GetOptions _ -> to_value (to_value_type get_options_rty_t) + | SetOptions _ -> to_value (to_value_type set_options_rty_t) + | MkCases _ -> to_value (to_value_type mkcases_rty_t ) + | Quit _ -> to_value (to_value_type quit_rty_t ) + | Wait _ -> to_value (to_value_type wait_rty_t ) + | About _ -> to_value (to_value_type about_rty_t ) + | Init _ -> to_value (to_value_type init_rty_t ) + | Interp _ -> to_value (to_value_type interp_rty_t ) + | StopWorker _ -> to_value (to_value_type stop_worker_rty_t) + | PrintAst _ -> to_value (to_value_type print_ast_rty_t ) + | Annotate _ -> to_value (to_value_type annotate_rty_t ) + +let of_call : type a. a call -> xml = fun q -> + 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) + | Wait x -> mkCall (of_value_type wait_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" -> Unknown (Add (mkCallArg add_sty_t a)) + | "Edit_at" -> Unknown (Edit_at (mkCallArg edit_at_sty_t a)) + | "Query" -> Unknown (Query (mkCallArg query_sty_t a)) + | "Goal" -> Unknown (Goal (mkCallArg goals_sty_t a)) + | "Evars" -> Unknown (Evars (mkCallArg evars_sty_t a)) + | "Hints" -> Unknown (Hints (mkCallArg hints_sty_t a)) + | "Status" -> Unknown (Status (mkCallArg status_sty_t a)) + | "Search" -> Unknown (Search (mkCallArg search_sty_t a)) + | "GetOptions" -> Unknown (GetOptions (mkCallArg get_options_sty_t a)) + | "SetOptions" -> Unknown (SetOptions (mkCallArg set_options_sty_t a)) + | "MkCases" -> Unknown (MkCases (mkCallArg mkcases_sty_t a)) + | "Quit" -> Unknown (Quit (mkCallArg quit_sty_t a)) + | "Wait" -> Unknown (Wait (mkCallArg wait_sty_t a)) + | "About" -> Unknown (About (mkCallArg about_sty_t a)) + | "Init" -> Unknown (Init (mkCallArg init_sty_t a)) + | "Interp" -> Unknown (Interp (mkCallArg interp_sty_t a)) + | "StopWorker" -> Unknown (StopWorker (mkCallArg stop_worker_sty_t a)) + | "PrintAst" -> Unknown (PrintAst (mkCallArg print_ast_sty_t a)) + | "Annotate" -> Unknown (Annotate (mkCallArg annotate_sty_t a)) + | x -> raise (Marshal_error("call",PCData x))) + +(** Debug printing *) + +let pr_value_gen pr = function + | Good v -> "GOOD " ^ pr v + | Fail (id,None,str) -> "FAIL "^Stateid.to_string id^" ["^ Pp.string_of_ppcmds str ^ "]" + | Fail (id,Some(i,j),str) -> + "FAIL "^Stateid.to_string id^ + " ("^string_of_int i^","^string_of_int j^")["^Pp.string_of_ppcmds str^"]" +let pr_value v = pr_value_gen (fun _ -> "FIXME") v +let pr_full_value : type a. a call -> a value -> string = fun call value -> match call with + | Add _ -> pr_value_gen (print add_rty_t ) value + | Edit_at _ -> pr_value_gen (print edit_at_rty_t ) value + | Query _ -> pr_value_gen (print query_rty_t ) value + | Goal _ -> pr_value_gen (print goals_rty_t ) value + | Evars _ -> pr_value_gen (print evars_rty_t ) value + | Hints _ -> pr_value_gen (print hints_rty_t ) value + | Status _ -> pr_value_gen (print status_rty_t ) value + | Search _ -> pr_value_gen (print search_rty_t ) value + | GetOptions _ -> pr_value_gen (print get_options_rty_t) value + | SetOptions _ -> pr_value_gen (print set_options_rty_t) value + | MkCases _ -> pr_value_gen (print mkcases_rty_t ) value + | Quit _ -> pr_value_gen (print quit_rty_t ) value + | Wait _ -> pr_value_gen (print wait_rty_t ) value + | About _ -> pr_value_gen (print about_rty_t ) value + | Init _ -> pr_value_gen (print init_rty_t ) value + | Interp _ -> pr_value_gen (print interp_rty_t ) value + | StopWorker _ -> pr_value_gen (print stop_worker_rty_t) value + | PrintAst _ -> pr_value_gen (print print_ast_rty_t ) value + | Annotate _ -> pr_value_gen (print annotate_rty_t ) value +let pr_call : type a. a call -> string = fun 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 + | Wait x -> return wait_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), Pp.str "error message")))); + document_type_encoding to_string_fmt + +(* Moved from feedback.mli : This is IDE specific and we don't want to + pollute the core with it *) + +open Feedback + +let of_message_level = function + | Debug -> + Serialize.constructor "message_level" "debug" [] + | Info -> Serialize.constructor "message_level" "info" [] + | Notice -> Serialize.constructor "message_level" "notice" [] + | Warning -> Serialize.constructor "message_level" "warning" [] + | Error -> Serialize.constructor "message_level" "error" [] +let to_message_level = + Serialize.do_match "message_level" (fun s args -> match s with + | "debug" -> Debug + | "info" -> Info + | "notice" -> Notice + | "warning" -> Warning + | "error" -> Error + | x -> raise Serialize.(Marshal_error("error level",PCData x))) + +let of_message lvl loc msg = + let lvl = of_message_level lvl in + let xloc = of_option of_loc loc in + let content = of_pp msg in + Xml_datatype.Element ("message", [], [lvl; xloc; content]) + +let to_message xml = match xml with + | Xml_datatype.Element ("message", [], [lvl; xloc; content]) -> + Message(to_message_level lvl, to_option to_loc xloc, to_pp content) + | x -> raise (Marshal_error("message",x)) + +let to_feedback_content = do_match "feedback_content" (fun s a -> match s,a with + | "addedaxiom", _ -> AddedAxiom + | "processed", _ -> Processed + | "processingin", [where] -> ProcessingIn (to_string where) + | "incomplete", _ -> Incomplete + | "complete", _ -> Complete + | "globref", [loc; filepath; modpath; ident; ty] -> + GlobRef(to_loc loc, to_string filepath, + to_string modpath, to_string ident, to_string ty) + | "globdef", [loc; ident; secpath; ty] -> + GlobDef(to_loc loc, to_string ident, to_string secpath, to_string ty) + | "inprogress", [n] -> InProgress (to_int n) + | "workerstatus", [ns] -> + let n, s = to_pair to_string to_string ns in + WorkerStatus(n,s) + | "custom", [loc;name;x]-> Custom (to_option to_loc loc, to_string name, x) + | "filedependency", [from; dep] -> + FileDependency (to_option to_string from, to_string dep) + | "fileloaded", [dirpath; filename] -> + FileLoaded (to_string dirpath, to_string filename) + | "message", [x] -> to_message x + | x,l -> raise (Marshal_error("feedback_content",PCData (x ^ " with attributes " ^ string_of_int (List.length l))))) + +let of_feedback_content = function + | AddedAxiom -> constructor "feedback_content" "addedaxiom" [] + | Processed -> constructor "feedback_content" "processed" [] + | ProcessingIn where -> + constructor "feedback_content" "processingin" [of_string where] + | Incomplete -> constructor "feedback_content" "incomplete" [] + | Complete -> constructor "feedback_content" "complete" [] + | GlobRef(loc, filepath, modpath, ident, ty) -> + constructor "feedback_content" "globref" [ + of_loc loc; + of_string filepath; + of_string modpath; + of_string ident; + of_string ty ] + | GlobDef(loc, ident, secpath, ty) -> + constructor "feedback_content" "globdef" [ + of_loc loc; + of_string ident; + of_string secpath; + of_string ty ] + | InProgress n -> constructor "feedback_content" "inprogress" [of_int n] + | WorkerStatus(n,s) -> + constructor "feedback_content" "workerstatus" + [of_pair of_string of_string (n,s)] + | Custom (loc, name, x) -> + constructor "feedback_content" "custom" [of_option of_loc loc; of_string name; x] + | FileDependency (from, depends_on) -> + constructor "feedback_content" "filedependency" [ + of_option of_string from; + of_string depends_on] + | FileLoaded (dirpath, filename) -> + constructor "feedback_content" "fileloaded" [ + of_string dirpath; + of_string filename ] + | Message (l,loc,m) -> constructor "feedback_content" "message" [ of_message l loc m ] + +let of_edit_or_state_id id = ["object","state"], of_stateid id + +let of_feedback msg = + let content = of_feedback_content msg.contents in + let obj, id = of_edit_or_state_id msg.span_id in + let route = string_of_int msg.route in + Element ("feedback", obj @ ["route",route], [id;content]) + +let of_feedback msg_fmt = + msg_format := msg_fmt; of_feedback + +let to_feedback xml = match xml with + | Element ("feedback", ["object","state";"route",route], [id;content]) -> { + doc_id = 0; + span_id = to_stateid id; + route = int_of_string route; + contents = to_feedback_content content } + | x -> raise (Marshal_error("feedback",x)) + +let is_feedback = function + | Element ("feedback", _, _) -> true + | _ -> false + +(* vim: set foldmethod=marker: *) + diff --git a/ide/protocol/xmlprotocol.mli b/ide/protocol/xmlprotocol.mli new file mode 100644 index 0000000000..ba6000f0a0 --- /dev/null +++ b/ide/protocol/xmlprotocol.mli @@ -0,0 +1,73 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** * Applicative part of the interface of CoqIde calls to Coq *) + +open Interface +open Xml_datatype + +type 'a call + +type unknown_call = Unknown : 'a call -> unknown_call + +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 +(* internal use (fake_ide) only, do not use *) +val wait : wait_sty -> wait_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 + +(** By default, we still output messages in Richpp so we are + compatible with 8.6, however, 8.7 aware clients will want to + set this to Ppcmds *) +type msg_format = Richpp of int | Ppcmds + +(** * XML data marshalling *) + +val of_call : 'a call -> xml +val to_call : xml -> unknown_call + +val of_answer : msg_format -> '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 + +(** * Serializaiton of feedback *) +val of_feedback : msg_format -> Feedback.feedback -> xml +val to_feedback : xml -> Feedback.feedback + +val is_feedback : xml -> bool diff --git a/ide/sentence.ml b/ide/sentence.ml new file mode 100644 index 0000000000..2e508969aa --- /dev/null +++ b/ide/sentence.ml @@ -0,0 +1,129 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** {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.warning; + 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 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 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/sentence.mli b/ide/sentence.mli new file mode 100644 index 0000000000..75c815c508 --- /dev/null +++ b/ide/sentence.mli @@ -0,0 +1,21 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Retag the ends of sentences around an inserted zone *) + +val tag_on_insert : GText.buffer -> unit + +(** 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 0000000000..90412f53f0 --- /dev/null +++ b/ide/session.ml @@ -0,0 +1,551 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Preferences + +(** 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 + method data : 'a + 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_RoutedMessageViews.message_views_router; + 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 = GSourceView3.source_buffer + ~tag_table:Tags.Script.table + ~highlight_matching_brackets:true + ?language:(lang_manager#language source_language#get) + ?style_scheme:(style_manager#style_scheme source_style#get) + () + 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 ?(stop_emit=true) reason = + Minilib.log ("user_action cancelled: "^reason); + action_was_cancelled := true; + if stop_emit then 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 ~stop_emit:false "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 update_prev it = + let prev = buffer#get_iter_at_mark (`NAME "prev_insert") in + if it#offset < prev#offset then + buffer#move_mark (`NAME "prev_insert") ~where:it + 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 processed_sentence_just_before_error it = + let rec aux old it = + if it#is_start then None + else if it#has_tag Tags.Script.processed then Some old + else if it#has_tag Tags.Script.error_bg then aux it it#backward_char + else None 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 + let () = update_prev 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.incomplete then + cancel_signal "Altering the script being processed in not implemented" + 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 + match processed_sentence_just_before_error it with + | None -> () + | Some prev_sentence_end -> + 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); + let min_iter, max_iter = + if start#compare stop < 0 then start, stop else stop, start in + let () = update_prev min_iter 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.incomplete then + cancel_signal "Altering the script being processed in not implemented" + 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.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 + match processed_sentence_just_before_error min_iter with + | None -> () + | Some prev_sentence_end -> + 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 + List.iter (fun tag -> buffer#remove_tag tag ~start ~stop) + Tags.Script.ephemere; + 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 () = Ideutils.display_location ins 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 ?sort 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 () = data#set_headers_clickable true in +(* FIXME: handle this using CSS *) +(* let refresh clr = data#misc#modify_bg [`NORMAL, `NAME clr] in *) +(* let _ = background_color#connect#changed ~callback:refresh in *) +(* let _ = data#misc#connect#realize ~callback:(fun () -> refresh background_color#get) 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 + let make_sorting i (_, c) = + let sort (store : GTree.model) it1 it2 = match c with + | `IntC c -> + Pervasives.compare (store#get ~row:it1 ~column:c) (store#get ~row:it2 ~column:c) + | `StringC c -> + Pervasives.compare (store#get ~row:it1 ~column:c) (store#get ~row:it2 ~column:c) + in + store#set_sort_func i sort + in + CList.iteri make_sorting columns; + CList.iteri (fun i c -> c#set_sort_column_id i) cols; + List.iter (fun c -> ignore(data#append_column c)) cols; + ignore( + data#connect#row_activated ~callback:(fun tp vc -> cb columns store tp vc) + ); + let () = match sort with None -> () | Some (i, t) -> store#set_sort_column_id i t in + frame, (fun f -> f columns store) + +let create_errpage (script : Wg_ScriptView.script_view) : errpage = + let table, access = + make_table_widget ~sort:(0, `ASCENDING) + [`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; + script#misc#grab_focus (); + 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 ~row:line ~column:(find_int_col "Line" columns) lno; + store#set ~row:line ~column:(find_string_col "Error message" columns) msg)) + errs + end + method on_update ~callback:cb = callback := cb + method data = !last_update + end + +let create_jobpage coqtop coqops : jobpage = + let table, access = + make_table_widget ~sort:(0, `ASCENDING) + [`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 ~row:line ~column id; + store#set ~row:line ~column:(find_string_col "Job name" columns) job)) + jobs + end + method on_update ~callback:cb = callback := cb + method data = !last_update + 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 + Wg_RoutedMessageViews.message_views ~route_0: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 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 command = new Wg_Command.command_window basename coqtop cops messages 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#pack1 ~shrink:false) () 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#pack2 ~shrink:false) () 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 (); + detachable, 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; + let detach, _ = add_msg_page 0 sn.tab_label#text "Messages" sn.messages#default_route#coerce in + let _, label = add_msg_page 1 sn.tab_label#text "Errors" sn.errpage#coerce in + let _, _ = add_msg_page 2 sn.tab_label#text "Jobs" sn.jobpage#coerce in + (* When a message is received, focus on the message pane *) + let _ = + sn.messages#default_route#connect#pushed ~callback:(fun _ _ -> + let num = message_frame#page_num detach#coerce in + if 0 <= num then message_frame#goto_page num + ) + in + (* When an error occurs, paint the error label in red *) + 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 0000000000..bb38169001 --- /dev/null +++ b/ide/session.mli @@ -0,0 +1,53 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** 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 + method data : 'a + 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_RoutedMessageViews.message_views_router; + 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 new file mode 100644 index 0000000000..e9dbcb9e67 --- /dev/null +++ b/ide/tags.ml @@ -0,0 +1,50 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + + +let make_tag (tt:GText.tag_table) ~name prop = + let new_tag = GText.tag ~name () in + new_tag#set_properties prop; + tt#add new_tag#as_tag; + new_tag + +module Script = +struct + (* More recently defined tags have highest priority in case of overlapping *) + let table = GText.tag_table () + let warning = make_tag table ~name:"warning" [`UNDERLINE `SINGLE; `FOREGROUND "blue"] + let error = make_tag table ~name:"error" [`UNDERLINE `SINGLE] + let error_bg = make_tag table ~name:"error_bg" [] + let to_process = make_tag table ~name:"to_process" [] + let processed = make_tag table ~name:"processed" [] + let incomplete = make_tag table ~name:"incomplete" [] + let unjustified = make_tag table ~name:"unjustified" [`BACKGROUND "gold"] + let tooltip = make_tag table ~name:"tooltip" [] (* debug:`BACKGROUND "blue" *) + let ephemere = + [error; warning; error_bg; tooltip; processed; to_process; incomplete; unjustified] + let comment = make_tag table ~name:"comment" [] + let sentence = make_tag table ~name:"sentence" [] + let edit_zone = make_tag table ~name:"edit_zone" [`UNDERLINE `SINGLE] (* for debugging *) + let all = edit_zone :: comment :: sentence :: ephemere +end +module Proof = +struct + let table = GText.tag_table () + let highlight = make_tag table ~name:"highlight" [] + let hypothesis = make_tag table ~name:"hypothesis" [] + let goal = make_tag table ~name:"goal" [] +end +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 diff --git a/ide/tags.mli b/ide/tags.mli new file mode 100644 index 0000000000..1df934fddf --- /dev/null +++ b/ide/tags.mli @@ -0,0 +1,43 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +module Script : +sig + val table : GText.tag_table + val comment : GText.tag + val error : GText.tag + val warning : 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 sentence : GText.tag + val tooltip : GText.tag + val edit_zone : GText.tag (* for debugging *) + val ephemere : GText.tag list + val all : GText.tag list +end + +module Proof : +sig + val table : GText.tag_table + val highlight : GText.tag + val hypothesis : GText.tag + val goal : GText.tag +end + +module Message : +sig + val table : GText.tag_table + val error : GText.tag + val warning : GText.tag + val item : GText.tag +end diff --git a/ide/unicode_bindings.ml b/ide/unicode_bindings.ml new file mode 100644 index 0000000000..e2f98302ea --- /dev/null +++ b/ide/unicode_bindings.ml @@ -0,0 +1,131 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + + +let all_bindings = ref [] + (* example unicode bindings table: + [ ("\\pi", "π", None); + ("\\lambdas", "λs", Some 4); + ("\\lambda", "λ", Some 3); + ("\\lake", "0", Some 2); + ("\\lemma", "Lemma foo : x. Proof. Qed", Some 1); ] *) + +(** Auxiliary function used by [load_files]. + Takes as argument a valid path. *) + +let process_file filename = + if not (Sys.file_exists filename) then begin + Ideutils.warning (Printf.sprintf "Warning: unicode bindings file '%s' was not found." filename) + end else begin + let ch = open_in filename in + begin try while true do + let line = input_line ch in + begin try + let chline = Scanf.Scanning.from_string line in + let (key,value) = + Scanf.bscanf chline "%s %s" (fun x y -> (x,y)) in + let prio = + try Scanf.bscanf chline " %d" (fun x -> Some x) + with Scanf.Scan_failure _ | Failure _ | End_of_file -> None + in + all_bindings := (key,value,prio)::!all_bindings; + (* Note: storing bindings in reverse order, flipping is done later *) + Scanf.Scanning.close_in chline; + with End_of_file -> () end; + done with End_of_file -> () end; + close_in ch + end + +let load_files filenames = + let selected_filenames = ref [] in + let add f = + selected_filenames := f::!selected_filenames in + let warn_default_not_found () = + Ideutils.warning (Printf.sprintf + "Warning: the file 'ide/default.bindings' was not found in %s." + (Envars.coqlib())) in + let warn_local_not_found () = + Ideutils.warning (Printf.sprintf + "Warning: the local configuration file 'coqide.bindings' was not found.") in + if filenames = [] then begin + (* If no argument is provided using [-unicode-bindings], + then use the default file and the local file, if it exists *) + begin match Preferences.get_unicode_bindings_default_file() with + | Some f -> add f + | None -> warn_default_not_found() + end; + begin match Preferences.get_unicode_bindings_local_file() with + | Some f -> add f + | None -> () + end; + end else begin + (* If [-unicode-bindings] is used with a list of file, consider + these files in order, with a special treatment for the tokens + "default" and "local", which are replaced by the appropriate path. *) + let add_arg f = + match f with + | "default" -> + begin match Preferences.get_unicode_bindings_default_file() with + | Some f -> add f + | None -> warn_default_not_found() + end + | "local" -> + begin match Preferences.get_unicode_bindings_local_file() with + | Some f -> add f + | None -> warn_local_not_found() + end + | _ -> add f + in + List.iter add_arg filenames + end; + (* Files must be processed in order, to build the list of bindings + by iteratively consing entry to its head, the list being reversed + at the very end *) + let real_filenames = List.rev !selected_filenames in + List.iter process_file real_filenames; + all_bindings := List.rev !all_bindings + (* For debugging the list of unicode files loaded: + List.iter (fun f -> Printf.eprintf "%s\n" f) real_filenames; *) + +(** Auxiliary function to test whether [s] is a prefix of [str]; + Note that there might be overlap with wg_Completion::is_substring *) + +let string_is_prefix s str = + let n = String.length s in + let m = String.length str in + if m < n + then false + else (s = String.sub str 0 n) + +let lookup prefix = + let max_priority = 100000000 in + let cur_word = ref None in + let cur_prio = ref (max_priority+1) in + let test_binding (key, word, prio_opt) = + let prio = + match prio_opt with + | None -> max_priority + | Some p -> p + in + if string_is_prefix prefix key && prio < !cur_prio then begin + cur_word := Some word; + cur_prio := prio; + end in + List.iter test_binding !all_bindings; + !cur_word + + +(* For debugging the list of unicode bindings loaded: + let print_unicode_bindings () = + List.iter (fun (x,y,p) -> + Printf.eprintf "%s %s %d\n" x y (match p with None -> -1 | Some n -> n)) + !all_bindings; + prerr_newline() +*) diff --git a/ide/unicode_bindings.mli b/ide/unicode_bindings.mli new file mode 100644 index 0000000000..5b38eeb920 --- /dev/null +++ b/ide/unicode_bindings.mli @@ -0,0 +1,48 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + + +(** Latex to unicode bindings. + See also the documentation in doc/sphinx/practical-tools/coqide.rst. + + Text description of the unicode bindings, in a file with one item per line, + each item consists of: + - a leading backslahs + - a ascii word next to it + - a unicode word (or possibly a full sentence in-between doube-quotes, + the sentence may include spaces and \n tokens), + - optionally, an integer indicating the "priority" (lower is higher priority), + technically the length of the prefix that suffices to obtain this word. + Ex. if "\lambda" has priority 3, then "\lam" always decodes as "\lambda". + + \pi π + \lambda λ 3 + \lambdas λs 4 + \lake Ο 2 + \lemma "Lemma foo : x. Proof. Qed." 1 ---currently not supported by the parser + + - In case of equality between two candidates (same ascii word, or same + priorities for two words with similar prefix), the first binding is considered. + + - Note that if a same token is bound in several bindings file, + the one with the lowest priority number will be considered. + In case of same priority, the binding from the first file loaded + is considered. +*) + + +(** [load_files] takes a list of filenames and load them as binding files. + Filenames may include "default" and "local" as items. *) + +val load_files : string list -> unit + +(** [lookup] takes a prefix and returns the corresponding unicode value *) + +val lookup : string -> string option diff --git a/ide/utf8_convert.mli b/ide/utf8_convert.mli new file mode 100644 index 0000000000..9b3db5fdd9 --- /dev/null +++ b/ide/utf8_convert.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val f : string -> string diff --git a/ide/utf8_convert.mll b/ide/utf8_convert.mll new file mode 100644 index 0000000000..6e36ae1c8a --- /dev/null +++ b/ide/utf8_convert.mll @@ -0,0 +1,51 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +{ + open Lexing + let b = Buffer.create 127 + +} + +(* Replace all occurrences of \x{iiii} and \x{iiiiiiii} by UTF-8 valid chars *) + +let digit = ['0'-'9''A'-'Z''a'-'z'] +let short = digit digit digit digit +let long = short short + +rule entry = parse + | "\\x{" (short | long ) '}' + { let s = lexeme lexbuf in + let n = String.length s in + let code = + try Glib.Utf8.from_unichar + (int_of_string ("0x"^(String.sub s 3 (n - 4)))) + with _ -> s + in + let c = if Glib.Utf8.validate code then code else s in + Buffer.add_string b c; + entry lexbuf + } + | _ + { let s = lexeme lexbuf in + Buffer.add_string b s; + entry lexbuf} + | eof + { + let s = Buffer.contents b in Buffer.reset b ; s + } + + +{ + let f s = + let lb = from_string s in + Buffer.reset b; + entry lb +} diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml new file mode 100644 index 0000000000..2cadd7ffbf --- /dev/null +++ b/ide/wg_Command.ml @@ -0,0 +1,183 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Preferences + +class command_window name coqtop coqops router = + 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 + + let route_id = + let r = ref 0 in + fun () -> incr r; !r in + +object(self) + val frame = frame + + val notebook = notebook + + (* We need access to coqops in order to place queries in the proper + document stint. This should remove access from this module to the + low-level Coq one. *) + val coqops = coqops + + 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 route_id = route_id () in + 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 () -> + router#delete_route route_id; + 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 = Wg_MessageView.message_view () in + router#register_route route_id result; + r_bin#add_with_viewport (result :> GObj.widget); + views <- (frame#coerce, result, combo#entry) :: views; +(* FIXME: handle this using CSS *) +(* let cb clr = result#misc#modify_bg [`NORMAL, `NAME clr] in *) +(* let _ = background_color#connect#changed ~callback:cb in *) +(* let _ = result#misc#connect#realize ~callback:(fun () -> cb background_color#get) in *) + let cb ft = result#misc#modify_font (GPango.font_description_from_string ft) in + stick text_font result cb; + result#misc#set_can_focus true; (* false causes problems for selection *) + 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 process = + let next = function + | Interface.Fail (_, _, err) -> + let err = Ideutils.validate err in + result#set err; + notebook#set_page ~tab_label:(new_tab_lbl "Error") frame#coerce; + Coq.return () + | Interface.Good () -> + notebook#set_page ~tab_label:(new_tab_lbl arg) frame#coerce; + Coq.return () + in + coqops#raw_coq_query ~route_id ~next phrase + in + result#set (Pp.str ("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 + match List.find (fun (p,_,_) -> p#get_oid == cur_page#get_oid) views with + | (_, _, e) -> e#misc#grab_focus () + | exception Not_found -> () + + method hide = + frame#hide + + method visible = + frame#visible + + method private refresh_color clr = + let clr = Gdk.Color.color_parse clr in + let iter (_,view,_) = view#misc#modify_bg [`NORMAL, `COLOR clr] in + List.iter iter views + + initializer + self#new_page_maker; + self#new_query_aux ~grab_now:false (); + frame#misc#hide (); +(* FIXME: handle this using CSS *) +(* let _ = background_color#connect#changed ~callback:self#refresh_color in *) +(* self#refresh_color background_color#get; *) + 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/wg_Command.mli b/ide/wg_Command.mli new file mode 100644 index 0000000000..1e0eb675c6 --- /dev/null +++ b/ide/wg_Command.mli @@ -0,0 +1,18 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +class command_window : string -> Coq.coqtop -> CoqOps.coqops -> Wg_RoutedMessageViews.message_views_router -> + object + method new_query : ?command:string -> ?term:string -> unit -> unit + method pack_in : (GObj.widget -> 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 0000000000..c39d6d0563 --- /dev/null +++ b/ide/wg_Completion.ml @@ -0,0 +1,455 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +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 + 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 ~row: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 = Pango.Font.from_string Preferences.text_font#get 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 ~tag:`WIDGET ~x:0 ~y: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 ~width:1 ~height:1 + + method private start_callback off = + let (x, y, w, h) = self#coordinates (`OFFSET off) in + let () = obj#move ~x ~y:(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 ~callback: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 ~callback:self#start_callback in + let _ = model#connect#update_completion ~callback:self#update_callback in + let _ = model#connect#end_completion ~callback:self#end_callback in + (* Popup interaction *) + let _ = view#event#connect#key_press ~callback:key_cb in + (* Hiding the popup when necessary*) + let _ = view#misc#connect#hide ~callback:obj#misc#hide in + let _ = view#event#connect#button_press ~callback:(fun _ -> self#hide (); false) in + let _ = view#connect#move_cursor ~callback:move_cb in + let _ = view#event#connect#focus_out ~callback:(fun _ -> self#hide (); false) in + () + +end diff --git a/ide/wg_Completion.mli b/ide/wg_Completion.mli new file mode 100644 index 0000000000..aa2f36a5d8 --- /dev/null +++ b/ide/wg_Completion.mli @@ -0,0 +1,36 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +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 0000000000..755a42eadd --- /dev/null +++ b/ide/wg_Detachable.ml @@ -0,0 +1,94 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +class type detachable_signals = + object + inherit GContainer.container_signals + method attached : callback:(GObj.widget -> unit) -> unit + method detached : callback:(GObj.widget -> unit) -> unit + end + +(* Cannot do a local warning in 4.05.0, fixme when we use a newer + OCaml to avoid the warning in the method itself. *) +[@@@ocaml.warning "-7"] +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 ~type_hint:`DIALOG () + 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 0000000000..9588cf18fa --- /dev/null +++ b/ide/wg_Detachable.mli @@ -0,0 +1,44 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +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 0000000000..fe079e8a9e --- /dev/null +++ b/ide/wg_Find.ml @@ -0,0 +1,246 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +let b2c = Ideutils.byte_offset_to_char_offset + +class finder name (view : GText.view) = + + let widget = Wg_Detachable.detachable + ~title:(Printf.sprintf "Find & Replace (%s)" name) () in + let replace_box = GPack.grid (* ~columns:4 ~rows:2 *) ~col_homogeneous:false ~row_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#begin_user_action () in + let _ = view#buffer#delete_selection () in + let _ = view#buffer#insert_interactive (self#replacement txt) in + let () = view#buffer#end_user_action () 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 + let offs = (String.length text - 1) in + if offs < 0 then None + else try + let i = Str.search_backward regexp text offs in + let j = Str.match_end () in + Some(view#buffer#start_iter#forward_chars (b2c text i), + view#buffer#start_iter#forward_chars (b2c text 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 (b2c text i), starti#forward_chars (b2c text j)) + with Not_found -> None + + method replace_all () = + let rec replace_at (iter : GText.iter) ct tot = + let found = self#forward_search iter in + match found with + | None -> + let tot_str = if Int.equal ct tot then "" else " of " ^ string_of_int tot in + let occ_str = CString.plural tot "occurrence" in + let _ = Ideutils.flash_info ("Replaced " ^ string_of_int ct ^ tot_str ^ " " ^ occ_str) in + () + | 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 mod_save = view#buffer#modified in + let _ = view#buffer#set_modified false 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 edited = view#buffer#modified in + let _ = view#buffer#set_modified (edited || mod_save) 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 + let next_ct = if edited then ct + 1 else ct in + replace_at next next_ct (tot + 1) + in + let () = view#buffer#begin_user_action () in + let () = replace_at view#buffer#start_iter 0 0 in + view#buffer#end_user_action () + + method private set_not_found () = + find_entry#misc#modify_bg [`NORMAL, `NAME "#F7E6E6"]; + + method private set_found () = + find_entry#misc#modify_bg [`NORMAL, `NAME "#BAF9CE"] + + method private set_normal () = + find_entry#misc#modify_bg [`NORMAL, `NAME "white"] + + method private find_from backward ?(wrapped=false) (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 ~wrapped:true view#buffer#start_iter + else if backward && not (starti#equal view#buffer#end_iter) then + self#find_from backward ~wrapped:true view#buffer#end_iter + else + let _ = Ideutils.flash_info "String not found" in + self#set_not_found () + | Some (start, stop) -> + let text = view#buffer#start_iter#get_text ~stop:view#buffer#end_iter in + let rec find_all offs accum = + if offs > String.length text then + List.rev accum + else try + let i = Str.search_forward self#regex text offs in + let j = Str.match_end () in + find_all (j + 1) (i :: accum) + with Not_found -> List.rev accum + in + let occurs = find_all 0 [] in + let num_occurs = List.length occurs in + (* assoc table of offset, occurrence index pairs *) + let occur_tbl = List.mapi (fun ndx occ -> (occ,ndx+1)) occurs in + 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 + let _ = + try + let occ_ndx = List.assoc start#offset occur_tbl in + let occ_str = CString.plural num_occurs "occurrence" in + let wrap_str = if wrapped then + if backward then " (wrapped backwards)" + else " (wrapped)" + else "" + in + Ideutils.flash_info + (string_of_int occ_ndx ^ " of " ^ string_of_int num_occurs ^ + " " ^ occ_str ^ wrap_str) + with Not_found -> + CErrors.anomaly (Pp.str "Occurrence of Find string not in table") + 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 ~callback:find_cb in + let _ = replace_entry#event#connect#key_press ~callback: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 ~callback:view_cb in + () + + end diff --git a/ide/wg_Find.mli b/ide/wg_Find.mli new file mode 100644 index 0000000000..b4c1a40ead --- /dev/null +++ b/ide/wg_Find.mli @@ -0,0 +1,20 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +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 0000000000..53e004c4e3 --- /dev/null +++ b/ide/wg_MessageView.ml @@ -0,0 +1,136 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Preferences + +class type message_view_signals = +object + inherit GObj.misc_signals + inherit GUtil.add_ml_signals + method pushed : callback:Ideutils.logger -> GtkSignal.id +end + +class message_view_signals_impl obj (pushed : 'a GUtil.signal) : message_view_signals = +object + val after = false + inherit GObj.misc_signals obj + inherit GUtil.add_ml_signals obj [pushed#disconnect] + method pushed ~callback = pushed#connect ~after ~callback:(fun (lvl, s) -> callback lvl s) +end + +class type message_view = + object + inherit GObj.widget + method connect : message_view_signals + method clear : unit + method add : Pp.t -> unit + method add_string : string -> unit + method set : Pp.t -> unit + method refresh : bool -> unit + method push : Ideutils.logger + (** same as [add], but with an explicit level instead of [Notice] *) + + method has_selection : bool + method get_selected_text : string + end + +let message_view () : message_view = + let buffer = GSourceView3.source_buffer + ~highlight_matching_brackets:true + ~tag_table:Tags.Message.table () + in + let mark = buffer#create_mark ~left_gravity:false buffer#start_iter in + let box = GPack.vbox () in + let scroll = GBin.scrolled_window + ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:(box#pack ~expand:true) () in + let view = GSourceView3.source_view + ~source_buffer:buffer ~packing:scroll#add + ~editable:false ~cursor_visible:false ~wrap_mode:`WORD () + in + let () = Gtk_parsing.fix_double_click view 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 + view#misc#show (); +(* FIXME: handle this using CSS *) +(* let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] in *) +(* let _ = background_color#connect#changed ~callback:cb in *) +(* let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in *) + let cb ft = view#misc#modify_font (GPango.font_description_from_string ft) in + stick text_font view cb; + + (* Inserts at point, advances the mark *) + let insert_msg (level, msg) = + let tags = match level with + | Feedback.Error -> [Tags.Message.error] + | Feedback.Warning -> [Tags.Message.warning] + | _ -> [] + in + let mark = `MARK mark in + let width = Ideutils.textview_width view in + Ideutils.insert_xml ~mark buffer ~tags (Richpp.richpp_of_pp width msg); + buffer#insert ~iter:(buffer#get_iter_at_mark mark) "\n" + in + + let mv = object (self) + inherit GObj.widget box#as_widget + + (* List of displayed messages *) + val mutable last_width = -1 + val mutable msgs = [] + + val push = new GUtil.signal () + + method connect = + new message_view_signals_impl box#as_widget push + + method refresh force = + (* We need to block updates here due to the following race: + insertion of messages may create a vertical scrollbar, this + will trigger a width change, calling refresh again and + going into an infinite loop. *) + let width = Ideutils.textview_width view in + (* Could still this method race if the scrollbar changes the + textview_width ?? *) + let needed = force || last_width <> width in + if needed then begin + last_width <- width; + buffer#set_text ""; + buffer#move_mark (`MARK mark) ~where:buffer#start_iter; + List.(iter insert_msg (rev msgs)) + end + + method clear = + msgs <- []; self#refresh true + + method push level msg = + msgs <- (level, msg) :: msgs; + insert_msg (level, msg); + push#call (level, msg) + + method add msg = self#push Feedback.Notice msg + + method add_string s = self#add (Pp.str s) + + method set msg = self#clear; self#add msg + + method has_selection = buffer#has_selection + method get_selected_text = + if buffer#has_selection then + let start, stop = buffer#selection_bounds in + buffer#get_text ~slice:true ~start ~stop () + else "" + + end + in + (* Is there a better way to connect the signal ? *) + let w_cb (_ : Gtk.rectangle) = mv#refresh false in + ignore (view#misc#connect#size_allocate ~callback:w_cb); + mv diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli new file mode 100644 index 0000000000..613f1b4190 --- /dev/null +++ b/ide/wg_MessageView.mli @@ -0,0 +1,34 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +class type message_view_signals = +object + inherit GObj.misc_signals + inherit GUtil.add_ml_signals + method pushed : callback:Ideutils.logger -> GtkSignal.id +end + +class type message_view = + object + inherit GObj.widget + method connect : message_view_signals + method clear : unit + method add : Pp.t -> unit + method add_string : string -> unit + method set : Pp.t -> unit + method refresh : bool -> unit + method push : Ideutils.logger + (** same as [add], but with an explicit level instead of [Notice] *) + + method has_selection : bool + method get_selected_text : string + end + +val message_view : unit -> message_view diff --git a/ide/wg_Notebook.ml b/ide/wg_Notebook.ml new file mode 100644 index 0000000000..424979d846 --- /dev/null +++ b/ide/wg_Notebook.ml @@ -0,0 +1,69 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +class ['a] typed_notebook make_page kill_page nb = +object(self) + inherit GPack.notebook nb as super + val mutable term_list = [] + + method append_term (term:'a) = + let tab_label,menu_label,page = make_page term in + (* 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 = 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 = Util.List.chop real_pos term_list in + term_list <- lower@[term]@higher; + real_pos + *) + method prepend_term (term:'a) = + let tab_label,menu_label,page = make_page term in + (* 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 = 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 <- 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 f p = + Util.List.index0 f p term_list + + method pages = term_list + + method! remove_page index = + 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 = + List.nth term_list super#current_page +end + +let create make kill = + GtkPack.Notebook.make_params [] + ~cont:(GContainer.pack_container + ~create:(fun pl -> + let nb = GtkPack.Notebook.create pl in + (new typed_notebook make kill nb))) + diff --git a/ide/wg_Notebook.mli b/ide/wg_Notebook.mli new file mode 100644 index 0000000000..9447b21c0b --- /dev/null +++ b/ide/wg_Notebook.mli @@ -0,0 +1,39 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +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 -> + ?group_name:string -> + ?scrollable:bool -> + ?show_border:bool -> + ?show_tabs:bool -> + ?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/wg_ProofView.ml b/ide/wg_ProofView.ml new file mode 100644 index 0000000000..7bf73b5ebe --- /dev/null +++ b/ide/wg_ProofView.ml @@ -0,0 +1,248 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Preferences +open Ideutils + +class type proof_view = + object + inherit GObj.widget + method buffer : GText.buffer + method refresh : force:bool -> unit + method clear : unit -> unit + method set_goals : Interface.goals option -> unit + method set_evars : Interface.evar list option -> unit + 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 + * there + * * is a selection o said menu, hover_cb is the callback when there is only + * * hovering *) +let hook_tag_cb tag menu_content sel_cb hover_cb = + ignore (tag#connect#event ~callback: + (fun ~origin evt it -> + let iter = new GText.iter it in + let start = iter#backward_to_tag_toggle (Some tag) in + let stop = iter#forward_to_tag_toggle (Some tag) in + match GdkEvent.get_type evt with + | `BUTTON_PRESS -> + let ev = GdkEvent.Button.cast evt in + if (GdkEvent.Button.button ev) <> 3 then false else begin + let ctxt_menu = GMenu.menu () in + let factory = new GMenu.factory ctxt_menu in + List.iter + (fun (text,cmd) -> ignore (factory#add_item text ~callback:(sel_cb cmd))) + menu_content; + ctxt_menu#popup ~button:3 ~time:(GdkEvent.Button.time ev); + true + end + | `MOTION_NOTIFY -> + hover_cb start stop; false + | _ -> false)) + +let mode_tactic sel_cb (proof : #GText.view_skel) goals ~unfoc_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 = + proof#buffer#remove_tag + ~start:proof#buffer#start_iter + ~stop:sel_start + Tags.Proof.highlight; + proof#buffer#remove_tag + ~start:sel_stop + ~stop:proof#buffer#end_iter + Tags.Proof.highlight; + proof#buffer#apply_tag ~start:sel_start ~stop:sel_stop Tags.Proof.highlight + 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 "s" else "") + in + let goal_str ?(shownum=false) index total = + if shownum then Printf.sprintf + "______________________________________(%d/%d)\n" index total + else Printf.sprintf + "______________________________________\n" + in + (* Insert current goal and its hypotheses *) + let hyps_hints, goal_hints = match hints with + | None -> [], [] + | Some (hl, h) -> (hl, h) + in + let width = Ideutils.textview_width proof in + let rec insert_hyp hints hs = match hs with + | [] -> () + | hyp :: hs -> + let tags, rem_hints = match hints with + | [] -> [], [] + | hint :: hints -> + let tag = proof#buffer#create_tag [] in + let () = hook_tag_cb tag hint sel_cb on_hover in + [tag], hints + in + let () = insert_xml ~tags proof#buffer (Richpp.richpp_of_pp width hyp) in + proof#buffer#insert "\n"; + insert_hyp rem_hints hs + in + let () = proof#buffer#insert head_str in + let () = insert_hyp hyps_hints hyps in + let () = + let _ = if goal_hints <> [] then + let tag = proof#buffer#create_tag [] in + let () = hook_tag_cb tag goal_hints sel_cb on_hover in + [tag] + else [] + in + proof#buffer#insert (goal_str ~shownum:true 1 goals_cnt); + insert_xml ~tags:[Tags.Proof.goal] proof#buffer (Richpp.richpp_of_pp width cur_goal); + proof#buffer#insert "\n" + in + (* Insert remaining goals (no hypotheses) *) + let fold_goal ?(shownum=false) i _ { Interface.goal_ccl = g } = + proof#buffer#insert (goal_str ~shownum i goals_cnt); + insert_xml proof#buffer (Richpp.richpp_of_pp width g); + proof#buffer#insert "\n" + in + let () = Util.List.fold_left_i (fold_goal ~shownum:true) 2 () rem_goals in + (* show unfocused goal if option set *) + (* Insert remaining goals (no hypotheses) *) + if Coq.PrintOpt.printing_unfocused () then + begin + ignore(proof#buffer#place_cursor ~where:(proof#buffer#end_iter)); + let unfoc = List.flatten (List.rev (List.map (fun (x,y) -> x@y) unfoc_goals)) in + if unfoc<>[] then + begin + proof#buffer#insert "\nUnfocused Goals:\n"; + Util.List.fold_left_i (fold_goal ~shownum:false) 0 () unfoc + end + end; + ignore(proof#buffer#place_cursor + ~where:(proof#buffer#end_iter#backward_to_tag_toggle + (Some Tags.Proof.goal))); + ignore(proof#scroll_to_mark `INSERT) + +let rec flatten = function +| [] -> [] +| (lg, rg) :: l -> + let inner = flatten l in + List.rev_append lg inner @ rg + +let display mode (view : #GText.view_skel) goals hints evars = + let () = view#buffer#set_text "" in + let width = Ideutils.textview_width view in + match goals with + | None -> () + (* No proof in progress *) + | 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, 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 there are non-instantiated existential variables:\n\n"; + let iter evar = + let msg = Printf.sprintf "%s\n" evar.Interface.evar_info in + view#buffer#insert msg + in + List.iter iter evars; + view#buffer#insert "\nYou can use Grab Existential Variables." + | [], [], _, _ -> + (* The proof is finished, with the exception of given up goals. *) + view#buffer#insert "No more subgoals, but there are some goals you gave up:\n\n"; + let iter goal = + insert_xml view#buffer (Richpp.richpp_of_pp width goal.Interface.goal_ccl); + view#buffer#insert "\n" + in + List.iter iter given_up_goals; + view#buffer#insert "\nYou need to go back and solve them." + | [], _, _, _ -> + (* 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 = + insert_xml view#buffer (Richpp.richpp_of_pp width goal.Interface.goal_ccl); + view#buffer#insert "\n" + in + List.iter iter shelved_goals + | _, _, _, _ -> + (* No foreground proofs, but still unfocused ones *) + let total = List.length bg in + let goal_str index = Printf.sprintf + "______________________________________(%d/%d)\n" index total + in + view#buffer#insert "This subproof is complete, but there are some unfocused goals:\n\n"; + let iter i goal = + let () = view#buffer#insert (goal_str (succ i)) in + insert_xml view#buffer (Richpp.richpp_of_pp width goal.Interface.goal_ccl); + view#buffer#insert "\n" + in + List.iteri iter bg + end + | Some { Interface.fg_goals = fg; bg_goals = bg } -> + mode view fg ~unfoc_goals:bg hints + + +let proof_view () = + let buffer = GSourceView3.source_buffer + ~highlight_matching_brackets:true + ~tag_table:Tags.Proof.table () + in + let text_buffer = new GText.buffer buffer#as_buffer in + let view = GSourceView3.source_view + ~source_buffer:buffer ~editable:false ~wrap_mode:`WORD () + in + let () = Gtk_parsing.fix_double_click view in + let default_clipboard = GData.clipboard Gdk.Atom.primary in + let _ = buffer#add_selection_clipboard default_clipboard in +(* FIXME: handle this using CSS *) +(* let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] in *) +(* let _ = background_color#connect#changed ~callback:cb in *) +(* let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in *) + let cb ft = view#misc#modify_font (GPango.font_description_from_string ft) in + stick text_font view cb; + + let pf = object + inherit GObj.widget view#as_widget + val mutable goals = None + val mutable evars = None + val mutable last_width = -1 + + method buffer = text_buffer + + method clear () = buffer#set_text "" + + method set_goals gls = goals <- gls + + method set_evars evs = evars <- evs + + method refresh ~force = + (* We need to block updates here due to the following race: + insertion of messages may create a vertical scrollbar, this + will trigger a width change, calling refresh again and + going into an infinite loop. *) + let width = Ideutils.textview_width view in + (* Could still this method race if the scrollbar changes the + textview_width ?? *) + let needed = force || last_width <> width in + if needed then begin + last_width <- width; + let dummy _ () = () in + display (mode_tactic dummy) view goals None evars + end + end + in + (* Is there a better way to connect the signal ? *) + (* Can this be done in the object constructor? *) + let w_cb _ = pf#refresh ~force:false in + ignore (view#misc#connect#size_allocate ~callback:w_cb); + pf diff --git a/ide/wg_ProofView.mli b/ide/wg_ProofView.mli new file mode 100644 index 0000000000..922f5a69e0 --- /dev/null +++ b/ide/wg_ProofView.mli @@ -0,0 +1,21 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +class type proof_view = + object + inherit GObj.widget + method buffer : GText.buffer + method refresh : force:bool -> unit + method clear : unit -> unit + method set_goals : Interface.goals option -> unit + method set_evars : Interface.evar list option -> unit + end + +val proof_view : unit -> proof_view diff --git a/ide/wg_RoutedMessageViews.ml b/ide/wg_RoutedMessageViews.ml new file mode 100644 index 0000000000..4bd3035244 --- /dev/null +++ b/ide/wg_RoutedMessageViews.ml @@ -0,0 +1,47 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +class type message_views_router = object + method route : int -> Wg_MessageView.message_view + method default_route : Wg_MessageView.message_view + + method has_selection : bool + method get_selected_text : string + + method register_route : int -> Wg_MessageView.message_view -> unit + method delete_route : int -> unit +end + +let message_views ~route_0 : message_views_router = + let route_table = Hashtbl.create 17 in + let () = Hashtbl.add route_table 0 route_0 in +object + method route i = + try Hashtbl.find route_table i + with Not_found -> + (* at least the message will be printed somewhere*) + Hashtbl.find route_table 0 + + method default_route = route_0 + + method register_route i mv = Hashtbl.add route_table i mv + + method delete_route i = Hashtbl.remove route_table i + + method has_selection = + Hashtbl.fold (fun _ v -> (||) v#has_selection) route_table false + + method get_selected_text = + Option.default "" + (Hashtbl.fold (fun _ v acc -> + if v#has_selection then Some v#get_selected_text else acc) + route_table None) + +end diff --git a/ide/wg_RoutedMessageViews.mli b/ide/wg_RoutedMessageViews.mli new file mode 100644 index 0000000000..cca43d55ba --- /dev/null +++ b/ide/wg_RoutedMessageViews.mli @@ -0,0 +1,23 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +class type message_views_router = object + method route : int -> Wg_MessageView.message_view + method default_route : Wg_MessageView.message_view + + method has_selection : bool + method get_selected_text : string + + method register_route : int -> Wg_MessageView.message_view -> unit + method delete_route : int -> unit +end + +val message_views : + route_0:Wg_MessageView.message_view -> message_views_router diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml new file mode 100644 index 0000000000..c1ed9b7506 --- /dev/null +++ b/ide/wg_ScriptView.ml @@ -0,0 +1,553 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Preferences + +exception Abort + +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 occurred, `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 begin fun () -> + buffer#begin_user_action (); + self#perform_undo (); + buffer#end_user_action () + end () + + method redo () = + Minilib.log "REDO"; + self#with_lock_undo begin fun () -> + buffer#begin_user_action (); + self#perform_redo (); + buffer#end_user_action () + end () + + 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 GSourceView3.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 GSourceView3.source_view (Gobject.unsafe_cast tv) + + 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 apply_unicode_binding () = + (* Auxiliary method to reach the beginning of line or the + nearest space before the iterator. *) + let rec get_line_start iter = + if iter#starts_line || Glib.Unichar.isspace iter#char then iter + else get_line_start iter#backward_char + in + (* Main action *) + let buffer = self#buffer in + let insert = buffer#get_iter `INSERT in + let insert_mark = buffer#create_mark ~left_gravity:false insert in + let () = buffer#begin_user_action () in + let word_to_insert = + try + let line_start = get_line_start insert in + let prev_backslash_search = insert#backward_search ~limit:line_start "\\" in + let backslash = + match prev_backslash_search with + | None -> raise Abort + | Some (backslash_start,backslash_stop) -> backslash_start + in + let prefix = backslash#get_text ~stop:insert in + let word = + match Unicode_bindings.lookup prefix with + | None -> raise Abort + | Some word -> word + in + let was_deleted = buffer#delete_interactive ~start:backslash ~stop:insert () in + if not was_deleted then raise Abort; + word + with Abort -> " " + (* Insert a space if no binding applies. This is to make sure that the user + gets some visual feedback that the keystroke was taken into account. + And also avoid slowing down users who press "Shift" for capitalizing the + first letter of a sentence just before typing the "Space" that comes in + front of that first letter. *) + in + let insert2 = buffer#get_iter_at_mark (`MARK insert_mark) in + let _was_inserted = buffer#insert_interactive ~iter:insert2 word_to_insert in + let () = self#buffer#end_user_action () in + self#buffer#delete_mark (`MARK insert_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 () = Gtk_parsing.fix_double_click self in + 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 + (* Plug on preferences *) +(* FIXME: handle this using CSS *) +(* let cb clr = self#misc#modify_bg [`NORMAL, `NAME clr] in *) +(* let _ = background_color#connect#changed ~callback:cb in *) +(* let _ = self#misc#connect#realize ~callback:(fun () -> cb background_color#get) in *) + + let cb b = self#set_wrap_mode (if b then `WORD else `NONE) in + stick dynamic_word_wrap self cb; + stick show_line_number self self#set_show_line_numbers; + stick auto_indent self self#set_auto_indent; + stick highlight_current_line self self#set_highlight_current_line; + + (* Hack to handle missing binding in lablgtk *) + let cb b = + let flag = if b then 0b1001011 (* SPACE, TAB, NBSP, TRAILING *) else 0 in + let conv = Gobject.({ name = "draw-spaces"; conv = Data.int }) in + Gobject.set conv self#as_widget flag + in + stick show_spaces self cb; + + stick show_right_margin self self#set_show_right_margin; + stick spaces_instead_of_tabs self self#set_insert_spaces_instead_of_tabs; + stick tab_length self self#set_tab_width; + stick auto_complete self self#set_auto_complete; + + let cb ft = self#misc#modify_font (GPango.font_description_from_string ft) in + stick text_font self cb; + + () + +end + +let script_view ct ?(source_buffer:GSourceView3.source_buffer option) ?draw_spaces = + GtkSourceView3.SourceView.make_params [] ~cont:( + GtkText.View.make_params ~cont:( + GContainer.pack_container ~create: + (fun pl -> + let w = match source_buffer with + | None -> GtkSourceView3.SourceView.new_ () + | Some buf -> GtkSourceView3.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:(GtkSourceView3.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 0000000000..a2e341c128 --- /dev/null +++ b/ide/wg_ScriptView.mli @@ -0,0 +1,57 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* An undoable view class *) + +type source_view = [ Gtk.text_view | `sourceview ] Gtk.obj + +class script_view : source_view -> Coq.coqtop -> +object + inherit GSourceView3.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 apply_unicode_binding : unit -> unit + method recenter_insert : unit + method complete_popup : Wg_Completion.complete_popup +end + +val script_view : Coq.coqtop -> + ?source_buffer:GSourceView3.source_buffer -> + ?draw_spaces:SourceView3Enums.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:SourceView3Enums.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 0000000000..b62c0a2190 --- /dev/null +++ b/ide/wg_Segment.ml @@ -0,0 +1,141 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Preferences + +type color = GDraw.color + +type model_event = [ `INSERT | `REMOVE | `SET of int * color ] + +class type model = +object + method changed : callback:(model_event -> unit) -> unit + method length : int + method fold : 'a. ('a -> color -> 'a) -> 'a -> 'a +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 + +let set_cairo_color ctx c = + let open Gdk.Color in + let c = GDraw.color c in + let cast i = i2f i /. 65536. in + Cairo.set_source_rgb ctx (cast @@ red c) (cast @@ green c) (cast @@ blue c) + +class type segment_signals = +object + inherit GObj.misc_signals + inherit GUtil.add_ml_signals + method clicked : callback:(int -> unit) -> GtkSignal.id +end + +class segment_signals_impl obj (clicked : 'a GUtil.signal) : segment_signals = +object + val after = false + inherit GObj.misc_signals obj + inherit GUtil.add_ml_signals obj [clicked#disconnect] + method clicked = clicked#connect ~after +end + +class segment () = +let box = GBin.frame () in +let draw = GMisc.drawing_area ~packing:box#add () in + +object (self) + + inherit GObj.widget box#as_widget + + val mutable width = 1 + val mutable height = 20 + val mutable model : model option = None + val mutable default : color = `WHITE + val clicked = new GUtil.signal () + + initializer + box#misc#set_size_request ~height (); + let cb rect = + let w = rect.Gtk.width in + let h = rect.Gtk.height in + width <- w; + height <- h + in + let _ = box#misc#connect#size_allocate ~callback:cb in + let () = draw#event#add [`BUTTON_PRESS] in + let clicked_cb ev = match model with + | None -> true + | Some md -> + let x = GdkEvent.Button.x ev in + let len = md#length in + let idx = f2i ((x *. i2f len) /. i2f width) in + let () = clicked#call idx in + true + in + let _ = draw#event#connect#button_press ~callback:clicked_cb in + let cb show = if show then self#misc#show () else self#misc#hide () in + stick show_progress_bar self cb; + let cb ctx = self#refresh ctx; false in + let _ = draw#misc#connect#draw ~callback:cb in + () + + method set_model md = + model <- Some md; + let changed_cb _ = self#misc#queue_draw () in + md#changed ~callback:changed_cb + + method private fill_range ctx color i j = match model with + | None -> () + | Some md -> + let i = i2f i in + let j = i2f j in + let width = i2f width in + let len = i2f md#length in + let x = f2i ((i *. width) /. len) in + let x' = f2i ((j *. width) /. len) in + let w = x' - x in + set_cairo_color ctx color; + Cairo.rectangle ctx (i2f x) 0. ~w:(i2f w) ~h:(i2f height); + Cairo.fill ctx + + method set_default_color color = default <- color + method default_color = default + + method private refresh ctx = match model with + | None -> () + | Some md -> + set_cairo_color ctx default; + Cairo.rectangle ctx 0. 0. ~w:(i2f width) ~h:(i2f height); + Cairo.fill ctx; + let make (k, cur, accu) v = match cur with + | None -> pred k, Some (k, k, v), accu + | Some (i, j, w) -> + if k = j - 1 && color_eq v w then pred k, Some (k, i, w), accu + else pred k, Some (k, k, v), (i, j, w) :: accu + in + let _, p, segments = md#fold make (md#length - 1, None, []) in + let segments = match p with + | None -> segments + | Some p -> p :: segments + in + List.iter (fun (i, j, v) -> self#fill_range ctx v i (j + 1)) segments + + method connect = + new segment_signals_impl box#as_widget clicked + +end diff --git a/ide/wg_Segment.mli b/ide/wg_Segment.mli new file mode 100644 index 0000000000..07f545fee7 --- /dev/null +++ b/ide/wg_Segment.mli @@ -0,0 +1,37 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +type color = GDraw.color + +type model_event = [ `INSERT | `REMOVE | `SET of int * color ] + +class type segment_signals = +object + inherit GObj.misc_signals + inherit GUtil.add_ml_signals + method clicked : callback:(int -> unit) -> GtkSignal.id +end + +class type model = +object + method changed : callback:(model_event -> unit) -> unit + method length : int + method fold : 'a. ('a -> color -> 'a) -> 'a -> 'a +end + +class segment : unit -> + object + inherit GObj.widget + val obj : Gtk.widget Gtk.obj + method set_model : model -> unit + method connect : segment_signals + method default_color : color + method set_default_color : color -> unit + end |
