diff options
Diffstat (limited to 'ide')
83 files changed, 4442 insertions, 8432 deletions
diff --git a/ide/.merlin b/ide/.merlin index 3f3d9d275d..953b5dce4c 100644 --- a/ide/.merlin +++ b/ide/.merlin @@ -1,4 +1,4 @@ -PKG lablgtk2.sourceview2 +PKG unix laglgtk2 lablgtk2.sourceview2 S utils B utils @@ -1,7 +1,7 @@ CoqIde FAQ Q0) What is CoqIde? -R0: A powerfull graphical interface for Coq. See http://coq.inria.fr. for more informations. +R0: A powerful graphical interface for Coq. See http://coq.inria.fr. for more informations. Q1) How to enable Emacs keybindings? R1: Insert diff --git a/ide/MacOS/Info.plist.template b/ide/MacOS/Info.plist.template index fd80c83969..fbe7773dd4 100644 --- a/ide/MacOS/Info.plist.template +++ b/ide/MacOS/Info.plist.template @@ -66,7 +66,7 @@ <key>CFBundleGetInfoString</key> <string>Coq_vVERSION</string> <key>NSHumanReadableCopyright</key> - <string>Copyright 1999-2014, The Coq Development Team INRIA - CNRS - LIX - LRI - PPS</string> + <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> diff --git a/ide/MacOS/default_accel_map b/ide/MacOS/default_accel_map index 6f474eb124..47612cdf72 100644 --- a/ide/MacOS/default_accel_map +++ b/ide/MacOS/default_accel_map @@ -247,7 +247,6 @@ ; (gtk_accel_path "<Actions>/Tactics/Tactic constructor" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic elim -- with" "") ; (gtk_accel_path "<Actions>/Templates/Template Identity Coercion" "") -; (gtk_accel_path "<Actions>/Queries/Whelp Locate" "") (gtk_accel_path "<Actions>/View/Display all low-level contents" "<Shift><Control>l") ; (gtk_accel_path "<Actions>/Tactics/Tactic right" "") ; (gtk_accel_path "<Actions>/Edit/Find Previous" "<Shift>F3") diff --git a/ide/config_lexer.mll b/ide/config_lexer.mll index 87cc6d06e7..ac9cc57bc0 100644 --- a/ide/config_lexer.mll +++ b/ide/config_lexer.mll @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -17,7 +17,7 @@ let space = [' ' '\010' '\013' '\009' '\012'] let char = ['A'-'Z' 'a'-'z' '_' '0'-'9'] -let ident = char+ +let ident = (char | '.')+ let ignore = space | ('#' [^ '\n']*) rule prefs m = parse diff --git a/ide/coq-ssreflect.lang b/ide/coq-ssreflect.lang index 4c488ae89a..7cfc167018 100644 --- a/ide/coq-ssreflect.lang +++ b/ide/coq-ssreflect.lang @@ -190,6 +190,7 @@ <keyword>Eval</keyword> <keyword>Load</keyword> <keyword>Undo</keyword> + <keyword>Restart</keyword> <keyword>Goal</keyword> <keyword>Print</keyword> <keyword>Save</keyword> diff --git a/ide/coq.lang b/ide/coq.lang index 608a4aeaea..484264ece3 100644 --- a/ide/coq.lang +++ b/ide/coq.lang @@ -5,7 +5,7 @@ <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"/> @@ -20,197 +20,230 @@ <style id="safe" _name="Checked Part"/> <style id="sentence" _name="Sentence terminator"/> </styles> - + <definitions> - <define-regex id="space">\s</define-regex> + <define-regex id="space">\s+</define-regex> <define-regex id="first_ident_char">[_\p{L}]</define-regex> <define-regex id="ident_char">[_\p{L}'\pN]</define-regex> <define-regex id="ident">\%{first_ident_char}\%{ident_char}*</define-regex> <define-regex id="qualit">(\%{ident}\.)*\%{ident}</define-regex> - <define-regex id="undotted_sep">[-+*{}]</define-regex> <define-regex id="dot_sep">\.(\s|\z)</define-regex> - <define-regex id="single_decl">(Definition)|(Let)|(Example)|(SubClass)|(Fixpoint)|(CoFixpoint)|(Scheme)|(Function)|(Hypothesis)|(Axiom)|(Variable)|(Parameter)|(Conjecture)|(Inductive)|(CoInductive)|(Record)|(Structure)|(Ltac)|(Instance)|(Context)|(Class)|(Module(\%{space}+Type)?)|(Existing\%{space}+Instance)|(Canonical\%{space}+Structure)</define-regex> - <define-regex id="mult_decl">(Hypotheses)|(Axioms)|(Variables)|(Parameters)|(Implicit\%{space}+Type(s)?)</define-regex> - <define-regex id="locality">(((Local)|(Global))\%{space}+)?</define-regex> - <define-regex id="begin_proof">(Theorem)|(Lemma)|(Fact)|(Remark)|(Corollary)|(Proposition)|(Property)</define-regex> - <define-regex id="end_proof">(Qed)|(Defined)|(Admitted)|(Abort)</define-regex> - <define-regex id="decl_head">((?'gal'\%{locality}(Program\%{space}+)?(\%{single_decl}|\%{begin_proof}))\%{space}+(?'id'\%{ident}))|((?'gal4list'\%{mult_decl})(?'id_list'(\%{space}+\%{ident})*))|(?'gal2'Goal)</define-regex> - - <context id="escape-seq" style-ref="escape"> - <match>""</match> - </context> - <context id="string" style-ref="string"> + <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 ref="escape-seq"/> + <context id="string-escape" style-ref="escape"> + <match>""</match> + </context> </include> </context> - <context id="coq" class="no-spell-check"> + + <!-- 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 id="coqdoc" style-ref="coqdoc" class-disabled="no-spell-check"> - <start>\(\*\*(\s|\z)</start> - <end>\*\)</end> - <include> - <context ref="comment-in-comment"/> - <context ref="string"/> - </include> - </context> - <context id="comment" style-ref="comment" class="comment" class-disabled="no-spell-check"> - <start>\(\*</start> - <end>\*\)</end> - <include> - <context id="comment-in-comment" style-ref="comment" class="comment" class-disabled="no-spell-check"> - <start>\(\*</start> - <end>\*\)</end> - <include> - <context ref="comment-in-comment"/> - <context ref="string"/> - </include> - </context> - <context ref="string"/> - </include> - </context> - <context id="declaration"> - <start>\%{decl_head}</start> - <end>\%{dot_sep}</end> - <include> - <context sub-pattern="id" where="start" style-ref="identifier"/> - <context sub-pattern="gal" where="start" style-ref="gallina-keyword"/> - <context sub-pattern="gal2" where="start" style-ref="gallina-keyword"/> - <context sub-pattern="id_list" where="start" style-ref="identifier"/> - <context sub-pattern="gal4list" where="start" style-ref="gallina-keyword"/> - <context id="constr-keyword" style-ref="constr-keyword"> - <keyword>forall</keyword> - <keyword>fun</keyword> - <keyword>match</keyword> - <keyword>fix</keyword> - <keyword>cofix</keyword> - <keyword>with</keyword> - <keyword>for</keyword> - <keyword>end</keyword> - <keyword>as</keyword> - <keyword>let</keyword> - <keyword>in</keyword> - <keyword>if</keyword> - <keyword>then</keyword> - <keyword>else</keyword> - <keyword>return</keyword> - <keyword>using</keyword> - </context> - <context id="constr-sort" style-ref="constr-sort"> - <keyword>Prop</keyword> - <keyword>Set</keyword> - <keyword>Type</keyword> - </context> - <context id="dot-nosep"> - <match>\.\.</match> - </context> - <context ref="comment"/> - <context ref="string"/> - <context ref="coqdoc"/> - </include> - </context> - <context id="proof"> - <start>Proof(\%{dot_sep}|\%{space}+(using)|\%{space}+(with))</start> - <end>\%{end_proof}\%{dot_sep}</end> - <include> - <context sub-pattern="0" where="start" style-ref="vernac-keyword"/> - <context sub-pattern="0" where="end" style-ref="vernac-keyword"/> - <context ref="command"/> - <context ref="scope-command"/> - <context ref="hint-command"/> - <context ref="command-for-qualit"/> - <context ref="declaration"/> - <context ref="comment"/> - <context ref="string"/> - <context ref="coqdoc"/> - <context ref="proof"/> - <context ref="undotted-sep"/> - <context id="tactic" extend-parent="false"> - <start>\b[^-+*{}]</start> - <end>\%{dot_sep}</end> - <include> - <context ref="dot-nosep"/> - <context ref="constr-keyword"/> - <context ref="constr-sort"/> - </include> - </context> - </include> - </context> - <context id="exact-proof"> - <start>Proof</start> - <end>\%{dot_sep}</end> - <include> - <context sub-pattern="0" where="start" style-ref="vernac-keyword"/> - <context ref="constr-keyword"/> - <context ref="constr-sort"/> - </include> - </context> - <context id="undotted-sep" style-ref="vernac-keyword"> - <match>\%{undotted_sep}</match> - </context> - <context id="command" style-ref="vernac-keyword"> - <keyword>Add</keyword> - <keyword>Check</keyword> - <keyword>Eval</keyword> - <keyword>Load</keyword> - <keyword>Undo</keyword> - <keyword>Print</keyword> - <keyword>Save</keyword> - <keyword>Comments</keyword> - <keyword>Solve\%{space}+Obligation</keyword> - <keyword>((Uns)|(S))et(\%{space}+\%{ident})+</keyword> - <keyword>(\%{locality}|((Reserved)|(Tactic))\%{space}+)?Notation</keyword> - <keyword>\%{locality}Infix</keyword> - <keyword>(Print)|(Reset)\%{space}+Extraction\%{space}+(Inline)|(Blacklist)</keyword> - </context> - <context id="hint-command" style-ref="vernac-keyword"> - <prefix>\%{locality}Hint\%{space}+</prefix> - <keyword>Resolve</keyword> - <keyword>Immediate</keyword> - <keyword>Constructors</keyword> - <keyword>Unfold</keyword> - <keyword>Opaque</keyword> - <keyword>Transparent</keyword> - <keyword>Extern</keyword> - <keyword>Rewrite</keyword> - </context> - <context id="scope-command" style-ref="vernac-keyword"> - <suffix>\%{space}+Scope</suffix> - <keyword>\%{locality}Open</keyword> - <keyword>\%{locality}Close</keyword> - <keyword>Bind</keyword> - <keyword>Delimit</keyword> - </context> - <context id="command-for-qualit"> - <suffix>\%{space}+(?'qua'\%{qualit})</suffix> - <keyword>Chapter</keyword> - <keyword>Combined\%{space}+Scheme</keyword> - <keyword>End</keyword> - <keyword>Section</keyword> - <keyword>Arguments</keyword> - <keyword>Implicit\%{space}+Arguments</keyword> - <keyword>Import</keyword> - <keyword>Include</keyword> - <keyword>Export</keyword> - <keyword>Require(\%{space}+((Import)|(Export)))?</keyword> - <keyword>(Recursive\%{space}+)?Extraction(\%{space}+(Language\%{space}+(Ocaml)|(Haskell)|(Scheme)|(Toplevel))|(Library)|((No)?Inline)|(Blacklist))?</keyword> - <keyword>Extract\%{space}+(Inlined\%{space}+)?(Constant)|(Inductive)</keyword> - <include> - <context sub-pattern="1" style-ref="vernac-keyword"/> - <context sub-pattern="qua" style-ref="identifier"/> - </include> - </context> - <context id="command-for-qualit-list" style-ref="vernac-keyword"> - <suffix>(?'qua_list'(\%{space}+\%{qualit})+)</suffix> - <keyword>Typeclasses (Transparent)|(Opaque)</keyword> - <include> - <context sub-pattern="qua_list" style-ref="identifier"/> - </include> - </context> + <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 index b7753e6e8a..6d44ca59e3 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -99,9 +99,6 @@ let display_coqtop_answer cmd lines = "Command was: "^cmd^"\n"^ "Answer was: "^(String.concat "\n " lines)) -let check_remaining_opt arg = - if arg <> "" && arg.[0] = '-' then fatal_error_popup ("Illegal option: "^arg) - 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 @@ -125,7 +122,7 @@ and asks_for_coqtop args = ~message_type:`QUESTION ~buttons:GWindow.Buttons.yes_no () in match pb_mes#run () with | `YES -> - let () = current.cmd_coqtop <- None in + let () = cmd_coqtop#set None in let () = custom_coqtop := None in let () = pb_mes#destroy () in filter_coq_opts args @@ -200,8 +197,6 @@ module GlibMainLoop = struct let read_all = Ideutils.io_read_all let async_chan_of_file fd = Glib.Io.channel_of_descr fd let async_chan_of_socket s = !gio_channel_of_descr_socket s - let add_timeout ~sec callback = - ignore(Glib.Timeout.add ~ms:(sec * 1000) ~callback) end module CoqTop = Spawn.Async(GlibMainLoop) @@ -232,7 +227,7 @@ type coqtop = { (* non quoted command-line arguments of coqtop *) mutable sup_args : string list; (* called whenever coqtop dies *) - mutable reset_handler : reset_kind -> unit task; + mutable reset_handler : unit task; (* called whenever coqtop sends a feedback message *) mutable feedback_handler : Feedback.feedback -> unit; (* actual coqtop process and its status *) @@ -295,23 +290,20 @@ let rec check_errors = function | `NVAL :: _ -> raise (TubeError "NVAL") | `OUT :: _ -> raise (TubeError "OUT") -let handle_intermediate_message handle xml = - let message = Pp.to_message xml in - let level = message.Pp.message_level in - let content = message.Pp.message_content in - let logger = match handle.waiting_for with - | Some (_, l) -> l +let handle_intermediate_message handle level content = + let logger = match handle.waiting_for with + | Some (_, l) -> l | None -> function - | Pp.Error -> Minilib.log ~level:`ERROR - | Pp.Info -> Minilib.log ~level:`INFO - | Pp.Notice -> Minilib.log ~level:`NOTICE - | Pp.Warning -> Minilib.log ~level:`WARNING - | Pp.Debug _ -> Minilib.log ~level:`DEBUG + | Feedback.Error -> fun s -> Minilib.log ~level:`ERROR (xml_to_string s) + | Feedback.Info -> fun s -> Minilib.log ~level:`INFO (xml_to_string s) + | Feedback.Notice -> fun s -> Minilib.log ~level:`NOTICE (xml_to_string s) + | Feedback.Warning -> fun s -> Minilib.log ~level:`WARNING (xml_to_string s) + | Feedback.Debug -> fun s -> Minilib.log ~level:`DEBUG (xml_to_string s) in logger level content let handle_feedback feedback_processor xml = - let feedback = Feedback.to_feedback xml in + let feedback = Xmlprotocol.to_feedback xml in feedback_processor feedback let handle_final_answer handle xml = @@ -336,19 +328,22 @@ let unsafe_handle_input handle feedback_processor state conds ~read_all = let lex = Lexing.from_string s in let p = Xml_parser.make (Xml_parser.SLexbuf lex) in let rec loop () = - let xml = Xml_parser.parse p in + let 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 Pp.is_message xml then begin - handle_intermediate_message handle xml; - loop () - end else if Feedback.is_feedback xml then begin - handle_feedback feedback_processor xml; + match Xmlprotocol.is_message xml with + | Some (lvl, _loc, msg) -> + handle_intermediate_message handle lvl msg; loop () - end else begin - ignore (handle_final_answer handle xml) - end + | 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 -> @@ -362,7 +357,9 @@ let unsafe_handle_input handle feedback_processor state conds ~read_all = let print_exception = function | Xml_parser.Error e -> Xml_parser.error e - | Serialize.Marshal_error -> "Protocol violation" + | 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 = @@ -424,6 +421,7 @@ let mkready coqtop = fun () -> coqtop.status <- Ready; Void let rec respawn_coqtop ?(why=Unexpected) coqtop = + if why = Unexpected then warning "Coqtop died badly. Resetting."; clear_handle coqtop.handle; ignore_error (fun () -> coqtop.handle <- @@ -435,7 +433,7 @@ let rec respawn_coqtop ?(why=Unexpected) coqtop = If not, there isn't much we can do ... *) assert (coqtop.handle.alive = true); coqtop.status <- New; - ignore (coqtop.reset_handler why coqtop.handle (mkready coqtop)) + ignore (coqtop.reset_handler coqtop.handle (mkready coqtop)) let spawn_coqtop sup_args = bind_self_as (fun this -> { @@ -443,7 +441,7 @@ let spawn_coqtop sup_args = (fun () -> respawn_coqtop (this ())) (fun msg -> (this ()).feedback_handler msg); sup_args = sup_args; - reset_handler = (fun _ _ k -> k ()); + reset_handler = (fun _ k -> k ()); feedback_handler = (fun _ -> ()); status = New; }) @@ -465,10 +463,6 @@ let close_coqtop coqtop = let reset_coqtop coqtop = respawn_coqtop ~why:Planned coqtop -let break_coqtop coqtop = - try !interrupter (CoqTop.unixpid coqtop.handle.proc) - with _ -> Minilib.log "Error while sending Ctrl-C" - let get_arguments coqtop = coqtop.sup_args let set_arguments coqtop args = @@ -518,6 +512,17 @@ 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 = string list diff --git a/ide/coq.mli b/ide/coq.mli index a72c67b43e..8a1fa3ed15 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,7 +16,7 @@ type coqtop Liveness management of coqtop is automatic. Whenever a coqtop dies abruptly, this module is responsible for relaunching the whole process. The reset handler set through [set_reset_handler] will be called after such an - abrupt failure. It is also called when explicitely requesting coqtop to + abrupt failure. It is also called when explicitly requesting coqtop to reset. *) type 'a task @@ -29,7 +29,7 @@ type 'a task ([is_computing] will answer [true]), and any other task submission will be rejected by [try_grab]. - Any exception occuring within the task will trigger a coqtop reset. + 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 @@ -43,7 +43,7 @@ val bind : 'a task -> ('a -> 'b task) -> 'b task (** Monadic binding of tasks *) val lift : (unit -> 'a) -> 'a task -(** Return the impertative computation waiting to be processed. *) +(** Return the imperative computation waiting to be processed. *) val seq : unit task -> 'a task -> 'a task (** Sequential composition *) @@ -60,7 +60,7 @@ val is_computing : coqtop -> bool val spawn_coqtop : string list -> coqtop (** Create a coqtop process with some command-line arguments. *) -val set_reset_handler : coqtop -> (reset_kind -> unit task) -> unit +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 @@ -70,8 +70,8 @@ val init_coqtop : coqtop -> unit task -> unit (** Finish initializing a freshly spawned coqtop, by running a first task on it. The task should run its inner continuation at the end. *) -val break_coqtop : coqtop -> unit -(** Interrupt the current computation of coqtop. *) +val 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. *) diff --git a/ide/coq.png b/ide/coq.png Binary files differindex cccd5a9a19..136bfdd5fe 100644 --- a/ide/coq.png +++ b/ide/coq.png diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 52e184564f..1563c7ffb4 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,15 +12,19 @@ open Ideutils open Interface open Feedback -type flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR of string ] -type mem_flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR ] +let b2c = byte_offset_to_char_offset + +type flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR of Loc.t * string | `WARNING of Loc.t * string ] +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 = @@ -44,12 +48,9 @@ module SentenceId : sig val mk_sentence : start:GText.mark -> stop:GText.mark -> flag list -> sentence - val set_flags : sentence -> flag list -> unit val add_flag : sentence -> flag -> unit val has_flag : sentence -> mem_flag -> bool val remove_flag : sentence -> mem_flag -> unit - val same_sentence : sentence -> sentence -> bool - val hidden_edit_id : unit -> int val find_all_tooltips : sentence -> int -> string list val add_tooltip : sentence -> int -> int -> string -> unit val set_index : sentence -> int -> unit @@ -87,18 +88,15 @@ end = struct index = -1; changed_sig = new GUtil.signal (); } - let hidden_edit_id () = decr id; !id let changed s = s.changed_sig#call (s.index, List.map mem_flag_of_flag s.flags) - let set_flags s f = s.flags <- f; changed s let add_flag s f = s.flags <- CList.add_set (=) f s.flags; changed s let has_flag s mf = List.exists (fun f -> mem_flag_of_flag f = mf) s.flags let remove_flag s mf = s.flags <- List.filter (fun f -> mem_flag_of_flag f <> mf) s.flags; changed s - let same_sentence s1 s2 = s1.edit_id = s2.edit_id let find_all_tooltips s off = CList.map_filter (fun (start,stop,t) -> if start <= off && off <= stop then Some t else None) @@ -130,8 +128,6 @@ end = struct end open SentenceId -let prefs = Preferences.current - let log msg : unit task = Coq.lift (fun () -> Minilib.log msg) @@ -142,7 +138,7 @@ object method tactic_wizard : string list -> unit task method process_next_phrase : unit task method process_until_end_or_error : unit task - method handle_reset_initial : Coq.reset_kind -> unit task + method handle_reset_initial : unit task method raw_coq_query : string -> unit task method show_goals : unit task method backtrack_last_phrase : unit task @@ -160,15 +156,71 @@ object end let flags_to_color f = - let of_col c = `NAME (Tags.string_of_color c) in if List.mem `PROCESSING f then `NAME "blue" else if List.mem `ERROR f then `NAME "red" else if List.mem `UNSAFE f then `NAME "orange" else if List.mem `INCOMPLETE f then `NAME "gray" - else of_col (Tags.get_processed_color ()) + else `NAME Preferences.processed_color#get + +let validate s = + let open Xml_datatype in + let rec validate = function + | PCData s -> Glib.Utf8.validate s + | Element (_, _, children) -> List.for_all validate children + in + validate (Richpp.repr s) 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 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 self#on_push in + let _ = (Doc.connect doc)#popped self#on_pop in + () + +end + class coqops (_script:Wg_ScriptView.script_view) (_pv:Wg_ProofView.proof_view) @@ -201,22 +253,24 @@ object(self) script#misc#set_has_tooltip true; ignore(script#misc#connect#query_tooltip ~callback:self#tooltip_callback); feedback_timer.Ideutils.run ~ms:300 ~callback:self#process_feedback; - let on_changed (i, f) = segment#add i (flags_to_color f) in - let on_push s = - set_index s document_length; - (SentenceId.connect s)#changed on_changed; - document_length <- succ document_length; - segment#set_length document_length; - let flags = List.map mem_flag_of_flag s.flags in - segment#add s.index (flags_to_color flags); - in - let on_pop s = - set_index s (-1); - document_length <- pred document_length; - segment#set_length document_length; + 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 iter; + ignore (script#scroll_to_iter ~use_align:true ~yalign:0. iter) in - let _ = (Doc.connect document)#pushed on_push in - let _ = (Doc.connect document)#popped on_pop in + let _ = segment#connect#clicked on_click in () method private tooltip_callback ~x ~y ~kbd tooltip = @@ -260,21 +314,11 @@ object(self) Doc.focus document ~cond_top:(at start) ~cond_bot:(at stop); self#print_stack; let qed_s = Doc.tip_data document in - buffer#apply_tag Tags.Script.read_only - ~start:((buffer#get_iter_at_mark qed_s.start)#forward_find_char - (fun c -> not(Glib.Unichar.isspace c))) - ~stop:(buffer#get_iter_at_mark qed_s.stop); buffer#move_mark ~where:(buffer#get_iter_at_mark qed_s.stop) (`NAME "stop_of_input") method private exit_focus = Minilib.log "Unfocusing"; - begin try - let { start; stop } = Doc.tip_data document in - buffer#remove_tag Tags.Script.read_only - ~start:(buffer#get_iter_at_mark start) - ~stop:(buffer#get_iter_at_mark stop) - with Doc.Empty -> () end; Doc.unfocus document; self#print_stack; begin try @@ -295,8 +339,11 @@ object(self) method private show_goals_aux ?(move_insert=false) () = Coq.PrintOpt.set_printing_width proof#width; if move_insert then begin - buffer#place_cursor ~where:self#get_start_of_input; - script#recenter_insert; + 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 ~logger:messages#push ()) (function | Fail x -> self#handle_failure_aux ~move_insert x @@ -316,7 +363,7 @@ object(self) method raw_coq_query phrase = let action = log "raw_coq_query starting now" in let display_error s = - if not (Glib.Utf8.validate s) then + if not (validate s) then flash_info "This error is so nasty that I can't even display it." else messages#add s; in @@ -325,7 +372,7 @@ object(self) let next = function | Fail (_, _, err) -> display_error err; Coq.return () | Good msg -> - messages#add msg; Coq.return () + messages#add_string msg; Coq.return () in Coq.bind (Coq.seq action query) next @@ -347,7 +394,7 @@ object(self) else if has_flag sentence `ERROR then [error_bg] else if has_flag sentence `INCOMPLETE then [incomplete] else [processed]) @ - (if [ `UNSAFE ] = sentence.flags then [unjustified] else []) + (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 @@ -356,8 +403,8 @@ object(self) let start_sentence, stop_sentence, phrase = self#get_sentence sentence in let pre_chars, post_chars = if Loc.is_ghost loc then 0, String.length phrase else Loc.unloc loc in - let pre = Ideutils.glib_utf8_pos_to_offset phrase ~off:pre_chars in - let post = Ideutils.glib_utf8_pos_to_offset phrase ~off:post_chars in + let 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 @@ -400,7 +447,6 @@ object(self) | Processed, Some (id,sentence) -> log "Processed" id; remove_flag sentence `PROCESSING; - remove_flag sentence `ERROR; self#mark_as_needed sentence | ProcessingIn _, Some (id,sentence) -> log "ProcessingIn" id; @@ -418,14 +464,25 @@ object(self) log "GlobRef" id; self#attach_tooltip sentence loc (Printf.sprintf "%s %s %s" filepath ident ty) - | ErrorMsg(loc, msg), Some (id,sentence) -> + | Message(Error, loc, msg), Some (id,sentence) -> + let loc = Option.default Loc.ghost loc in + let msg = Richpp.raw_print msg in log "ErrorMsg" id; remove_flag sentence `PROCESSING; - add_flag sentence (`ERROR msg); + add_flag sentence (`ERROR (loc, msg)); self#mark_as_needed sentence; self#attach_tooltip sentence loc msg; if not (Loc.is_ghost loc) then self#position_error_tag_at_sentence sentence (Some (Loc.unloc loc)) + | Message(Warning, loc, msg), Some (id,sentence) -> + let loc = Option.default Loc.ghost loc in + let msg = Richpp.raw_print msg in + log "WarningMsg" id; + add_flag sentence (`WARNING (loc, msg)); + self#attach_tooltip sentence loc msg; + self#position_warning_tag_at_sentence sentence loc + | Message((Info|Notice|Debug as lvl), _, msg), _ -> + messages#push lvl msg | InProgress n, _ -> if n < 0 then processed <- processed + abs n else to_process <- to_process + n @@ -460,13 +517,25 @@ object(self) | None -> () | Some (start, stop) -> buffer#apply_tag Tags.Script.error - ~start:(iter#forward_chars (byte_offset_to_char_offset phrase start)) - ~stop:(iter#forward_chars (byte_offset_to_char_offset phrase stop)) + ~start:(iter#forward_chars (b2c phrase start)) + ~stop:(iter#forward_chars (b2c phrase stop)) method private position_error_tag_at_sentence sentence loc = let start, _, phrase = self#get_sentence sentence in self#position_error_tag_at_iter start phrase loc + method private position_warning_tag_at_iter iter_start iter_stop phrase loc = + if Loc.is_ghost loc then + buffer#apply_tag Tags.Script.warning ~start:iter_start ~stop:iter_stop + else + buffer#apply_tag Tags.Script.warning + ~start:(iter_start#forward_chars (b2c phrase loc.Loc.bp)) + ~stop:(iter_stop#forward_chars (b2c phrase loc.Loc.ep)) + + method private position_warning_tag_at_sentence sentence loc = + let start, stop, phrase = self#get_sentence sentence in + self#position_warning_tag_at_iter start stop phrase loc + method private process_interp_error queue sentence loc msg tip id = Coq.bind (Coq.return ()) (function () -> let start, stop, phrase = self#get_sentence sentence in @@ -477,7 +546,7 @@ object(self) self#position_error_tag_at_iter start phrase loc; buffer#place_cursor ~where:stop; messages#clear; - messages#push Pp.Error msg; + messages#push Feedback.Error msg; self#show_goals end else self#show_goals_aux ~move_insert:true () @@ -493,13 +562,19 @@ object(self) 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 start#has_tag Tags.Script.processed 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 @@ -547,12 +622,16 @@ object(self) 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 + | (_,s)::_ -> self#backtrack_to_iter (buffer#get_iter_at_mark s.start) in let process_queue queue = let rec loop tip topstack = if Queue.is_empty queue then conclude topstack else match Queue.pop queue, topstack with - | `Skip(start,stop), [] -> assert false + | `Skip(start,stop), [] -> + + logger Feedback.Error (Richpp.richpp_of_string "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)); @@ -566,7 +645,7 @@ object(self) let handle_answer = function | Good (id, (Util.Inl (* NewTip *) (), msg)) -> Doc.assign_tip_id document id; - logger Pp.Notice msg; + logger Feedback.Notice (Richpp.richpp_of_string msg); self#commit_queue_transaction sentence; loop id [] | Good (id, (Util.Inr (* Unfocus *) tip, msg)) -> @@ -574,7 +653,7 @@ object(self) let topstack, _ = Doc.context document in self#exit_focus; self#cleanup (Doc.cut_at document tip); - logger Pp.Notice msg; + logger Feedback.Notice (Richpp.richpp_of_string msg); self#mark_as_needed sentence; if Queue.is_empty queue then loop tip [] else loop tip (List.rev topstack) @@ -593,7 +672,7 @@ object(self) let next = function | Good _ -> messages#clear; - messages#push Pp.Info "All proof terms checked by the kernel"; + messages#push Feedback.Info (Richpp.richpp_of_string "All proof terms checked by the kernel"); Coq.return () | Fail x -> self#handle_failure x in Coq.bind (Coq.status ~logger:messages#push true) next @@ -609,7 +688,15 @@ object(self) method get_errors = let extract_error s = match List.find (function `ERROR _ -> true | _ -> false) s.flags with - | `ERROR msg -> (buffer#get_iter_at_mark s.start)#line + 1, msg + | `ERROR (loc, msg) -> + let iter = + if Loc.is_ghost loc then + buffer#get_iter_at_mark s.start + else + let (iter, _, phrase) = self#get_sentence s in + let (start, _) = Loc.unloc loc in + iter#forward_chars (b2c phrase start) in + iter#line + 1, msg | _ -> assert false in List.rev (Doc.fold_all document [] (fun acc _ _ s -> @@ -621,7 +708,7 @@ object(self) method private process_until_iter iter = let until _ start stop = - if prefs.Preferences.stop_before then stop#compare iter > 0 + if Preferences.stop_before#get then stop#compare iter > 0 else start#compare iter >= 0 in self#process_until until false @@ -649,7 +736,8 @@ object(self) 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 + 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) = @@ -659,7 +747,10 @@ object(self) push_info "Coq is undoing" in let conclusion () = pop_info (); - if move_insert then buffer#place_cursor ~where:self#get_start_of_input; + 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); @@ -683,8 +774,8 @@ object(self) self#cleanup (Doc.cut_at document to_id); conclusion () | Fail (safe_id, loc, msg) -> - if loc <> None then messages#push Pp.Error "Fixme LOC"; - messages#push Pp.Error msg; +(* if loc <> None then messages#push Feedback.Error (Richpp.richpp_of_string "Fixme LOC"); *) + messages#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)) @@ -701,8 +792,7 @@ object(self) method private handle_failure_aux ?(move_insert=false) (safe_id, (loc : (int * int) option), msg) = - messages#clear; - messages#push Pp.Error msg; + messages#push Feedback.Error msg; ignore(self#process_feedback ()); if Stateid.equal safe_id Stateid.dummy then Coq.lift (fun () -> ()) else @@ -759,7 +849,7 @@ object(self) self#show_goals in let display_error (loc, s) = - if not (Glib.Utf8.validate s) then + if not (validate s) then flash_info "This error is so nasty that I can't even display it." else messages#add s in @@ -769,10 +859,10 @@ object(self) let next = function | Fail (_, l, str) -> (* FIXME: check *) display_error (l, str); - messages#add ("Unsuccessfully tried: "^phrase); + messages#add (Richpp.richpp_of_string ("Unsuccessfully tried: "^phrase)); more | Good msg -> - messages#add msg; + messages#add_string msg; stop Tags.Script.processed in Coq.bind (Coq.seq action query) next @@ -784,10 +874,8 @@ object(self) in loop l - method handle_reset_initial why = + method handle_reset_initial = let action () = - if why = Coq.Unexpected then warning "Coqtop died badly. Resetting." - else (* clear the stack *) if Doc.focused document then Doc.unfocus document; while not (Doc.is_empty document) do @@ -816,7 +904,10 @@ object(self) method initialize = let get_initial_state = let next = function - | Fail _ -> messages#set ("Couln't initialize Coq"); Coq.return () + | Fail (_, _, message) -> + let message = "Couldn't initialize coqtop\n\n" ^ (Richpp.raw_print 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 diff --git a/ide/coqOps.mli b/ide/coqOps.mli index 8e76d3b270..332c18f2f0 100644 --- a/ide/coqOps.mli +++ b/ide/coqOps.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -15,7 +15,7 @@ object method tactic_wizard : string list -> unit task method process_next_phrase : unit task method process_until_end_or_error : unit task - method handle_reset_initial : Coq.reset_kind -> unit task + method handle_reset_initial : unit task method raw_coq_query : string -> unit task method show_goals : unit task method backtrack_last_phrase : unit task diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml index 995c45c5ae..d55e7f9dd7 100644 --- a/ide/coq_commands.ml +++ b/ide/coq_commands.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -228,8 +228,6 @@ let state_preserving = [ "Test Printing Synth"; "Test Printing Wildcard"; - "Whelp Hint"; - "Whelp Locate"; ] diff --git a/ide/coq_lex.mll b/ide/coq_lex.mll index e333c0b24c..b6286c49fb 100644 --- a/ide/coq_lex.mll +++ b/ide/coq_lex.mll @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/coqide.ml b/ide/coqide.ml index fa64defabd..450bfcdfb1 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -44,8 +44,6 @@ open Session (** {2 Some static elements } *) -let prefs = Preferences.current - (** The arguments that will be passed to coqtop. No quoting here, since no /bin/sh when using create_process instead of open_process. *) let custom_project_files = ref [] @@ -84,14 +82,15 @@ let pr_exit_status = function | _ -> " failed" let make_coqtop_args = function - |None -> !sup_args + |None -> "", !sup_args |Some the_file -> let get_args f = Project_file.args_from_project f - !custom_project_files prefs.project_file_name + !custom_project_files project_file_name#get in - match prefs.read_project with - |Ignore_args -> !sup_args - |Append_args -> get_args the_file @ !sup_args + match read_project#get with + |Ignore_args -> "", !sup_args + |Append_args -> + let fname, args = get_args the_file in fname, args @ !sup_args |Subst_args -> get_args the_file (** Setting drag & drop on widgets *) @@ -120,7 +119,10 @@ let set_drag (w : GObj.drag_ops) = (** Session management *) let create_session f = - let ans = Session.create f (make_coqtop_args f) in + 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 @@ -160,7 +162,6 @@ let load_file ?(maycreate=false) f = input_buffer#place_cursor ~where:input_buffer#start_iter; Sentence.tag_all input_buffer; session.script#clear_undo (); - !refresh_editor_hook (); Minilib.log "Loading: success"; end with e -> flash_info ("Load failed: "^(Printexc.to_string e)) @@ -246,11 +247,13 @@ module File = struct let newfile _ = let session = create_session None in let index = notebook#append_term session in - !refresh_editor_hook (); notebook#goto_page index let load _ = - match select_file_for_open ~title:"Load file" () with + let filename = + try notebook#current_term.fileops#filename + with Invalid_argument _ -> None in + match select_file_for_open ~title:"Load file" ?filename () with | None -> () | Some f -> FileAux.load_file f @@ -312,13 +315,13 @@ let export kind sn = | _ -> assert false in let cmd = - local_cd f ^ prefs.cmd_coqdoc ^ " --" ^ kind ^ " -o " ^ + local_cd f ^ cmd_coqdoc#get ^ " --" ^ kind ^ " -o " ^ (Filename.quote output) ^ " " ^ (Filename.quote basef) ^ " 2>&1" in - sn.messages#set ("Running: "^cmd); + sn.messages#set (Richpp.richpp_of_string ("Running: "^cmd)); let finally st = flash_info (cmd ^ pr_exit_status st) in - run_command sn.messages#add finally cmd + run_command (fun msg -> sn.messages#add_string msg) finally cmd let export kind = cb_on_current_term (export kind) @@ -327,8 +330,8 @@ let print sn = |None -> flash_info "Cannot print: this buffer has no name" |Some f_name -> let cmd = - local_cd f_name ^ prefs.cmd_coqdoc ^ " -ps " ^ - Filename.quote (Filename.basename f_name) ^ " | " ^ prefs.cmd_print + 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 ~wm_class:"CoqIDE" ~wm_name: "CoqIDE" () @@ -371,17 +374,17 @@ end let reset_revert_timer () = FileOps.revert_timer.kill (); - if prefs.global_auto_revert then + if global_auto_revert#get then FileOps.revert_timer.run - ~ms:prefs.global_auto_revert_delay + ~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 prefs.auto_save then - FileOps.autosave_timer.run ~ms:prefs.auto_save_delay ~callback:autosave_all + if auto_save#get then + FileOps.autosave_timer.run ~ms:auto_save_delay#get ~callback:autosave_all (** Export of functions used in [coqide_main] : *) @@ -401,8 +404,8 @@ let coq_makefile sn = match sn.fileops#filename with |None -> flash_info "Cannot make makefile: this buffer has no name" |Some f -> - let cmd = local_cd f ^ prefs.cmd_coqmakefile in - let finally st = flash_info (current.cmd_coqmakefile ^ pr_exit_status st) + 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 @@ -414,7 +417,7 @@ let editor sn = |Some f -> File.save (); let f = Filename.quote f in - let cmd = Util.subst_command_placeholder prefs.cmd_editor f in + let cmd = Util.subst_command_placeholder cmd_editor#get f in run_command ignore (fun _ -> sn.fileops#revert) cmd let editor = cb_on_current_term editor @@ -424,13 +427,13 @@ let compile sn = match sn.fileops#filename with |None -> flash_info "Active buffer has no name" |Some f -> - let cmd = prefs.cmd_coqc ^ " -I " ^ (Filename.quote (Filename.dirname f)) + let cmd = cmd_coqc#get ^ " -I " ^ (Filename.quote (Filename.dirname f)) ^ " " ^ (Filename.quote f) ^ " 2>&1" in let buf = Buffer.create 1024 in - sn.messages#set ("Running: "^cmd); + sn.messages#set (Richpp.richpp_of_string ("Running: "^cmd)); let display s = - sn.messages#add s; + sn.messages#add_string s; Buffer.add_string buf s in let finally st = @@ -438,8 +441,8 @@ let compile sn = flash_info (f ^ " successfully compiled") else begin flash_info (f ^ " failed to compile"); - sn.messages#set "Compilation output:\n"; - sn.messages#add (Buffer.contents buf); + sn.messages#set (Richpp.richpp_of_string "Compilation output:\n"); + sn.messages#add (Richpp.richpp_of_string (Buffer.contents buf)); end in run_command display finally cmd @@ -460,17 +463,17 @@ let make sn = |None -> flash_info "Cannot make: this buffer has no name" |Some f -> File.saveall (); - let cmd = local_cd f ^ prefs.cmd_make ^ " 2>&1" in - sn.messages#set "Compilation output:\n"; + let cmd = local_cd f ^ cmd_make#get ^ " 2>&1" in + sn.messages#set (Richpp.richpp_of_string "Compilation output:\n"); Buffer.reset last_make_buf; last_make := ""; last_make_index := 0; last_make_dir := Filename.dirname f; let display s = - sn.messages#add s; + sn.messages#add_string s; Buffer.add_string last_make_buf s in - let finally st = flash_info (current.cmd_make ^ pr_exit_status st) + let finally st = flash_info (cmd_make#get ^ pr_exit_status st) in run_command display finally cmd @@ -505,11 +508,11 @@ let next_error sn = let stopi = b#get_iter_at_byte ~line:(line-1) stop in b#apply_tag Tags.Script.error ~start:starti ~stop:stopi; b#place_cursor ~where:starti; - sn.messages#set error_msg; + sn.messages#set (Richpp.richpp_of_string error_msg); sn.script#misc#grab_focus () with Not_found -> last_make_index := 0; - sn.messages#set "No more errors.\n" + sn.messages#set (Richpp.richpp_of_string "No more errors.\n") let next_error = cb_on_current_term next_error @@ -530,7 +533,7 @@ let update_status sn = | None -> "" | Some n -> ", proving " ^ n in - display ("Ready"^ if current.nanoPG then ", [μPG]" else "" ^ path ^ name); + display ("Ready"^ (if nanoPG#get then ", [μPG]" else "") ^ path ^ name); Coq.return () in Coq.bind (Coq.status ~logger:sn.messages#push false) next @@ -567,7 +570,7 @@ module Nav = struct let restart _ = on_current_term restart let interrupt sn = Minilib.log "User break received"; - Coq.break_coqtop sn.coqtop + 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 @@ -588,13 +591,24 @@ let get_current_word term = | Some p -> p | None -> (** Then look at the current selected word *) - if term.script#buffer#has_selection then - let (start, stop) = term.script#buffer#selection_bounds in + let buf1 = term.script#buffer in + let buf2 = term.proof#buffer in + let buf3 = term.messages#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 buf3#has_selection then + let (start, stop) = buf3#selection_bounds in + buf3#get_text ~slice:true ~start ~stop () + (** 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 () - (** Otherwise try to recover the clipboard *) - else match Ideutils.cb#text with - | Some t -> t - | None -> "" let print_branch c l = Format.fprintf c " | @[<hov 1>%a@]=> _@\n" @@ -663,12 +677,18 @@ let searchabout sn = let searchabout () = on_current_term searchabout +let doquery query sn = + sn.messages#clear; + Coq.try_grab sn.coqtop (sn.coqops#raw_coq_query query) ignore + let otherquery command sn = - let word = get_current_word sn in - if word <> "" then - let query = command ^ " " ^ word ^ "." in - sn.messages#clear; - Coq.try_grab sn.coqtop (sn.coqops#raw_coq_query query) ignore + 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 otherquery command = cb_on_current_term (otherquery command) @@ -704,7 +724,7 @@ let initial_about () = else "" in let msg = initial_string ^ version_info ^ log_file_message () in - on_current_term (fun term -> term.messages#add msg) + on_current_term (fun term -> term.messages#add_string msg) let coq_icon () = (* May raise Nof_found *) @@ -769,7 +789,7 @@ let coqtop_arguments sn = let args = String.concat " " args in let msg = Printf.sprintf "Invalid arguments: %s" args in let () = sn.messages#clear in - sn.messages#push Pp.Error msg + sn.messages#push Feedback.Error (Richpp.richpp_of_string msg) else dialog#destroy () in let _ = entry#connect#activate ok_cb in @@ -791,63 +811,19 @@ let zoom_fit sn = let cols = script#right_margin_position in let pango_ctx = script#misc#pango_context in let layout = pango_ctx#create_layout in - let fsize = Pango.Font.get_size current.text_font in + 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 current.text_font + Pango.Font.set_size (Pango.Font.from_string text_font#get) (fsize * space / tlen / Pango.scale * Pango.scale); - save_pref (); - !refresh_editor_hook () + save_pref () end (** Refresh functions *) -let refresh_editor_prefs () = - let wrap_mode = if prefs.dynamic_word_wrap then `WORD else `NONE in - let show_spaces = - if prefs.show_spaces then 0b1001011 (* SPACE, TAB, NBSP, TRAILING *) - else 0 - in - let fd = prefs.text_font in - let clr = Tags.color_of_string prefs.background_color - in - let iter_session sn = - (* Editor settings *) - sn.script#set_wrap_mode wrap_mode; - sn.script#set_show_line_numbers prefs.show_line_number; - sn.script#set_auto_indent prefs.auto_indent; - sn.script#set_highlight_current_line prefs.highlight_current_line; - - (* Hack to handle missing binding in lablgtk *) - let conv = { Gobject.name = "draw-spaces"; Gobject.conv = Gobject.Data.int } - in - Gobject.set conv sn.script#as_widget show_spaces; - - sn.script#set_show_right_margin prefs.show_right_margin; - if prefs.show_progress_bar then sn.segment#misc#show () else sn.segment#misc#hide (); - sn.script#set_insert_spaces_instead_of_tabs - prefs.spaces_instead_of_tabs; - sn.script#set_tab_width prefs.tab_length; - sn.script#set_auto_complete prefs.auto_complete; - - (* Fonts *) - sn.script#misc#modify_font fd; - sn.proof#misc#modify_font fd; - sn.messages#modify_font fd; - sn.command#refresh_font (); - - (* Colors *) - sn.script#misc#modify_base [`NORMAL, `COLOR clr]; - sn.proof#misc#modify_base [`NORMAL, `COLOR clr]; - sn.messages#misc#modify_base [`NORMAL, `COLOR clr]; - sn.command#refresh_color () - - in - List.iter iter_session notebook#pages - let refresh_notebook_pos () = - let pos = match prefs.vertical_tabs, prefs.opposite_tabs with + let pos = match vertical_tabs#get, opposite_tabs#get with | false, false -> `TOP | false, true -> `BOTTOM | true , false -> `LEFT @@ -882,19 +858,19 @@ let toggle_items menu_name l = let f d = let label = d.Opt.label in let k, name = get_shortcut label in - let accel = Option.map ((^) prefs.modifier_for_display) k in + 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 no_under = Util.String.map (fun x -> if x = '_' then '-' else x) - in let mk_item text = let text' = let last = String.length text - 1 in @@ -924,7 +900,7 @@ let alpha_items menu_name item_name l = Caveat: the offset is now from the start of the text. *) let template_item (text, offset, len, key) = - let modifier = prefs.modifier_for_templates in + let modifier = modifier_for_templates#get in let idx = String.index text ' ' in let name = String.sub text 0 idx in let label = "_"^name^" __" in @@ -941,6 +917,16 @@ let template_item (text, offset, len, key) = 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 @@ -951,8 +937,7 @@ let emit_to_focus window sgn = let build_ui () = let w = GWindow.window ~wm_class:"CoqIde" ~wm_name:"CoqIde" - ~allow_grow:true ~allow_shrink:true - ~width:prefs.window_width ~height:prefs.window_height + ~width:window_width#get ~height:window_height#get ~title:"CoqIde" () in let () = @@ -1050,77 +1035,60 @@ let build_ui () = ~callback:(fun _ -> notebook#next_page ()); item "Zoom in" ~label:"_Zoom in" ~accel:("<Control>plus") ~stock:`ZOOM_IN ~callback:(fun _ -> - Pango.Font.set_size current.text_font - (Pango.Font.get_size current.text_font + Pango.scale); - save_pref (); - !refresh_editor_hook ()); + 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 _ -> - Pango.Font.set_size current.text_font - (Pango.Font.get_size current.text_font - Pango.scale); - save_pref (); - !refresh_editor_hook ()); + 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:(prefs.show_toolbar) - ~callback:(fun _ -> - prefs.show_toolbar <- not prefs.show_toolbar; - !refresh_toolbar_hook ()); + ~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) ]; toggle_items view_menu Coq.PrintOpt.bool_items; - menu navigation_menu [ - item "Navigation" ~label:"_Navigation"; - item "Forward" ~label:"_Forward" ~stock:`GO_DOWN ~callback:Nav.forward_one - ~tooltip:"Forward one command" - ~accel:(prefs.modifier_for_navigation^"Down"); - item "Backward" ~label:"_Backward" ~stock:`GO_UP ~callback:Nav.backward_one - ~tooltip:"Backward one command" - ~accel:(prefs.modifier_for_navigation^"Up"); - item "Go to" ~label:"_Go to" ~stock:`JUMP_TO ~callback:Nav.goto - ~tooltip:"Go to cursor" - ~accel:(prefs.modifier_for_navigation^"Right"); - item "Start" ~label:"_Start" ~stock:`GOTO_TOP ~callback:Nav.restart - ~tooltip:"Restart coq" - ~accel:(prefs.modifier_for_navigation^"Home"); - item "End" ~label:"_End" ~stock:`GOTO_BOTTOM ~callback:Nav.goto_end - ~tooltip:"Go to end" - ~accel:(prefs.modifier_for_navigation^"End"); - item "Interrupt" ~label:"_Interrupt" ~stock:`STOP ~callback:Nav.interrupt - ~tooltip:"Interrupt computations" - ~accel:(prefs.modifier_for_navigation^"Break"); -(* wait for this available in GtkSourceView ! - item "Hide" ~label:"_Hide" ~stock:`MISSING_IMAGE - ~callback:(fun _ -> let sess = notebook#current_term in - toggle_proof_visibility sess.buffer - sess.analyzed_view#get_insert) ~tooltip:"Hide proof" - ~accel:(prefs.modifier_for_navigation^"h");*) - item "Previous" ~label:"_Previous" ~stock:`GO_BACK - ~callback:Nav.previous_occ - ~tooltip:"Previous occurence" - ~accel:(prefs.modifier_for_navigation^"less"); - item "Next" ~label:"_Next" ~stock:`GO_FORWARD ~callback:Nav.next_occ - ~tooltip:"Next occurence" - ~accel:(prefs.modifier_for_navigation^"greater"); - item "Force" ~label:"_Force" ~stock:`EXECUTE ~callback:Nav.join_document - ~tooltip:"Fully check the document" - ~accel:(current.modifier_for_navigation^"f"); - ]; + let 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:(prefs.modifier_for_tactics^sc) + ~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:(prefs.modifier_for_tactics^"dollar") - ~callback:(tactic_wizard_callback prefs.automatic_tactics); + ~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"; @@ -1135,29 +1103,34 @@ let build_ui () = menu templates_menu [ item "Templates" ~label:"Te_mplates"; - template_item ("Lemma new_lemma : .\nProof.\n\nSave.\n", 6,9, "L"); + template_item ("Lemma new_lemma : .\nProof.\n\nSave.\n", 6,9, "J"); template_item ("Theorem new_theorem : .\nProof.\n\nSave.\n", 8,11, "T"); template_item ("Definition ident := .\n", 11,5, "E"); template_item ("Inductive ident : :=\n | : .\n", 10,5, "I"); template_item ("Fixpoint ident (_ : _) {struct _} : _ :=\n.\n", 9,5, "F"); template_item ("Scheme new_scheme := Induction for _ Sort _\n" ^ "with _ := Induction for _ Sort _.\n", 7,10, "S"); - item "match" ~label:"match ..." ~accel:(prefs.modifier_for_templates^"C") + item "match" ~label:"match ..." ~accel:(modifier_for_templates#get^"M") ~callback:match_callback ]; alpha_items templates_menu "Template" Coq_commands.commands; - let qitem s accel = item s ~label:("_"^s) ?accel ~callback:(Query.query s) in + let qitem s sc ?(dots = true) = + let query = if dots then s ^ "..." else 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" (Some "F2"); - qitem "Check" (Some "F3"); - qitem "Print" (Some "F4"); - qitem "About" (Some "F5"); - qitem "Locate" None; - qitem "Print Assumptions" None; - qitem "Whelp Locate" None; + qitem "Search" "K" ~dots:false; + 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"; @@ -1188,17 +1161,17 @@ let build_ui () = item "Help" ~label:"_Help"; item "Browse Coq Manual" ~label:"Browse Coq _Manual" ~callback:(fun _ -> - browse notebook#current_term.messages#add (doc_url ())); + browse notebook#current_term.messages#add_string (doc_url ())); item "Browse Coq Library" ~label:"Browse Coq _Library" ~callback:(fun _ -> - browse notebook#current_term.messages#add prefs.library_url); + browse notebook#current_term.messages#add_string library_url#get); item "Help for keyword" ~label:"Help for _keyword" ~stock:`HELP ~callback:(fun _ -> on_current_term (fun sn -> - browse_keyword sn.messages#add (get_current_word sn))); + browse_keyword sn.messages#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#clear; - sn.messages#add (NanoPG.get_documentation ()))); + sn.messages#add_string (NanoPG.get_documentation ()))); item "About Coq" ~label:"_About" ~stock:`ABOUT ~callback:MiscMenu.about ]; @@ -1236,7 +1209,7 @@ let build_ui () = (* Reset on tab switch *) let _ = notebook#connect#switch_page ~callback:(fun _ -> - if prefs.reset_on_tab_switch then Nav.restart ()) + if reset_on_tab_switch#get then Nav.restart ()) in (* Vertical Separator between Scripts and Goals *) @@ -1244,7 +1217,7 @@ let build_ui () = let () = refresh_notebook_pos () in let lower_hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in let () = lower_hbox#pack ~expand:true status#coerce in - let () = push_info ("Ready"^ if current.nanoPG then ", [μPG]" else "") in + let () = push_info ("Ready"^ if nanoPG#get then ", [μPG]" else "") in (* Location display *) let l = GMisc.label @@ -1287,45 +1260,33 @@ let build_ui () = let _ = Glib.Timeout.add ~ms:300 ~callback in (* Initializing hooks *) - let refresh_toolbar () = - if prefs.show_toolbar - then toolbar#misc#show () - else toolbar#misc#hide () - in - let refresh_style () = - let style = style_manager#style_scheme prefs.source_style in + 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 () = - let lang = lang_manager#language prefs.source_language 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 resize_window () = - w#resize ~width:prefs.window_width ~height:prefs.window_height + let refresh_toolbar b = + if b then toolbar#misc#show () else toolbar#misc#hide () in - refresh_toolbar (); - refresh_toolbar_hook := refresh_toolbar; - refresh_style_hook := refresh_style; - refresh_language_hook := refresh_language; - refresh_editor_hook := refresh_editor_prefs; - resize_window_hook := resize_window; - refresh_tabs_hook := refresh_notebook_pos; + stick show_toolbar toolbar refresh_toolbar; + let _ = source_style#connect#changed refresh_style in + let _ = source_language#connect#changed refresh_language in (* Color configuration *) - Tags.set_processing_color (Tags.color_of_string prefs.processing_color); - Tags.set_processed_color (Tags.color_of_string prefs.processed_color); Tags.Script.incomplete#set_property (`BACKGROUND_STIPPLE (Gdk.Bitmap.create_from_data ~width:2 ~height:2 "\x01\x02")); - Tags.Script.incomplete#set_property - (`BACKGROUND_GDK (Tags.get_processed_color ())); (* Showtime ! *) w#show () + (** {2 Coqide main function } *) let make_file_buffer f = @@ -1335,7 +1296,7 @@ let make_file_buffer f = let make_scratch_buffer () = let session = create_session None in let _ = notebook#append_term session in - !refresh_editor_hook () + () let main files = build_ui (); diff --git a/ide/coqide.mli b/ide/coqide.mli index 6691512845..744b974ffa 100644 --- a/ide/coqide.mli +++ b/ide/coqide.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/coqide_main.ml4 b/ide/coqide_main.ml4 index db69ec661f..534a3f179d 100644 --- a/ide/coqide_main.ml4 +++ b/ide/coqide_main.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml index af71b1e78c..2ae18593ac 100644 --- a/ide/coqide_ui.ml +++ b/ide/coqide_ui.ml @@ -18,6 +18,15 @@ let list_items menu li = 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> <menubar name='CoqIde MenuBar'> @@ -119,7 +128,8 @@ let init () = <menuitem action='About' /> <menuitem action='Locate' /> <menuitem action='Print Assumptions' /> - <menuitem action='Whelp Locate' /> + <separator /> + %s </menu> <menu name='Tools' action='Tools'> <menuitem action='Comment' /> @@ -163,5 +173,6 @@ let init () = (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/coqidetop.mllib b/ide/coqidetop.mllib index 92301dc30e..ed1fa465d2 100644 --- a/ide/coqidetop.mllib +++ b/ide/coqidetop.mllib @@ -1,2 +1,9 @@ +Xml_lexer +Xml_parser +Xml_printer +Serialize +Richprinter Xmlprotocol +Texmacspp +Document Ide_slave diff --git a/ide/document.ml b/ide/document.ml index 9823e7576c..62457fe56b 100644 --- a/ide/document.ml +++ b/ide/document.ml @@ -16,8 +16,8 @@ type id = Stateid.t class type ['a] signals = object - method popped : callback:('a -> unit) -> unit - method pushed : callback:('a -> unit) -> unit + 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 () = @@ -32,14 +32,14 @@ end type 'a document = { mutable stack : 'a sentence list; mutable context : ('a sentence list * 'a sentence list) option; - pushed_sig : 'a signal; - popped_sig : 'a signal; + pushed_sig : ('a * ('a list * 'a list) option) signal; + popped_sig : ('a * ('a list * 'a list) option) signal; } -let connect d = +let connect d : 'a signals = object - method pushed ~callback = d.pushed_sig#connect callback - method popped ~callback = d.popped_sig#connect callback + 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 () = { @@ -49,6 +49,12 @@ let create () = { 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 @@ -64,12 +70,13 @@ let tip_data = function let push d x = assert(invariant d.stack); d.stack <- { data = x; state_id = None } :: d.stack; - d.pushed_sig#call x + 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; data - + | { 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"; @@ -124,12 +131,6 @@ let context d = let pair _ x y = try Option.get x, y with Option.IsNone -> assert false in List.map (flat pair true) top, List.map (flat pair true) bot -let iter d f = - let a, s, b = to_lists d in - List.iter (flat f false) a; - List.iter (flat f true) s; - List.iter (flat f false) b - let stateid_opt_equal = Option.equal Stateid.equal let is_in_focus d id = @@ -154,7 +155,7 @@ let cut_at d id = 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; + for _i = 1 to n do ignore(pop d) done; List.rev zone let find_id d f = diff --git a/ide/document.mli b/ide/document.mli index 0d803ff003..fb96cb6d76 100644 --- a/ide/document.mli +++ b/ide/document.mli @@ -108,8 +108,8 @@ val print : class type ['a] signals = object - method popped : callback:('a -> unit) -> unit - method pushed : callback:('a -> unit) -> unit + 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/fileOps.ml b/ide/fileOps.ml index 03b3fcd4ee..7be1bdb927 100644 --- a/ide/fileOps.ml +++ b/ide/fileOps.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ open Ideutils -let prefs = Preferences.current - let revert_timer = mktimer () let autosave_timer = mktimer () @@ -87,7 +85,7 @@ object(self) flash_info "Could not overwrite file" | _ -> Minilib.log "Auto revert set to false"; - prefs.Preferences.global_auto_revert <- false; + Preferences.global_auto_revert#set false; revert_timer.kill () method save f = @@ -120,9 +118,9 @@ object(self) | None -> None | Some f -> let dir = Filename.dirname f in - let base = (fst prefs.Preferences.auto_save_name) ^ + let base = (fst Preferences.auto_save_name#get) ^ (Filename.basename f) ^ - (snd prefs.Preferences.auto_save_name) + (snd Preferences.auto_save_name#get) in Some (Filename.concat dir base) method private need_auto_save = diff --git a/ide/fileOps.mli b/ide/fileOps.mli index 48b7c8f656..9f0b75ac56 100644 --- a/ide/fileOps.mli +++ b/ide/fileOps.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/gtk_parsing.ml b/ide/gtk_parsing.ml index abbd7e6d59..f905053ddb 100644 --- a/ide/gtk_parsing.ml +++ b/ide/gtk_parsing.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -166,3 +166,16 @@ let find_nearest_backward (cursor:GText.iter) targets = | None -> raise Not_found | Some nearest -> nearest +(** 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/ide.mllib b/ide/ide.mllib index e082bd18c1..72a14134bf 100644 --- a/ide/ide.mllib +++ b/ide/ide.mllib @@ -1,26 +1,26 @@ Minilib -Okey -Config_file -Configwin_keys -Configwin_types Configwin_messages Configwin_ihm Configwin -Editable_cells Config_parser Tags -Wg_Segment Wg_Notebook Config_lexer Utf8_convert Preferences Project_file -Ideutils +Serialize +Richprinter +Xml_lexer +Xml_parser +Xml_printer Xmlprotocol +Ideutils Coq Coq_lex Sentence Gtk_parsing +Wg_Segment Wg_ProofView Wg_MessageView Wg_Detachable diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index ac38f1ea5a..48fd0a93e4 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -1,17 +1,22 @@ (************************************************************************) + (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) open Vernacexpr -open Errors +open CErrors open Util open Pp open Printer +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration +module CompactedDecl = Context.Compacted.Declaration + (** Ide_slave : an implementation of [Interface], i.e. mainly an interp function and a rewind function. This specialized loop is triggered when the -ideslave option is passed to Coqtop. Currently CoqIDE is @@ -47,6 +52,7 @@ let init_stdout, read_stdout = 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 = @@ -94,15 +100,15 @@ let is_undo cmd = match cmd with (** Check whether a command is forbidden by CoqIDE *) let coqide_cmd_checks (loc,ast) = - let user_error s = Errors.user_err_loc (loc, "CoqIde", str s) in + let user_error s = CErrors.user_err ~loc ~hdr:"CoqIde" (str s) in if is_debug ast then user_error "Debug mode not available within CoqIDE"; if is_known_option ast then - msg_warning (strbrk"This will not work. Use CoqIDE display menu instead"); + Feedback.msg_warning (strbrk"This will not work. Use CoqIDE view menu instead"); if Vernac.is_navigation_vernac ast || is_undo ast then - msg_warning (strbrk "Rather use CoqIDE navigation instead"); + Feedback.msg_warning (strbrk "Rather use CoqIDE navigation instead"); if is_query ast then - msg_warning (strbrk "Query commands should not be inserted in scripts") + Feedback.msg_warning (strbrk "Query commands should not be inserted in scripts") (** Interpretation (cf. [Ide_intf.interp]) *) @@ -123,14 +129,16 @@ let annotate phrase = let pa = Pcoq.Gram.parsable (Stream.of_string phrase) in Vernac.parse_sentence (pa,None) in - let (_, _, xml) = + let (_, xml) = Richprinter.richpp_vernac ast in xml (** Goal display *) -let hyp_next_tac sigma env (id,_,ast) = +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 [ @@ -184,14 +192,17 @@ let process_goal sigma g = let id = Goal.uid g in let ccl = let norm_constr = Reductionops.nf_evar sigma (Goal.V82.concl sigma g) in - string_of_ppcmds (pr_goal_concl_style_env env sigma norm_constr) in - let process_hyp d = - let d = Context.map_named_list_declaration (Reductionops.nf_evar sigma) d in - (string_of_ppcmds (pr_var_list_decl min_env sigma d)) in - let hyps = - List.map process_hyp - (Termops.compact_named_context_reverse (Environ.named_context env)) in - { Interface.goal_hyp = hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; } + Richpp.richpp_of_pp (pr_goal_concl_style_env env sigma norm_constr) + in + let process_hyp d (env,l) = + let d = CompactedDecl.map_constr (Reductionops.nf_evar sigma) d in + let d' = CompactedDecl.to_named_context d in + (List.fold_right Environ.push_named d' env, + (Richpp.richpp_of_pp (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 export_pre_goals pgs = { @@ -204,7 +215,7 @@ let export_pre_goals pgs = let goals () = Stm.finish (); let s = read_stdout () in - if not (String.is_empty s) then msg_info (str s); + if not (String.is_empty s) then Feedback.msg_info (str s); try let pfts = Proof_global.give_me_the_proof () in Some (export_pre_goals (Proof.map_structured_proof pfts process_goal)) @@ -214,7 +225,7 @@ let evars () = try Stm.finish (); let s = read_stdout () in - if not (String.is_empty s) then msg_info (str s); + if not (String.is_empty s) then Feedback.msg_info (str s); let pfts = Proof_global.give_me_the_proof () in let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in let exl = Evar.Map.bindings (Evarutil.non_instantiated sigma) in @@ -247,7 +258,7 @@ let status force = Stm.finish (); if force then Stm.join (); let s = read_stdout () in - if not (String.is_empty s) then msg_info (str s); + if not (String.is_empty s) then Feedback.msg_info (str s); let path = let l = Names.DirPath.repr (Lib.cwd ()) in List.rev_map Names.Id.to_string l @@ -273,11 +284,33 @@ let export_coq_object t = { Interface.coq_object_object = 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 constr in + pat + +let dirpath_of_string_list s = + let path = String.concat "." s in + let m = Pcoq.parse_string Pcoq.Constr.global path in + let (_, qid) = Libnames.qualid_of_reference m 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 s - | Interface.Type_Pattern s -> Search.Type_Pattern s - | Interface.SubType_Pattern s -> Search.SubType_Pattern s - | Interface.In_Module ms -> Search.In_Module ms + | Interface.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 = @@ -289,11 +322,13 @@ 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 = s.Goptions.opt_sync; @@ -312,6 +347,8 @@ let set_options options = | BoolValue b -> Goptions.set_bool_option_value name b | IntValue i -> Goptions.set_int_option_value name i | StringValue s -> Goptions.set_string_option_value name s + | StringOptValue (Some s) -> Goptions.set_string_option_value name s + | StringOptValue None -> Goptions.unset_option_value_gen None name in List.iter iter options @@ -327,14 +364,18 @@ let handle_exn (e, info) = let loc_of e = match Loc.get_loc e with | Some loc when not (Loc.is_ghost loc) -> Some (Loc.unloc loc) | _ -> None in - let mk_msg e = read_stdout ()^"\n"^string_of_ppcmds (Errors.print e) in + let mk_msg () = + let msg = read_stdout () in + let msg = str msg ++ fnl () ++ CErrors.print ~info e in + Richpp.richpp_of_pp msg + in match e with - | Errors.Drop -> dummy, None, "Drop is not allowed by coqide!" - | Errors.Quit -> dummy, None, "Quit is not allowed by coqide!" + | CErrors.Drop -> dummy, None, Richpp.richpp_of_string "Drop is not allowed by coqide!" + | CErrors.Quit -> dummy, None, Richpp.richpp_of_string "Quit is not allowed by coqide!" | e -> match Stateid.get info with - | Some (valid, _) -> valid, loc_of info, mk_msg e - | None -> dummy, loc_of info, mk_msg e + | Some (valid, _) -> valid, loc_of info, mk_msg () + | None -> dummy, loc_of info, mk_msg () let init = let initialized = ref false in @@ -345,8 +386,6 @@ let init = match file with | None -> Stm.get_current_state () | Some file -> - if not (Filename.check_suffix file ".v") then - error "A file with suffix .v is expected."; let dir = Filename.dirname file in let open Loadpath in let open CUnix in let initial_id, _ = @@ -355,6 +394,7 @@ let init = 0 (Printf.sprintf "Add LoadPath \"%s\". " dir) else Stm.get_current_state (), `NewTip in Stm.set_compilation_hints file; + Stm.finish (); initial_id end @@ -376,6 +416,15 @@ let interp ((_raw, verbose), s) = let quit = ref false +(** Serializes the output of Stm.get_ast *) +let print_ast id = + match Stm.get_ast id with + | Some (expr, loc) -> begin + try Texmacspp.tmpp expr loc + with e -> Xml_datatype.PCData ("ERROR " ^ Printexc.to_string e) + end + | None -> Xml_datatype.PCData "ERROR" + (** Grouping all call handlers together + error handling *) let eval_call xml_oc log c = @@ -406,7 +455,7 @@ let eval_call xml_oc log c = Interface.interp = interruptible interp; Interface.handle_exn = handle_exn; Interface.stop_worker = Stm.stop_worker; - Interface.print_ast = Stm.print_ast; + Interface.print_ast = print_ast; Interface.annotate = interruptible annotate; } in Xmlprotocol.abstract_eval_call handler c @@ -421,22 +470,18 @@ let print_xml = fun oc xml -> Mutex.lock m; try Xml_printer.print oc xml; Mutex.unlock m - with e -> let e = Errors.push e in Mutex.unlock m; iraise e + with e -> let e = CErrors.push e in Mutex.unlock m; iraise e -let slave_logger xml_oc level message = +let slave_logger xml_oc ?loc level message = (* convert the message into XML *) - let msg = string_of_ppcmds (hov 0 message) in - let message = { - Pp.message_level = level; - Pp.message_content = msg; - } in - let () = pr_debug (Printf.sprintf "-> %S" msg) in - let xml = Pp.of_message message in + let msg = hov 0 message in + let () = pr_debug (Printf.sprintf "-> %S" (string_of_ppcmds msg)) in + let xml = Xmlprotocol.of_message level loc (Richpp.richpp_of_pp message) in print_xml xml_oc xml let slave_feeder xml_oc msg = - let xml = Feedback.of_feedback msg in + let xml = Xmlprotocol.of_feedback msg in print_xml xml_oc xml (** The main loop *) @@ -454,8 +499,8 @@ let loop () = CThread.thread_friendly_read in_ch s ~off:0 ~len) in let xml_ic = Xml_parser.make (Xml_parser.SLexbuf in_lb) in let () = Xml_parser.check_eof xml_ic false in - set_logger (slave_logger xml_oc); - set_feeder (slave_feeder xml_oc); + Feedback.set_logger (slave_logger xml_oc); + Feedback.add_feeder (slave_feeder xml_oc); (* We'll handle goal fetching and display in our own way *) Vernacentries.enable_goal_printing := false; Vernacentries.qed_display_script := false; @@ -463,9 +508,9 @@ let loop () = try let xml_query = Xml_parser.parse xml_ic in (* pr_with_pid (Xml_printer.to_string_fmt xml_query); *) - let q = Xmlprotocol.to_call xml_query in + let Xmlprotocol.Unknown q = Xmlprotocol.to_call xml_query in let () = pr_debug_call q in - let r = eval_call xml_oc (slave_logger xml_oc Pp.Notice) q in + let r = eval_call xml_oc (slave_logger xml_oc Feedback.Notice) q in let () = pr_debug_answer q r in (* pr_with_pid (Xml_printer.to_string_fmt (Xmlprotocol.of_answer q r)); *) print_xml xml_oc (Xmlprotocol.of_answer q r); @@ -475,11 +520,11 @@ let loop () = pr_debug "End of input, exiting gracefully."; exit 0 | Xml_parser.Error (err, loc) -> - pr_debug ("Syntax error in query: " ^ Xml_parser.error_msg err); - exit 1 - | Serialize.Marshal_error -> - pr_debug "Incorrect query."; - exit 1 + 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 diff --git a/ide/ideutils.ml b/ide/ideutils.ml index d2305b58c1..06a1327320 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,8 +9,6 @@ open Preferences -exception Forbidden - let warn_image () = let img = GMisc.image () in img#set_stock `DIALOG_WARNING; @@ -31,13 +29,54 @@ let push_info,pop_info,clear_info = 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) + (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) - +let xml_to_string xml = + let open Xml_datatype in + let buf = Buffer.create 1024 in + let rec iter = function + | PCData s -> Buffer.add_string buf s + | Element (_, _, children) -> + List.iter iter children + in + let () = iter (Richpp.repr xml) in + Buffer.contents buf + +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 tags + +let insert_xml ?(mark = `INSERT) ?(tags = []) (buf : #GText.buffer_skel) msg = + let open Xml_datatype 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 + let rec insert tags = function + | PCData s -> insert_with_tags buf mark rmark tags s + | Element (t, _, children) -> + let tags = try tag t :: tags with Not_found -> tags in + List.iter (fun xml -> insert tags xml) children + in + let () = try insert tags (Richpp.repr msg) with _ -> () in + buf#delete_mark rmark let set_location = ref (function s -> failwith "not ready") @@ -74,7 +113,7 @@ let do_convert s = in let s = if Glib.Utf8.validate s then (Minilib.log "Input is UTF-8"; s) - else match current.encoding with + else match encoding#get with |Preferences.Eutf8 | Preferences.Elocale -> from_loc () |Emanual enc -> try from_manual enc with _ -> from_loc () in @@ -87,10 +126,28 @@ let try_convert s = "(* 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 current.encoding with + try match encoding#get with |Eutf8 -> Minilib.log "UTF-8 is enforced" ; s |Elocale -> let is_unicode,char_set = Glib.Convert.get_charset () in @@ -109,11 +166,7 @@ let try_export file_name s = Minilib.log ("Error ("^str^") in transcoding: falling back to UTF-8"); s in - try - let oc = open_out file_name in - output_string oc s; - close_out oc; - true + try export file_name s; true with e -> Minilib.log (Printexc.to_string e);false type timer = { run : ms:int -> callback:(unit->bool) -> unit; @@ -132,8 +185,6 @@ let mktimer () = with Glib.GError _ -> ()); timer := None) } -let last_dir = ref "" - let filter_all_files () = GFile.filter ~name:"All" ~patterns:["*"] () @@ -142,8 +193,11 @@ let filter_coq_files () = GFile.filter ~name:"Coq source code" ~patterns:[ "*.v"] () -let select_file_for_open ~title () = - let file = ref None in +let current_dir () = match project_path#get with +| None -> "" +| Some dir -> dir + +let select_file_for_open ~title ?filename () = let file_chooser = GWindow.file_chooser_dialog ~action:`OPEN ~modal:true ~title () in @@ -152,19 +206,22 @@ let select_file_for_open ~title () = file_chooser#add_filter (filter_coq_files ()); file_chooser#add_filter (filter_all_files ()); file_chooser#set_default_response `OPEN; - ignore (file_chooser#set_current_folder !last_dir); - begin match file_chooser#run () with + 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 - file := file_chooser#filename; - match !file with - | None -> () - | Some s -> last_dir := Filename.dirname s; + match file_chooser#filename with + | None -> None + | Some _ as f -> + project_path#set file_chooser#current_folder; f end - | `DELETE_EVENT | `CANCEL -> () - end ; + | `DELETE_EVENT | `CANCEL -> None in file_chooser#destroy (); - !file + file let select_file_for_save ~title ?filename () = let file = ref None in @@ -175,13 +232,10 @@ let select_file_for_save ~title ?filename () = file_chooser#add_select_button_stock `SAVE `SAVE ; file_chooser#add_filter (filter_coq_files ()); file_chooser#add_filter (filter_all_files ()); - (* this line will be used when a lablgtk >= 2.10.0 is the default - on most distributions: - file_chooser#set_do_overwrite_confirmation true; - *) + file_chooser#set_do_overwrite_confirmation true; file_chooser#set_default_response `SAVE; let dir,filename = match filename with - |None -> !last_dir, "" + |None -> current_dir (), "" |Some f -> Filename.dirname f, Filename.basename f in ignore (file_chooser#set_current_folder dir); @@ -192,7 +246,7 @@ let select_file_for_save ~title ?filename () = file := file_chooser#filename; match !file with None -> () - | Some s -> last_dir := Filename.dirname s; + | Some s -> project_path#set file_chooser#current_folder end | `DELETE_EVENT | `CANCEL -> () end ; @@ -237,7 +291,7 @@ let coqtop_path () = let file = match !custom_coqtop with | Some s -> s | None -> - match current.cmd_coqtop with + match cmd_coqtop#get with | Some s -> s | None -> let prog = String.copy Sys.executable_name in @@ -246,7 +300,14 @@ let coqtop_path () = let i = Str.search_backward (Str.regexp_string "coqide") prog pos in String.blit "coqtop" 0 prog i 6; - if Sys.file_exists prog then prog else "coqtop" + if Sys.file_exists prog then prog + else + let in_macos_bundle = + Filename.concat + (Filename.dirname prog) + (Filename.concat "../Resources/bin" (Filename.basename prog)) + in if Sys.file_exists in_macos_bundle then in_macos_bundle + else "coqtop" with Not_found -> "coqtop" in file @@ -264,22 +325,22 @@ let textview_width (view : #GText.view_skel) = let char_width = GPango.to_pixels metrics#approx_char_width in pixel_width / char_width -type logger = Pp.message_level -> string -> unit +type logger = Feedback.level -> Richpp.richpp -> unit let default_logger level message = let level = match level with - | Pp.Debug _ -> `DEBUG - | Pp.Info -> `INFO - | Pp.Notice -> `NOTICE - | Pp.Warning -> `WARNING - | Pp.Error -> `ERROR + | Feedback.Debug -> `DEBUG + | Feedback.Info -> `INFO + | Feedback.Notice -> `NOTICE + | Feedback.Warning -> `WARNING + | Feedback.Error -> `ERROR in - Minilib.log ~level message + Minilib.log ~level (xml_to_string message) (** {6 File operations} *) -(** A customized [stat] function. Exceptions are catched. *) +(** A customized [stat] function. Exceptions are caught. *) type stats = MTime of float | NoSuchFile | OtherError @@ -303,7 +364,7 @@ let read_buffer = Buffer.create maxread I/O Exceptions are propagated. *) let read_file name buf = - let ic = open_in name in + 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 @@ -356,7 +417,7 @@ let run_command display finally cmd = (** Web browsing *) let browse prerr url = - let com = Util.subst_command_placeholder current.cmd_browse url in + let com = Util.subst_command_placeholder cmd_browse#get url in let finally = function | Unix.WEXITED 127 -> prerr @@ -367,13 +428,13 @@ let browse prerr url = run_command (fun _ -> ()) finally com let doc_url () = - if current.doc_url = use_default_doc_url || current.doc_url = "" + if doc_url#get = use_default_doc_url || doc_url#get = "" then let addr = List.fold_left Filename.concat (Coq_config.docdir) ["html";"refman";"index.html"] in if Sys.file_exists addr then "file://"^addr else Coq_config.wwwrefman - else current.doc_url + else doc_url#get let url_for_keyword = let ht = Hashtbl.create 97 in diff --git a/ide/ideutils.mli b/ide/ideutils.mli index 8269582dfe..e32a4d9e38 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -29,7 +29,7 @@ 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 -> unit -> string option +val select_file_for_open : title:string -> ?filename:string -> unit -> string option val select_file_for_save : title:string -> ?filename:string -> unit -> string option val try_convert : string -> string @@ -52,6 +52,11 @@ val pop_info : unit -> unit val clear_info : unit -> unit val flash_info : ?delay:int -> string -> unit +val xml_to_string : Richpp.richpp -> string + +val insert_xml : ?mark:GText.mark -> ?tags:GText.tag list -> + #GText.buffer_skel -> Richpp.richpp -> unit + val set_location : (string -> unit) ref (* In win32, when a command-line is to be executed via cmd.exe @@ -64,14 +69,14 @@ val requote : string -> string val textview_width : #GText.view_skel -> int (** Returns an approximate value of the character width of a textview *) -type logger = Pp.message_level -> string -> unit +type logger = Feedback.level -> Richpp.richpp -> unit -val default_logger : Pp.message_level -> string -> 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 catched. *) +(** A customized [stat] function. Exceptions are caught. *) type stats = MTime of float | NoSuchFile | OtherError val stat : string -> stats diff --git a/ide/interface.mli b/ide/interface.mli index 464e851f6d..2a9b8b241f 100644 --- a/ide/interface.mli +++ b/ide/interface.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,14 +12,15 @@ type raw = bool type verbose = bool +type richpp = Richpp.richpp (** The type of coqtop goals *) type goal = { goal_id : string; (** Unique goal identifier *) - goal_hyp : string list; + goal_hyp : richpp list; (** List of hypotheses *) - goal_ccl : string; + goal_ccl : richpp; (** Goal conclusion *) } @@ -61,6 +62,7 @@ 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 = { @@ -117,7 +119,7 @@ type edit_id = Feedback.edit_id should probably retract to that point *) type 'a value = | Good of 'a - | Fail of (state_id * location * string) + | Fail of (state_id * location * richpp) type ('a, 'b) union = ('a, 'b) Util.union @@ -201,7 +203,7 @@ type about_sty = unit type about_rty = coq_info type handle_exn_sty = Exninfo.iexn -type handle_exn_rty = state_id * location * string +type handle_exn_rty = state_id * location * richpp (* Retrocompatibility stuff *) type interp_sty = (raw * verbose) * string diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml index 805ace935c..93bdeb324c 100644 --- a/ide/nanoPG.ml +++ b/ide/nanoPG.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -303,7 +303,7 @@ let init w nb ags = then false else begin eprintf "got key %s\n%!" (pr_key t); - if current.nanoPG then begin + 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); diff --git a/ide/preferences.ml b/ide/preferences.ml index c850613253..f0fd45d77f 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -17,19 +17,67 @@ let style_manager = GSourceView2.source_style_scheme_manager ~default:true let () = style_manager#set_search_path ((Minilib.coqide_data_dirs ())@style_manager#search_path) -let get_config_file name = - let find_config dir = Sys.file_exists (Filename.concat dir name) in - let config_dir = List.find find_config (Minilib.coqide_config_dirs ()) in - Filename.concat config_dir name +type tag = { + tag_fg_color : string option; + tag_bg_color : string option; + tag_bold : bool; + tag_italic : bool; + tag_underline : bool; +} -(* 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" +(** Generic preferences *) -let loaded_accel_file = - try get_config_file "coqide.keys" - with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqide.keys" +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 : #GObj.widget as 'obj) + (cb : 'a -> unit) = + let _ = cb pref#get in + let p_id = pref#connect#changed (fun v -> cb v) in + let _ = obj#misc#connect#destroy (fun () -> pref#connect#disconnect p_id) in + () + +(** Useful marshallers *) let mod_to_str m = match m with @@ -74,351 +122,537 @@ let inputenc_of_string s = 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 = CString.split 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; + ] + method into = function + | [fg; bg; bd; it; ul] -> + (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; + } + 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" (** Hooks *) -let refresh_style_hook = ref (fun () -> ()) -let refresh_language_hook = ref (fun () -> ()) -let refresh_editor_hook = ref (fun () -> ()) -let refresh_toolbar_hook = ref (fun () -> ()) -let contextual_menus_on_goal_hook = ref (fun x -> ()) -let resize_window_hook = ref (fun () -> ()) -let refresh_tabs_hook = ref (fun () -> ()) +(** New style preferences *) -type pref = - { - mutable cmd_coqtop : string option; - mutable cmd_coqc : string; - mutable cmd_make : string; - mutable cmd_coqmakefile : string; - mutable cmd_coqdoc : string; +let cmd_coqtop = + new preference ~name:["cmd_coqtop"] ~init:None ~repr:Repr.(option string) - mutable source_language : string; - mutable source_style : string; +let cmd_coqc = + new preference ~name:["cmd_coqc"] ~init:"coqc" ~repr:Repr.(string) - mutable global_auto_revert : bool; - mutable global_auto_revert_delay : int; +let cmd_make = + new preference ~name:["cmd_make"] ~init:"make" ~repr:Repr.(string) - mutable auto_save : bool; - mutable auto_save_delay : int; - mutable auto_save_name : string * string; +let cmd_coqmakefile = + new preference ~name:["cmd_coqmakefile"] ~init:"coq_makefile -o makefile *.v" ~repr:Repr.(string) - mutable read_project : project_behavior; - mutable project_file_name : string; +let cmd_coqdoc = + new preference ~name:["cmd_coqdoc"] ~init:"coqdoc -q -g" ~repr:Repr.(string) - mutable encoding : inputenc; +let source_language = + new preference ~name:["source_language"] ~init:"coq" ~repr:Repr.(string) - mutable automatic_tactics : string list; - mutable cmd_print : string; +let source_style = + new preference ~name:["source_style"] ~init:"coq_style" ~repr:Repr.(string) - mutable modifier_for_navigation : string; - mutable modifier_for_templates : string; - mutable modifier_for_tactics : string; - mutable modifier_for_display : string; - mutable modifiers_valid : string; +let global_auto_revert = + new preference ~name:["global_auto_revert"] ~init:false ~repr:Repr.(bool) - mutable cmd_browse : string; - mutable cmd_editor : string; +let global_auto_revert_delay = + new preference ~name:["global_auto_revert_delay"] ~init:10000 ~repr:Repr.(int) - mutable text_font : Pango.font_description; +let auto_save = + new preference ~name:["auto_save"] ~init:true ~repr:Repr.(bool) - mutable doc_url : string; - mutable library_url : string; +let auto_save_delay = + new preference ~name:["auto_save_delay"] ~init:10000 ~repr:Repr.(int) - mutable show_toolbar : bool; - mutable contextual_menus_on_goal : bool; - mutable window_width : int; - mutable window_height :int; - mutable query_window_width : int; - mutable query_window_height : int; -(* - mutable use_utf8_notation : bool; -*) - mutable auto_complete : bool; - mutable stop_before : bool; - mutable reset_on_tab_switch : bool; - mutable vertical_tabs : bool; - mutable opposite_tabs : bool; - - mutable background_color : string; - mutable processing_color : string; - mutable processed_color : string; - mutable error_color : string; - - mutable dynamic_word_wrap : bool; - mutable show_line_number : bool; - mutable auto_indent : bool; - mutable show_spaces : bool; - mutable show_right_margin : bool; - mutable show_progress_bar : bool; - mutable spaces_instead_of_tabs : bool; - mutable tab_length : int; - mutable highlight_current_line : bool; - - mutable nanoPG : bool; +let 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 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 cmd_browse = + new preference ~name:["cmd_browse"] ~init:Flags.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 doc_url = +object + inherit [string] preference + ~name:["doc_url"] ~init:Coq_config.wwwrefman ~repr:Repr.(string) + as super + + method set v = + if not (Flags.is_standard_doc_url v) && + v <> use_default_doc_url && + (* Extra hack to support links to last released doc version *) + v <> Coq_config.wwwcoq ^ "doc" && + v <> Coq_config.wwwcoq ^ "doc/" + then super#set v + +end + +let library_url = + new preference ~name:["library_url"] ~init:Coq_config.wwwstdlib ~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_bg (pref : string preference) (tag : GText.tag) = + pref#connect#changed (fun c -> tag#set_property (`BACKGROUND c)) + +let attach_fg (pref : string preference) (tag : GText.tag) = + pref#connect#changed (fun c -> tag#set_property (`FOREGROUND c)) + +let processing_color = + new preference ~name:["processing_color"] ~init:"light blue" ~repr:Repr.(string) + +let _ = attach_bg processing_color Tags.Script.to_process +let _ = attach_bg processing_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) () = { + tag_fg_color = fg; + tag_bg_color = bg; + tag_bold = bold; + tag_italic = italic; + tag_underline = underline; } -let use_default_doc_url = "(automatic)" +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; + in + let iter table = + let tag = GText.tag ~name () in + table#add tag#as_tag; + ignore (pref#connect#changed (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 -let current = { - cmd_coqtop = None; - cmd_coqc = "coqc"; - cmd_make = "make"; - cmd_coqmakefile = "coq_makefile -o makefile *.v"; - cmd_coqdoc = "coqdoc -q -g"; - cmd_print = "lpr"; +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 ()); + ] - global_auto_revert = false; - global_auto_revert_delay = 10000; +let processed_color = + new preference ~name:["processed_color"] ~init:"light green" ~repr:Repr.(string) - auto_save = true; - auto_save_delay = 10000; - auto_save_name = "#","#"; +let _ = attach_bg processed_color Tags.Script.processed +let _ = attach_bg processed_color Tags.Proof.highlight - source_language = "coq"; - source_style = "coq_style"; +let error_color = + new preference ~name:["error_color"] ~init:"#FFCCCC" ~repr:Repr.(string) - read_project = Ignore_args; - project_file_name = "_CoqProject"; +let _ = attach_bg error_color Tags.Script.error_bg - encoding = if Sys.os_type = "Win32" then Eutf8 else Elocale; +let error_fg_color = + new preference ~name:["error_fg_color"] ~init:"red" ~repr:Repr.(string) - automatic_tactics = ["trivial"; "tauto"; "auto"; "omega"; - "auto with *"; "intuition" ]; +let _ = attach_fg error_fg_color Tags.Script.error - modifier_for_navigation = "<Control><Alt>"; - modifier_for_templates = "<Control><Shift>"; - modifier_for_tactics = "<Control><Alt>"; - modifier_for_display = "<Alt><Shift>"; - modifiers_valid = "<Alt><Control><Shift>"; +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) - cmd_browse = Flags.browser_cmd_fmt; - cmd_editor = if Sys.os_type = "Win32" then "NOTEPAD %s" else "emacs %s"; +let auto_indent = + new preference ~name:["auto_indent"] ~init:false ~repr:Repr.(bool) -(* text_font = Pango.Font.from_string "sans 12";*) - text_font = Pango.Font.from_string (match Coq_config.gtk_platform with - |`QUARTZ -> "Arial Unicode MS 11" - |_ -> "Monospace 10"); +let show_spaces = + new preference ~name:["show_spaces"] ~init:true ~repr:Repr.(bool) - doc_url = Coq_config.wwwrefman; - library_url = Coq_config.wwwstdlib; +let show_right_margin = + new preference ~name:["show_right_margin"] ~init:false ~repr:Repr.(bool) - show_toolbar = true; - contextual_menus_on_goal = true; - window_width = 800; - window_height = 600; - query_window_width = 600; - query_window_height = 400; -(* - use_utf8_notation = false; -*) - auto_complete = false; - stop_before = true; - reset_on_tab_switch = false; - vertical_tabs = false; - opposite_tabs = false; - - background_color = "cornsilk"; - processed_color = "light green"; - processing_color = "light blue"; - error_color = "#FFCCCC"; - - dynamic_word_wrap = false; - show_line_number = false; - auto_indent = false; - show_spaces = true; - show_right_margin = false; - show_progress_bar = true; - spaces_instead_of_tabs = true; - tab_length = 2; - highlight_current_line = false; - - nanoPG = false; - } +let 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 '$') + +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 () + + 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 (Tags.color_of_string 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; + + method tag = + let get but set = + if set#active then None + else Some (Tags.string_of_color 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; + } + + 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; + 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; + let cb but obj = obj#set_sensitive (not but#active) in + let _ = fg_unset#connect#toggled (fun () -> cb fg_unset fg_color#misc) in + let _ = bg_unset#connect#toggled (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 p = current in - - let add = Util.String.Map.add in - let (++) x f = f x in - Util.String.Map.empty ++ - add "cmd_coqtop" (match p.cmd_coqtop with | None -> [] | Some v-> [v]) ++ - add "cmd_coqc" [p.cmd_coqc] ++ - add "cmd_make" [p.cmd_make] ++ - add "cmd_coqmakefile" [p.cmd_coqmakefile] ++ - add "cmd_coqdoc" [p.cmd_coqdoc] ++ - add "source_language" [p.source_language] ++ - add "source_style" [p.source_style] ++ - add "global_auto_revert" [string_of_bool p.global_auto_revert] ++ - add "global_auto_revert_delay" - [string_of_int p.global_auto_revert_delay] ++ - add "auto_save" [string_of_bool p.auto_save] ++ - add "auto_save_delay" [string_of_int p.auto_save_delay] ++ - add "auto_save_name" [fst p.auto_save_name; snd p.auto_save_name] ++ - - add "project_options" [string_of_project_behavior p.read_project] ++ - add "project_file_name" [p.project_file_name] ++ - - add "encoding" [string_of_inputenc p.encoding] ++ - - add "automatic_tactics" p.automatic_tactics ++ - add "cmd_print" [p.cmd_print] ++ - add "modifier_for_navigation" [p.modifier_for_navigation] ++ - add "modifier_for_templates" [p.modifier_for_templates] ++ - add "modifier_for_tactics" [p.modifier_for_tactics] ++ - add "modifier_for_display" [p.modifier_for_display] ++ - add "modifiers_valid" [p.modifiers_valid] ++ - add "cmd_browse" [p.cmd_browse] ++ - add "cmd_editor" [p.cmd_editor] ++ - - add "text_font" [Pango.Font.to_string p.text_font] ++ - - add "doc_url" [p.doc_url] ++ - add "library_url" [p.library_url] ++ - add "show_toolbar" [string_of_bool p.show_toolbar] ++ - add "contextual_menus_on_goal" - [string_of_bool p.contextual_menus_on_goal] ++ - add "window_height" [string_of_int p.window_height] ++ - add "window_width" [string_of_int p.window_width] ++ - add "query_window_height" [string_of_int p.query_window_height] ++ - add "query_window_width" [string_of_int p.query_window_width] ++ - add "auto_complete" [string_of_bool p.auto_complete] ++ - add "stop_before" [string_of_bool p.stop_before] ++ - add "reset_on_tab_switch" [string_of_bool p.reset_on_tab_switch] ++ - add "vertical_tabs" [string_of_bool p.vertical_tabs] ++ - add "opposite_tabs" [string_of_bool p.opposite_tabs] ++ - add "background_color" [p.background_color] ++ - add "processing_color" [p.processing_color] ++ - add "processed_color" [p.processed_color] ++ - add "error_color" [p.error_color] ++ - add "dynamic_word_wrap" [string_of_bool p.dynamic_word_wrap] ++ - add "show_line_number" [string_of_bool p.show_line_number] ++ - add "auto_indent" [string_of_bool p.auto_indent] ++ - add "show_spaces" [string_of_bool p.show_spaces] ++ - add "show_right_margin" [string_of_bool p.show_right_margin] ++ - add "show_progress_bar" [string_of_bool p.show_progress_bar] ++ - add "spaces_instead_of_tabs" [string_of_bool p.spaces_instead_of_tabs] ++ - add "tab_length" [string_of_int p.tab_length] ++ - add "highlight_current_line" [string_of_bool p.highlight_current_line] ++ - add "nanoPG" [string_of_bool p.nanoPG] ++ - Config_lexer.print_file pref_file + let 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 np = current in - let set k f = try let v = Util.String.Map.find k m in f v with _ -> () in - let set_hd k f = set k (fun v -> f (List.hd v)) in - let set_bool k f = set_hd k (fun v -> f (bool_of_string v)) in - let set_int k f = set_hd k (fun v -> f (int_of_string v)) in - let set_pair k f = set k (function [v1;v2] -> f v1 v2 | _ -> raise Exit) in - let set_command_with_pair_compat k f = - set k (function [v1;v2] -> f (v1^"%s"^v2) | [v] -> f v | _ -> raise Exit) + 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 - let set_option k f = set k (fun v -> f (match v with |[] -> None |h::_ -> Some h)) in - set_option "cmd_coqtop" (fun v -> np.cmd_coqtop <- v); - set_hd "cmd_coqc" (fun v -> np.cmd_coqc <- v); - set_hd "cmd_make" (fun v -> np.cmd_make <- v); - set_hd "cmd_coqmakefile" (fun v -> np.cmd_coqmakefile <- v); - set_hd "cmd_coqdoc" (fun v -> np.cmd_coqdoc <- v); - set_hd "source_language" (fun v -> np.source_language <- v); - set_hd "source_style" (fun v -> np.source_style <- v); - set_bool "global_auto_revert" (fun v -> np.global_auto_revert <- v); - set_int "global_auto_revert_delay" - (fun v -> np.global_auto_revert_delay <- v); - set_bool "auto_save" (fun v -> np.auto_save <- v); - set_int "auto_save_delay" (fun v -> np.auto_save_delay <- v); - set_pair "auto_save_name" (fun v1 v2 -> np.auto_save_name <- (v1,v2)); - set_hd "encoding" (fun v -> np.encoding <- (inputenc_of_string v)); - set_hd "project_options" - (fun v -> np.read_project <- (project_behavior_of_string v)); - set_hd "project_file_name" (fun v -> np.project_file_name <- v); - set "automatic_tactics" - (fun v -> np.automatic_tactics <- v); - set_hd "cmd_print" (fun v -> np.cmd_print <- v); - set_hd "modifier_for_navigation" - (fun v -> np.modifier_for_navigation <- v); - set_hd "modifier_for_templates" - (fun v -> np.modifier_for_templates <- v); - set_hd "modifier_for_tactics" - (fun v -> np.modifier_for_tactics <- v); - set_hd "modifier_for_display" - (fun v -> np.modifier_for_display <- v); - set_hd "modifiers_valid" - (fun v -> - np.modifiers_valid <- v); - set_command_with_pair_compat "cmd_browse" (fun v -> np.cmd_browse <- v); - set_command_with_pair_compat "cmd_editor" (fun v -> np.cmd_editor <- v); - set_hd "text_font" (fun v -> np.text_font <- Pango.Font.from_string v); - set_hd "doc_url" (fun v -> - if not (Flags.is_standard_doc_url v) && - v <> use_default_doc_url && - (* Extra hack to support links to last released doc version *) - v <> Coq_config.wwwcoq ^ "doc" && - v <> Coq_config.wwwcoq ^ "doc/" - then - (* ("Warning: Non-standard URL for Coq documentation in preference file: "^v);*) - np.doc_url <- v); - set_hd "library_url" (fun v -> np.library_url <- v); - set_bool "show_toolbar" (fun v -> np.show_toolbar <- v); - set_bool "contextual_menus_on_goal" - (fun v -> np.contextual_menus_on_goal <- v); - set_int "window_width" (fun v -> np.window_width <- v); - set_int "window_height" (fun v -> np.window_height <- v); - set_int "query_window_width" (fun v -> np.query_window_width <- v); - set_int "query_window_height" (fun v -> np.query_window_height <- v); - set_bool "auto_complete" (fun v -> np.auto_complete <- v); - set_bool "stop_before" (fun v -> np.stop_before <- v); - set_bool "reset_on_tab_switch" (fun v -> np.reset_on_tab_switch <- v); - set_bool "vertical_tabs" (fun v -> np.vertical_tabs <- v); - set_bool "opposite_tabs" (fun v -> np.opposite_tabs <- v); - set_hd "background_color" (fun v -> np.background_color <- v); - set_hd "processing_color" (fun v -> np.processing_color <- v); - set_hd "processed_color" (fun v -> np.processed_color <- v); - set_hd "error_color" (fun v -> np.error_color <- v); - set_bool "dynamic_word_wrap" (fun v -> np.dynamic_word_wrap <- v); - set_bool "show_line_number" (fun v -> np.show_line_number <- v); - set_bool "auto_indent" (fun v -> np.auto_indent <- v); - set_bool "show_spaces" (fun v -> np.show_spaces <- v); - set_bool "show_right_margin" (fun v -> np.show_right_margin <- v); - set_bool "show_progress_bar" (fun v -> np.show_progress_bar <- v); - set_bool "spaces_instead_of_tabs" (fun v -> np.spaces_instead_of_tabs <- v); - set_int "tab_length" (fun v -> np.tab_length <- v); - set_bool "highlight_current_line" (fun v -> np.highlight_current_line <- v); - set_bool "nanoPG" (fun v -> np.nanoPG <- v); - () + 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 () -> ())) () = let cmd_coqtop = string - ~f:(fun s -> current.cmd_coqtop <- if s = "AUTO" then None else Some s) - " coqtop" (match current.cmd_coqtop with |None -> "AUTO" | Some x -> x) in - let cmd_coqc = - string - ~f:(fun s -> current.cmd_coqc <- s) - " coqc" current.cmd_coqc in - let cmd_make = - string - ~f:(fun s -> current.cmd_make <- s) - " make" current.cmd_make in - let cmd_coqmakefile = - string - ~f:(fun s -> current.cmd_coqmakefile <- s) - "coqmakefile" current.cmd_coqmakefile in - let cmd_coqdoc = - string - ~f:(fun s -> current.cmd_coqdoc <- s) - " coqdoc" current.cmd_coqdoc in - let cmd_print = - string - ~f:(fun s -> current.cmd_print <- s) - " Print ps" current.cmd_print in + ~f:(fun s -> cmd_coqtop#set (if s = "AUTO" then None else Some s)) + " coqtop" (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 @@ -427,18 +661,13 @@ let configure ?(apply=(fun () -> ())) () = "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 - (Pango.Font.to_string current.text_font))); + ~callback:(fun () -> w#set_font_name text_font#get)); custom ~label:"Fonts for text" box (fun () -> let fd = w#font_name in - current.text_font <- (Pango.Font.from_string fd) ; -(* - Format.printf "in config_font: current.text_font = %s@." (Pango.Font.to_string current.text_font); -*) - !refresh_editor_hook ()) + text_font#set fd) true in @@ -450,110 +679,94 @@ let configure ?(apply=(fun () -> ())) () = ~border_width:2 ~packing:(box#pack ~expand:true) () in - let background_label = GMisc.label - ~text:"Background color" - ~packing:(table#attach ~expand:`X ~left:0 ~top:0) () - in - let processed_label = GMisc.label - ~text:"Background color of processed text" - ~packing:(table#attach ~expand:`X ~left:0 ~top:1) () - in - let processing_label = GMisc.label - ~text:"Background color of text being processed" - ~packing:(table#attach ~expand:`X ~left:0 ~top:2) () - in - let error_label = GMisc.label - ~text:"Background color of errors" - ~packing:(table#attach ~expand:`X ~left:0 ~top:3) () - in - let () = background_label#set_xalign 0. in - let () = processed_label#set_xalign 0. in - let () = processing_label#set_xalign 0. in - let () = error_label#set_xalign 0. in - let background_button = GButton.color_button - ~color:(Tags.color_of_string (current.background_color)) - ~packing:(table#attach ~left:1 ~top:0) () - in - let processed_button = GButton.color_button - ~color:(Tags.get_processed_color ()) - ~packing:(table#attach ~left:1 ~top:1) () - in - let processing_button = GButton.color_button - ~color:(Tags.get_processing_color ()) - ~packing:(table#attach ~left:1 ~top:2) () - in - let error_button = GButton.color_button - ~color:(Tags.get_error_color ()) - ~packing:(table#attach ~left:1 ~top:3) () - in let reset_button = GButton.button ~label:"Reset" ~packing:box#pack () in - let reset_cb () = - background_button#set_color (Tags.color_of_string "cornsilk"); - processing_button#set_color (Tags.color_of_string "light blue"); - processed_button#set_color (Tags.color_of_string "light green"); - error_button#set_color (Tags.color_of_string "#FFCCCC"); + let iter i (text, pref) = + let label = GMisc.label + ~text ~packing:(table#attach ~expand:`X ~left:0 ~top:i) () + in + let () = label#set_xalign 0. in + let button = GButton.color_button + ~color:(Tags.color_of_string pref#get) + ~packing:(table#attach ~left:1 ~top:i) () + in + let _ = button#connect#color_set begin fun () -> + pref#set (Tags.string_of_color button#color) + end in + let reset _ = + pref#reset (); + button#set_color Tags.(color_of_string pref#get) + in + let _ = reset_button#connect#clicked ~callback:reset in + () in - let _ = reset_button#connect#clicked ~callback:reset_cb 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 errors", error_color); + ("Foreground color of errors", error_fg_color); + ] in let label = "Color configuration" in - let callback () = - current.background_color <- Tags.string_of_color background_button#color; - current.processing_color <- Tags.string_of_color processing_button#color; - current.processed_color <- Tags.string_of_color processed_button#color; - current.error_color <- Tags.string_of_color error_button#color; - !refresh_editor_hook (); - Tags.set_processing_color processing_button#color; - Tags.set_processed_color processed_button#color; - Tags.set_error_color error_button#color + 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 table = GPack.table + ~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:(table#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; + table#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 gen_button text active = - GButton.check_button ~label:text ~active ~packing:box#pack () in - let wrap = gen_button "Dynamic word wrap" current.dynamic_word_wrap in - let line = gen_button "Show line number" current.show_line_number in - let auto_indent = gen_button "Auto indentation" current.auto_indent in - let auto_complete = gen_button "Auto completion" current.auto_complete in - let show_spaces = gen_button "Show spaces" current.show_spaces in - let show_right_margin = gen_button "Show right margin" current.show_right_margin in - let show_progress_bar = gen_button "Show progress bar" current.show_progress_bar in - let spaces_instead_of_tabs = - gen_button "Insert spaces instead of tabs" - current.spaces_instead_of_tabs - in - let highlight_current_line = - gen_button "Highlight current line" - current.highlight_current_line - in - let nanoPG = gen_button "Emacs/PG keybindings (μPG mode)" current.nanoPG in -(* let lbox = GPack.hbox ~packing:box#pack () in *) -(* let _ = GMisc.label ~text:"Tab width" *) -(* ~xalign:0. *) -(* ~packing:(lbox#pack ~expand:true) () *) -(* in *) -(* let tab_width = GEdit.spin_button *) -(* ~digits:0 ~packing:lbox#pack () *) -(* in *) - let callback () = - current.dynamic_word_wrap <- wrap#active; - current.show_line_number <- line#active; - current.auto_indent <- auto_indent#active; - current.show_spaces <- show_spaces#active; - current.show_right_margin <- show_right_margin#active; - current.show_progress_bar <- show_progress_bar#active; - current.spaces_instead_of_tabs <- spaces_instead_of_tabs#active; - current.highlight_current_line <- highlight_current_line#active; - current.nanoPG <- nanoPG#active; - current.auto_complete <- auto_complete#active; -(* current.tab_length <- tab_width#value_as_int; *) - !refresh_editor_hook () + 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 (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 @@ -581,170 +794,110 @@ let configure ?(apply=(fun () -> ())) () = (string_of_int current.window_width) in *) -(* let use_utf8_notation = - bool - ~f:(fun b -> - current.use_utf8_notation <- b; - ) - "Use Unicode Notation: " current.use_utf8_notation - in -*) (* let config_appearance = [show_toolbar; window_width; window_height] in *) - let global_auto_revert = - bool - ~f:(fun s -> current.global_auto_revert <- s) - "Enable global auto revert" current.global_auto_revert - in + let global_auto_revert = pbool "Enable global auto revert" global_auto_revert in let global_auto_revert_delay = string - ~f:(fun s -> current.global_auto_revert_delay <- + ~f:(fun s -> global_auto_revert_delay#set (try int_of_string s with _ -> 10000)) "Global auto revert delay (ms)" - (string_of_int current.global_auto_revert_delay) + (string_of_int global_auto_revert_delay#get) in - let auto_save = - bool - ~f:(fun s -> current.auto_save <- s) - "Enable auto save" current.auto_save - in + let auto_save = pbool "Enable auto save" auto_save in let auto_save_delay = string - ~f:(fun s -> current.auto_save_delay <- + ~f:(fun s -> auto_save_delay#set (try int_of_string s with _ -> 10000)) "Auto save delay (ms)" - (string_of_int current.auto_save_delay) + (string_of_int auto_save_delay#get) in - let stop_before = - bool - ~f:(fun s -> current.stop_before <- s) - "Stop interpreting before the current point" current.stop_before - in + let stop_before = pbool "Stop interpreting before the current point" stop_before in - let reset_on_tab_switch = - bool - ~f:(fun s -> current.reset_on_tab_switch <- s) - "Reset coqtop on tab switch" current.reset_on_tab_switch - in + let reset_on_tab_switch = pbool "Reset coqtop on tab switch" reset_on_tab_switch in - let vertical_tabs = - bool - ~f:(fun s -> current.vertical_tabs <- s; !refresh_tabs_hook ()) - "Vertical tabs" current.vertical_tabs - in + let vertical_tabs = pbool "Vertical tabs" vertical_tabs in - let opposite_tabs = - bool - ~f:(fun s -> current.opposite_tabs <- s; !refresh_tabs_hook ()) - "Tabs on opposite side" current.opposite_tabs - in + let opposite_tabs = pbool "Tabs on opposite side" opposite_tabs in let encodings = combo "File charset encoding " - ~f:(fun s -> current.encoding <- (inputenc_of_string s)) + ~f:(fun s -> encoding#set (inputenc_of_string s)) ~new_allowed: true - ("UTF-8"::"LOCALE":: match current.encoding with + ("UTF-8"::"LOCALE":: match encoding#get with |Emanual s -> [s] |_ -> [] ) - (string_of_inputenc current.encoding) + (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 = - let f s = - current.source_style <- s; - !refresh_style_hook () - in combo "Highlighting style:" - ~f ~new_allowed:false - style_manager#style_scheme_ids current.source_style + ~f:source_style#set ~new_allowed:false + style_manager#style_scheme_ids source_style#get in let source_language = - let f s = - current.source_language <- s; - !refresh_language_hook () - in combo "Language:" - ~f ~new_allowed:false + ~f:source_language#set ~new_allowed:false (List.filter (fun x -> Str.string_match (Str.regexp "^coq") x 0) lang_manager#language_ids) - current.source_language + source_language#get in let read_project = combo "Project file options are" - ~f:(fun s -> current.read_project <- project_behavior_of_string s) + ~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 current.read_project) - in - let project_file_name = - string "Default name for project file" - ~f:(fun s -> current.project_file_name <- s) - current.project_file_name - in - let help_string = - "restart to apply" + (string_of_project_behavior read_project#get) in - let the_valid_mod = str_to_mod_list current.modifiers_valid in + let project_file_name = pstring "Default name for project file" project_file_name in let modifier_for_tactics = - modifiers - ~allow:the_valid_mod - ~f:(fun l -> current.modifier_for_tactics <- mod_list_to_str l) - ~help:help_string - "Modifiers for Tactics Menu" - (str_to_mod_list current.modifier_for_tactics) + pmodifiers "Modifiers for Tactics Menu" modifier_for_tactics in let modifier_for_templates = - modifiers - ~allow:the_valid_mod - ~f:(fun l -> current.modifier_for_templates <- mod_list_to_str l) - ~help:help_string - "Modifiers for Templates Menu" - (str_to_mod_list current.modifier_for_templates) + pmodifiers "Modifiers for Templates Menu" modifier_for_templates in let modifier_for_navigation = - modifiers - ~allow:the_valid_mod - ~f:(fun l -> current.modifier_for_navigation <- mod_list_to_str l) - ~help:help_string - "Modifiers for Navigation Menu" - (str_to_mod_list current.modifier_for_navigation) + pmodifiers "Modifiers for Navigation Menu" modifier_for_navigation in let modifier_for_display = - modifiers - ~allow:the_valid_mod - ~f:(fun l -> current.modifier_for_display <- mod_list_to_str l) - ~help:help_string - "Modifiers for View Menu" - (str_to_mod_list current.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 = - modifiers - ~f:(fun l -> - current.modifiers_valid <- mod_list_to_str l) - "Allowed modifiers" - the_valid_mod + 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:(fun s -> current.cmd_editor <- s) + ~f:cmd_editor#set ~new_allowed: true - (predefined@[if List.mem current.cmd_editor predefined then "" - else current.cmd_editor]) - current.cmd_editor + (predefined@[if List.mem cmd_editor#get predefined then "" + else cmd_editor#get]) + cmd_editor#get in let cmd_browse = let predefined = [ @@ -757,58 +910,82 @@ let configure ?(apply=(fun () -> ())) () = combo ~help:"(%s for url)" "Browser" - ~f:(fun s -> current.cmd_browse <- s) + ~f:cmd_browse#set ~new_allowed: true - (predefined@[if List.mem current.cmd_browse predefined then "" - else current.cmd_browse]) - current.cmd_browse + (predefined@[if List.mem cmd_browse#get predefined then "" + else cmd_browse#get]) + cmd_browse#get in let doc_url = let predefined = [ - "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["html";"refman";""]); + "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["refman";"html"]); Coq_config.wwwrefman; use_default_doc_url ] in combo "Manual URL" - ~f:(fun s -> current.doc_url <- s) + ~f:doc_url#set ~new_allowed: true - (predefined@[if List.mem current.doc_url predefined then "" - else current.doc_url]) - current.doc_url in + (predefined@[if List.mem doc_url#get predefined then "" + else doc_url#get]) + doc_url#get in let library_url = let predefined = [ - "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["html";"stdlib";""]); + "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["stdlib";"html"]); Coq_config.wwwstdlib ] in combo "Library URL" - ~f:(fun s -> current.library_url <- s) + ~f:(fun s -> library_url#set s) ~new_allowed: true - (predefined@[if List.mem current.library_url predefined then "" - else current.library_url]) - current.library_url + (predefined@[if List.mem library_url#get predefined then "" + else library_url#get]) + library_url#get in let automatic_tactics = strings - ~f:(fun l -> current.automatic_tactics <- l) + ~f:automatic_tactics#set ~add:(fun () -> ["<edit me>"]) "Wizard tactics to try in order" - current.automatic_tactics + automatic_tactics#get in - let contextual_menus_on_goal = - bool - ~f:(fun s -> - current.contextual_menus_on_goal <- s; - !contextual_menus_on_goal_hook s) - "Contextual menus on goal" current.contextual_menus_on_goal - 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 = CString.uppercase 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 = @@ -816,11 +993,13 @@ let configure ?(apply=(fun () -> ())) () = [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; + encodings; line_ending; ]); Section("Project", Some (`STOCK "gtk-page-setup"), [project_file_name;read_project; @@ -836,9 +1015,10 @@ let configure ?(apply=(fun () -> ())) () = [automatic_tactics]); Section("Shortcuts", Some `PREFERENCES, [modifiers_valid; modifier_for_tactics; - modifier_for_templates; modifier_for_display; modifier_for_navigation]); + modifier_for_templates; modifier_for_display; modifier_for_navigation; + modifier_for_queries; user_queries]); Section("Misc", Some `ADD, - misc)] + misc)] in (* Format.printf "before edit: current.text_font = %s@." (Pango.Font.to_string current.text_font); diff --git a/ide/preferences.mli b/ide/preferences.mli index 1b52d20a4c..801869d1dc 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -11,94 +11,101 @@ val style_manager : GSourceView2.source_style_scheme_manager type project_behavior = Ignore_args | Append_args | Subst_args type inputenc = Elocale | Eutf8 | Emanual of string - -type pref = - { - mutable cmd_coqtop : string option; - mutable cmd_coqc : string; - mutable cmd_make : string; - mutable cmd_coqmakefile : string; - mutable cmd_coqdoc : string; - - mutable source_language : string; - mutable source_style : string; - - mutable global_auto_revert : bool; - mutable global_auto_revert_delay : int; - - mutable auto_save : bool; - mutable auto_save_delay : int; - mutable auto_save_name : string * string; - - mutable read_project : project_behavior; - mutable project_file_name : string; - - mutable encoding : inputenc; - - mutable automatic_tactics : string list; - mutable cmd_print : string; - - mutable modifier_for_navigation : string; - mutable modifier_for_templates : string; - mutable modifier_for_tactics : string; - mutable modifier_for_display : string; - mutable modifiers_valid : string; - - mutable cmd_browse : string; - mutable cmd_editor : string; - - mutable text_font : Pango.font_description; - - mutable doc_url : string; - mutable library_url : string; - - mutable show_toolbar : bool; - mutable contextual_menus_on_goal : bool; - mutable window_width : int; - mutable window_height : int; - mutable query_window_width : int; - mutable query_window_height : int; -(* - mutable use_utf8_notation : bool; -*) - mutable auto_complete : bool; - mutable stop_before : bool; - mutable reset_on_tab_switch : bool; - mutable vertical_tabs : bool; - mutable opposite_tabs : bool; - - mutable background_color : string; - mutable processing_color : string; - mutable processed_color : string; - mutable error_color : string; - - mutable dynamic_word_wrap : bool; - mutable show_line_number : bool; - mutable auto_indent : bool; - mutable show_spaces : bool; - mutable show_right_margin : bool; - mutable show_progress_bar : bool; - mutable spaces_instead_of_tabs : bool; - mutable tab_length : int; - mutable highlight_current_line : bool; - - mutable nanoPG : bool; - - } +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; +} + +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 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 doc_url : string preference +val library_url : 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 save_pref : unit -> unit val load_pref : unit -> unit -val current : pref - val configure : ?apply:(unit -> unit) -> unit -> unit -(* Hooks *) -val refresh_editor_hook : (unit -> unit) ref -val refresh_style_hook : (unit -> unit) ref -val refresh_language_hook : (unit -> unit) ref -val refresh_toolbar_hook : (unit -> unit) ref -val resize_window_hook : (unit -> unit) ref -val refresh_tabs_hook : (unit -> unit) ref +val stick : 'a preference -> + (#GObj.widget as 'obj) -> ('a -> unit) -> unit val use_default_doc_url : string diff --git a/ide/project_file.ml4 b/ide/project_file.ml4 index 41dc1befa2..de0720e033 100644 --- a/ide/project_file.ml4 +++ b/ide/project_file.ml4 @@ -28,6 +28,7 @@ let rec parse_string = parser and parse_string2 = parser | [< ''"' >] -> "" | [< 'c; s >] -> (String.make 1 c)^(parse_string2 s) + | [< >] -> raise Parsing_error and parse_skip_comment = parser | [< ''\n'; s >] -> s | [< 'c; s >] -> parse_skip_comment s @@ -47,7 +48,7 @@ let parse f = res let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) l = function - | [] -> opts,List.rev l + | [] -> opts, l | ("-h"|"--help") :: _ -> raise Parsing_error | ("-no-opt"|"-byte") :: r -> @@ -55,24 +56,24 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) | ("-full"|"-opt") :: r -> process_cmd_line orig_dir (project_file,makefile,install,true) l r | "-impredicative-set" :: r -> - Pp.msg_warning (Pp.str "Please now use \"-arg -impredicative-set\" instead of \"-impredicative-set\" alone to be more uniform."); + Feedback.msg_warning (Pp.str "Please now use \"-arg -impredicative-set\" instead of \"-impredicative-set\" alone to be more uniform."); process_cmd_line orig_dir opts (Arg "-impredicative-set" :: l) r | "-no-install" :: r -> - Pp.msg_warning (Pp.(++) (Pp.str "Option -no-install is deprecated.") (Pp.(++) (Pp.spc ()) (Pp.str "Use \"-install none\" instead"))); + Feedback.msg_warning (Pp.(++) (Pp.str "Option -no-install is deprecated.") (Pp.(++) (Pp.spc ()) (Pp.str "Use \"-install none\" instead"))); process_cmd_line orig_dir (project_file,makefile,NoInstall,opt) l r | "-install" :: d :: r -> - if install <> UnspecInstall then Pp.msg_warning (Pp.str "-install sets more than once."); + if install <> UnspecInstall then Feedback.msg_warning (Pp.str "-install sets more than once."); let install = match d with | "user" -> UserInstall | "none" -> NoInstall | "global" -> TraditionalInstall - | _ -> Pp.msg_warning (Pp.(++) (Pp.str "invalid option '") (Pp.(++) (Pp.str d) (Pp.str "' passed to -install."))); + | _ -> Feedback.msg_warning (Pp.(++) (Pp.str "invalid option '") (Pp.(++) (Pp.str d) (Pp.str "' passed to -install."))); install in process_cmd_line orig_dir (project_file,makefile,install,opt) l r | "-custom" :: com :: dependencies :: file :: r -> - Pp.msg_warning (Pp.app + Feedback.msg_warning (Pp.app (Pp.str "Please now use \"-extra[-phony] result deps command\" instead of \"-custom command deps result\".") (Pp.pr_arg Pp.str "It follows makefile target declaration order and has a clearer semantic.") ); @@ -85,7 +86,6 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) process_cmd_line orig_dir opts ((Include (CUnix.correct_path d orig_dir, lp)) :: l) r | "-I" :: d :: r -> process_cmd_line orig_dir opts ((MLInclude (CUnix.correct_path d orig_dir)) :: l) r - | "-R" :: p :: "-as" :: lp :: r | "-R" :: p :: lp :: r -> process_cmd_line orig_dir opts (RInclude (CUnix.correct_path p orig_dir,lp) :: l) r | ("-Q"|"-R"|"-I"|"-custom"|"-extra"|"-extra-phony") :: _ -> @@ -94,7 +94,7 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) let file = CUnix.remove_path_dot (CUnix.correct_path file orig_dir) in let () = match project_file with | None -> () - | Some _ -> Pp.msg_warning (Pp.str + | Some _ -> Feedback.msg_warning (Pp.str "Several features will not work with multiple project files.") in let (opts',l') = process_cmd_line (Filename.dirname file) (Some file,makefile,install,opt) l (parse file) in @@ -109,7 +109,7 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) let () = match makefile with |None -> () |Some f -> - Pp.msg_warning (Pp.(++) (Pp.str "Only one output file is genererated. ") (Pp.(++) (Pp.str f) (Pp.str " will not be."))) + Feedback.msg_warning (Pp.(++) (Pp.str "Only one output file is genererated. ") (Pp.(++) (Pp.str f) (Pp.str " will not be."))) in process_cmd_line orig_dir (project_file,Some file,install,opt) l r end | v :: "=" :: def :: r -> @@ -127,6 +127,10 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) else if (Filename.check_suffix f ".mlpack") then MLPACK f else Subdir f) :: l) r +let process_cmd_line orig_dir opts l args = + let (opts, l) = process_cmd_line orig_dir opts l args in + opts, List.rev l + let rec post_canonize f = if Filename.basename f = Filename.current_dir_name then let dir = Filename.dirname f in @@ -134,77 +138,65 @@ let rec post_canonize f = else f (* Return: ((v,(mli,ml4,ml,mllib,mlpack),special,subdir),(ml_inc,q_inc,r_inc),(args,defs)) *) -let split_arguments = - let rec aux = function - | V n :: r -> - let (v,m,o,s),i,d = aux r in ((CUnix.remove_path_dot n::v,m,o,s),i,d) - | ML n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(mli,ml4,CUnix.remove_path_dot n::ml,mllib,mlpack),o,s),i,d) - | MLI n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(CUnix.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d) - | ML4 n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(mli,CUnix.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d) - | MLLIB n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(mli,ml4,ml,CUnix.remove_path_dot n::mllib,mlpack),o,s),i,d) - | MLPACK n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(mli,ml4,ml,mllib,CUnix.remove_path_dot n::mlpack),o,s),i,d) - | Special (n,dep,is_phony,c) :: r -> - let (v,m,o,s),i,d = aux r in ((v,m,(n,dep,is_phony,c)::o,s),i,d) - | Subdir n :: r -> - let (v,m,o,s),i,d = aux r in ((v,m,o,n::s),i,d) - | MLInclude p :: r -> - let t,(ml,q,r),d = aux r in (t,((CUnix.remove_path_dot (post_canonize p), - CUnix.canonical_path_name p)::ml,q,r),d) - | Include (p,l) :: r -> - let t,(ml,i,r),d = aux r in - let i_new = (CUnix.remove_path_dot (post_canonize p),l, - CUnix.canonical_path_name p) in - (t,(ml,i_new::i,r),d) - | RInclude (p,l) :: r -> - let t,(ml,i,r),d = aux r in - let r_new = (CUnix.remove_path_dot (post_canonize p),l, - CUnix.canonical_path_name p) in - (t,(ml,i,r_new::r),d) - | Def (v,def) :: r -> - let t,i,(args,defs) = aux r in (t,i,(args,(v,def)::defs)) - | Arg a :: r -> - let t,i,(args,defs) = aux r in (t,i,(a::args,defs)) - | [] -> ([],([],[],[],[],[]),[],[]),([],[],[]),([],[]) - in aux +let split_arguments args = + List.fold_right + (fun a ((v,(mli,ml4,ml,mllib,mlpack as m),o,s as t), + (ml_inc,q_inc,r_inc as i),(args,defs as d)) -> + match a with + | V n -> + ((CUnix.remove_path_dot n::v,m,o,s),i,d) + | ML n -> + ((v,(mli,ml4,CUnix.remove_path_dot n::ml,mllib,mlpack),o,s),i,d) + | MLI n -> + ((v,(CUnix.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d) + | ML4 n -> + ((v,(mli,CUnix.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d) + | MLLIB n -> + ((v,(mli,ml4,ml,CUnix.remove_path_dot n::mllib,mlpack),o,s),i,d) + | MLPACK n -> + ((v,(mli,ml4,ml,mllib,CUnix.remove_path_dot n::mlpack),o,s),i,d) + | Special (n,dep,is_phony,c) -> + ((v,m,(n,dep,is_phony,c)::o,s),i,d) + | Subdir n -> + ((v,m,o,n::s),i,d) + | MLInclude p -> + let ml_new = (CUnix.remove_path_dot (post_canonize p), + CUnix.canonical_path_name p) in + (t,(ml_new::ml_inc,q_inc,r_inc),d) + | Include (p,l) -> + let q_new = (CUnix.remove_path_dot (post_canonize p),l, + CUnix.canonical_path_name p) in + (t,(ml_inc,q_new::q_inc,r_inc),d) + | RInclude (p,l) -> + let r_new = (CUnix.remove_path_dot (post_canonize p),l, + CUnix.canonical_path_name p) in + (t,(ml_inc,q_inc,r_new::r_inc),d) + | Def (v,def) -> + (t,i,(args,(v,def)::defs)) + | Arg a -> + (t,i,(a::args,defs))) + args (([],([],[],[],[],[]),[],[]),([],[],[]),([],[])) let read_project_file f = split_arguments (snd (process_cmd_line (Filename.dirname f) (Some f, None, NoInstall, true) [] (parse f))) let args_from_project file project_files default_name = - let is_f = CUnix.same_file file in - let contains_file dir = - List.exists (fun x -> is_f (CUnix.correct_path x dir)) - in let build_cmd_line ml_inc i_inc r_inc args = List.fold_right (fun (_,i) o -> "-I" :: i :: o) ml_inc (List.fold_right (fun (_,l,i) o -> "-Q" :: i :: l :: o) i_inc (List.fold_right (fun (_,l,p) o -> "-R" :: p :: l :: o) r_inc (List.fold_right (fun a o -> parse_args (Stream.of_string a) @ o) args []))) in try - let (_,(_,(ml_inc,i_inc,r_inc),(args,_))) = - List.find (fun (dir,((v_files,_,_,_),_,_)) -> - contains_file dir v_files) project_files in - build_cmd_line ml_inc i_inc r_inc args - with Not_found -> + let (fname,(_,(ml_inc,i_inc,r_inc),(args,_))) = List.hd project_files in + fname, build_cmd_line ml_inc i_inc r_inc args + with Failure _ -> let rec find_project_file dir = try + let fname = Filename.concat dir default_name in let ((v_files,_,_,_),(ml_inc,i_inc,r_inc),(args,_)) = - read_project_file (Filename.concat dir default_name) in - if contains_file dir v_files - then build_cmd_line ml_inc i_inc r_inc args - else let newdir = Filename.dirname dir in - if dir = newdir then [] else find_project_file newdir + read_project_file fname in + fname, build_cmd_line ml_inc i_inc r_inc args with Sys_error s -> let newdir = Filename.dirname dir in - if dir = newdir then [] else find_project_file newdir + if dir = newdir then "",[] else find_project_file newdir in find_project_file (Filename.dirname file) diff --git a/ide/richprinter.ml b/ide/richprinter.ml new file mode 100644 index 0000000000..995cef1ac5 --- /dev/null +++ b/ide/richprinter.ml @@ -0,0 +1,23 @@ +open Richpp + +module RichppConstr = Ppconstr.Richpp +module RichppVernac = Ppvernac.Richpp + +type rich_pp = + Ppannotation.t Richpp.located Xml_datatype.gxml + * Xml_datatype.xml + +let get_annotations obj = Pp.Tag.prj obj Ppannotation.tag + +let make_richpp pr ast = + let rich_pp = + rich_pp get_annotations (pr ast) + in + let xml = Ppannotation.( + xml_of_rich_pp tag_of_annotation attributes_of_annotation rich_pp + ) + in + (rich_pp, xml) + +let richpp_vernac = make_richpp RichppVernac.pr_vernac +let richpp_constr = make_richpp RichppConstr.pr_constr_expr diff --git a/ide/richprinter.mli b/ide/richprinter.mli new file mode 100644 index 0000000000..c9e84e3eb4 --- /dev/null +++ b/ide/richprinter.mli @@ -0,0 +1,36 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** This module provides an entry point to "rich" pretty-printers that + produce pretty-printing as done by {!Printer} but with additional + annotations represented as a semi-structured document. + + To understand what are these annotations and how they are represented + as standard XML attributes, please refer to {!Ppannotation}. + + In addition to these annotations, each node of the semi-structured + document contains a [startpos] and an [endpos] attribute that + relate this node to the raw pretty-printing. + Please refer to {!Richpp} for more details. *) + +(** A rich pretty-print is composed of: *) +type rich_pp = + + (** - a generalized semi-structured document whose attributes are + annotations ; *) + Ppannotation.t Richpp.located Xml_datatype.gxml + + (** - an XML document, representing annotations as usual textual + XML attributes. *) + * Xml_datatype.xml + +(** [richpp_vernac phrase] produces a rich pretty-printing of [phrase]. *) +val richpp_vernac : Vernacexpr.vernac_expr -> rich_pp + +(** [richpp_constr constr] produces a rich pretty-printing of [constr]. *) +val richpp_constr : Constrexpr.constr_expr -> rich_pp diff --git a/ide/sentence.ml b/ide/sentence.ml index dd6b10a461..e332682dd0 100644 --- a/ide/sentence.ml +++ b/ide/sentence.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,6 +16,7 @@ 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 = @@ -63,13 +64,13 @@ let grab_sentence_start (iter:GText.iter) soi = (** Search forward the first character immediately after a sentence end *) -let rec grab_sentence_stop (start:GText.iter) = +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 rec grab_ending_dot (start:GText.iter) = +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 diff --git a/ide/sentence.mli b/ide/sentence.mli index f0ba5d22c3..feb3c0ac03 100644 --- a/ide/sentence.mli +++ b/ide/sentence.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/serialize.ml b/ide/serialize.ml new file mode 100644 index 0000000000..7b568501ed --- /dev/null +++ b/ide/serialize.ml @@ -0,0 +1,121 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +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/serialize.mli b/ide/serialize.mli new file mode 100644 index 0000000000..bf9e184ebb --- /dev/null +++ b/ide/serialize.mli @@ -0,0 +1,39 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +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/session.ml b/ide/session.ml index 2936321128..fc6340d283 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ open Preferences -let prefs = Preferences.current - (** A session is a script buffer + proof + messages, interacting with a coqtop, and a few other elements around *) @@ -18,6 +16,7 @@ class type ['a] page = inherit GObj.widget method update : 'a -> unit method on_update : callback:('a -> unit) -> unit + method data : 'a end class type control = @@ -49,8 +48,8 @@ let create_buffer () = let buffer = GSourceView2.source_buffer ~tag_table:Tags.Script.table ~highlight_matching_brackets:true - ?language:(lang_manager#language prefs.source_language) - ?style_scheme:(style_manager#style_scheme prefs.source_style) + ?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 @@ -109,10 +108,10 @@ let set_buffer_handlers let id = ref 0 in fun () -> incr id; !id in let running_action = ref None in - let cancel_signal reason = + let cancel_signal ?(stop_emit=true) reason = Minilib.log ("user_action cancelled: "^reason); action_was_cancelled := true; - GtkSignal.stop_emit () in + if stop_emit then GtkSignal.stop_emit () in let del_mark () = try buffer#delete_mark (`NAME "target") with GText.No_such_mark _ -> () in @@ -125,7 +124,7 @@ let set_buffer_handlers fun () -> (* If Coq is busy due to the current action, we don't cancel *) match !running_action with | Some aid when aid = action -> () - | _ -> cancel_signal "Coq busy" in + | _ -> 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 @@ -133,6 +132,11 @@ let set_buffer_handlers 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; @@ -147,10 +151,9 @@ let set_buffer_handlers 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.read_only then - cancel_signal "Altering read_only text not allowed" else if it#has_tag Tags.Script.processed then call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark)) else if it#has_tag Tags.Script.error_bg then begin @@ -160,16 +163,14 @@ let set_buffer_handlers end end in let delete_cb ~start ~stop = Minilib.log (Printf.sprintf "delete_cb %d %d" start#offset stop#offset); - cur_action := new_action_id (); let min_iter, max_iter = if start#compare stop < 0 then start, stop else stop, start in + let () = 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.to_process then cancel_signal "Altering the script being processed in not implemented" - else if min_iter#has_tag Tags.Script.read_only then - cancel_signal "Altering read_only text not allowed" else if min_iter#has_tag Tags.Script.processed then call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark)) else if min_iter#has_tag Tags.Script.error_bg then @@ -194,12 +195,8 @@ let set_buffer_handlers to a point indicated by coq. *) if !no_coq_action_required then begin let start, stop = get_start (), get_stop () in - buffer#remove_tag Tags.Script.error ~start ~stop; - buffer#remove_tag Tags.Script.error_bg ~start ~stop; - buffer#remove_tag Tags.Script.tooltip ~start ~stop; - buffer#remove_tag Tags.Script.processed ~start ~stop; - buffer#remove_tag Tags.Script.to_process ~start ~stop; - buffer#remove_tag Tags.Script.incomplete ~start ~stop; + List.iter (fun tag -> buffer#remove_tag tag ~start ~stop) + Tags.Script.ephemere; Sentence.tag_on_insert buffer end; end in @@ -236,7 +233,7 @@ let find_int_col s l = let find_string_col s l = match List.assoc s l with `StringC c -> c | _ -> assert false -let make_table_widget cd cb = +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 @@ -250,6 +247,10 @@ let make_table_widget cd cb = ~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 + let refresh clr = data#misc#modify_base [`NORMAL, `NAME clr] in + let _ = background_color#connect#changed refresh in + let _ = data#misc#connect#realize (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) -> @@ -261,21 +262,34 @@ let make_table_widget cd cb = 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 + 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 @@ -299,11 +313,12 @@ let create_errpage (script : Wg_ScriptView.script_view) : errpage = 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 + 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 @@ -338,6 +353,7 @@ let create_jobpage coqtop coqops : jobpage = jobs end method on_update ~callback:cb = callback := cb + method data = !last_update end let create_proof () = @@ -465,7 +481,7 @@ let build_layout (sn:session) = message_frame#misc#show (); detachable#show); detachable#button#misc#hide (); - lbl in + detachable, lbl in let session_tab = GPack.hbox ~homogeneous:false () in let img = GMisc.image ~icon_size:`SMALL_TOOLBAR ~packing:session_tab#pack () in @@ -496,9 +512,17 @@ let build_layout (sn:session) = sn.command#pack_in (session_paned#pack2 ~shrink:false ~resize:false); script_scroll#add sn.script#coerce; proof_scroll#add sn.proof#coerce; - ignore(add_msg_page 0 sn.tab_label#text "Messages" sn.messages#coerce); - let label = add_msg_page 1 sn.tab_label#text "Errors" sn.errpage#coerce in - ignore(add_msg_page 2 sn.tab_label#text "Jobs" sn.jobpage#coerce); + let detach, _ = add_msg_page 0 sn.tab_label#text "Messages" sn.messages#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#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 -> diff --git a/ide/session.mli b/ide/session.mli index 3a6b458582..028a1f9de6 100644 --- a/ide/session.mli +++ b/ide/session.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -14,6 +14,7 @@ class type ['a] page = inherit GObj.widget method update : 'a -> unit method on_update : callback:('a -> unit) -> unit + method data : 'a end class type control = diff --git a/ide/tags.ml b/ide/tags.ml index 04ad9a519c..e4510e7af4 100644 --- a/ide/tags.ml +++ b/ide/tags.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,20 +13,16 @@ let make_tag (tt:GText.tag_table) ~name prop = tt#add new_tag#as_tag; new_tag -let processed_color = ref "light green" -let processing_color = ref "light blue" -let error_color = ref "#FFCCCC" - module Script = struct let table = GText.tag_table () let comment = make_tag table ~name:"comment" [] - let error = make_tag table ~name:"error" [`UNDERLINE `SINGLE ; `FOREGROUND "red"] - let error_bg = make_tag table ~name:"error_bg" [`BACKGROUND !error_color] - let to_process = make_tag table ~name:"to_process" [`BACKGROUND !processing_color] - let processed = make_tag table ~name:"processed" [`BACKGROUND !processed_color] + let error = make_tag table ~name:"error" [`UNDERLINE `SINGLE] + let warning = make_tag table ~name:"warning" [`UNDERLINE `SINGLE; `FOREGROUND "blue"] + 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" [ - `BACKGROUND !processing_color; `BACKGROUND_STIPPLE_SET true; ] let unjustified = make_tag table ~name:"unjustified" [`BACKGROUND "gold"] @@ -34,9 +30,11 @@ struct let sentence = make_tag table ~name:"sentence" [] let tooltip = make_tag table ~name:"tooltip" [] (* debug:`BACKGROUND "blue" *) + let ephemere = + [error; warning; error_bg; tooltip; processed; to_process; incomplete; unjustified] + let all = - [comment; error; error_bg; to_process; processed; incomplete; unjustified; - found; sentence; tooltip] + comment :: found :: sentence :: ephemere let edit_zone = let t = make_tag table ~name:"edit_zone" [`UNDERLINE `SINGLE] in @@ -44,13 +42,11 @@ struct t let all = edit_zone :: all - let read_only = make_tag table ~name:"read_only" [`EDITABLE false ] - end module Proof = struct let table = GText.tag_table () - let highlight = make_tag table ~name:"highlight" [`BACKGROUND !processed_color] + let highlight = make_tag table ~name:"highlight" [] let hypothesis = make_tag table ~name:"hypothesis" [] let goal = make_tag table ~name:"goal" [] end @@ -71,26 +67,3 @@ let string_of_color clr = let color_of_string s = let colormap = Gdk.Color.get_system_colormap () in Gdk.Color.alloc ~colormap (`NAME s) - -let get_processed_color () = color_of_string !processed_color - -let set_processed_color clr = - let s = string_of_color clr in - processed_color := s; - Script.processed#set_property (`BACKGROUND s); - Proof.highlight#set_property (`BACKGROUND s) - -let get_processing_color () = color_of_string !processing_color - -let set_processing_color clr = - let s = string_of_color clr in - processing_color := s; - Script.incomplete#set_property (`BACKGROUND s); - Script.to_process#set_property (`BACKGROUND s) - -let get_error_color () = color_of_string !error_color - -let set_error_color clr = - let s = string_of_color clr in - error_color := s; - Script.error_bg#set_property (`BACKGROUND s) diff --git a/ide/tags.mli b/ide/tags.mli index 9c3261d66d..02e15a5ae4 100644 --- a/ide/tags.mli +++ b/ide/tags.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -11,6 +11,7 @@ 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 @@ -20,10 +21,8 @@ sig 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 - - (* Not part of the all list. Special tags! *) - val read_only : GText.tag end module Proof : @@ -44,12 +43,3 @@ end val string_of_color : Gdk.color -> string val color_of_string : string -> Gdk.color - -val get_processed_color : unit -> Gdk.color -val set_processed_color : Gdk.color -> unit - -val get_processing_color : unit -> Gdk.color -val set_processing_color : Gdk.color -> unit - -val get_error_color : unit -> Gdk.color -val set_error_color : Gdk.color -> unit diff --git a/ide/texmacspp.ml b/ide/texmacspp.ml new file mode 100644 index 0000000000..6fbed38fb4 --- /dev/null +++ b/ide/texmacspp.ml @@ -0,0 +1,764 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Xml_datatype +open Vernacexpr +open Constrexpr +open Names +open Misctypes +open Bigint +open Decl_kinds +open Extend +open Libnames + +let unlock loc = + let start, stop = Loc.unloc loc in + (string_of_int start, string_of_int stop) + +let xmlWithLoc loc ename attr xml = + let start, stop = unlock loc in + Element(ename, [ "begin", start; "end", stop ] @ attr, xml) + +let get_fst_attr_in_xml_list attr xml_list = + let attrs_list = + List.map (function + | Element (_, attrs, _) -> (List.filter (fun (a,_) -> a = attr) attrs) + | _ -> []) + xml_list in + match List.flatten attrs_list with + | [] -> (attr, "") + | l -> (List.hd l) + +let backstep_loc xmllist = + let start_att = get_fst_attr_in_xml_list "begin" xmllist in + let stop_att = get_fst_attr_in_xml_list "end" (List.rev xmllist) in + [start_att ; stop_att] + +let compare_begin_att xml1 xml2 = + let att1 = get_fst_attr_in_xml_list "begin" [xml1] in + let att2 = get_fst_attr_in_xml_list "begin" [xml2] in + match att1, att2 with + | (_, s1), (_, s2) when s1 == "" || s2 == "" -> 0 + | (_, s1), (_, s2) when int_of_string s1 > int_of_string s2 -> 1 + | (_, s1), (_, s2) when int_of_string s1 < int_of_string s2 -> -1 + | _ -> 0 + +let xmlBeginSection loc name = xmlWithLoc loc "beginsection" ["name", name] [] + +let xmlEndSegment loc name = xmlWithLoc loc "endsegment" ["name", name] [] + +let xmlThm typ name loc xml = + xmlWithLoc loc "theorem" ["type", typ; "name", name] xml + +let xmlDef typ name loc xml = + xmlWithLoc loc "definition" ["type", typ; "name", name] xml + +let xmlNotation attr name loc xml = + xmlWithLoc loc "notation" (("name", name) :: attr) xml + +let xmlReservedNotation attr name loc = + xmlWithLoc loc "reservednotation" (("name", name) :: attr) [] + +let xmlCst name ?(attr=[]) loc = + xmlWithLoc loc "constant" (("name", name) :: attr) [] + +let xmlOperator name ?(attr=[]) ?(pprules=[]) loc = + xmlWithLoc loc "operator" + (("name", name) :: List.map (fun (a,b) -> "format"^a,b) pprules @ attr) [] + +let xmlApply loc ?(attr=[]) xml = xmlWithLoc loc "apply" attr xml + +let xmlToken loc ?(attr=[]) xml = xmlWithLoc loc "token" attr xml + +let xmlTyped xml = Element("typed", (backstep_loc xml), xml) + +let xmlReturn ?(attr=[]) xml = Element("return", attr, xml) + +let xmlCase xml = Element("case", [], xml) + +let xmlScrutinee ?(attr=[]) xml = Element("scrutinee", attr, xml) + +let xmlWith xml = Element("with", [], xml) + +let xmlAssign id xml = Element("assign", ["target",string_of_id id], [xml]) + +let xmlInductive kind loc xml = xmlWithLoc loc "inductive" ["kind",kind] xml + +let xmlCoFixpoint xml = Element("cofixpoint", [], xml) + +let xmlFixpoint xml = Element("fixpoint", [], xml) + +let xmlCheck loc xml = xmlWithLoc loc "check" [] xml + +let xmlAssumption kind loc xml = xmlWithLoc loc "assumption" ["kind",kind] xml + +let xmlComment loc xml = xmlWithLoc loc "comment" [] xml + +let xmlCanonicalStructure attr loc = xmlWithLoc loc "canonicalstructure" attr [] + +let xmlQed ?(attr=[]) loc = xmlWithLoc loc "qed" attr [] + +let xmlPatvar id loc = xmlWithLoc loc "patvar" ["id", id] [] + +let xmlReference ref = + let name = Libnames.string_of_reference ref in + let i, j = Loc.unloc (Libnames.loc_of_reference ref) in + let b, e = string_of_int i, string_of_int j in + Element("reference",["name", name; "begin", b; "end", e] ,[]) + +let xmlRequire loc ?(attr=[]) xml = xmlWithLoc loc "require" attr xml +let xmlImport loc ?(attr=[]) xml = xmlWithLoc loc "import" attr xml + +let xmlAddLoadPath loc ?(attr=[]) xml = xmlWithLoc loc "addloadpath" attr xml +let xmlRemoveLoadPath loc ?(attr=[]) = xmlWithLoc loc "removeloadpath" attr +let xmlAddMLPath loc ?(attr=[]) = xmlWithLoc loc "addmlpath" attr + +let xmlExtend loc xml = xmlWithLoc loc "extend" [] xml + +let xmlScope loc action ?(attr=[]) name xml = + xmlWithLoc loc "scope" (["name",name;"action",action] @ attr) xml + +let xmlProofMode loc name = xmlWithLoc loc "proofmode" ["name",name] [] + +let xmlProof loc xml = xmlWithLoc loc "proof" [] xml + +let xmlSectionSubsetDescr name ssd = + Element("sectionsubsetdescr",["name",name], + [PCData (Proof_using.to_string ssd)]) + +let xmlDeclareMLModule loc s = + xmlWithLoc loc "declarexmlmodule" [] + (List.map (fun x -> Element("path",["value",x],[])) s) + +(* tactics *) +let xmlLtac loc xml = xmlWithLoc loc "ltac" [] xml + +(* toplevel commands *) +let xmlGallina loc xml = xmlWithLoc loc "gallina" [] xml + +let xmlTODO loc x = + xmlWithLoc loc "todo" [] [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] + +let string_of_name n = + match n with + | Anonymous -> "_" + | Name id -> Id.to_string id + +let string_of_glob_sort s = + match s with + | GProp -> "Prop" + | GSet -> "Set" + | GType _ -> "Type" + +let string_of_cast_sort c = + match c with + | CastConv _ -> "CastConv" + | CastVM _ -> "CastVM" + | CastNative _ -> "CastNative" + | CastCoerce -> "CastCoerce" + +let string_of_case_style s = + match s with + | LetStyle -> "Let" + | IfStyle -> "If" + | LetPatternStyle -> "LetPattern" + | MatchStyle -> "Match" + | RegularStyle -> "Regular" + +let attribute_of_syntax_modifier sm = +match sm with + | SetItemLevel (sl, NumLevel n) -> + List.map (fun s -> ("itemlevel", s)) sl @ ["level", string_of_int n] + | SetItemLevel (sl, NextLevel) -> + List.map (fun s -> ("itemlevel", s)) sl @ ["level", "next"] + | SetLevel i -> ["level", string_of_int i] + | SetAssoc a -> + begin match a with + | NonA -> ["",""] + | RightA -> ["associativity", "right"] + | LeftA -> ["associativity", "left"] + end + | SetEntryType (s, _) -> ["entrytype", s] + | SetOnlyPrinting -> ["onlyprinting", ""] + | SetOnlyParsing -> ["onlyparsing", ""] + | SetCompatVersion v -> ["compat", Flags.pr_version v] + | SetFormat (system, (loc, s)) -> + let start, stop = unlock loc in + ["format-"^system, s; "begin", start; "end", stop] + +let string_of_assumption_kind l a many = + match l, a, many with + | (Discharge, Logical, true) -> "Hypotheses" + | (Discharge, Logical, false) -> "Hypothesis" + | (Discharge, Definitional, true) -> "Variables" + | (Discharge, Definitional, false) -> "Variable" + | (Global, Logical, true) -> "Axioms" + | (Global, Logical, false) -> "Axiom" + | (Global, Definitional, true) -> "Parameters" + | (Global, Definitional, false) -> "Parameter" + | (Local, Logical, true) -> "Local Axioms" + | (Local, Logical, false) -> "Local Axiom" + | (Local, Definitional, true) -> "Local Parameters" + | (Local, Definitional, false) -> "Local Parameter" + | (Global, Conjectural, _) -> "Conjecture" + | ((Discharge | Local), Conjectural, _) -> assert false + +let rec pp_bindlist bl = + let tlist = + List.flatten + (List.map + (fun (loc_names, _, e) -> + let names = + (List.map + (fun (loc, name) -> + xmlCst (string_of_name name) loc) loc_names) in + match e with + | CHole _ -> names + | _ -> names @ [pp_expr e]) + bl) in + match tlist with + | [e] -> e + | l -> xmlTyped l +and pp_decl_notation ((_, s), ce, sc) = (* don't know what it is for now *) + Element ("decl_notation", ["name", s], [pp_expr ce]) +and pp_local_binder lb = (* don't know what it is for now *) + match lb with + | LocalRawDef ((_, nam), ce) -> + let attrs = ["name", string_of_name nam] in + pp_expr ~attr:attrs ce + | LocalRawAssum (namll, _, ce) -> + let ppl = + List.map (fun (loc, nam) -> (xmlCst (string_of_name nam) loc)) namll in + xmlTyped (ppl @ [pp_expr ce]) + | LocalPattern _ -> + assert false +and pp_local_decl_expr lde = (* don't know what it is for now *) + match lde with + | AssumExpr (_, ce) -> pp_expr ce + | DefExpr (_, ce, _) -> pp_expr ce +and pp_inductive_expr ((_, ((l, id),_)), lbl, ceo, _, cl_or_rdexpr) = + (* inductive_expr *) + let b,e = Loc.unloc l in + let location = ["begin", string_of_int b; "end", string_of_int e] in + [Element ("lident", ["name", Id.to_string id] @ location, [])] @ (* inductive name *) + begin match cl_or_rdexpr with + | Constructors coel -> List.map (fun (_, (_, ce)) -> pp_expr ce) coel + | RecordDecl (_, ldewwwl) -> + List.map (fun (((_, x), _), _) -> pp_local_decl_expr x) ldewwwl + end @ + begin match ceo with (* don't know what it is for now *) + | Some ce -> [pp_expr ce] + | None -> [] + end @ + (List.map pp_local_binder lbl) +and pp_recursion_order_expr optid roe = (* don't know what it is for now *) + let attrs = + match optid with + | None -> [] + | Some (loc, id) -> + let start, stop = unlock loc in + ["begin", start; "end", stop ; "name", Id.to_string id] in + let kind, expr = + match roe with + | CStructRec -> "struct", [] + | CWfRec e -> "rec", [pp_expr e] + | CMeasureRec (e, None) -> "mesrec", [pp_expr e] + | CMeasureRec (e, Some rel) -> "mesrec", [pp_expr e] @ [pp_expr rel] in + Element ("recursion_order", ["kind", kind] @ attrs, expr) +and pp_fixpoint_expr (((loc, id), pl), (optid, roe), lbl, ce, ceo) = + (* fixpoint_expr *) + let start, stop = unlock loc in + let id = Id.to_string id in + [Element ("lident", ["begin", start; "end", stop ; "name", id], [])] @ + (* fixpoint name *) + [pp_recursion_order_expr optid roe] @ + (List.map pp_local_binder lbl) @ + [pp_expr ce] @ + begin match ceo with (* don't know what it is for now *) + | Some ce -> [pp_expr ce] + | None -> [] + end +and pp_cofixpoint_expr (((loc, id), pl), lbl, ce, ceo) = (* cofixpoint_expr *) + (* Nota: it is like fixpoint_expr without (optid, roe) + * so could be merged if there is no more differences *) + let start, stop = unlock loc in + let id = Id.to_string id in + [Element ("lident", ["begin", start; "end", stop ; "name", id], [])] @ + (* cofixpoint name *) + (List.map pp_local_binder lbl) @ + [pp_expr ce] @ + begin match ceo with (* don't know what it is for now *) + | Some ce -> [pp_expr ce] + | None -> [] + end +and pp_lident (loc, id) = xmlCst (Id.to_string id) loc +and pp_simple_binder (idl, ce) = List.map pp_lident idl @ [pp_expr ce] +and pp_cases_pattern_expr cpe = + match cpe with + | CPatAlias (loc, cpe, id) -> + xmlApply loc + (xmlOperator "alias" ~attr:["name", string_of_id id] loc :: + [pp_cases_pattern_expr cpe]) + | CPatCstr (loc, ref, None, cpel2) -> + xmlApply loc + (xmlOperator "reference" + ~attr:["name", Libnames.string_of_reference ref] loc :: + [Element ("impargs", [], []); + Element ("args", [], (List.map pp_cases_pattern_expr cpel2))]) + | CPatCstr (loc, ref, Some cpel1, cpel2) -> + xmlApply loc + (xmlOperator "reference" + ~attr:["name", Libnames.string_of_reference ref] loc :: + [Element ("impargs", [], (List.map pp_cases_pattern_expr cpel1)); + Element ("args", [], (List.map pp_cases_pattern_expr cpel2))]) + | CPatAtom (loc, optr) -> + let attrs = match optr with + | None -> [] + | Some r -> ["name", Libnames.string_of_reference r] in + xmlApply loc (xmlOperator "atom" ~attr:attrs loc :: []) + | CPatOr (loc, cpel) -> + xmlApply loc (xmlOperator "or" loc :: List.map pp_cases_pattern_expr cpel) + | CPatNotation (loc, n, (subst_constr, subst_rec), cpel) -> + xmlApply loc + (xmlOperator "notation" loc :: + [xmlOperator n loc; + Element ("subst", [], + [Element ("subterms", [], + List.map pp_cases_pattern_expr subst_constr); + Element ("recsubterms", [], + List.map + (fun (cpel) -> + Element ("recsubterm", [], + List.map pp_cases_pattern_expr cpel)) + subst_rec)]); + Element ("args", [], (List.map pp_cases_pattern_expr cpel))]) + | CPatPrim (loc, tok) -> pp_token loc tok + | CPatRecord (loc, rcl) -> + xmlApply loc + (xmlOperator "record" loc :: + List.map (fun (r, cpe) -> + Element ("field", + ["reference", Libnames.string_of_reference r], + [pp_cases_pattern_expr cpe])) + rcl) + | CPatDelimiters (loc, delim, cpe) -> + xmlApply loc + (xmlOperator "delimiter" ~attr:["name", delim] loc :: + [pp_cases_pattern_expr cpe]) + | CPatCast _ -> assert false +and pp_case_expr (e, name, pat) = + match name, pat with + | None, None -> xmlScrutinee [pp_expr e] + | Some (loc, name), None -> + let start, stop= unlock loc in + xmlScrutinee ~attr:["name", string_of_name name; + "begin", start; "end", stop] [pp_expr e] + | Some (loc, name), Some p -> + let start, stop= unlock loc in + xmlScrutinee ~attr:["name", string_of_name name; + "begin", start; "end", stop] + [Element ("in", [], [pp_cases_pattern_expr p]) ; pp_expr e] + | None, Some p -> + xmlScrutinee [Element ("in", [], [pp_cases_pattern_expr p]) ; pp_expr e] +and pp_branch_expr_list bel = + xmlWith + (List.map + (fun (_, cpel, e) -> + let ppcepl = + List.map pp_cases_pattern_expr (List.flatten (List.map snd cpel)) in + let ppe = [pp_expr e] in + xmlCase (ppcepl @ ppe)) + bel) +and pp_token loc tok = + let tokstr = + match tok with + | String s -> PCData s + | Numeral n -> PCData (to_string n) in + xmlToken loc [tokstr] +and pp_local_binder_list lbl = + let l = (List.map pp_local_binder lbl) in + Element ("recurse", (backstep_loc l), l) +and pp_const_expr_list cel = + let l = List.map pp_expr cel in + Element ("recurse", (backstep_loc l), l) +and pp_expr ?(attr=[]) e = + match e with + | CRef (r, _) -> + xmlCst ~attr + (Libnames.string_of_reference r) (Libnames.loc_of_reference r) + | CProdN (loc, bl, e) -> + xmlApply loc + (xmlOperator "forall" loc :: [pp_bindlist bl] @ [pp_expr e]) + | CApp (loc, (_, hd), args) -> + xmlApply ~attr loc (pp_expr hd :: List.map (fun (e,_) -> pp_expr e) args) + | CAppExpl (loc, (_, r, _), args) -> + xmlApply ~attr loc + (xmlCst (Libnames.string_of_reference r) + (Libnames.loc_of_reference r) :: List.map pp_expr args) + | CNotation (loc, notation, ([],[],[])) -> + xmlOperator notation loc + | CNotation (loc, notation, (args, cell, lbll)) -> + let fmts = Notation.find_notation_extra_printing_rules notation in + let oper = xmlOperator notation loc ~pprules:fmts in + let cels = List.map pp_const_expr_list cell in + let lbls = List.map pp_local_binder_list lbll in + let args = List.map pp_expr args in + xmlApply loc (oper :: (List.sort compare_begin_att (args @ cels @ lbls))) + | CSort(loc, s) -> + xmlOperator (string_of_glob_sort s) loc + | CDelimiters (loc, scope, ce) -> + xmlApply loc (xmlOperator "delimiter" ~attr:["name", scope] loc :: + [pp_expr ce]) + | CPrim (loc, tok) -> pp_token loc tok + | CGeneralization (loc, kind, _, e) -> + let kind= match kind with + | Explicit -> "explicit" + | Implicit -> "implicit" in + xmlApply loc + (xmlOperator "generalization" ~attr:["kind", kind] loc :: [pp_expr e]) + | CCast (loc, e, tc) -> + begin match tc with + | CastConv t | CastVM t |CastNative t -> + xmlApply loc + (xmlOperator ":" loc ~attr:["kind", (string_of_cast_sort tc)] :: + [pp_expr e; pp_expr t]) + | CastCoerce -> + xmlApply loc + (xmlOperator ":" loc ~attr:["kind", "CastCoerce"] :: + [pp_expr e]) + end + | CEvar (loc, ek, cel) -> + let ppcel = List.map (fun (id,e) -> xmlAssign id (pp_expr e)) cel in + xmlApply loc + (xmlOperator "evar" loc ~attr:["id", string_of_id ek] :: + ppcel) + | CPatVar (loc, id) -> xmlPatvar (string_of_id id) loc + | CHole (loc, _, _, _) -> xmlCst ~attr "_" loc + | CIf (loc, test, (_, ret), th, el) -> + let return = match ret with + | None -> [] + | Some r -> [xmlReturn [pp_expr r]] in + xmlApply loc + (xmlOperator "if" loc :: + return @ [pp_expr th] @ [pp_expr el]) + | CLetTuple (loc, names, (_, ret), value, body) -> + let return = match ret with + | None -> [] + | Some r -> [xmlReturn [pp_expr r]] in + xmlApply loc + (xmlOperator "lettuple" loc :: + return @ + (List.map (fun (loc, var) -> xmlCst (string_of_name var) loc) names) @ + [pp_expr value; pp_expr body]) + | CCases (loc, sty, ret, cel, bel) -> + let return = match ret with + | None -> [] + | Some r -> [xmlReturn [pp_expr r]] in + xmlApply loc + (xmlOperator "match" loc ~attr:["style", (string_of_case_style sty)] :: + (return @ + [Element ("scrutinees", [], List.map pp_case_expr cel)] @ + [pp_branch_expr_list bel])) + | CRecord (_, _) -> assert false + | CLetIn (loc, (varloc, var), value, body) -> + xmlApply loc + (xmlOperator "let" loc :: + [xmlCst (string_of_name var) varloc; pp_expr value; pp_expr body]) + | CLambdaN (loc, bl, e) -> + xmlApply loc + (xmlOperator "lambda" loc :: [pp_bindlist bl] @ [pp_expr e]) + | CCoFix (_, _, _) -> assert false + | CFix (loc, lid, fel) -> + xmlApply loc + (xmlOperator "fix" loc :: + List.flatten (List.map + (fun (a,b,cl,c,d) -> pp_fixpoint_expr ((a,None),b,cl,c,Some d)) + fel)) + +let pp_comment (c) = + match c with + | CommentConstr e -> [pp_expr e] + | CommentString s -> [Element ("string", [], [PCData s])] + | CommentInt i -> [PCData (string_of_int i)] + +let rec tmpp v loc = + match v with + (* Control *) + | VernacLoad (verbose,f) -> + xmlWithLoc loc "load" ["verbose",string_of_bool verbose;"file",f] [] + | VernacTime (loc,e) -> + xmlApply loc (Element("time",[],[]) :: + [tmpp e loc]) + | VernacRedirect (s, (loc,e)) -> + xmlApply loc (Element("redirect",["path", s],[]) :: + [tmpp e loc]) + | VernacTimeout (s,e) -> + xmlApply loc (Element("timeout",["val",string_of_int s],[]) :: + [tmpp e loc]) + | VernacFail e -> xmlApply loc (Element("fail",[],[]) :: [tmpp e loc]) + | VernacError _ -> xmlWithLoc loc "error" [] [] + + (* Syntax *) + | VernacSyntaxExtension (_, ((_, name), sml)) -> + let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in + xmlReservedNotation attrs name loc + + | VernacOpenCloseScope (_,(true,name)) -> xmlScope loc "open" name [] + | VernacOpenCloseScope (_,(false,name)) -> xmlScope loc "close" name [] + | VernacDelimiters (name,Some tag) -> + xmlScope loc "delimit" name ~attr:["delimiter",tag] [] + | VernacDelimiters (name,None) -> + xmlScope loc "undelimit" name ~attr:[] [] + | VernacInfix (_,((_,name),sml),ce,sn) -> + let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in + let sc_attr = + match sn with + | Some scope -> ["scope", scope] + | None -> [] in + xmlNotation (sc_attr @ attrs) name loc [pp_expr ce] + | VernacNotation (_, ce, (lstr, sml), sn) -> + let name = snd lstr in + let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in + let sc_attr = + match sn with + | Some scope -> ["scope", scope] + | None -> [] in + xmlNotation (sc_attr @ attrs) name loc [pp_expr ce] + | VernacBindScope _ as x -> xmlTODO loc x + | VernacNotationAddFormat _ as x -> xmlTODO loc x + | VernacUniverse _ + | VernacConstraint _ + | VernacPolymorphic (_, _) as x -> xmlTODO loc x + (* Gallina *) + | VernacDefinition (ldk, ((_,id),_), de) -> + let l, dk = + match ldk with + | Some l, dk -> (l, dk) + | None, dk -> (Global, dk) in (* Like in ppvernac.ml, l 585 *) + let e = + match de with + | ProveBody (_, ce) -> ce + | DefineBody (_, Some _, ce, None) -> ce + | DefineBody (_, None , ce, None) -> ce + | DefineBody (_, Some _, ce, Some _) -> ce + | DefineBody (_, None , ce, Some _) -> ce in + let str_dk = Kindops.string_of_definition_kind (l, false, dk) in + let str_id = Id.to_string id in + (xmlDef str_dk str_id loc [pp_expr e]) + | VernacStartTheoremProof (tk, [ Some ((_,id),_), ([], statement, None) ], b) -> + let str_tk = Kindops.string_of_theorem_kind tk in + let str_id = Id.to_string id in + (xmlThm str_tk str_id loc [pp_expr statement]) + | VernacStartTheoremProof _ as x -> xmlTODO loc x + | VernacEndProof pe -> + begin + match pe with + | Admitted -> xmlQed loc + | Proved (_, Some ((_, id), Some tk)) -> + let nam = Id.to_string id in + let typ = Kindops.string_of_theorem_kind tk in + xmlQed ~attr:["name", nam; "type", typ] loc + | Proved (_, Some ((_, id), None)) -> + let nam = Id.to_string id in + xmlQed ~attr:["name", nam] loc + | Proved _ -> xmlQed loc + end + | VernacExactProof _ as x -> xmlTODO loc x + | VernacAssumption ((l, a), _, sbwcl) -> + let binders = List.map (fun (_, (id, c)) -> (List.map fst id, c)) sbwcl in + let many = + List.length (List.flatten (List.map fst binders)) > 1 in + let exprs = + List.flatten (List.map pp_simple_binder binders) in + let l = match l with Some x -> x | None -> Decl_kinds.Global in + let kind = string_of_assumption_kind l a many in + xmlAssumption kind loc exprs + | VernacInductive (_, _, iednll) -> + let kind = + let (_, _, _, k, _),_ = List.hd iednll in + begin + match k with + | Record -> "Record" + | Structure -> "Structure" + | Inductive_kw -> "Inductive" + | CoInductive -> "CoInductive" + | Class _ -> "Class" + | Variant -> "Variant" + end in + let exprs = + List.flatten (* should probably not be flattened *) + (List.map + (fun (ie, dnl) -> (pp_inductive_expr ie) @ + (List.map pp_decl_notation dnl)) iednll) in + xmlInductive kind loc exprs + | VernacFixpoint (_, fednll) -> + let exprs = + List.flatten (* should probably not be flattened *) + (List.map + (fun (fe, dnl) -> (pp_fixpoint_expr fe) @ + (List.map pp_decl_notation dnl)) fednll) in + xmlFixpoint exprs + | VernacCoFixpoint (_, cfednll) -> + (* Nota: it is like VernacFixpoint without so could be merged *) + let exprs = + List.flatten (* should probably not be flattened *) + (List.map + (fun (cfe, dnl) -> (pp_cofixpoint_expr cfe) @ + (List.map pp_decl_notation dnl)) cfednll) in + xmlCoFixpoint exprs + | VernacScheme _ as x -> xmlTODO loc x + | VernacCombinedScheme _ as x -> xmlTODO loc x + + (* Gallina extensions *) + | VernacBeginSection (_, id) -> xmlBeginSection loc (Id.to_string id) + | VernacEndSegment (_, id) -> xmlEndSegment loc (Id.to_string id) + | VernacNameSectionHypSet _ as x -> xmlTODO loc x + | VernacRequire (from, import, l) -> + let import = match import with + | None -> [] + | Some true -> ["export","true"] + | Some false -> ["import","true"] + in + let from = match from with + | None -> [] + | Some r -> ["from", Libnames.string_of_reference r] + in + xmlRequire loc ~attr:(from @ import) (List.map (fun ref -> + xmlReference ref) l) + | VernacImport (true,l) -> + xmlImport loc ~attr:["export","true"] (List.map (fun ref -> + xmlReference ref) l) + | VernacImport (false,l) -> + xmlImport loc (List.map (fun ref -> + xmlReference ref) l) + | VernacCanonical r -> + let attr = + match r with + | AN (Qualid (_, q)) -> ["qualid", string_of_qualid q] + | AN (Ident (_, id)) -> ["id", Id.to_string id] + | ByNotation (_, s, _) -> ["notation", s] in + xmlCanonicalStructure attr loc + | VernacCoercion _ as x -> xmlTODO loc x + | VernacIdentityCoercion _ as x -> xmlTODO loc x + + (* Type classes *) + | VernacInstance _ as x -> xmlTODO loc x + + | VernacContext _ as x -> xmlTODO loc x + + | VernacDeclareInstances _ as x -> xmlTODO loc x + + | VernacDeclareClass _ as x -> xmlTODO loc x + + (* Modules and Module Types *) + | VernacDeclareModule _ as x -> xmlTODO loc x + | VernacDefineModule _ as x -> xmlTODO loc x + | VernacDeclareModuleType _ as x -> xmlTODO loc x + | VernacInclude _ as x -> xmlTODO loc x + + (* Solving *) + + | (VernacSolveExistential _) as x -> + xmlLtac loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] + + (* Auxiliary file and library management *) + | VernacAddLoadPath (recf,name,None) -> + xmlAddLoadPath loc ~attr:["rec",string_of_bool recf;"path",name] [] + | VernacAddLoadPath (recf,name,Some dp) -> + xmlAddLoadPath loc ~attr:["rec",string_of_bool recf;"path",name] + [PCData (Names.DirPath.to_string dp)] + | VernacRemoveLoadPath name -> xmlRemoveLoadPath loc ~attr:["path",name] [] + | VernacAddMLPath (recf,name) -> + xmlAddMLPath loc ~attr:["rec",string_of_bool recf;"path",name] [] + | VernacDeclareMLModule sl -> xmlDeclareMLModule loc sl + | VernacChdir _ as x -> xmlTODO loc x + + (* State management *) + | VernacWriteState _ as x -> xmlTODO loc x + | VernacRestoreState _ as x -> xmlTODO loc x + + (* Resetting *) + | VernacResetName _ as x -> xmlTODO loc x + | VernacResetInitial as x -> xmlTODO loc x + | VernacBack _ as x -> xmlTODO loc x + | VernacBackTo _ -> PCData "VernacBackTo" + + (* Commands *) + | VernacCreateHintDb _ as x -> xmlTODO loc x + | VernacRemoveHints _ as x -> xmlTODO loc x + | VernacHints _ as x -> xmlTODO loc x + | VernacSyntacticDefinition ((_, name), (idl, ce), _, _) -> + let name = Id.to_string name in + let attrs = List.map (fun id -> ("id", Id.to_string id)) idl in + xmlNotation attrs name loc [pp_expr ce] + | VernacDeclareImplicits _ as x -> xmlTODO loc x + | VernacArguments _ as x -> xmlTODO loc x + | VernacArgumentsScope _ as x -> xmlTODO loc x + | VernacReserve _ as x -> xmlTODO loc x + | VernacGeneralizable _ as x -> xmlTODO loc x + | VernacSetOpacity _ as x -> xmlTODO loc x + | VernacSetStrategy _ as x -> xmlTODO loc x + | VernacUnsetOption _ as x -> xmlTODO loc x + | VernacSetOption _ as x -> xmlTODO loc x + | VernacSetAppendOption _ as x -> xmlTODO loc x + | VernacAddOption _ as x -> xmlTODO loc x + | VernacRemoveOption _ as x -> xmlTODO loc x + | VernacMemOption _ as x -> xmlTODO loc x + | VernacPrintOption _ as x -> xmlTODO loc x + | VernacCheckMayEval (_,_,e) -> xmlCheck loc [pp_expr e] + | VernacGlobalCheck _ as x -> xmlTODO loc x + | VernacDeclareReduction _ as x -> xmlTODO loc x + | VernacPrint _ as x -> xmlTODO loc x + | VernacSearch _ as x -> xmlTODO loc x + | VernacLocate _ as x -> xmlTODO loc x + | VernacRegister _ as x -> xmlTODO loc x + | VernacComments (cl) -> + xmlComment loc (List.flatten (List.map pp_comment cl)) + + (* Stm backdoor *) + | VernacStm _ as x -> xmlTODO loc x + + (* Proof management *) + | VernacGoal _ as x -> xmlTODO loc x + | VernacAbort _ as x -> xmlTODO loc x + | VernacAbortAll -> PCData "VernacAbortAll" + | VernacRestart as x -> xmlTODO loc x + | VernacUndo _ as x -> xmlTODO loc x + | VernacUndoTo _ as x -> xmlTODO loc x + | VernacBacktrack _ as x -> xmlTODO loc x + | VernacFocus _ as x -> xmlTODO loc x + | VernacUnfocus as x -> xmlTODO loc x + | VernacUnfocused as x -> xmlTODO loc x + | VernacBullet _ as x -> xmlTODO loc x + | VernacSubproof _ as x -> xmlTODO loc x + | VernacEndSubproof as x -> xmlTODO loc x + | VernacShow _ as x -> xmlTODO loc x + | VernacCheckGuard as x -> xmlTODO loc x + | VernacProof (tac,using) -> + let tac = None (** FIXME *) in + let using = Option.map (xmlSectionSubsetDescr "using") using in + xmlProof loc (Option.List.(cons tac (cons using []))) + | VernacProofMode name -> xmlProofMode loc name + + (* Toplevel control *) + | VernacToplevelControl _ as x -> xmlTODO loc x + + (* For extension *) + | VernacExtend _ as x -> + xmlExtend loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] + + (* Flags *) + | VernacProgram e -> xmlApply loc (Element("program",[],[]) :: [tmpp e loc]) + | VernacLocal (b,e) -> + xmlApply loc (Element("local",["flag",string_of_bool b],[]) :: + [tmpp e loc]) + +let tmpp v loc = + match tmpp v loc with + | Element("ltac",_,_) as x -> x + | xml -> xmlGallina loc [xml] diff --git a/ide/texmacspp.mli b/ide/texmacspp.mli new file mode 100644 index 0000000000..858847fb6a --- /dev/null +++ b/ide/texmacspp.mli @@ -0,0 +1,12 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Xml_datatype +open Vernacexpr + +val tmpp : vernac_expr -> Loc.t -> xml diff --git a/ide/utf8_convert.mll b/ide/utf8_convert.mll index 621833ddea..5cc8cbc0d2 100644 --- a/ide/utf8_convert.mll +++ b/ide/utf8_convert.mll @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,7 +12,7 @@ } -(* Replace all occurences of \x{iiii} and \x{iiiiiiii} by UTF-8 valid chars *) +(* 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 diff --git a/ide/utils/config_file.ml b/ide/utils/config_file.ml deleted file mode 100644 index 4d0aabeb6a..0000000000 --- a/ide/utils/config_file.ml +++ /dev/null @@ -1,640 +0,0 @@ -(*********************************************************************************) -(* 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 *) -(* *) -(*********************************************************************************) - -(* TODO *) -(* section comments *) -(* better obsoletes: no "{}", line cuts *) - -(* possible improvements: *) -(* use lex/yacc instead of genlex to be more robust, efficient, allow arrays and other types, read comments. *) -(* description and help, level (beginner/advanced/...) for each cp *) -(* find an option from its name and group *) -(* class hooks *) -(* get the sections of a group / of a file *) -(* read file format from inifiles and ConfigParser *) - - -(* Read the mli before reading this file! *) - - -(* ******************************************************************************** *) -(* ******************************** misc utilities ******************************** *) -(* ******************************************************************************** *) -(* This code is intended to be usable without any dependencies. *) - -(* pipeline style, see for instance Raw.of_channel. *) -let (|>) x f = f x - -(* as List.assoc, but applies f to the element matching [key] and returns the list -where this element has been replaced by the result of f. *) -let rec list_assoc_remove key f = function - | [] -> raise Not_found - | (key',value) as elt :: tail -> - if key <> key' - then elt :: list_assoc_remove key f tail - else match f value with - | None -> tail - | Some a -> (key',a) :: tail - -(* reminiscent of String.concat. Same as [Queue.iter f1 queue] - but calls [f2 ()] between each calls to f1. - Does not call f2 before the first call nor after the last call to f2. - Could be more efficient with a richer module interface of Queue. -*) -let queue_iter_between f1 f2 queue = -(* let f flag elt = if flag then f2 (); (f1 elt:unit); true in *) - let f flag elt = if flag then f2 (); f1 elt; true in - ignore (Queue.fold f false queue) - -let list_iter_between f1 f2 = function - [] -> () - | a::[] -> f1 a - | a::tail -> f1 a; List.iter (fun elt -> (f2 ():unit); f1 elt) tail -(* | a::tail -> f1 a; List.iter (fun elt -> f2 (); f1 elt) tail *) -(* !! types ??? *) - -(* to ensure that strings will be parsed correctly by Genlex. -It's more comfortable not to have quotes around the string, but sometimes it's necessary. *) -exception Unsafe_string -let safe_string s = - if s = "" - then "\"\"" - else if ( - try match s.[0] with - | 'a'..'z' | 'A'..'Z' -> - for i = 1 to String.length s - 1 do - match s.[i] with - 'a'..'z' | 'A'..'Z' | '_' | '0'..'9' -> () - | _ -> raise Unsafe_string - done; - false - | _ -> - try - string_of_int (int_of_string s) <> s || - string_of_float (float_of_string s) <> s - with Failure "int_of_string" | Failure "float_of_string" -> true - with Unsafe_string -> true) - then Printf.sprintf "\"%s\"" (String.escaped s) - else s - - -(* ******************************************************************************** *) -(* ************************************* core ************************************* *) -(* ******************************************************************************** *) - -module Raw = struct - type cp = - | String of string - | Int of int - | Float of float - | List of cp list - | Tuple of cp list - | Section of (string * cp) list - -(* code generated by -camlp4 pa_o.cmo pa_op.cmo pr_o.cmo -- -o config_file_parser.ml -impl config_file_parser.ml4 -Unreadable on purpose, edit the file config_file_parser.ml4 rather than editing this (huge) lines. Then manually copy-paste here the content of config_file_parser.ml. -Could be one day rewritten with ocamllex/yacc to be more robust, efficient, allow arrays, read comments...*) - module Parse = struct - let lexer = Genlex.make_lexer ["="; "{"; "}"; "["; "]"; ";"; "("; ")"; ","] - let rec file l (strm__ : _ Stream.t) = match try Some (ident strm__) with Stream.Failure -> None with Some id -> begin match Stream.peek strm__ with Some (Genlex.Kwd "=") -> Stream.junk strm__; let v = try value strm__ with Stream.Failure -> raise (Stream.Error "") in begin try file ((id, v) :: l) strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> raise (Stream.Error "") end | _ -> List.rev l - and value (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Kwd "{") -> Stream.junk strm__; let v = try file [] strm__ with Stream.Failure -> raise (Stream.Error "") in begin match Stream.peek strm__ with Some (Genlex.Kwd "}") -> Stream.junk strm__; Section v | _ -> raise (Stream.Error "") end | Some (Genlex.Ident s) -> Stream.junk strm__; String s | Some (Genlex.String s) -> Stream.junk strm__; String s | Some (Genlex.Int i) -> Stream.junk strm__; Int i | Some (Genlex.Float f) -> Stream.junk strm__; Float f | Some (Genlex.Char c) -> Stream.junk strm__; String (String.make 1 c) | Some (Genlex.Kwd "[") -> Stream.junk strm__; let v = try list [] strm__ with Stream.Failure -> raise (Stream.Error "") in List v | Some (Genlex.Kwd "(") -> Stream.junk strm__; let v = try list [] strm__ with Stream.Failure -> raise (Stream.Error "") in Tuple v | _ -> raise Stream.Failure - and ident (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Ident s) -> Stream.junk strm__; s | Some (Genlex.String s) -> Stream.junk strm__; s | _ -> raise Stream.Failure - and list l (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Kwd ";") -> Stream.junk strm__; begin try list l strm__ with Stream.Failure -> raise (Stream.Error "") end | Some (Genlex.Kwd ",") -> Stream.junk strm__; begin try list l strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> match try Some (value strm__) with Stream.Failure -> None with Some v -> begin try list (v :: l) strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> match Stream.peek strm__ with Some (Genlex.Kwd "]") -> Stream.junk strm__; List.rev l | Some (Genlex.Kwd ")") -> Stream.junk strm__; List.rev l | _ -> raise Stream.Failure - end - - open Format - (* formating convention: the caller has to open the box, close it and flush the output *) - (* remarks on Format: - set_margin forces a call to set_max_indent - sprintf et bprintf are flushed at each call*) - - (* pretty print a Raw.cp *) - let rec save formatter = function - | String s -> fprintf formatter "%s" (safe_string s) (* How can I cut lines and *) - | Int i -> fprintf formatter "%d" i (* print backslashes just before the \n? *) - | Float f -> fprintf formatter "%g" f - | List l -> - fprintf formatter "[@[<b0>"; - list_iter_between - (fun v -> fprintf formatter "@[<b2>"; save formatter v; fprintf formatter "@]") - (fun () -> fprintf formatter ";@ ") - l; - fprintf formatter "@]]" - | Tuple l -> - fprintf formatter "(@[<b0>"; - list_iter_between - (fun v -> fprintf formatter "@[<b2>"; save formatter v; fprintf formatter "@]") - (fun () -> fprintf formatter ",@ ") - l; - fprintf formatter "@])" - | Section l -> - fprintf formatter "{@;<0 2>@[<hv0>"; - list_iter_between - (fun (name,value) -> - fprintf formatter "@[<hov2>%s =@ @[<b2>" name; - save formatter value; - fprintf formatter "@]@]";) - (fun () -> fprintf formatter "@;<2 0>") - l; - fprintf formatter "@]}" - -(* let to_string r = save str_formatter r; flush_str_formatter () *) - let to_channel out_channel r = - let f = formatter_of_out_channel out_channel in - fprintf f "@[<b2>"; save f r; fprintf f "@]@?" - - let of_string s = s |> Stream.of_string |> Parse.lexer |> Parse.value - - let of_channel in_channel = - let result = in_channel |> Stream.of_channel |> Parse.lexer |> Parse.file [] in - close_in in_channel; - result -end - -(* print the given string in a way compatible with Format. - Truncate the lines when needed, indent the newlines.*) -let print_help formatter = - String.iter (function - | ' ' -> Format.pp_print_space formatter () - | '\n' -> Format.pp_force_newline formatter () - | c -> Format.pp_print_char formatter c) - -type 'a wrappers = { - to_raw : 'a -> Raw.cp; - of_raw : Raw.cp -> 'a} - -class type ['a] cp = object -(* method private to_raw = wrappers.to_raw *) -(* method private of_raw = wrappers.of_raw *) -(* method private set_string s = s |> Raw.of_string |> self#of_raw |> self#set *) - method add_hook : ('a -> 'a -> unit) -> unit - method get : 'a - method get_default : 'a - method set : 'a -> unit - method reset : unit - - method get_formatted : Format.formatter -> unit - method get_default_formatted : Format.formatter -> unit - method get_help_formatted : Format.formatter -> unit - - method get_name : string list - method get_short_name : string option - method set_short_name : string -> unit - method get_help : string - method get_spec : Arg.spec - - method set_raw : Raw.cp -> unit -end - -type groupable_cp = < - get_name : string list; - get_short_name : string option; - get_help : string; - - get_formatted : Format.formatter -> unit; - get_default_formatted : Format.formatter -> unit; - get_help_formatted : Format.formatter -> unit; - get_spec : Arg.spec; - - reset : unit; - set_raw : Raw.cp -> unit; > - -exception Double_name -exception Missing_cp of groupable_cp -exception Wrong_type of (out_channel -> unit) - -(* Two exceptions to stop the iteration on queues. *) -exception Found -exception Found_cp of groupable_cp - -(* The data structure to store the cps. -It's a tree, each node is a section, and a queue of sons with their name. -Each leaf contains a cp. *) -type 'a nametree = - | Immediate of 'a - | Subsection of ((string * 'a nametree) Queue.t) - (* this Queue must be nonempty for group.read.choose *) - -class group = object (self) - val mutable cps = Queue.create () (* hold all the added cps, in a nametree. *) - - method add : 'a. 'a cp -> unit = fun original_cp -> - let cp = (original_cp :> groupable_cp) in - (* function called when we reach the end of the list cp#get_name. *) - let add_immediate name cp queue = - Queue.iter (fun (name',_) -> if name = name' then raise Double_name) queue; - Queue.push (name, Immediate cp) queue in - (* adds the cp with name [first_name::last_name] in section [section]. *) - let rec add_in_section section first_name last_name cp queue = - let sub_add = match last_name with (* what to do once we have find the correct section *) - | [] -> add_immediate first_name - | middle_name :: last_name -> add_in_section first_name middle_name last_name in - try - Queue.iter - (function - | name, Subsection subsection when name = section -> - sub_add cp subsection; raise Found - | _ -> ()) - queue; - let sub_queue = Queue.create () in - sub_add cp sub_queue; - Queue.push (section, Subsection sub_queue) queue - with Found -> () in - (match cp#get_name with - | [] -> failwith "empty name" - | first_name :: [] -> add_immediate first_name cp cps - | first_name :: middle_name :: last_name -> - add_in_section first_name middle_name last_name cp cps) - - method write ?(with_help=true) filename = - let out_channel = open_out filename in - let formatter = Format.formatter_of_out_channel out_channel in - let print = Format.fprintf formatter in - print "@[<v>"; - let rec save_queue formatter = - queue_iter_between - (fun (name,nametree) -> save_nametree name nametree) - (Format.pp_print_cut formatter) - and save_nametree name = function - | Immediate cp -> - if with_help && cp#get_help <> "" then - (print "@[<hov3>(* "; cp#get_help_formatted formatter; - print "@ *)@]@,"); - Format.fprintf formatter "@[<hov2>%s =@ @[<b2>" (safe_string name); - cp#get_formatted formatter; - print "@]@]" - | Subsection queue -> - Format.fprintf formatter "%s = {@;<0 2>@[<v>" (safe_string name); - save_queue formatter queue; - print "@]@,}" in - save_queue formatter cps; - print "@]@."; close_out out_channel - - method read ?obsoletes ?(no_default=false) - ?(on_type_error = fun groupable_cp raw_cp output filename in_channel -> - close_in in_channel; - Printf.eprintf - "Type error while loading configuration parameter %s from file %s.\n%!" - (String.concat "." groupable_cp#get_name) filename; - output stderr; - exit 1) - filename = - (* [filename] is created if it doesn't exist. In this case there is no need to read it. *) - match Sys.file_exists filename with false -> self#write filename | true -> - let in_channel = open_in filename in - (* what to do when a cp is missing: *) - let missing cp default = if no_default then raise (Missing_cp cp) else default in - (* returns a cp contained in the nametree queue, which must be nonempty *) - let choose queue = - let rec iter q = Queue.iter (function - | _, Immediate cp -> raise (Found_cp cp) - | _, Subsection q -> iter q) q in - try iter queue; failwith "choose" with Found_cp cp -> cp in - (* [set_and_remove raw_cps nametree] sets the cp of [nametree] to their value - defined in [raw_cps] and returns the remaining raw_cps. *) - let set_cp cp value = - try cp#set_raw value - with Wrong_type output -> on_type_error cp value output filename in_channel in - let rec set_and_remove raw_cps = function - | name, Immediate cp -> - (try list_assoc_remove name (fun value -> set_cp cp value; None) raw_cps - with Not_found -> missing cp raw_cps) - | name, Subsection queue -> - (try list_assoc_remove name - (function - | Raw.Section l -> - (match remainings l queue with - | [] -> None - | l -> Some (Raw.Section l)) - | r -> missing (choose queue) (Some r)) - raw_cps - with Not_found -> missing (choose queue) raw_cps) - and remainings raw_cps queue = Queue.fold set_and_remove raw_cps queue in - let remainings = remainings (Raw.of_channel in_channel) cps in - (* Handling of cps defined in filename but not belonging to self. *) - if remainings <> [] then match obsoletes with - | Some filename -> - let out_channel = - open_out filename in -(* open_out_gen [Open_wronly; Open_creat; Open_append; Open_text] 0o666 filename in *) - let formatter = Format.formatter_of_out_channel out_channel in - Format.fprintf formatter "@[<v>"; - Raw.save formatter (Raw.Section remainings); - Format.fprintf formatter "@]@."; - close_out out_channel - | None -> () - - method command_line_args ~section_separator = - let print = Format.fprintf Format.str_formatter in (* shortcut *) - let result = ref [] in let push x = result := x :: !result in - let rec iter = function - | _, Immediate cp -> - let key = "-" ^ String.concat section_separator cp#get_name in - let spec = cp#get_spec in - let doc = ( - print "@[<hv5>"; - Format.pp_print_as Format.str_formatter (String.length key +3) ""; - if cp#get_help <> "" - then (print "@,@[<b2>"; cp#get_help_formatted Format.str_formatter; print "@]@ ") - else print "@,"; - print "@[<hv>@[current:@;<1 2>@[<hov1>"; cp#get_formatted Format.str_formatter; - print "@]@],@ @[default:@;<1 2>@[<b2>"; cp#get_default_formatted Format.str_formatter; - print "@]@]@]@]"; - Format.flush_str_formatter ()) in - (match cp#get_short_name with - | None -> () - | Some short_name -> push ("-" ^ short_name,spec,"")); - push (key,spec,doc) - | _, Subsection queue -> Queue.iter iter queue in - Queue.iter iter cps; - List.rev !result -end - - -(* Given wrappers for the type 'a, cp_custom_type defines a class 'a cp. *) -class ['a] cp_custom_type wrappers - ?group:(group:group option) name ?short_name default help = -object (self) - method private to_raw = wrappers.to_raw - method private of_raw = wrappers.of_raw - - val mutable value = default - (* output *) - method get = value - method get_default = default - method get_formatted formatter = self#get |> self#to_raw |> Raw.save formatter - method get_default_formatted formatter = self#get_default |> self#to_raw |> Raw.save formatter - (* input *) - method set v = let v' = value in value <- v; self#exec_hooks v' v - method set_raw v = self#of_raw v |> self#set - method private set_string s = s |> Raw.of_string |> self#of_raw |> self#set - method reset = self#set self#get_default - - (* name *) - val mutable shortname = short_name - method get_name = name - method get_short_name = shortname - method set_short_name s = shortname <- Some s - - (* help *) - method get_help = help - method get_help_formatted formatter = print_help formatter self#get_help - method get_spec = Arg.String self#set_string - - (* hooks *) - val mutable hooks = [] - method add_hook f = hooks <- (f:'a->'a->unit) :: hooks - method private exec_hooks v' v = List.iter (fun f -> f v' v) hooks - - initializer match group with Some g -> g#add (self :> 'a cp) | None -> () -end - - -(* ******************************************************************************** *) -(* ****************************** predefined classes ****************************** *) -(* ******************************************************************************** *) - -let int_wrappers = { - to_raw = (fun v -> Raw.Int v); - of_raw = function - | Raw.Int v -> v - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Int expected, got %a\n%!" Raw.to_channel r))} -class int_cp ?group name ?short_name default help = object (self) - inherit [int] cp_custom_type int_wrappers ?group name ?short_name default help - method get_spec = Arg.Int self#set -end - -let float_wrappers = { - to_raw = (fun v -> Raw.Float v); - of_raw = function - | Raw.Float v -> v - | Raw.Int v -> float v - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Float expected, got %a\n%!" Raw.to_channel r)) -} -class float_cp ?group name ?short_name default help = object (self) - inherit [float] cp_custom_type float_wrappers ?group name ?short_name default help - method get_spec = Arg.Float self#set -end - -(* The Pervasives version is too restrictive *) -let bool_of_string s = - match String.lowercase s with - | "false" | "no" | "n" | "0" -> false (* "0" and "1" aren't used. *) - | "true" | "yes" | "y" | "1" -> true - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Bool expected, got %s\n%!" r)) -let bool_wrappers = { - to_raw = (fun v -> Raw.String (string_of_bool v)); - of_raw = function - | Raw.String v -> bool_of_string v - | Raw.Int v -> v <> 0 - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Bool expected, got %a\n%!" Raw.to_channel r)) -} -class bool_cp ?group name ?short_name default help = object (self) - inherit [bool] cp_custom_type bool_wrappers ?group name ?short_name default help - method get_spec = Arg.Bool self#set -end - -let string_wrappers = { - to_raw = (fun v -> Raw.String v); - of_raw = function - | Raw.String v -> v - | Raw.Int v -> string_of_int v - | Raw.Float v -> string_of_float v - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.String expected, got %a\n%!" Raw.to_channel r)) -} -class string_cp ?group name ?short_name default help = object (self) - inherit [string] cp_custom_type string_wrappers ?group name ?short_name default help - method private of_string s = s - method get_spec = Arg.String self#set -end - -let list_wrappers wrappers = { - to_raw = (fun l -> Raw.List (List.map wrappers.to_raw l)); - of_raw = function - | Raw.List l -> List.map wrappers.of_raw l - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.List expected, got %a\n%!" Raw.to_channel r)) -} -class ['a] list_cp wrappers = ['a list] cp_custom_type (list_wrappers wrappers) - -let option_wrappers wrappers = { - to_raw = (function - | Some v -> wrappers.to_raw v - | None -> Raw.String ""); - of_raw = function - | Raw.String s as v -> ( - if s = "" || s = "None" then None - else if String.length s >= 5 && String.sub s 0 5 = "Some " - then Some (wrappers.of_raw (Raw.String (String.sub s 5 (String.length s -5)))) - else Some (wrappers.of_raw v)) - | r -> Some (wrappers.of_raw r)} -class ['a] option_cp wrappers = ['a option] cp_custom_type (option_wrappers wrappers) - -let enumeration_wrappers enum = - let switched = List.map (fun (string,cons) -> cons,string) enum in - {to_raw = (fun v -> Raw.String (List.assq v switched)); - of_raw = function - | Raw.String s -> - (try List.assoc s enum - with Not_found -> failwith (Printf.sprintf "%s isn't a known constructor" s)) - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw enumeration expected, got %a\n%!" Raw.to_channel r)) -} -class ['a] enumeration_cp enum ?group name ?short_name default help = object (self) - inherit ['a] cp_custom_type (enumeration_wrappers enum) - ?group name ?short_name default help - method get_spec = Arg.Symbol (List.map fst enum, (fun s -> self#set (List.assoc s enum))) -end - -let tuple2_wrappers wrapa wrapb = { - to_raw = (fun (a,b) -> Raw.Tuple [wrapa.to_raw a; wrapb.to_raw b]); - of_raw = function - | Raw.Tuple [a;b] -> wrapa.of_raw a, wrapb.of_raw b - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Tuple 2 expected, got %a\n%!" Raw.to_channel r)) -} -class ['a, 'b] tuple2_cp wrapa wrapb = ['a*'b] cp_custom_type (tuple2_wrappers wrapa wrapb) - -let tuple3_wrappers wrapa wrapb wrapc = { - to_raw = (fun (a,b,c) -> Raw.Tuple[wrapa.to_raw a; wrapb.to_raw b; wrapc.to_raw c]); - of_raw = function - | Raw.Tuple [a;b;c] -> wrapa.of_raw a, wrapb.of_raw b, wrapc.of_raw c - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Tuple 3 expected, got %a\n%!" Raw.to_channel r)) -} -class ['a,'b,'c] tuple3_cp wrapa wrapb wrapc = - ['a*'b*'c] cp_custom_type (tuple3_wrappers wrapa wrapb wrapc) - -let tuple4_wrappers wrapa wrapb wrapc wrapd = { - to_raw=(fun (a,b,c,d)->Raw.Tuple[wrapa.to_raw a;wrapb.to_raw b;wrapc.to_raw c;wrapd.to_raw d]); - of_raw = function - | Raw.Tuple [a;b;c;d] -> wrapa.of_raw a, wrapb.of_raw b, wrapc.of_raw c, wrapd.of_raw d - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Tuple 4 expected, got %a\n%!" Raw.to_channel r)) -} -class ['a,'b,'c,'d] tuple4_cp wrapa wrapb wrapc wrapd = - ['a*'b*'c*'d] cp_custom_type (tuple4_wrappers wrapa wrapb wrapc wrapd) - -class string2_cp = [string,string] tuple2_cp string_wrappers string_wrappers -(* class color_cp = string_cp *) -class font_cp = string_cp -class filename_cp = string_cp - - -(* ******************************************************************************** *) -(******************** Backward compatibility with module Flags.****************** *) -(* ******************************************************************************** *) - -type 'a option_class = 'a wrappers -type 'a option_record = 'a cp -type options_file = {mutable filename:string; group:group} - -let create_options_file filename = {filename = filename; group = new group} -let set_options_file options_file filename = options_file.filename <- filename -let load {filename=f; group = g} = g#read f -let append {group=g} filename = g#read filename -let save {filename=f; group = g} = g#write ~with_help:false f -let save_with_help {filename=f; group = g} = g#write ~with_help:true f -let define_option {group=group} name help option_class default = - (new cp_custom_type option_class ~group name default help) -let option_hook cp f = cp#add_hook (fun _ _ -> f ()) - -let string_option = string_wrappers -let color_option = string_wrappers -let font_option = string_wrappers -let int_option = int_wrappers -let bool_option = bool_wrappers -let float_option = float_wrappers -let string2_option = tuple2_wrappers string_wrappers string_wrappers - -let option_option = option_wrappers -let list_option = list_wrappers -let sum_option = enumeration_wrappers -let tuple2_option (a,b) = tuple2_wrappers a b -let tuple3_option (a,b,c) = tuple3_wrappers a b c -let tuple4_option (a,b,c,d) = tuple4_wrappers a b c d - -let ( !! ) cp = cp#get -let ( =:= ) cp value = cp#set value - -let shortname cp = String.concat ":" cp#get_name -let get_help cp = cp#get_help - -type option_value = - Module of option_module -| StringValue of string -| IntValue of int -| FloatValue of float -| List of option_value list -| SmallList of option_value list -and option_module = (string * option_value) list - -let rec value_to_raw = function - | Module a -> Raw.Section (List.map (fun (name,value) -> name, value_to_raw value) a) - | StringValue a -> Raw.String a - | IntValue a -> Raw.Int a - | FloatValue a -> Raw.Float a - | List a -> Raw.List (List.map value_to_raw a) - | SmallList a -> Raw.Tuple (List.map value_to_raw a) -let rec raw_to_value = function - | Raw.String a -> StringValue a - | Raw.Int a -> IntValue a - | Raw.Float a -> FloatValue a - | Raw.List a -> List (List.map raw_to_value a) - | Raw.Tuple a -> SmallList (List.map raw_to_value a) - | Raw.Section a -> Module (List.map (fun (name,value) -> name, raw_to_value value) a) - -let define_option_class _ of_option_value to_option_value = - {to_raw = (fun a -> a |> to_option_value |> value_to_raw); - of_raw = (fun a -> a |> raw_to_value |> of_option_value)} - -let to_value {to_raw = to_raw} a = a |> to_raw |> raw_to_value -let from_value {of_raw = of_raw} a = a |> value_to_raw |> of_raw - -let of_value_w wrappers a = a |> value_to_raw |> wrappers.of_raw -let to_value_w wrappers a = a |> wrappers.to_raw |> raw_to_value -(* fancy indentation when finishing this stub code, not good style :-) *) -let value_to_string : option_value -> string = of_value_w string_option -let string_to_value = to_value_w string_option -let value_to_int = of_value_w int_option -let int_to_value = to_value_w int_option -let value_to_bool = of_value_w bool_option -let bool_to_value = to_value_w bool_option -let value_to_float = of_value_w float_option -let float_to_value = to_value_w float_option -let value_to_string2 = of_value_w string2_option -let string2_to_value = to_value_w string2_option -let value_to_list of_value = - let wrapper = define_option_class "" of_value (fun _ -> failwith "value_to_list") in - of_value_w (list_option wrapper) -let list_to_value to_value = - let wrapper = define_option_class "" (fun _ -> failwith "value_to_list") to_value in - to_value_w (list_option wrapper) diff --git a/ide/utils/config_file.mli b/ide/utils/config_file.mli deleted file mode 100644 index 22328e7f1f..0000000000 --- a/ide/utils/config_file.mli +++ /dev/null @@ -1,352 +0,0 @@ -(*********************************************************************************) -(* 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 implements a mechanism to handle configuration files. - A configuration file is defined as a set of [variable = value] lines, - where value can be - a simple string (types int, string, bool...), - a list of values between brackets (lists) or parentheses (tuples), - or a set of [variable = value] lines between braces. - The configuration file is automatically loaded and saved, - and configuration parameters are manipulated inside the program as easily as references. - - Object implementation by Jean-Baptiste Rouquier. -*) - -(** {1:lowlevelinterface Low level interface} *) -(** Skip this section on a first reading... *) - -(** The type of cp freshly parsed from configuration file, -not yet wrapped in their proper type. *) -module Raw : sig - type cp = - | String of string (** base types, reproducing the tokens of Genlex *) - | Int of int - | Float of float - | List of cp list (** compound types *) - | Tuple of cp list - | Section of (string * cp) list - - (** A parser. *) - val of_string : string -> cp - - (** Used to print the values into a log file for instance. *) - val to_channel : out_channel -> cp -> unit -end - -(** A type used to specialize polymorphics classes and define new classes. - {!Config_file.predefinedwrappers} are provided. - *) -type 'a wrappers = { to_raw : 'a -> Raw.cp; of_raw : Raw.cp -> 'a; } - -(** An exception raised by {!Config_file.cp.set_raw} - when the argument doesn't have a suitable {!Config_file.Raw.cp} type. - The function explains the problem and flush the output.*) -exception Wrong_type of (out_channel -> unit) - -(* (\** {2 Miscellaneous functions} *\) *) - -(* val bool_of_string : string -> bool *) - -(** {1 High level interface} *) -(** {2 The two main classes} *) - -(** A Configuration Parameter, in short cp, ie - a value we can store in and read from a configuration file. *) -class type ['a] cp = object - (** {1 Accessing methods} *) - - method get : 'a - method set : 'a -> unit - method get_default : 'a - method get_help : string - method get_name : string list - - (** Resets to the default value. *) - method reset : unit - - (** {1 Miscellaneous} *) - - (** All the hooks are executed each time the method set is called, - just after setting the new value.*) - method add_hook : ('a -> 'a -> unit) -> unit - - (** Used to generate command line arguments in {!Config_file.group.command_line_args} *) - method set_short_name : string -> unit - - (** [None] if no optional short_name was provided during object creation - and [set_short_name] was never called.*) - method get_short_name : string option - - (** {1 Methods for internal use} *) - - method get_formatted : Format.formatter -> unit - method get_default_formatted : Format.formatter -> unit - method get_help_formatted : Format.formatter -> unit - - method get_spec : Arg.spec - method set_raw : Raw.cp -> unit -end - -(** Unification over all possible ['a cp]: - contains the main methods of ['a cp] except the methods using the type ['a]. - A [group] manipulates only [groupable_cp] for homogeneity. *) -type groupable_cp = < - get_name : string list; - get_short_name : string option; - get_help : string; - - get_formatted : Format.formatter -> unit; - get_default_formatted : Format.formatter -> unit; - get_help_formatted : Format.formatter -> unit; - get_spec : Arg.spec; - - reset : unit; - set_raw : Raw.cp -> unit; > - -(** Raised in case a name is already used. - See {!Config_file.group.add} *) -exception Double_name - -(** An exception possibly raised if we want to check that - every cp is defined in a configuration file. - See {!Config_file.group.read}. -*) -exception Missing_cp of groupable_cp - -(** A group of cps, that can be loaded and saved, -or used to generate command line arguments. - -The basic usage is to have only one group and one configuration file, -but this mechanism allows having more, -for instance having another smaller group for the options to pass on the command line. -*) -class group : object - (** Adds a cp to the group. - Note that the type ['a] must be lost - to allow cps of different types to belong to the same group. - @raise Double_name if [cp#get_name] is already used. *) -(* method add : 'a cp -> 'a cp *) - method add : 'a cp -> unit - - (**[write filename] saves all the cps into the configuration file [filename].*) - method write : ?with_help:bool -> string -> unit - - (** [read filename] reads [filename] - and stores the values it specifies into the cps belonging to this group. - The file is created (and not read) if it doesn't exists. - In the default behaviour, no warning is issued - if not all cps are updated or if some values of [filename] aren't used. - - If [obsoletes] is specified, - then prints in this file all the values that are - in [filename] but not in this group. - Those cps are likely to be erroneous or obsolete. - Opens this file only if there is something to write in it. - - If [no_default] is [true], then raises [Missing_cp foo] if - the cp [foo] isn't defined in [filename] but belongs to this group. - - [on_type_error groupable_cp value output filename in_channel] - is called if the file doesn't give suitable value - (string instead of int for instance, or a string not belonging to the expected enumeration) - for the cp [groupable_cp]. - [value] is the value read from the file, - [output] is the argument of {!Config_file.Wrong_type}, - [filename] is the same argument as the one given to read, - and [in_channel] refers to [filename] to allow a function to close it if needed. - Default behaviour is to print an error message and call [exit 1]. -*) - method read : ?obsoletes:string -> ?no_default:bool -> - ?on_type_error : (groupable_cp -> Raw.cp -> (out_channel -> unit) -> - string -> in_channel -> unit) -> - string -> unit - - (** Interface with module Arg. - @param section_separator the string used to concatenate the name of a cp, - to get the command line option name. - ["-"] is a good default. - @return a list that can be used with [Arg.parse] and [Arg.usage].*) - method command_line_args : section_separator:string -> (string * Arg.spec * string) list - end - -(** {2 Predefined cp classes} *) - -(** The last three non-optional arguments are always - [name] (of type string list), [default_value] and [help] (of type string). - - [name] is the path to the cp: [["section";"subsection"; ...; "foo"]]. - It can consists of a single element but must not be empty. - - [short_name] will be added a "-" and used in - {!Config_file.group.command_line_args}. - - [group], if provided, adds the freshly defined option to it - (something like [initializer group#add self]). - - [help] needs not contain newlines, it will be automatically truncated where needed. - It is mandatory but can be [""]. -*) - -class int_cp : ?group:group -> string list -> ?short_name:string -> int -> string -> [int] cp -class float_cp : ?group:group -> string list -> ?short_name:string -> float -> string -> [float] cp -class bool_cp : ?group:group -> string list -> ?short_name:string -> bool -> string -> [bool] cp -class string_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> [string] cp -class ['a] list_cp : 'a wrappers -> ?group:group -> string list -> ?short_name:string -> 'a list -> string -> ['a list] cp -class ['a] option_cp : 'a wrappers -> ?group:group -> string list -> ?short_name:string -> 'a option -> string -> ['a option] cp -class ['a] enumeration_cp : (string * 'a) list -> ?group:group -> string list -> ?short_name:string -> 'a -> string -> ['a] cp -class ['a, 'b] tuple2_cp : 'a wrappers -> 'b wrappers -> ?group:group -> string list -> ?short_name:string -> 'a * 'b -> string -> ['a * 'b] cp -class ['a, 'b, 'c] tuple3_cp : 'a wrappers -> 'b wrappers -> 'c wrappers -> ?group:group -> string list -> ?short_name:string -> 'a * 'b * 'c -> string -> ['a * 'b * 'c] cp -class ['a, 'b, 'c, 'd] tuple4_cp : 'a wrappers -> 'b wrappers -> 'c wrappers -> 'd wrappers -> ?group:group -> string list -> ?short_name:string -> 'a * 'b * 'c * 'd -> string -> ['a * 'b * 'c * 'd] cp -class string2_cp : ?group:group -> string list -> ?short_name:string -> string * string -> string -> [string, string] tuple2_cp -(* class color_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> string_cp *) -class font_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> string_cp -class filename_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> string_cp - -(** {2:predefinedwrappers Predefined wrappers} *) - -val int_wrappers : int wrappers -val float_wrappers : float wrappers -val bool_wrappers : bool wrappers -val string_wrappers : string wrappers -val list_wrappers : 'a wrappers -> 'a list wrappers -val option_wrappers : 'a wrappers -> 'a option wrappers - -(** If you have a [type suit = Spades | Hearts | Diamond | Clubs], then -{[enumeration_wrappers ["spades",Spades; "hearts",Hearts; "diamond",Diamond; "clubs",Clubs]]} -will allow you to use cp of this type. -For sum types with not only constant constructors, -you will need to define your own cp class. *) -val enumeration_wrappers : (string * 'a) list -> 'a wrappers -val tuple2_wrappers : 'a wrappers -> 'b wrappers -> ('a * 'b) wrappers -val tuple3_wrappers : 'a wrappers -> 'b wrappers -> 'c wrappers -> ('a * 'b * 'c) wrappers -val tuple4_wrappers : 'a wrappers -> 'b wrappers -> 'c wrappers -> 'd wrappers -> ('a * 'b * 'c * 'd) wrappers - -(** {2 Defining new cp classes} *) - -(** To define a new cp class, you just have to provide an implementation for the wrappers -between your type [foo] and the type [Raw.cp]. -Once you have your wrappers [w], write -{[class foo_cp = [foo] cp_custom_type w]} - -For further details, have a look at the commented .ml file, -section "predefined cp classes". -*) -class ['a] cp_custom_type : 'a wrappers -> - ?group:group -> string list -> ?short_name:string -> 'a -> string -> ['a] cp - - -(** {1 Backward compatibility} - -Deprecated. - -All the functions from the module Options are available, except: - -- [prune_file]: use [group#write ?obsoletes:"foo.ml"]. -- [smalllist_to_value], [smalllist_option]: use lists or tuples. -- [get_class]. -- [class_hook]: hooks are local to a cp. - If you want hooks global to a class, - define a new class that inherit from {!Config_file.cp_custom_type}. -- [set_simple_option], [get_simple_option], [simple_options], [simple_args]: - use {!Config_file.group.write}. -- [set_option_hook]: use {!Config_file.cp.add_hook}. -- [set_string_wrappers]: define a new class with {!Config_file.cp_custom_type}. - -The old configurations files are readable by this module. -*) - - - - - -(**/**) -type 'a option_class -type 'a option_record -type options_file - -val create_options_file : string -> options_file -val set_options_file : options_file -> string -> unit -val load : options_file -> unit -val append : options_file -> string -> unit -val save : options_file -> unit -val save_with_help : options_file -> unit -(* val define_option : options_file -> *) -(* string list -> string -> 'a option_class -> 'a -> 'a option_record *) -val option_hook : 'a option_record -> (unit -> unit) -> unit - -val string_option : string option_class -val color_option : string option_class -val font_option : string option_class -val int_option : int option_class -val bool_option : bool option_class -val float_option : float option_class -val string2_option : (string * string) option_class - -val option_option : 'a option_class -> 'a option option_class -val list_option : 'a option_class -> 'a list option_class -val sum_option : (string * 'a) list -> 'a option_class -val tuple2_option : - 'a option_class * 'b option_class -> ('a * 'b) option_class -val tuple3_option : 'a option_class * 'b option_class * 'c option_class -> - ('a * 'b * 'c) option_class -val tuple4_option : - 'a option_class * 'b option_class * 'c option_class * 'd option_class -> - ('a * 'b * 'c * 'd) option_class - -val ( !! ) : 'a option_record -> 'a -val ( =:= ) : 'a option_record -> 'a -> unit -val shortname : 'a option_record -> string -val get_help : 'a option_record -> string - -type option_value = - Module of option_module -| StringValue of string -| IntValue of int -| FloatValue of float -| List of option_value list -| SmallList of option_value list -and option_module = (string * option_value) list - -val define_option_class : - string -> (option_value -> 'a) -> ('a -> option_value) -> 'a option_class - -val to_value : 'a option_class -> 'a -> option_value -val from_value : 'a option_class -> option_value -> 'a - -val value_to_string : option_value -> string -val string_to_value : string -> option_value -val value_to_int : option_value -> int -val int_to_value : int -> option_value -val bool_of_string : string -> bool -val value_to_bool : option_value -> bool -val bool_to_value : bool -> option_value -val value_to_float : option_value -> float -val float_to_value : float -> option_value -val value_to_string2 : option_value -> string * string -val string2_to_value : string * string -> option_value -val value_to_list : (option_value -> 'a) -> option_value -> 'a list -val list_to_value : ('a -> option_value) -> 'a list -> option_value diff --git a/ide/utils/configwin.ml b/ide/utils/configwin.ml index 4606ef29fd..69e8b647ae 100644 --- a/ide/utils/configwin.ml +++ b/ide/utils/configwin.ml @@ -36,44 +36,16 @@ type return_button = | Return_ok | Return_cancel -let string_to_key = Configwin_types.string_to_key -let key_to_string = Configwin_types.key_to_string -let key_cp_wrapper = Configwin_types.key_cp_wrapper -class key_cp = Configwin_types.key_cp - - let string = Configwin_ihm.string -let text = Configwin_ihm.text let strings = Configwin_ihm.strings let list = Configwin_ihm.list let bool = Configwin_ihm.bool -let filename = Configwin_ihm.filename -let filenames = Configwin_ihm.filenames -let color = Configwin_ihm.color -let font = Configwin_ihm.font let combo = Configwin_ihm.combo let custom = Configwin_ihm.custom -let date = Configwin_ihm.date -let hotkey = Configwin_ihm.hotkey let modifiers = Configwin_ihm.modifiers -let html = Configwin_ihm.html let edit ?(apply=(fun () -> ())) title ?width ?height conf_struct_list = Configwin_ihm.edit ~with_apply: true ~apply title ?width ?height conf_struct_list - -let get = Configwin_ihm.edit ~with_apply: false ~apply: (fun () -> ()) - -let simple_edit - ?(apply=(fun () -> ())) - title ?width ?height - param_list = Configwin_ihm.simple_edit ~with_apply: true ~apply title ?width ?height param_list - -let simple_get = Configwin_ihm.simple_edit - ~with_apply: false ~apply: (fun () -> ()) - -let box = Configwin_ihm.box - -let tabbed_box = Configwin_ihm.tabbed_box diff --git a/ide/utils/configwin.mli b/ide/utils/configwin.mli index c5fbf39a01..7616e471db 100644 --- a/ide/utils/configwin.mli +++ b/ide/utils/configwin.mli @@ -50,22 +50,6 @@ type return_button = button or the window manager but never clicked on the apply button.*) - -(** {2 The key option class (to use with the {!Config_file} library)} *) - -val string_to_key : string -> Gdk.Tags.modifier list * int - -val key_to_string : Gdk.Tags.modifier list * int -> string - -val key_cp_wrapper : (Gdk.Tags.modifier list * int) Config_file.wrappers - -class key_cp : - ?group:Config_file.group -> - string list -> - ?short_name:string -> - Gdk.Tags.modifier list * int -> - string -> [Gdk.Tags.modifier list * int] Config_file.cp_custom_type - (** {2 Functions to create parameters} *) (** [string label value] creates a string parameter. @@ -136,24 +120,6 @@ val list : ?editable: bool -> ?help: string -> 'a list -> parameter_kind -(** [color label value] creates a color 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 color : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: (string -> unit) -> string -> string -> parameter_kind - -(** [font label value] creates a font 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 font : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: (string -> unit) -> string -> string -> 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]). @@ -169,69 +135,6 @@ val combo : ?editable: bool -> ?expand: bool -> ?help: string -> ?new_allowed: bool -> ?blank_allowed: bool -> string -> string list -> string -> parameter_kind -(** [text label value] creates a text parameter. - @param editable indicate if the value is editable (default is [true]). - @param expand indicate if the box for the text 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 text : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: (string -> unit) -> string -> string -> parameter_kind - -(** Same as {!Configwin.text} but html bindings are available - in the text widget. Use the [configwin_html_config] utility - to edit your bindings. -*) -val html : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: (string -> unit) -> string -> string -> parameter_kind - -(** [filename label value] creates a filename 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 filename : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: (string -> unit) -> string -> string -> parameter_kind - -(** [filenames label value] creates a filename 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 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 filenames : ?editable: bool -> ?help: string -> - ?f: (string list -> unit) -> - ?eq: (string -> string -> bool) -> - string -> string list -> parameter_kind - -(** [date label value] creates a date 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 f_string the function used to display the date as a string. The parameter - is a tupe [(day,month,year)], where [month] is between [0] and [11]. The default - function creates the string [year/month/day]. -*) -val date : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: ((int * int * int) -> unit) -> - ?f_string: ((int * int * int -> string)) -> - string -> (int * int * int) -> parameter_kind - -(** [hotkey label value] creates a hot key parameter. - A hot key is defined by a list of modifiers and a key code. - @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 hotkey : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: ((Gdk.Tags.modifier list * int) -> unit) -> - string -> (Gdk.Tags.modifier list * int) -> parameter_kind - val modifiers : ?editable: bool -> ?expand: bool -> ?help: string -> ?allow:(Gdk.Tags.modifier list) -> ?f: (Gdk.Tags.modifier list -> unit) -> @@ -259,46 +162,3 @@ val edit : ?height:int -> configuration_structure list -> return_button - -(** This function takes a configuration structure and creates a window used - to get the various parameters from the user. It is the same window as edit but - there is no apply button.*) -val get : - string -> - ?width:int -> - ?height:int -> - configuration_structure list -> - return_button - -(** This function takes a list of parameter specifications 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 simple_edit : - ?apply: (unit -> unit) -> - string -> - ?width:int -> - ?height:int -> - parameter_kind list -> return_button - -(** This function takes a list of parameter specifications and - creates a window to configure the various parameters, - without Apply button.*) -val simple_get : - string -> - ?width:int -> - ?height:int -> - parameter_kind list -> return_button - -(** Create a [GPack.box] with the list of given parameters, - Return the box and the function to call to apply new values to parameters. -*) -val box : parameter_kind list -> GData.tooltips -> GPack.box * (unit -> unit) - -(** Create a [GPack.box] with the list of given configuration structure list, - and the given list of buttons (defined by their label and callback). - Before calling the callback of a button, the [apply] function - of each parameter is called. -*) -val tabbed_box : configuration_structure list -> - (string * (unit -> unit)) list -> GData.tooltips -> GPack.box diff --git a/ide/utils/configwin_ihm.ml b/ide/utils/configwin_ihm.ml index c1062a9db1..70133fb9f5 100644 --- a/ide/utils/configwin_ihm.ml +++ b/ide/utils/configwin_ihm.ml @@ -27,7 +27,25 @@ open Configwin_types -module O = Config_file +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 @@ -35,112 +53,9 @@ class type widget = method apply : unit -> unit end -let file_html_config = Filename.concat Configwin_messages.home ".configwin_html" - let debug = false let dbg s = if debug then Minilib.log s else () -(** Return the config group for the html config file, - and the option for bindings. *) -let html_config_file_and_option () = - let ini = new O.group in - let bindings = new O.list_cp - Configwin_types.htmlbinding_cp_wrapper - ~group: ini - ["bindings"] - ~short_name: "bd" - [ { html_key = Configwin_types.string_to_key "A-b" ; - html_begin = "<b>"; - html_end = "</b>" ; - } ; - { html_key = Configwin_types.string_to_key "A-i" ; - html_begin = "<i>"; - html_end = "</i>" ; - } - ] - "" - in - ini#read file_html_config ; - (ini, bindings) - -(** This variable contains the last directory where the user selected a file.*) -let last_dir = ref "";; - -(** This function allows the user to select a file and returns the - selected file name. An optional function allows changing the - behaviour of the ok button. - A VOIR : mutli-selection ? *) -let select_files ?dir - ?(fok : (string -> unit) option) - the_title = - let files = ref ([] : string list) in - let fs = GWindow.file_selection ~modal:true - ~title: the_title () in - (* we set the previous directory, if no directory is given *) - ( - match dir with - None -> - if !last_dir <> "" then - let _ = fs#set_filename !last_dir in - () - else - () - | Some dir -> - let _ = fs#set_filename !last_dir in - () - ); - - let _ = fs # connect#destroy ~callback: GMain.Main.quit in - let _ = fs # ok_button # connect#clicked ~callback: - (match fok with - None -> - (fun () -> files := [fs#filename] ; fs#destroy ()) - | Some f -> - (fun () -> f fs#filename) - ) - in - let _ = fs # cancel_button # connect#clicked ~callback:fs#destroy in - fs # show (); - GMain.Main.main (); - match !files with - | [] -> - [] - | [""] -> - [] - | l -> - (* we keep the directory in last_dir *) - last_dir := Filename.dirname (List.hd l); - l -;; - -(** Make the user select a date. *) -let select_date title (day,mon,year) = - let v_opt = ref None in - let window = GWindow.dialog ~modal:true ~title () in - let hbox = GPack.hbox ~border_width:10 ~packing:window#vbox#add () in - let cal = GMisc.calendar ~packing: (hbox#pack ~expand: true) () in - cal#select_month ~month: mon ~year: year ; - cal#select_day day; - let bbox = window#action_area in - - let bok = GButton.button ~label: Configwin_messages.mOk - ~packing:(bbox#pack ~expand:true ~padding:4) () - in - let bcancel = GButton.button ~label: Configwin_messages.mCancel - ~packing:(bbox#pack ~expand:true ~padding:4) () - in - ignore (bok#connect#clicked ~callback: - (fun () -> v_opt := Some (cal#date); window#destroy ())); - ignore(bcancel#connect#clicked ~callback: window#destroy); - - bok#grab_default (); - ignore(window#connect#destroy ~callback: GMain.Main.quit); - window#set_position `CENTER; - window#show (); - GMain.Main.main (); - !v_opt - - (** 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 @@ -460,164 +375,6 @@ class custom_param_box param (tt:GData.tooltips) = method apply = param.custom_f_apply () end -(** This class is used to build a box for a color parameter.*) -class color_param_box param (tt:GData.tooltips) = - let _ = dbg "color_param_box" in - let v = ref param.color_value in - let hbox = GPack.hbox () in - let wb = GButton.button ~label: param.color_label - ~packing: (hbox#pack ~expand: false ~padding: 2) () - in - let w_test = GMisc.arrow - ~kind: `RIGHT - ~shadow: `OUT - ~width: 20 - ~height: 20 - ~packing: (hbox#pack ~expand: false ~padding: 2 ) - () - in - let we = GEdit.entry - ~editable: param.color_editable - ~packing: (hbox#pack ~expand: param.color_expand ~padding: 2) - () - in - let _ = - match param.color_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wb#coerce - in - let set_color s = - let style = w_test#misc#style#copy in - ( - try style#set_fg [ (`NORMAL, `NAME s) ; ] - with _ -> () - ); - w_test#misc#set_style style; - in - let _ = set_color !v in - let _ = we#set_text !v in - let f_sel () = - let dialog = GWindow.color_selection_dialog - ~title: param.color_label - ~modal: true - ~show: true - () - in - let wb_ok = dialog#ok_button in - let wb_cancel = dialog#cancel_button in - let _ = dialog#connect#destroy ~callback:GMain.Main.quit in - let _ = wb_ok#connect#clicked - ~callback:(fun () -> -(* let color = dialog#colorsel#color in - let r = (Gdk.Color.red color) in - let g = (Gdk.Color.green color)in - let b = (Gdk.Color.blue color) in - let s = Printf.sprintf "#%4X%4X%4X" r g b in - let _ = - for i = 1 to (String.length s) - 1 do - if s.[i] = ' ' then s.[i] <- '0' - done - in - we#set_text s ; *) - dialog#destroy () - ) - in - let _ = wb_cancel#connect#clicked ~callback:dialog#destroy in - GMain.Main.main () - in - let _ = - if param.color_editable then ignore (wb#connect#clicked ~callback:f_sel) - 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 = we#text in - if new_value <> param.color_value then - let _ = param.color_f_apply new_value in - param.color_value <- new_value - else - () - - initializer - ignore (we#connect#changed ~callback:(fun () -> set_color we#text)); - - end ;; - -(** This class is used to build a box for a font parameter.*) -class font_param_box param (tt:GData.tooltips) = - let _ = dbg "font_param_box" in - let v = ref param.font_value in - let hbox = GPack.hbox () in - let wb = GButton.button ~label: param.font_label - ~packing: (hbox#pack ~expand: false ~padding: 2) () - in - let we = GEdit.entry - ~editable: false - ~packing: (hbox#pack ~expand: param.font_expand ~padding: 2) - () - in - let _ = - match param.font_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wb#coerce - in - let set_entry_font font_opt = - match font_opt with - None -> () - | Some s -> - let style = we#misc#style#copy in - ( - try - let font = Gdk.Font.load_fontset s in - style#set_font font - with _ -> () - ); - we#misc#set_style style - in - let _ = set_entry_font (Some !v) in - let _ = we#set_text !v in - let f_sel () = - let dialog = GWindow.font_selection_dialog - ~title: param.font_label - ~modal: true - ~show: true - () - in - dialog#selection#set_font_name !v; - let wb_ok = dialog#ok_button in - let wb_cancel = dialog#cancel_button in - let _ = dialog#connect#destroy ~callback:GMain.Main.quit in - let _ = wb_ok#connect#clicked - ~callback:(fun () -> - let font = dialog#selection#font_name in - we#set_text font ; - set_entry_font (Some font); - dialog#destroy () - ) - in - let _ = wb_cancel#connect#clicked ~callback:dialog#destroy in - GMain.Main.main () - in - let _ = if param.font_editable then ignore (wb#connect#clicked ~callback:f_sel) 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 = we#text in - if new_value <> param.font_value then - let _ = param.font_f_apply new_value in - param.font_value <- new_value - else - () - end ;; - (** This class is used to build a box for a text parameter.*) class text_param_box param (tt:GData.tooltips) = let _ = dbg "text_param_box" in @@ -662,35 +419,6 @@ class text_param_box param (tt:GData.tooltips) = () end ;; -(** This class is used to build a box a html parameter. *) -class html_param_box param (tt:GData.tooltips) = - let _ = dbg "html_param_box" in - object (self) - inherit text_param_box param tt - - method private exec html_start html_end () = - let (i1,i2) = wview#buffer#selection_bounds in - let s = i1#get_text ~stop: i2 in - match s with - "" -> - wview#buffer#insert (html_start^html_end) - | _ -> - ignore (wview#buffer#insert ~iter: i2 html_end); - ignore (wview#buffer#insert ~iter: i1 html_start); - wview#buffer#place_cursor ~where: i2 - - initializer - dbg "html_param_box:initializer"; - let (_,html_bindings) = html_config_file_and_option () in - dbg "html_param_box:connecting key press events"; - let add_shortcut hb = - let (mods, k) = hb.html_key in - Okey.add wview ~mods k (self#exec hb.html_begin hb.html_end) - in - List.iter add_shortcut html_bindings#get; - dbg "html_param_box:end" - end - (** This class is used to build a box for a boolean parameter.*) class bool_param_box param (tt:GData.tooltips) = let _ = dbg "bool_param_box" in @@ -719,105 +447,6 @@ class bool_param_box param (tt:GData.tooltips) = () end ;; -(** This class is used to build a box for a file name parameter.*) -class filename_param_box param (tt:GData.tooltips) = - let _ = dbg "filename_param_box" in - let hbox = GPack.hbox () in - let wb = GButton.button ~label: param.string_label - ~packing: (hbox#pack ~expand: false ~padding: 2) () - in - let we = GEdit.entry - ~editable: param.string_editable - ~packing: (hbox#pack ~expand: param.string_expand ~padding: 2) - () - in - let _ = - match param.string_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wb#coerce - in - let _ = we#set_text (param.string_to_string param.string_value) in - - let f_click () = - match select_files param.string_label with - [] -> - () - | f :: _ -> - we#set_text f - in - let _ = - if param.string_editable then - let _ = wb#connect#clicked ~callback:f_click in - () - else - () - 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 hot key parameter.*) -class hotkey_param_box param (tt:GData.tooltips) = - let _ = dbg "hotkey_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.hk_label ~packing: wev#add () in - let we = GEdit.entry - ~editable: false - ~packing: (hbox#pack ~expand: param.hk_expand ~padding: 2) - () - in - let value = ref param.hk_value in - let _ = - match param.hk_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wev#coerce - in - let _ = we#set_text (Configwin_types.key_to_string param.hk_value) in - let mods_we_dont_care = [`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK] in - let capture ev = - let key = GdkEvent.Key.keyval ev in - let modifiers = GdkEvent.Key.state ev in - let mods = List.filter - (fun m -> not (List.mem m mods_we_dont_care)) - modifiers - in - value := (mods, key); - we#set_text (Glib.Convert.locale_to_utf8 (Configwin_types.key_to_string !value)); - false - in - let _ = - if param.hk_editable then - ignore (we#event#connect#key_press ~callback:capture) - else - () - 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.hk_value then - let _ = param.hk_f_apply new_value in - param.hk_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 @@ -825,7 +454,7 @@ class modifiers_param_box param = let value = ref param.md_value in let _ = List.map (fun modifier -> let but = GButton.toggle_button - ~label:(Configwin_types.modifiers_to_string [modifier]) + ~label:(modifiers_to_string [modifier]) ~active:(List.mem modifier param.md_value) ~packing:(hbox#pack ~expand:false) () in ignore (but#connect#toggled @@ -854,55 +483,6 @@ class modifiers_param_box param = () end ;; -(** This class is used to build a box for a date parameter.*) -class date_param_box param (tt:GData.tooltips) = - let _ = dbg "date_param_box" in - let v = ref param.date_value in - let hbox = GPack.hbox () in - let wb = GButton.button ~label: param.date_label - ~packing: (hbox#pack ~expand: false ~padding: 2) () - in - let we = GEdit.entry - ~editable: false - ~packing: (hbox#pack ~expand: param.date_expand ~padding: 2) - () - in - - let _ = - match param.date_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wb#coerce - in - - let _ = we#set_text (param.date_f_string param.date_value) in - let f_click () = - match select_date param.date_label !v with - None -> () - | Some (y,m,d) -> - v := (d,m,y) ; - we#set_text (param.date_f_string (d,m,y)) - in - let _ = - if param.date_editable then - let _ = wb#connect#clicked ~callback:f_click in - () - else - () - 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 = - if !v <> param.date_value then - let _ = param.date_f_apply !v in - param.date_value <- !v - 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) (tt:GData.tooltips) = let _ = dbg "list_param_box" in @@ -975,10 +555,6 @@ class configuration_box (tt : GData.tooltips) conf_struct = let box = new bool_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box - | Filename_param p -> - let box = new filename_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box | List_param f -> let box = f tt in let _ = main_box#pack ~expand: true ~padding: 2 box#box in @@ -987,30 +563,10 @@ class configuration_box (tt : GData.tooltips) conf_struct = let box = new custom_param_box p tt in let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in box - | Color_param p -> - let box = new color_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Font_param p -> - let box = new font_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Date_param p -> - let box = new date_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Hotkey_param p -> - let box = new hotkey_param_box p tt in - let _ = main_box#pack ~expand: false ~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 - | Html_param p -> - let box = new html_param_box p tt in - let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in - box in let set_icon iter = function @@ -1102,36 +658,6 @@ class configuration_box (tt : GData.tooltips) conf_struct = end -(** Create a vbox with the list of given configuration structure list, - and the given list of buttons (defined by their label and callback). - Before calling the callback of a button, the [apply] function - of each parameter is called. -*) -let tabbed_box conf_struct_list buttons tooltips = - let param_box = - new configuration_box tooltips conf_struct_list - in - let f_apply () = param_box#apply - in - let hbox_buttons = GPack.hbox ~packing: (param_box#box#pack ~expand: false ~padding: 4) () in - let rec iter_buttons ?(grab=false) = function - [] -> - () - | (label, callb) :: q -> - let b = GButton.button ~label: label - ~packing:(hbox_buttons#pack ~expand:true ~fill: true ~padding:4) () - in - ignore (b#connect#clicked ~callback: - (fun () -> f_apply (); callb ())); - (* If it's the first button then give it the focus *) - if grab then b#grab_default (); - - iter_buttons q - in - iter_buttons ~grab: true buttons; - - param_box#box - (** This function takes a configuration structure list and creates a window to configure the various parameters. *) let edit ?(with_apply=true) @@ -1174,110 +700,6 @@ let edit ?(with_apply=true) in iter Return_cancel -(** Create a vbox with the list of given parameters. *) -let box param_list tt = - let main_box = GPack.vbox () in - let f parameter = - match parameter with - String_param p -> - let box = new string_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Combo_param p -> - let box = new combo_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Text_param p -> - let box = new text_param_box p tt 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 tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Filename_param p -> - let box = new filename_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | List_param f -> - let box = f tt in - let _ = main_box#pack ~expand: true ~padding: 2 box#box in - box - | Custom_param p -> - let box = new custom_param_box p tt in - let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in - box - | Color_param p -> - let box = new color_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Font_param p -> - let box = new font_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Date_param p -> - let box = new date_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Hotkey_param p -> - let box = new hotkey_param_box p tt in - let _ = main_box#pack ~expand: false ~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 - | Html_param p -> - let box = new html_param_box p tt in - let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in - box - in - let list_param_box = List.map f param_list in - let f_apply () = - List.iter (fun param_box -> param_box#apply) list_param_box - in - (main_box, f_apply) - -(** This function takes a list of parameter specifications and - creates a window to configure the various parameters.*) -let simple_edit ?(with_apply=true) - ?(apply=(fun () -> ())) - title ?width ?height - param_list = - let dialog = GWindow.dialog - ~modal: true ~title: title - ?height ?width - () - in - let tooltips = GData.tooltips () 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 (box, f_apply) = box param_list tooltips in - dialog#vbox#pack ~expand: true ~fill: true box#coerce; - - let destroy () = - tooltips#destroy () ; - dialog#destroy (); - in - let rec iter rep = - try - match dialog#run () with - | `APPLY -> f_apply (); apply (); iter Return_apply - | `OK -> f_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 @@ -1342,30 +764,6 @@ let strings ?(editable=true) ?help ?(add=(fun () -> [])) label v = list ~editable ?help ~f ~eq ~edit: (edit_string label) ~add label (fun s -> [s]) v -(** Create a color param. *) -let color ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Color_param - { - color_label = label ; - color_help = help ; - color_value = v ; - color_editable = editable ; - color_f_apply = f ; - color_expand = expand ; - } - -(** Create a font param. *) -let font ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Font_param - { - font_label = label ; - font_help = help ; - font_value = v ; - font_editable = editable ; - font_f_apply = f ; - font_expand = expand ; - } - (** Create a combo param. *) let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) ?(new_allowed=false) @@ -1383,82 +781,6 @@ let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) combo_expand = expand ; } -(** Create a text param. *) -let text ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Text_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 html param. *) -let html ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Html_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 filename param. *) -let filename ?(editable=true) ?(expand=true)?help ?(f=(fun _ -> ())) label v = - Filename_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 filenames param.*) -let filenames ?(editable=true) ?help ?(f=(fun _ -> ())) - ?(eq=Pervasives.(=)) - label v = - let add () = select_files label in - list ~editable ?help ~f ~eq ~add label (fun s -> [Glib.Convert.locale_to_utf8 s]) v - -(** Create a date param. *) -let date ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) - ?(f_string=(fun(d,m,y)-> Printf.sprintf "%d/%d/%d" y (m+1) d)) - label v = - Date_param - { - date_label = label ; - date_help = help ; - date_value = v ; - date_editable = editable ; - date_f_string = f_string ; - date_f_apply = f ; - date_expand = expand ; - } - -(** Create a hot key param. *) -let hotkey ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Hotkey_param - { - hk_label = label ; - hk_help = help ; - hk_value = v ; - hk_editable = editable ; - hk_f_apply = f ; - hk_expand = expand ; - } - let modifiers ?(editable=true) ?(expand=true) diff --git a/ide/utils/configwin_ihm.mli b/ide/utils/configwin_ihm.mli new file mode 100644 index 0000000000..c867ad9127 --- /dev/null +++ b/ide/utils/configwin_ihm.mli @@ -0,0 +1,66 @@ +(*********************************************************************************) +(* 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 -> + ?width:int -> + ?height:int -> + configuration_structure list -> + return_button diff --git a/ide/utils/configwin_keys.ml b/ide/utils/configwin_keys.ml deleted file mode 100644 index 9f44e5c6be..0000000000 --- a/ide/utils/configwin_keys.ml +++ /dev/null @@ -1,4176 +0,0 @@ -(*********************************************************************************) -(* 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 *) -(* *) -(*********************************************************************************) - -(** Key codes - - Ce fichier provient de X11/keysymdef.h - les noms des symboles deviennent : XK_ -> xk_ - - Thanks to Fabrice Le Fessant. -*) - -let xk_VoidSymbol = 0xFFFFFF (** void symbol *) - - -(** TTY Functions, cleverly chosen to map to ascii, for convenience of - programming, but could have been arbitrary (at the cost of lookup - tables in client code. -*) - -let xk_BackSpace = 0xFF08 (** back space, back char *) -let xk_Tab = 0xFF09 -let xk_Linefeed = 0xFF0A (** Linefeed, LF *) -let xk_Clear = 0xFF0B -let xk_Return = 0xFF0D (** Return, enter *) -let xk_Pause = 0xFF13 (** Pause, hold *) -let xk_Scroll_Lock = 0xFF14 -let xk_Sys_Req = 0xFF15 -let xk_Escape = 0xFF1B -let xk_Delete = 0xFFFF (** Delete, rubout *) - - - -(** International & multi-key character composition *) - -let xk_Multi_key = 0xFF20 (** Multi-key character compose *) - -(** Japanese keyboard support *) - -let xk_Kanji = 0xFF21 (** Kanji, Kanji convert *) -let xk_Muhenkan = 0xFF22 (** Cancel Conversion *) -let xk_Henkan_Mode = 0xFF23 (** Start/Stop Conversion *) -let xk_Henkan = 0xFF23 (** Alias for Henkan_Mode *) -let xk_Romaji = 0xFF24 (** to Romaji *) -let xk_Hiragana = 0xFF25 (** to Hiragana *) -let xk_Katakana = 0xFF26 (** to Katakana *) -let xk_Hiragana_Katakana = 0xFF27 (** Hiragana/Katakana toggle *) -let xk_Zenkaku = 0xFF28 (** to Zenkaku *) -let xk_Hankaku = 0xFF29 (** to Hankaku *) -let xk_Zenkaku_Hankaku = 0xFF2A (** Zenkaku/Hankaku toggle *) -let xk_Touroku = 0xFF2B (** Add to Dictionary *) -let xk_Massyo = 0xFF2C (** Delete from Dictionary *) -let xk_Kana_Lock = 0xFF2D (** Kana Lock *) -let xk_Kana_Shift = 0xFF2E (** Kana Shift *) -let xk_Eisu_Shift = 0xFF2F (** Alphanumeric Shift *) -let xk_Eisu_toggle = 0xFF30 (** Alphanumeric toggle *) - -(** = 0xFF31 thru = 0xFF3F are under xk_KOREAN *) - -(** Cursor control & motion *) - -let xk_Home = 0xFF50 -let xk_Left = 0xFF51 (** Move left, left arrow *) -let xk_Up = 0xFF52 (** Move up, up arrow *) -let xk_Right = 0xFF53 (** Move right, right arrow *) -let xk_Down = 0xFF54 (** Move down, down arrow *) -let xk_Prior = 0xFF55 (** Prior, previous *) -let xk_Page_Up = 0xFF55 -let xk_Next = 0xFF56 (** Next *) -let xk_Page_Down = 0xFF56 -let xk_End = 0xFF57 (** EOL *) -let xk_Begin = 0xFF58 (** BOL *) - - -(** Misc Functions *) - -let xk_Select = 0xFF60 (** Select, mark *) -let xk_Print = 0xFF61 -let xk_Execute = 0xFF62 (** Execute, run, do *) -let xk_Insert = 0xFF63 (** Insert, insert here *) -let xk_Undo = 0xFF65 (** Undo, oops *) -let xk_Redo = 0xFF66 (** redo, again *) -let xk_Menu = 0xFF67 -let xk_Find = 0xFF68 (** Find, search *) -let xk_Cancel = 0xFF69 (** Cancel, stop, abort, exit *) -let xk_Help = 0xFF6A (** Help *) -let xk_Break = 0xFF6B -let xk_Mode_switch = 0xFF7E (** Character set switch *) -let xk_script_switch = 0xFF7E (** Alias for mode_switch *) -let xk_Num_Lock = 0xFF7F - -(** Keypad Functions, keypad numbers cleverly chosen to map to ascii *) - -let xk_KP_Space = 0xFF80 (** space *) -let xk_KP_Tab = 0xFF89 -let xk_KP_Enter = 0xFF8D (** enter *) -let xk_KP_F1 = 0xFF91 (** PF1, KP_A, ... *) -let xk_KP_F2 = 0xFF92 -let xk_KP_F3 = 0xFF93 -let xk_KP_F4 = 0xFF94 -let xk_KP_Home = 0xFF95 -let xk_KP_Left = 0xFF96 -let xk_KP_Up = 0xFF97 -let xk_KP_Right = 0xFF98 -let xk_KP_Down = 0xFF99 -let xk_KP_Prior = 0xFF9A -let xk_KP_Page_Up = 0xFF9A -let xk_KP_Next = 0xFF9B -let xk_KP_Page_Down = 0xFF9B -let xk_KP_End = 0xFF9C -let xk_KP_Begin = 0xFF9D -let xk_KP_Insert = 0xFF9E -let xk_KP_Delete = 0xFF9F -let xk_KP_Equal = 0xFFBD (** equals *) -let xk_KP_Multiply = 0xFFAA -let xk_KP_Add = 0xFFAB -let xk_KP_Separator = 0xFFAC (** separator, often comma *) -let xk_KP_Subtract = 0xFFAD -let xk_KP_Decimal = 0xFFAE -let xk_KP_Divide = 0xFFAF - -let xk_KP_0 = 0xFFB0 -let xk_KP_1 = 0xFFB1 -let xk_KP_2 = 0xFFB2 -let xk_KP_3 = 0xFFB3 -let xk_KP_4 = 0xFFB4 -let xk_KP_5 = 0xFFB5 -let xk_KP_6 = 0xFFB6 -let xk_KP_7 = 0xFFB7 -let xk_KP_8 = 0xFFB8 -let xk_KP_9 = 0xFFB9 - - - -(* - * Auxilliary Functions; note the duplicate definitions for left and right - * function keys; Sun keyboards and a few other manufactures have such - * function key groups on the left and/or right sides of the keyboard. - * We've not found a keyboard with more than 35 function keys total. - *) - -let xk_F1 = 0xFFBE -let xk_F2 = 0xFFBF -let xk_F3 = 0xFFC0 -let xk_F4 = 0xFFC1 -let xk_F5 = 0xFFC2 -let xk_F6 = 0xFFC3 -let xk_F7 = 0xFFC4 -let xk_F8 = 0xFFC5 -let xk_F9 = 0xFFC6 -let xk_F10 = 0xFFC7 -let xk_F11 = 0xFFC8 -let xk_L1 = 0xFFC8 -let xk_F12 = 0xFFC9 -let xk_L2 = 0xFFC9 -let xk_F13 = 0xFFCA -let xk_L3 = 0xFFCA -let xk_F14 = 0xFFCB -let xk_L4 = 0xFFCB -let xk_F15 = 0xFFCC -let xk_L5 = 0xFFCC -let xk_F16 = 0xFFCD -let xk_L6 = 0xFFCD -let xk_F17 = 0xFFCE -let xk_L7 = 0xFFCE -let xk_F18 = 0xFFCF -let xk_L8 = 0xFFCF -let xk_F19 = 0xFFD0 -let xk_L9 = 0xFFD0 -let xk_F20 = 0xFFD1 -let xk_L10 = 0xFFD1 -let xk_F21 = 0xFFD2 -let xk_R1 = 0xFFD2 -let xk_F22 = 0xFFD3 -let xk_R2 = 0xFFD3 -let xk_F23 = 0xFFD4 -let xk_R3 = 0xFFD4 -let xk_F24 = 0xFFD5 -let xk_R4 = 0xFFD5 -let xk_F25 = 0xFFD6 -let xk_R5 = 0xFFD6 -let xk_F26 = 0xFFD7 -let xk_R6 = 0xFFD7 -let xk_F27 = 0xFFD8 -let xk_R7 = 0xFFD8 -let xk_F28 = 0xFFD9 -let xk_R8 = 0xFFD9 -let xk_F29 = 0xFFDA -let xk_R9 = 0xFFDA -let xk_F30 = 0xFFDB -let xk_R10 = 0xFFDB -let xk_F31 = 0xFFDC -let xk_R11 = 0xFFDC -let xk_F32 = 0xFFDD -let xk_R12 = 0xFFDD -let xk_F33 = 0xFFDE -let xk_R13 = 0xFFDE -let xk_F34 = 0xFFDF -let xk_R14 = 0xFFDF -let xk_F35 = 0xFFE0 -let xk_R15 = 0xFFE0 - -(** Modifiers *) - -let xk_Shift_L = 0xFFE1 (** Left shift *) -let xk_Shift_R = 0xFFE2 (** Right shift *) -let xk_Control_L = 0xFFE3 (** Left control *) -let xk_Control_R = 0xFFE4 (** Right control *) -let xk_Caps_Lock = 0xFFE5 (** Caps lock *) -let xk_Shift_Lock = 0xFFE6 (** Shift lock *) - -let xk_Meta_L = 0xFFE7 (** Left meta *) -let xk_Meta_R = 0xFFE8 (** Right meta *) -let xk_Alt_L = 0xFFE9 (** Left alt *) -let xk_Alt_R = 0xFFEA (** Right alt *) -let xk_Super_L = 0xFFEB (** Left super *) -let xk_Super_R = 0xFFEC (** Right super *) -let xk_Hyper_L = 0xFFED (** Left hyper *) -let xk_Hyper_R = 0xFFEE (** Right hyper *) - - -(* - * ISO 9995 Function and Modifier Keys - * Byte 3 = = 0xFE - *) - - -let xk_ISO_Lock = 0xFE01 -let xk_ISO_Level2_Latch = 0xFE02 -let xk_ISO_Level3_Shift = 0xFE03 -let xk_ISO_Level3_Latch = 0xFE04 -let xk_ISO_Level3_Lock = 0xFE05 -let xk_ISO_Group_Shift = 0xFF7E (** Alias for mode_switch *) -let xk_ISO_Group_Latch = 0xFE06 -let xk_ISO_Group_Lock = 0xFE07 -let xk_ISO_Next_Group = 0xFE08 -let xk_ISO_Next_Group_Lock = 0xFE09 -let xk_ISO_Prev_Group = 0xFE0A -let xk_ISO_Prev_Group_Lock = 0xFE0B -let xk_ISO_First_Group = 0xFE0C -let xk_ISO_First_Group_Lock = 0xFE0D -let xk_ISO_Last_Group = 0xFE0E -let xk_ISO_Last_Group_Lock = 0xFE0F - -let xk_ISO_Left_Tab = 0xFE20 -let xk_ISO_Move_Line_Up = 0xFE21 -let xk_ISO_Move_Line_Down = 0xFE22 -let xk_ISO_Partial_Line_Up = 0xFE23 -let xk_ISO_Partial_Line_Down = 0xFE24 -let xk_ISO_Partial_Space_Left = 0xFE25 -let xk_ISO_Partial_Space_Right = 0xFE26 -let xk_ISO_Set_Margin_Left = 0xFE27 -let xk_ISO_Set_Margin_Right = 0xFE28 -let xk_ISO_Release_Margin_Left = 0xFE29 -let xk_ISO_Release_Margin_Right = 0xFE2A -let xk_ISO_Release_Both_Margins = 0xFE2B -let xk_ISO_Fast_Cursor_Left = 0xFE2C -let xk_ISO_Fast_Cursor_Right = 0xFE2D -let xk_ISO_Fast_Cursor_Up = 0xFE2E -let xk_ISO_Fast_Cursor_Down = 0xFE2F -let xk_ISO_Continuous_Underline = 0xFE30 -let xk_ISO_Discontinuous_Underline = 0xFE31 -let xk_ISO_Emphasize = 0xFE32 -let xk_ISO_Center_Object = 0xFE33 -let xk_ISO_Enter = 0xFE34 - -let xk_dead_grave = 0xFE50 -let xk_dead_acute = 0xFE51 -let xk_dead_circumflex = 0xFE52 -let xk_dead_tilde = 0xFE53 -let xk_dead_macron = 0xFE54 -let xk_dead_breve = 0xFE55 -let xk_dead_abovedot = 0xFE56 -let xk_dead_diaeresis = 0xFE57 -let xk_dead_abovering = 0xFE58 -let xk_dead_doubleacute = 0xFE59 -let xk_dead_caron = 0xFE5A -let xk_dead_cedilla = 0xFE5B -let xk_dead_ogonek = 0xFE5C -let xk_dead_iota = 0xFE5D -let xk_dead_voiced_sound = 0xFE5E -let xk_dead_semivoiced_sound = 0xFE5F -let xk_dead_belowdot = 0xFE60 - -let xk_First_Virtual_Screen = 0xFED0 -let xk_Prev_Virtual_Screen = 0xFED1 -let xk_Next_Virtual_Screen = 0xFED2 -let xk_Last_Virtual_Screen = 0xFED4 -let xk_Terminate_Server = 0xFED5 - -let xk_AccessX_Enable = 0xFE70 -let xk_AccessX_Feedback_Enable = 0xFE71 -let xk_RepeatKeys_Enable = 0xFE72 -let xk_SlowKeys_Enable = 0xFE73 -let xk_BounceKeys_Enable = 0xFE74 -let xk_StickyKeys_Enable = 0xFE75 -let xk_MouseKeys_Enable = 0xFE76 -let xk_MouseKeys_Accel_Enable = 0xFE77 -let xk_Overlay1_Enable = 0xFE78 -let xk_Overlay2_Enable = 0xFE79 -let xk_AudibleBell_Enable = 0xFE7A - -let xk_Pointer_Left = 0xFEE0 -let xk_Pointer_Right = 0xFEE1 -let xk_Pointer_Up = 0xFEE2 -let xk_Pointer_Down = 0xFEE3 -let xk_Pointer_UpLeft = 0xFEE4 -let xk_Pointer_UpRight = 0xFEE5 -let xk_Pointer_DownLeft = 0xFEE6 -let xk_Pointer_DownRight = 0xFEE7 -let xk_Pointer_Button_Dflt = 0xFEE8 -let xk_Pointer_Button1 = 0xFEE9 -let xk_Pointer_Button2 = 0xFEEA -let xk_Pointer_Button3 = 0xFEEB -let xk_Pointer_Button4 = 0xFEEC -let xk_Pointer_Button5 = 0xFEED -let xk_Pointer_DblClick_Dflt = 0xFEEE -let xk_Pointer_DblClick1 = 0xFEEF -let xk_Pointer_DblClick2 = 0xFEF0 -let xk_Pointer_DblClick3 = 0xFEF1 -let xk_Pointer_DblClick4 = 0xFEF2 -let xk_Pointer_DblClick5 = 0xFEF3 -let xk_Pointer_Drag_Dflt = 0xFEF4 -let xk_Pointer_Drag1 = 0xFEF5 -let xk_Pointer_Drag2 = 0xFEF6 -let xk_Pointer_Drag3 = 0xFEF7 -let xk_Pointer_Drag4 = 0xFEF8 -let xk_Pointer_Drag5 = 0xFEFD - -let xk_Pointer_EnableKeys = 0xFEF9 -let xk_Pointer_Accelerate = 0xFEFA -let xk_Pointer_DfltBtnNext = 0xFEFB -let xk_Pointer_DfltBtnPrev = 0xFEFC - - - -(* - * 3270 Terminal Keys - * Byte 3 = = 0xFD - *) - - -let xk_3270_Duplicate = 0xFD01 -let xk_3270_FieldMark = 0xFD02 -let xk_3270_Right2 = 0xFD03 -let xk_3270_Left2 = 0xFD04 -let xk_3270_BackTab = 0xFD05 -let xk_3270_EraseEOF = 0xFD06 -let xk_3270_EraseInput = 0xFD07 -let xk_3270_Reset = 0xFD08 -let xk_3270_Quit = 0xFD09 -let xk_3270_PA1 = 0xFD0A -let xk_3270_PA2 = 0xFD0B -let xk_3270_PA3 = 0xFD0C -let xk_3270_Test = 0xFD0D -let xk_3270_Attn = 0xFD0E -let xk_3270_CursorBlink = 0xFD0F -let xk_3270_AltCursor = 0xFD10 -let xk_3270_KeyClick = 0xFD11 -let xk_3270_Jump = 0xFD12 -let xk_3270_Ident = 0xFD13 -let xk_3270_Rule = 0xFD14 -let xk_3270_Copy = 0xFD15 -let xk_3270_Play = 0xFD16 -let xk_3270_Setup = 0xFD17 -let xk_3270_Record = 0xFD18 -let xk_3270_ChangeScreen = 0xFD19 -let xk_3270_DeleteWord = 0xFD1A -let xk_3270_ExSelect = 0xFD1B -let xk_3270_CursorSelect = 0xFD1C -let xk_3270_PrintScreen = 0xFD1D -let xk_3270_Enter = 0xFD1E - - -(* - * Latin 1 - * Byte 3 = 0 - *) - -let xk_space = 0x020 -let xk_exclam = 0x021 -let xk_quotedbl = 0x022 -let xk_numbersign = 0x023 -let xk_dollar = 0x024 -let xk_percent = 0x025 -let xk_ampersand = 0x026 -let xk_apostrophe = 0x027 -let xk_quoteright = 0x027 (** deprecated *) -let xk_parenleft = 0x028 -let xk_parenright = 0x029 -let xk_asterisk = 0x02a -let xk_plus = 0x02b -let xk_comma = 0x02c -let xk_minus = 0x02d -let xk_period = 0x02e -let xk_slash = 0x02f -let xk_0 = 0x030 -let xk_1 = 0x031 -let xk_2 = 0x032 -let xk_3 = 0x033 -let xk_4 = 0x034 -let xk_5 = 0x035 -let xk_6 = 0x036 -let xk_7 = 0x037 -let xk_8 = 0x038 -let xk_9 = 0x039 -let xk_colon = 0x03a -let xk_semicolon = 0x03b -let xk_less = 0x03c -let xk_equal = 0x03d -let xk_greater = 0x03e -let xk_question = 0x03f -let xk_at = 0x040 -let xk_A = 0x041 -let xk_B = 0x042 -let xk_C = 0x043 -let xk_D = 0x044 -let xk_E = 0x045 -let xk_F = 0x046 -let xk_G = 0x047 -let xk_H = 0x048 -let xk_I = 0x049 -let xk_J = 0x04a -let xk_K = 0x04b -let xk_L = 0x04c -let xk_M = 0x04d -let xk_N = 0x04e -let xk_O = 0x04f -let xk_P = 0x050 -let xk_Q = 0x051 -let xk_R = 0x052 -let xk_S = 0x053 -let xk_T = 0x054 -let xk_U = 0x055 -let xk_V = 0x056 -let xk_W = 0x057 -let xk_X = 0x058 -let xk_Y = 0x059 -let xk_Z = 0x05a -let xk_bracketleft = 0x05b -let xk_backslash = 0x05c -let xk_bracketright = 0x05d -let xk_asciicircum = 0x05e -let xk_underscore = 0x05f -let xk_grave = 0x060 -let xk_quoteleft = 0x060 (** deprecated *) -let xk_a = 0x061 -let xk_b = 0x062 -let xk_c = 0x063 -let xk_d = 0x064 -let xk_e = 0x065 -let xk_f = 0x066 -let xk_g = 0x067 -let xk_h = 0x068 -let xk_i = 0x069 -let xk_j = 0x06a -let xk_k = 0x06b -let xk_l = 0x06c -let xk_m = 0x06d -let xk_n = 0x06e -let xk_o = 0x06f -let xk_p = 0x070 -let xk_q = 0x071 -let xk_r = 0x072 -let xk_s = 0x073 -let xk_t = 0x074 -let xk_u = 0x075 -let xk_v = 0x076 -let xk_w = 0x077 -let xk_x = 0x078 -let xk_y = 0x079 -let xk_z = 0x07a -let xk_braceleft = 0x07b -let xk_bar = 0x07c -let xk_braceright = 0x07d -let xk_asciitilde = 0x07e - -let xk_nobreakspace = 0x0a0 -let xk_exclamdown = 0x0a1 -let xk_cent = 0x0a2 -let xk_sterling = 0x0a3 -let xk_currency = 0x0a4 -let xk_yen = 0x0a5 -let xk_brokenbar = 0x0a6 -let xk_section = 0x0a7 -let xk_diaeresis = 0x0a8 -let xk_copyright = 0x0a9 -let xk_ordfeminine = 0x0aa -let xk_guillemotleft = 0x0ab (** left angle quotation mark *) -let xk_notsign = 0x0ac -let xk_hyphen = 0x0ad -let xk_registered = 0x0ae -let xk_macron = 0x0af -let xk_degree = 0x0b0 -let xk_plusminus = 0x0b1 -let xk_twosuperior = 0x0b2 -let xk_threesuperior = 0x0b3 -let xk_acute = 0x0b4 -let xk_mu = 0x0b5 -let xk_paragraph = 0x0b6 -let xk_periodcentered = 0x0b7 -let xk_cedilla = 0x0b8 -let xk_onesuperior = 0x0b9 -let xk_masculine = 0x0ba -let xk_guillemotright = 0x0bb (** right angle quotation mark *) -let xk_onequarter = 0x0bc -let xk_onehalf = 0x0bd -let xk_threequarters = 0x0be -let xk_questiondown = 0x0bf -let xk_Agrave = 0x0c0 -let xk_Aacute = 0x0c1 -let xk_Acircumflex = 0x0c2 -let xk_Atilde = 0x0c3 -let xk_Adiaeresis = 0x0c4 -let xk_Aring = 0x0c5 -let xk_AE = 0x0c6 -let xk_Ccedilla = 0x0c7 -let xk_Egrave = 0x0c8 -let xk_Eacute = 0x0c9 -let xk_Ecircumflex = 0x0ca -let xk_Ediaeresis = 0x0cb -let xk_Igrave = 0x0cc -let xk_Iacute = 0x0cd -let xk_Icircumflex = 0x0ce -let xk_Idiaeresis = 0x0cf -let xk_ETH = 0x0d0 -let xk_Eth = 0x0d0 (** deprecated *) -let xk_Ntilde = 0x0d1 -let xk_Ograve = 0x0d2 -let xk_Oacute = 0x0d3 -let xk_Ocircumflex = 0x0d4 -let xk_Otilde = 0x0d5 -let xk_Odiaeresis = 0x0d6 -let xk_multiply = 0x0d7 -let xk_Ooblique = 0x0d8 -let xk_Ugrave = 0x0d9 -let xk_Uacute = 0x0da -let xk_Ucircumflex = 0x0db -let xk_Udiaeresis = 0x0dc -let xk_Yacute = 0x0dd -let xk_THORN = 0x0de -let xk_Thorn = 0x0de (** deprecated *) -let xk_ssharp = 0x0df -let xk_agrave = 0x0e0 -let xk_aacute = 0x0e1 -let xk_acircumflex = 0x0e2 -let xk_atilde = 0x0e3 -let xk_adiaeresis = 0x0e4 -let xk_aring = 0x0e5 -let xk_ae = 0x0e6 -let xk_ccedilla = 0x0e7 -let xk_egrave = 0x0e8 -let xk_eacute = 0x0e9 -let xk_ecircumflex = 0x0ea -let xk_ediaeresis = 0x0eb -let xk_igrave = 0x0ec -let xk_iacute = 0x0ed -let xk_icircumflex = 0x0ee -let xk_idiaeresis = 0x0ef -let xk_eth = 0x0f0 -let xk_ntilde = 0x0f1 -let xk_ograve = 0x0f2 -let xk_oacute = 0x0f3 -let xk_ocircumflex = 0x0f4 -let xk_otilde = 0x0f5 -let xk_odiaeresis = 0x0f6 -let xk_division = 0x0f7 -let xk_oslash = 0x0f8 -let xk_ugrave = 0x0f9 -let xk_uacute = 0x0fa -let xk_ucircumflex = 0x0fb -let xk_udiaeresis = 0x0fc -let xk_yacute = 0x0fd -let xk_thorn = 0x0fe -let xk_ydiaeresis = 0x0ff - - -(* - * Latin 2 - * Byte 3 = 1 - *) - - -let xk_Aogonek = 0x1a1 -let xk_breve = 0x1a2 -let xk_Lstroke = 0x1a3 -let xk_Lcaron = 0x1a5 -let xk_Sacute = 0x1a6 -let xk_Scaron = 0x1a9 -let xk_Scedilla = 0x1aa -let xk_Tcaron = 0x1ab -let xk_Zacute = 0x1ac -let xk_Zcaron = 0x1ae -let xk_Zabovedot = 0x1af -let xk_aogonek = 0x1b1 -let xk_ogonek = 0x1b2 -let xk_lstroke = 0x1b3 -let xk_lcaron = 0x1b5 -let xk_sacute = 0x1b6 -let xk_caron = 0x1b7 -let xk_scaron = 0x1b9 -let xk_scedilla = 0x1ba -let xk_tcaron = 0x1bb -let xk_zacute = 0x1bc -let xk_doubleacute = 0x1bd -let xk_zcaron = 0x1be -let xk_zabovedot = 0x1bf -let xk_Racute = 0x1c0 -let xk_Abreve = 0x1c3 -let xk_Lacute = 0x1c5 -let xk_Cacute = 0x1c6 -let xk_Ccaron = 0x1c8 -let xk_Eogonek = 0x1ca -let xk_Ecaron = 0x1cc -let xk_Dcaron = 0x1cf -let xk_Dstroke = 0x1d0 -let xk_Nacute = 0x1d1 -let xk_Ncaron = 0x1d2 -let xk_Odoubleacute = 0x1d5 -let xk_Rcaron = 0x1d8 -let xk_Uring = 0x1d9 -let xk_Udoubleacute = 0x1db -let xk_Tcedilla = 0x1de -let xk_racute = 0x1e0 -let xk_abreve = 0x1e3 -let xk_lacute = 0x1e5 -let xk_cacute = 0x1e6 -let xk_ccaron = 0x1e8 -let xk_eogonek = 0x1ea -let xk_ecaron = 0x1ec -let xk_dcaron = 0x1ef -let xk_dstroke = 0x1f0 -let xk_nacute = 0x1f1 -let xk_ncaron = 0x1f2 -let xk_odoubleacute = 0x1f5 -let xk_udoubleacute = 0x1fb -let xk_rcaron = 0x1f8 -let xk_uring = 0x1f9 -let xk_tcedilla = 0x1fe -let xk_abovedot = 0x1ff - - -(* - * Latin 3 - * Byte 3 = 2 - *) - - -let xk_Hstroke = 0x2a1 -let xk_Hcircumflex = 0x2a6 -let xk_Iabovedot = 0x2a9 -let xk_Gbreve = 0x2ab -let xk_Jcircumflex = 0x2ac -let xk_hstroke = 0x2b1 -let xk_hcircumflex = 0x2b6 -let xk_idotless = 0x2b9 -let xk_gbreve = 0x2bb -let xk_jcircumflex = 0x2bc -let xk_Cabovedot = 0x2c5 -let xk_Ccircumflex = 0x2c6 -let xk_Gabovedot = 0x2d5 -let xk_Gcircumflex = 0x2d8 -let xk_Ubreve = 0x2dd -let xk_Scircumflex = 0x2de -let xk_cabovedot = 0x2e5 -let xk_ccircumflex = 0x2e6 -let xk_gabovedot = 0x2f5 -let xk_gcircumflex = 0x2f8 -let xk_ubreve = 0x2fd -let xk_scircumflex = 0x2fe - - - -(* - * Latin 4 - * Byte 3 = 3 - *) - - -let xk_kra = 0x3a2 -let xk_kappa = 0x3a2 (** deprecated *) -let xk_Rcedilla = 0x3a3 -let xk_Itilde = 0x3a5 -let xk_Lcedilla = 0x3a6 -let xk_Emacron = 0x3aa -let xk_Gcedilla = 0x3ab -let xk_Tslash = 0x3ac -let xk_rcedilla = 0x3b3 -let xk_itilde = 0x3b5 -let xk_lcedilla = 0x3b6 -let xk_emacron = 0x3ba -let xk_gcedilla = 0x3bb -let xk_tslash = 0x3bc -let xk_ENG = 0x3bd -let xk_eng = 0x3bf -let xk_Amacron = 0x3c0 -let xk_Iogonek = 0x3c7 -let xk_Eabovedot = 0x3cc -let xk_Imacron = 0x3cf -let xk_Ncedilla = 0x3d1 -let xk_Omacron = 0x3d2 -let xk_Kcedilla = 0x3d3 -let xk_Uogonek = 0x3d9 -let xk_Utilde = 0x3dd -let xk_Umacron = 0x3de -let xk_amacron = 0x3e0 -let xk_iogonek = 0x3e7 -let xk_eabovedot = 0x3ec -let xk_imacron = 0x3ef -let xk_ncedilla = 0x3f1 -let xk_omacron = 0x3f2 -let xk_kcedilla = 0x3f3 -let xk_uogonek = 0x3f9 -let xk_utilde = 0x3fd -let xk_umacron = 0x3fe - - -(* - * Katakana - * Byte 3 = 4 - *) - - -let xk_overline = 0x47e -let xk_kana_fullstop = 0x4a1 -let xk_kana_openingbracket = 0x4a2 -let xk_kana_closingbracket = 0x4a3 -let xk_kana_comma = 0x4a4 -let xk_kana_conjunctive = 0x4a5 -let xk_kana_middledot = 0x4a5 (** deprecated *) -let xk_kana_WO = 0x4a6 -let xk_kana_a = 0x4a7 -let xk_kana_i = 0x4a8 -let xk_kana_u = 0x4a9 -let xk_kana_e = 0x4aa -let xk_kana_o = 0x4ab -let xk_kana_ya = 0x4ac -let xk_kana_yu = 0x4ad -let xk_kana_yo = 0x4ae -let xk_kana_tsu = 0x4af -let xk_kana_tu = 0x4af (** deprecated *) -let xk_prolongedsound = 0x4b0 -let xk_kana_A = 0x4b1 -let xk_kana_I = 0x4b2 -let xk_kana_U = 0x4b3 -let xk_kana_E = 0x4b4 -let xk_kana_O = 0x4b5 -let xk_kana_KA = 0x4b6 -let xk_kana_KI = 0x4b7 -let xk_kana_KU = 0x4b8 -let xk_kana_KE = 0x4b9 -let xk_kana_KO = 0x4ba -let xk_kana_SA = 0x4bb -let xk_kana_SHI = 0x4bc -let xk_kana_SU = 0x4bd -let xk_kana_SE = 0x4be -let xk_kana_SO = 0x4bf -let xk_kana_TA = 0x4c0 -let xk_kana_CHI = 0x4c1 -let xk_kana_TI = 0x4c1 (** deprecated *) -let xk_kana_TSU = 0x4c2 -let xk_kana_TU = 0x4c2 (** deprecated *) -let xk_kana_TE = 0x4c3 -let xk_kana_TO = 0x4c4 -let xk_kana_NA = 0x4c5 -let xk_kana_NI = 0x4c6 -let xk_kana_NU = 0x4c7 -let xk_kana_NE = 0x4c8 -let xk_kana_NO = 0x4c9 -let xk_kana_HA = 0x4ca -let xk_kana_HI = 0x4cb -let xk_kana_FU = 0x4cc -let xk_kana_HU = 0x4cc (** deprecated *) -let xk_kana_HE = 0x4cd -let xk_kana_HO = 0x4ce -let xk_kana_MA = 0x4cf -let xk_kana_MI = 0x4d0 -let xk_kana_MU = 0x4d1 -let xk_kana_ME = 0x4d2 -let xk_kana_MO = 0x4d3 -let xk_kana_YA = 0x4d4 -let xk_kana_YU = 0x4d5 -let xk_kana_YO = 0x4d6 -let xk_kana_RA = 0x4d7 -let xk_kana_RI = 0x4d8 -let xk_kana_RU = 0x4d9 -let xk_kana_RE = 0x4da -let xk_kana_RO = 0x4db -let xk_kana_WA = 0x4dc -let xk_kana_N = 0x4dd -let xk_voicedsound = 0x4de -let xk_semivoicedsound = 0x4df -let xk_kana_switch = 0xFF7E (** Alias for mode_switch *) - - -(* - * Arabic - * Byte 3 = 5 - *) - - -let xk_Arabic_comma = 0x5ac -let xk_Arabic_semicolon = 0x5bb -let xk_Arabic_question_mark = 0x5bf -let xk_Arabic_hamza = 0x5c1 -let xk_Arabic_maddaonalef = 0x5c2 -let xk_Arabic_hamzaonalef = 0x5c3 -let xk_Arabic_hamzaonwaw = 0x5c4 -let xk_Arabic_hamzaunderalef = 0x5c5 -let xk_Arabic_hamzaonyeh = 0x5c6 -let xk_Arabic_alef = 0x5c7 -let xk_Arabic_beh = 0x5c8 -let xk_Arabic_tehmarbuta = 0x5c9 -let xk_Arabic_teh = 0x5ca -let xk_Arabic_theh = 0x5cb -let xk_Arabic_jeem = 0x5cc -let xk_Arabic_hah = 0x5cd -let xk_Arabic_khah = 0x5ce -let xk_Arabic_dal = 0x5cf -let xk_Arabic_thal = 0x5d0 -let xk_Arabic_ra = 0x5d1 -let xk_Arabic_zain = 0x5d2 -let xk_Arabic_seen = 0x5d3 -let xk_Arabic_sheen = 0x5d4 -let xk_Arabic_sad = 0x5d5 -let xk_Arabic_dad = 0x5d6 -let xk_Arabic_tah = 0x5d7 -let xk_Arabic_zah = 0x5d8 -let xk_Arabic_ain = 0x5d9 -let xk_Arabic_ghain = 0x5da -let xk_Arabic_tatweel = 0x5e0 -let xk_Arabic_feh = 0x5e1 -let xk_Arabic_qaf = 0x5e2 -let xk_Arabic_kaf = 0x5e3 -let xk_Arabic_lam = 0x5e4 -let xk_Arabic_meem = 0x5e5 -let xk_Arabic_noon = 0x5e6 -let xk_Arabic_ha = 0x5e7 -let xk_Arabic_heh = 0x5e7 (** deprecated *) -let xk_Arabic_waw = 0x5e8 -let xk_Arabic_alefmaksura = 0x5e9 -let xk_Arabic_yeh = 0x5ea -let xk_Arabic_fathatan = 0x5eb -let xk_Arabic_dammatan = 0x5ec -let xk_Arabic_kasratan = 0x5ed -let xk_Arabic_fatha = 0x5ee -let xk_Arabic_damma = 0x5ef -let xk_Arabic_kasra = 0x5f0 -let xk_Arabic_shadda = 0x5f1 -let xk_Arabic_sukun = 0x5f2 -let xk_Arabic_switch = 0xFF7E (** Alias for mode_switch *) - - -(* - * Cyrillic - * Byte 3 = 6 - *) - -let xk_Serbian_dje = 0x6a1 -let xk_Macedonia_gje = 0x6a2 -let xk_Cyrillic_io = 0x6a3 -let xk_Ukrainian_ie = 0x6a4 -let xk_Ukranian_je = 0x6a4 (** deprecated *) -let xk_Macedonia_dse = 0x6a5 -let xk_Ukrainian_i = 0x6a6 -let xk_Ukranian_i = 0x6a6 (** deprecated *) -let xk_Ukrainian_yi = 0x6a7 -let xk_Ukranian_yi = 0x6a7 (** deprecated *) -let xk_Cyrillic_je = 0x6a8 -let xk_Serbian_je = 0x6a8 (** deprecated *) -let xk_Cyrillic_lje = 0x6a9 -let xk_Serbian_lje = 0x6a9 (** deprecated *) -let xk_Cyrillic_nje = 0x6aa -let xk_Serbian_nje = 0x6aa (** deprecated *) -let xk_Serbian_tshe = 0x6ab -let xk_Macedonia_kje = 0x6ac -let xk_Byelorussian_shortu = 0x6ae -let xk_Cyrillic_dzhe = 0x6af -let xk_Serbian_dze = 0x6af (** deprecated *) -let xk_numerosign = 0x6b0 -let xk_Serbian_DJE = 0x6b1 -let xk_Macedonia_GJE = 0x6b2 -let xk_Cyrillic_IO = 0x6b3 -let xk_Ukrainian_IE = 0x6b4 -let xk_Ukranian_JE = 0x6b4 (** deprecated *) -let xk_Macedonia_DSE = 0x6b5 -let xk_Ukrainian_I = 0x6b6 -let xk_Ukranian_I = 0x6b6 (** deprecated *) -let xk_Ukrainian_YI = 0x6b7 -let xk_Ukranian_YI = 0x6b7 (** deprecated *) -let xk_Cyrillic_JE = 0x6b8 -let xk_Serbian_JE = 0x6b8 (** deprecated *) -let xk_Cyrillic_LJE = 0x6b9 -let xk_Serbian_LJE = 0x6b9 (** deprecated *) -let xk_Cyrillic_NJE = 0x6ba -let xk_Serbian_NJE = 0x6ba (** deprecated *) -let xk_Serbian_TSHE = 0x6bb -let xk_Macedonia_KJE = 0x6bc -let xk_Byelorussian_SHORTU = 0x6be -let xk_Cyrillic_DZHE = 0x6bf -let xk_Serbian_DZE = 0x6bf (** deprecated *) -let xk_Cyrillic_yu = 0x6c0 -let xk_Cyrillic_a = 0x6c1 -let xk_Cyrillic_be = 0x6c2 -let xk_Cyrillic_tse = 0x6c3 -let xk_Cyrillic_de = 0x6c4 -let xk_Cyrillic_ie = 0x6c5 -let xk_Cyrillic_ef = 0x6c6 -let xk_Cyrillic_ghe = 0x6c7 -let xk_Cyrillic_ha = 0x6c8 -let xk_Cyrillic_i = 0x6c9 -let xk_Cyrillic_shorti = 0x6ca -let xk_Cyrillic_ka = 0x6cb -let xk_Cyrillic_el = 0x6cc -let xk_Cyrillic_em = 0x6cd -let xk_Cyrillic_en = 0x6ce -let xk_Cyrillic_o = 0x6cf -let xk_Cyrillic_pe = 0x6d0 -let xk_Cyrillic_ya = 0x6d1 -let xk_Cyrillic_er = 0x6d2 -let xk_Cyrillic_es = 0x6d3 -let xk_Cyrillic_te = 0x6d4 -let xk_Cyrillic_u = 0x6d5 -let xk_Cyrillic_zhe = 0x6d6 -let xk_Cyrillic_ve = 0x6d7 -let xk_Cyrillic_softsign = 0x6d8 -let xk_Cyrillic_yeru = 0x6d9 -let xk_Cyrillic_ze = 0x6da -let xk_Cyrillic_sha = 0x6db -let xk_Cyrillic_e = 0x6dc -let xk_Cyrillic_shcha = 0x6dd -let xk_Cyrillic_che = 0x6de -let xk_Cyrillic_hardsign = 0x6df -let xk_Cyrillic_YU = 0x6e0 -let xk_Cyrillic_A = 0x6e1 -let xk_Cyrillic_BE = 0x6e2 -let xk_Cyrillic_TSE = 0x6e3 -let xk_Cyrillic_DE = 0x6e4 -let xk_Cyrillic_IE = 0x6e5 -let xk_Cyrillic_EF = 0x6e6 -let xk_Cyrillic_GHE = 0x6e7 -let xk_Cyrillic_HA = 0x6e8 -let xk_Cyrillic_I = 0x6e9 -let xk_Cyrillic_SHORTI = 0x6ea -let xk_Cyrillic_KA = 0x6eb -let xk_Cyrillic_EL = 0x6ec -let xk_Cyrillic_EM = 0x6ed -let xk_Cyrillic_EN = 0x6ee -let xk_Cyrillic_O = 0x6ef -let xk_Cyrillic_PE = 0x6f0 -let xk_Cyrillic_YA = 0x6f1 -let xk_Cyrillic_ER = 0x6f2 -let xk_Cyrillic_ES = 0x6f3 -let xk_Cyrillic_TE = 0x6f4 -let xk_Cyrillic_U = 0x6f5 -let xk_Cyrillic_ZHE = 0x6f6 -let xk_Cyrillic_VE = 0x6f7 -let xk_Cyrillic_SOFTSIGN = 0x6f8 -let xk_Cyrillic_YERU = 0x6f9 -let xk_Cyrillic_ZE = 0x6fa -let xk_Cyrillic_SHA = 0x6fb -let xk_Cyrillic_E = 0x6fc -let xk_Cyrillic_SHCHA = 0x6fd -let xk_Cyrillic_CHE = 0x6fe -let xk_Cyrillic_HARDSIGN = 0x6ff - - -(* - * Greek - * Byte 3 = 7 - *) - - -let xk_Greek_ALPHAaccent = 0x7a1 -let xk_Greek_EPSILONaccent = 0x7a2 -let xk_Greek_ETAaccent = 0x7a3 -let xk_Greek_IOTAaccent = 0x7a4 -let xk_Greek_IOTAdiaeresis = 0x7a5 -let xk_Greek_OMICRONaccent = 0x7a7 -let xk_Greek_UPSILONaccent = 0x7a8 -let xk_Greek_UPSILONdieresis = 0x7a9 -let xk_Greek_OMEGAaccent = 0x7ab -let xk_Greek_accentdieresis = 0x7ae -let xk_Greek_horizbar = 0x7af -let xk_Greek_alphaaccent = 0x7b1 -let xk_Greek_epsilonaccent = 0x7b2 -let xk_Greek_etaaccent = 0x7b3 -let xk_Greek_iotaaccent = 0x7b4 -let xk_Greek_iotadieresis = 0x7b5 -let xk_Greek_iotaaccentdieresis = 0x7b6 -let xk_Greek_omicronaccent = 0x7b7 -let xk_Greek_upsilonaccent = 0x7b8 -let xk_Greek_upsilondieresis = 0x7b9 -let xk_Greek_upsilonaccentdieresis = 0x7ba -let xk_Greek_omegaaccent = 0x7bb -let xk_Greek_ALPHA = 0x7c1 -let xk_Greek_BETA = 0x7c2 -let xk_Greek_GAMMA = 0x7c3 -let xk_Greek_DELTA = 0x7c4 -let xk_Greek_EPSILON = 0x7c5 -let xk_Greek_ZETA = 0x7c6 -let xk_Greek_ETA = 0x7c7 -let xk_Greek_THETA = 0x7c8 -let xk_Greek_IOTA = 0x7c9 -let xk_Greek_KAPPA = 0x7ca -let xk_Greek_LAMDA = 0x7cb -let xk_Greek_LAMBDA = 0x7cb -let xk_Greek_MU = 0x7cc -let xk_Greek_NU = 0x7cd -let xk_Greek_XI = 0x7ce -let xk_Greek_OMICRON = 0x7cf -let xk_Greek_PI = 0x7d0 -let xk_Greek_RHO = 0x7d1 -let xk_Greek_SIGMA = 0x7d2 -let xk_Greek_TAU = 0x7d4 -let xk_Greek_UPSILON = 0x7d5 -let xk_Greek_PHI = 0x7d6 -let xk_Greek_CHI = 0x7d7 -let xk_Greek_PSI = 0x7d8 -let xk_Greek_OMEGA = 0x7d9 -let xk_Greek_alpha = 0x7e1 -let xk_Greek_beta = 0x7e2 -let xk_Greek_gamma = 0x7e3 -let xk_Greek_delta = 0x7e4 -let xk_Greek_epsilon = 0x7e5 -let xk_Greek_zeta = 0x7e6 -let xk_Greek_eta = 0x7e7 -let xk_Greek_theta = 0x7e8 -let xk_Greek_iota = 0x7e9 -let xk_Greek_kappa = 0x7ea -let xk_Greek_lamda = 0x7eb -let xk_Greek_lambda = 0x7eb -let xk_Greek_mu = 0x7ec -let xk_Greek_nu = 0x7ed -let xk_Greek_xi = 0x7ee -let xk_Greek_omicron = 0x7ef -let xk_Greek_pi = 0x7f0 -let xk_Greek_rho = 0x7f1 -let xk_Greek_sigma = 0x7f2 -let xk_Greek_finalsmallsigma = 0x7f3 -let xk_Greek_tau = 0x7f4 -let xk_Greek_upsilon = 0x7f5 -let xk_Greek_phi = 0x7f6 -let xk_Greek_chi = 0x7f7 -let xk_Greek_psi = 0x7f8 -let xk_Greek_omega = 0x7f9 -let xk_Greek_switch = 0xFF7E (** Alias for mode_switch *) - - -(* - * Technical - * Byte 3 = 8 - *) - - -let xk_leftradical = 0x8a1 -let xk_topleftradical = 0x8a2 -let xk_horizconnector = 0x8a3 -let xk_topintegral = 0x8a4 -let xk_botintegral = 0x8a5 -let xk_vertconnector = 0x8a6 -let xk_topleftsqbracket = 0x8a7 -let xk_botleftsqbracket = 0x8a8 -let xk_toprightsqbracket = 0x8a9 -let xk_botrightsqbracket = 0x8aa -let xk_topleftparens = 0x8ab -let xk_botleftparens = 0x8ac -let xk_toprightparens = 0x8ad -let xk_botrightparens = 0x8ae -let xk_leftmiddlecurlybrace = 0x8af -let xk_rightmiddlecurlybrace = 0x8b0 -let xk_topleftsummation = 0x8b1 -let xk_botleftsummation = 0x8b2 -let xk_topvertsummationconnector = 0x8b3 -let xk_botvertsummationconnector = 0x8b4 -let xk_toprightsummation = 0x8b5 -let xk_botrightsummation = 0x8b6 -let xk_rightmiddlesummation = 0x8b7 -let xk_lessthanequal = 0x8bc -let xk_notequal = 0x8bd -let xk_greaterthanequal = 0x8be -let xk_integral = 0x8bf -let xk_therefore = 0x8c0 -let xk_variation = 0x8c1 -let xk_infinity = 0x8c2 -let xk_nabla = 0x8c5 -let xk_approximate = 0x8c8 -let xk_similarequal = 0x8c9 -let xk_ifonlyif = 0x8cd -let xk_implies = 0x8ce -let xk_identical = 0x8cf -let xk_radical = 0x8d6 -let xk_includedin = 0x8da -let xk_includes = 0x8db -let xk_intersection = 0x8dc -let xk_union = 0x8dd -let xk_logicaland = 0x8de -let xk_logicalor = 0x8df -let xk_partialderivative = 0x8ef -let xk_function = 0x8f6 -let xk_leftarrow = 0x8fb -let xk_uparrow = 0x8fc -let xk_rightarrow = 0x8fd -let xk_downarrow = 0x8fe - - -(* - * Special - * Byte 3 = 9 - *) - - -let xk_blank = 0x9df -let xk_soliddiamond = 0x9e0 -let xk_checkerboard = 0x9e1 -let xk_ht = 0x9e2 -let xk_ff = 0x9e3 -let xk_cr = 0x9e4 -let xk_lf = 0x9e5 -let xk_nl = 0x9e8 -let xk_vt = 0x9e9 -let xk_lowrightcorner = 0x9ea -let xk_uprightcorner = 0x9eb -let xk_upleftcorner = 0x9ec -let xk_lowleftcorner = 0x9ed -let xk_crossinglines = 0x9ee -let xk_horizlinescan1 = 0x9ef -let xk_horizlinescan3 = 0x9f0 -let xk_horizlinescan5 = 0x9f1 -let xk_horizlinescan7 = 0x9f2 -let xk_horizlinescan9 = 0x9f3 -let xk_leftt = 0x9f4 -let xk_rightt = 0x9f5 -let xk_bott = 0x9f6 -let xk_topt = 0x9f7 -let xk_vertbar = 0x9f8 - - -(* - * Publishing - * Byte 3 = a - *) - - -let xk_emspace = 0xaa1 -let xk_enspace = 0xaa2 -let xk_em3space = 0xaa3 -let xk_em4space = 0xaa4 -let xk_digitspace = 0xaa5 -let xk_punctspace = 0xaa6 -let xk_thinspace = 0xaa7 -let xk_hairspace = 0xaa8 -let xk_emdash = 0xaa9 -let xk_endash = 0xaaa -let xk_signifblank = 0xaac -let xk_ellipsis = 0xaae -let xk_doubbaselinedot = 0xaaf -let xk_onethird = 0xab0 -let xk_twothirds = 0xab1 -let xk_onefifth = 0xab2 -let xk_twofifths = 0xab3 -let xk_threefifths = 0xab4 -let xk_fourfifths = 0xab5 -let xk_onesixth = 0xab6 -let xk_fivesixths = 0xab7 -let xk_careof = 0xab8 -let xk_figdash = 0xabb -let xk_leftanglebracket = 0xabc -let xk_decimalpoint = 0xabd -let xk_rightanglebracket = 0xabe -let xk_marker = 0xabf -let xk_oneeighth = 0xac3 -let xk_threeeighths = 0xac4 -let xk_fiveeighths = 0xac5 -let xk_seveneighths = 0xac6 -let xk_trademark = 0xac9 -let xk_signaturemark = 0xaca -let xk_trademarkincircle = 0xacb -let xk_leftopentriangle = 0xacc -let xk_rightopentriangle = 0xacd -let xk_emopencircle = 0xace -let xk_emopenrectangle = 0xacf -let xk_leftsinglequotemark = 0xad0 -let xk_rightsinglequotemark = 0xad1 -let xk_leftdoublequotemark = 0xad2 -let xk_rightdoublequotemark = 0xad3 -let xk_prescription = 0xad4 -let xk_minutes = 0xad6 -let xk_seconds = 0xad7 -let xk_latincross = 0xad9 -let xk_hexagram = 0xada -let xk_filledrectbullet = 0xadb -let xk_filledlefttribullet = 0xadc -let xk_filledrighttribullet = 0xadd -let xk_emfilledcircle = 0xade -let xk_emfilledrect = 0xadf -let xk_enopencircbullet = 0xae0 -let xk_enopensquarebullet = 0xae1 -let xk_openrectbullet = 0xae2 -let xk_opentribulletup = 0xae3 -let xk_opentribulletdown = 0xae4 -let xk_openstar = 0xae5 -let xk_enfilledcircbullet = 0xae6 -let xk_enfilledsqbullet = 0xae7 -let xk_filledtribulletup = 0xae8 -let xk_filledtribulletdown = 0xae9 -let xk_leftpointer = 0xaea -let xk_rightpointer = 0xaeb -let xk_club = 0xaec -let xk_diamond = 0xaed -let xk_heart = 0xaee -let xk_maltesecross = 0xaf0 -let xk_dagger = 0xaf1 -let xk_doubledagger = 0xaf2 -let xk_checkmark = 0xaf3 -let xk_ballotcross = 0xaf4 -let xk_musicalsharp = 0xaf5 -let xk_musicalflat = 0xaf6 -let xk_malesymbol = 0xaf7 -let xk_femalesymbol = 0xaf8 -let xk_telephone = 0xaf9 -let xk_telephonerecorder = 0xafa -let xk_phonographcopyright = 0xafb -let xk_caret = 0xafc -let xk_singlelowquotemark = 0xafd -let xk_doublelowquotemark = 0xafe -let xk_cursor = 0xaff - - -(* - * APL - * Byte 3 = b - *) - - -let xk_leftcaret = 0xba3 -let xk_rightcaret = 0xba6 -let xk_downcaret = 0xba8 -let xk_upcaret = 0xba9 -let xk_overbar = 0xbc0 -let xk_downtack = 0xbc2 -let xk_upshoe = 0xbc3 -let xk_downstile = 0xbc4 -let xk_underbar = 0xbc6 -let xk_jot = 0xbca -let xk_quad = 0xbcc -let xk_uptack = 0xbce -let xk_circle = 0xbcf -let xk_upstile = 0xbd3 -let xk_downshoe = 0xbd6 -let xk_rightshoe = 0xbd8 -let xk_leftshoe = 0xbda -let xk_lefttack = 0xbdc -let xk_righttack = 0xbfc - - -(* - * Hebrew - * Byte 3 = c - *) - - -let xk_hebrew_doublelowline = 0xcdf -let xk_hebrew_aleph = 0xce0 -let xk_hebrew_bet = 0xce1 -let xk_hebrew_beth = 0xce1 (** deprecated *) -let xk_hebrew_gimel = 0xce2 -let xk_hebrew_gimmel = 0xce2 (** deprecated *) -let xk_hebrew_dalet = 0xce3 -let xk_hebrew_daleth = 0xce3 (** deprecated *) -let xk_hebrew_he = 0xce4 -let xk_hebrew_waw = 0xce5 -let xk_hebrew_zain = 0xce6 -let xk_hebrew_zayin = 0xce6 (** deprecated *) -let xk_hebrew_chet = 0xce7 -let xk_hebrew_het = 0xce7 (** deprecated *) -let xk_hebrew_tet = 0xce8 -let xk_hebrew_teth = 0xce8 (** deprecated *) -let xk_hebrew_yod = 0xce9 -let xk_hebrew_finalkaph = 0xcea -let xk_hebrew_kaph = 0xceb -let xk_hebrew_lamed = 0xcec -let xk_hebrew_finalmem = 0xced -let xk_hebrew_mem = 0xcee -let xk_hebrew_finalnun = 0xcef -let xk_hebrew_nun = 0xcf0 -let xk_hebrew_samech = 0xcf1 -let xk_hebrew_samekh = 0xcf1 (** deprecated *) -let xk_hebrew_ayin = 0xcf2 -let xk_hebrew_finalpe = 0xcf3 -let xk_hebrew_pe = 0xcf4 -let xk_hebrew_finalzade = 0xcf5 -let xk_hebrew_finalzadi = 0xcf5 (** deprecated *) -let xk_hebrew_zade = 0xcf6 -let xk_hebrew_zadi = 0xcf6 (** deprecated *) -let xk_hebrew_qoph = 0xcf7 -let xk_hebrew_kuf = 0xcf7 (** deprecated *) -let xk_hebrew_resh = 0xcf8 -let xk_hebrew_shin = 0xcf9 -let xk_hebrew_taw = 0xcfa -let xk_hebrew_taf = 0xcfa (** deprecated *) -let xk_Hebrew_switch = 0xFF7E (** Alias for mode_switch *) - - -(* - * Thai - * Byte 3 = d - *) - - -let xk_Thai_kokai = 0xda1 -let xk_Thai_khokhai = 0xda2 -let xk_Thai_khokhuat = 0xda3 -let xk_Thai_khokhwai = 0xda4 -let xk_Thai_khokhon = 0xda5 -let xk_Thai_khorakhang = 0xda6 -let xk_Thai_ngongu = 0xda7 -let xk_Thai_chochan = 0xda8 -let xk_Thai_choching = 0xda9 -let xk_Thai_chochang = 0xdaa -let xk_Thai_soso = 0xdab -let xk_Thai_chochoe = 0xdac -let xk_Thai_yoying = 0xdad -let xk_Thai_dochada = 0xdae -let xk_Thai_topatak = 0xdaf -let xk_Thai_thothan = 0xdb0 -let xk_Thai_thonangmontho = 0xdb1 -let xk_Thai_thophuthao = 0xdb2 -let xk_Thai_nonen = 0xdb3 -let xk_Thai_dodek = 0xdb4 -let xk_Thai_totao = 0xdb5 -let xk_Thai_thothung = 0xdb6 -let xk_Thai_thothahan = 0xdb7 -let xk_Thai_thothong = 0xdb8 -let xk_Thai_nonu = 0xdb9 -let xk_Thai_bobaimai = 0xdba -let xk_Thai_popla = 0xdbb -let xk_Thai_phophung = 0xdbc -let xk_Thai_fofa = 0xdbd -let xk_Thai_phophan = 0xdbe -let xk_Thai_fofan = 0xdbf -let xk_Thai_phosamphao = 0xdc0 -let xk_Thai_moma = 0xdc1 -let xk_Thai_yoyak = 0xdc2 -let xk_Thai_rorua = 0xdc3 -let xk_Thai_ru = 0xdc4 -let xk_Thai_loling = 0xdc5 -let xk_Thai_lu = 0xdc6 -let xk_Thai_wowaen = 0xdc7 -let xk_Thai_sosala = 0xdc8 -let xk_Thai_sorusi = 0xdc9 -let xk_Thai_sosua = 0xdca -let xk_Thai_hohip = 0xdcb -let xk_Thai_lochula = 0xdcc -let xk_Thai_oang = 0xdcd -let xk_Thai_honokhuk = 0xdce -let xk_Thai_paiyannoi = 0xdcf -let xk_Thai_saraa = 0xdd0 -let xk_Thai_maihanakat = 0xdd1 -let xk_Thai_saraaa = 0xdd2 -let xk_Thai_saraam = 0xdd3 -let xk_Thai_sarai = 0xdd4 -let xk_Thai_saraii = 0xdd5 -let xk_Thai_saraue = 0xdd6 -let xk_Thai_sarauee = 0xdd7 -let xk_Thai_sarau = 0xdd8 -let xk_Thai_sarauu = 0xdd9 -let xk_Thai_phinthu = 0xdda -let xk_Thai_maihanakat_maitho = 0xdde -let xk_Thai_baht = 0xddf -let xk_Thai_sarae = 0xde0 -let xk_Thai_saraae = 0xde1 -let xk_Thai_sarao = 0xde2 -let xk_Thai_saraaimaimuan = 0xde3 -let xk_Thai_saraaimaimalai = 0xde4 -let xk_Thai_lakkhangyao = 0xde5 -let xk_Thai_maiyamok = 0xde6 -let xk_Thai_maitaikhu = 0xde7 -let xk_Thai_maiek = 0xde8 -let xk_Thai_maitho = 0xde9 -let xk_Thai_maitri = 0xdea -let xk_Thai_maichattawa = 0xdeb -let xk_Thai_thanthakhat = 0xdec -let xk_Thai_nikhahit = 0xded -let xk_Thai_leksun = 0xdf0 -let xk_Thai_leknung = 0xdf1 -let xk_Thai_leksong = 0xdf2 -let xk_Thai_leksam = 0xdf3 -let xk_Thai_leksi = 0xdf4 -let xk_Thai_lekha = 0xdf5 -let xk_Thai_lekhok = 0xdf6 -let xk_Thai_lekchet = 0xdf7 -let xk_Thai_lekpaet = 0xdf8 -let xk_Thai_lekkao = 0xdf9 - - -(* - * Korean - * Byte 3 = e - *) - - - -let xk_Hangul = 0xff31 (** Hangul start/stop(toggle) *) -let xk_Hangul_Start = 0xff32 (** Hangul start *) -let xk_Hangul_End = 0xff33 (** Hangul end, English start *) -let xk_Hangul_Hanja = 0xff34 (** Start Hangul->Hanja Conversion *) -let xk_Hangul_Jamo = 0xff35 (** Hangul Jamo mode *) -let xk_Hangul_Romaja = 0xff36 (** Hangul Romaja mode *) -let xk_Hangul_Codeinput = 0xff37 (** Hangul code input mode *) -let xk_Hangul_Jeonja = 0xff38 (** Jeonja mode *) -let xk_Hangul_Banja = 0xff39 (** Banja mode *) -let xk_Hangul_PreHanja = 0xff3a (** Pre Hanja conversion *) -let xk_Hangul_PostHanja = 0xff3b (** Post Hanja conversion *) -let xk_Hangul_SingleCandidate = 0xff3c (** Single candidate *) -let xk_Hangul_MultipleCandidate = 0xff3d (** Multiple candidate *) -let xk_Hangul_PreviousCandidate = 0xff3e (** Previous candidate *) -let xk_Hangul_Special = 0xff3f (** Special symbols *) -let xk_Hangul_switch = 0xFF7E (** Alias for mode_switch *) - -(** Hangul Consonant Characters *) -let xk_Hangul_Kiyeog = 0xea1 -let xk_Hangul_SsangKiyeog = 0xea2 -let xk_Hangul_KiyeogSios = 0xea3 -let xk_Hangul_Nieun = 0xea4 -let xk_Hangul_NieunJieuj = 0xea5 -let xk_Hangul_NieunHieuh = 0xea6 -let xk_Hangul_Dikeud = 0xea7 -let xk_Hangul_SsangDikeud = 0xea8 -let xk_Hangul_Rieul = 0xea9 -let xk_Hangul_RieulKiyeog = 0xeaa -let xk_Hangul_RieulMieum = 0xeab -let xk_Hangul_RieulPieub = 0xeac -let xk_Hangul_RieulSios = 0xead -let xk_Hangul_RieulTieut = 0xeae -let xk_Hangul_RieulPhieuf = 0xeaf -let xk_Hangul_RieulHieuh = 0xeb0 -let xk_Hangul_Mieum = 0xeb1 -let xk_Hangul_Pieub = 0xeb2 -let xk_Hangul_SsangPieub = 0xeb3 -let xk_Hangul_PieubSios = 0xeb4 -let xk_Hangul_Sios = 0xeb5 -let xk_Hangul_SsangSios = 0xeb6 -let xk_Hangul_Ieung = 0xeb7 -let xk_Hangul_Jieuj = 0xeb8 -let xk_Hangul_SsangJieuj = 0xeb9 -let xk_Hangul_Cieuc = 0xeba -let xk_Hangul_Khieuq = 0xebb -let xk_Hangul_Tieut = 0xebc -let xk_Hangul_Phieuf = 0xebd -let xk_Hangul_Hieuh = 0xebe - -(** Hangul Vowel Characters *) -let xk_Hangul_A = 0xebf -let xk_Hangul_AE = 0xec0 -let xk_Hangul_YA = 0xec1 -let xk_Hangul_YAE = 0xec2 -let xk_Hangul_EO = 0xec3 -let xk_Hangul_E = 0xec4 -let xk_Hangul_YEO = 0xec5 -let xk_Hangul_YE = 0xec6 -let xk_Hangul_O = 0xec7 -let xk_Hangul_WA = 0xec8 -let xk_Hangul_WAE = 0xec9 -let xk_Hangul_OE = 0xeca -let xk_Hangul_YO = 0xecb -let xk_Hangul_U = 0xecc -let xk_Hangul_WEO = 0xecd -let xk_Hangul_WE = 0xece -let xk_Hangul_WI = 0xecf -let xk_Hangul_YU = 0xed0 -let xk_Hangul_EU = 0xed1 -let xk_Hangul_YI = 0xed2 -let xk_Hangul_I = 0xed3 - -(** Hangul syllable-final (JongSeong) Characters *) -let xk_Hangul_J_Kiyeog = 0xed4 -let xk_Hangul_J_SsangKiyeog = 0xed5 -let xk_Hangul_J_KiyeogSios = 0xed6 -let xk_Hangul_J_Nieun = 0xed7 -let xk_Hangul_J_NieunJieuj = 0xed8 -let xk_Hangul_J_NieunHieuh = 0xed9 -let xk_Hangul_J_Dikeud = 0xeda -let xk_Hangul_J_Rieul = 0xedb -let xk_Hangul_J_RieulKiyeog = 0xedc -let xk_Hangul_J_RieulMieum = 0xedd -let xk_Hangul_J_RieulPieub = 0xede -let xk_Hangul_J_RieulSios = 0xedf -let xk_Hangul_J_RieulTieut = 0xee0 -let xk_Hangul_J_RieulPhieuf = 0xee1 -let xk_Hangul_J_RieulHieuh = 0xee2 -let xk_Hangul_J_Mieum = 0xee3 -let xk_Hangul_J_Pieub = 0xee4 -let xk_Hangul_J_PieubSios = 0xee5 -let xk_Hangul_J_Sios = 0xee6 -let xk_Hangul_J_SsangSios = 0xee7 -let xk_Hangul_J_Ieung = 0xee8 -let xk_Hangul_J_Jieuj = 0xee9 -let xk_Hangul_J_Cieuc = 0xeea -let xk_Hangul_J_Khieuq = 0xeeb -let xk_Hangul_J_Tieut = 0xeec -let xk_Hangul_J_Phieuf = 0xeed -let xk_Hangul_J_Hieuh = 0xeee - -(** Ancient Hangul Consonant Characters *) -let xk_Hangul_RieulYeorinHieuh = 0xeef -let xk_Hangul_SunkyeongeumMieum = 0xef0 -let xk_Hangul_SunkyeongeumPieub = 0xef1 -let xk_Hangul_PanSios = 0xef2 -let xk_Hangul_KkogjiDalrinIeung = 0xef3 -let xk_Hangul_SunkyeongeumPhieuf = 0xef4 -let xk_Hangul_YeorinHieuh = 0xef5 - -(** Ancient Hangul Vowel Characters *) -let xk_Hangul_AraeA = 0xef6 -let xk_Hangul_AraeAE = 0xef7 - -(** Ancient Hangul syllable-final (JongSeong) Characters *) -let xk_Hangul_J_PanSios = 0xef8 -let xk_Hangul_J_KkogjiDalrinIeung = 0xef9 -let xk_Hangul_J_YeorinHieuh = 0xefa - -(** Korean currency symbol *) -let xk_Korean_Won = 0xeff - - - -let name_to_keysym = [ -"VoidSymbol",0xFFFFFF; -"BackSpace",0xFF08; -"Tab",0xFF09; -"Linefeed",0xFF0A; -"Clear",0xFF0B; -"Return",0xFF0D; -"Pause",0xFF13; -"Scroll_Lock",0xFF14; -"Sys_Req",0xFF15; -"Escape",0xFF1B; -"Delete",0xFFFF; -"Multi_key",0xFF20; -"Kanji",0xFF21; -"Muhenkan",0xFF22; -"Henkan_Mode",0xFF23; -"Henkan",0xFF23; -"Romaji",0xFF24; -"Hiragana",0xFF25; -"Katakana",0xFF26; -"Hiragana_Katakana",0xFF27; -"Zenkaku",0xFF28; -"Hankaku",0xFF29; -"Zenkaku_Hankaku",0xFF2A; -"Touroku",0xFF2B; -"Massyo",0xFF2C; -"Kana_Lock",0xFF2D; -"Kana_Shift",0xFF2E; -"Eisu_Shift",0xFF2F; -"Eisu_toggle",0xFF30; -"Home",0xFF50; -"Left",0xFF51; -"Up",0xFF52; -"Right",0xFF53; -"Down",0xFF54; -"Prior",0xFF55; -"Page_Up",0xFF55; -"Next",0xFF56; -"Page_Down",0xFF56; -"End",0xFF57; -"Begin",0xFF58; -"Select",0xFF60; -"Print",0xFF61; -"Execute",0xFF62; -"Insert",0xFF63; -"Undo",0xFF65; -"Redo",0xFF66; -"Menu",0xFF67; -"Find",0xFF68; -"Cancel",0xFF69; -"Help",0xFF6A; -"Break",0xFF6B; -"Mode_switch",0xFF7E; -"script_switch",0xFF7E; -"Num_Lock",0xFF7F; -"KP_Space",0xFF80; -"KP_Tab",0xFF89; -"KP_Enter",0xFF8D; -"KP_F1",0xFF91; -"KP_F2",0xFF92; -"KP_F3",0xFF93; -"KP_F4",0xFF94; -"KP_Home",0xFF95; -"KP_Left",0xFF96; -"KP_Up",0xFF97; -"KP_Right",0xFF98; -"KP_Down",0xFF99; -"KP_Prior",0xFF9A; -"KP_Page_Up",0xFF9A; -"KP_Next",0xFF9B; -"KP_Page_Down",0xFF9B; -"KP_End",0xFF9C; -"KP_Begin",0xFF9D; -"KP_Insert",0xFF9E; -"KP_Delete",0xFF9F; -"KP_Equal",0xFFBD; -"KP_Multiply",0xFFAA; -"KP_Add",0xFFAB; -"KP_Separator",0xFFAC; -"KP_Subtract",0xFFAD; -"KP_Decimal",0xFFAE; -"KP_Divide",0xFFAF; -"KP_0",0xFFB0; -"KP_1",0xFFB1; -"KP_2",0xFFB2; -"KP_3",0xFFB3; -"KP_4",0xFFB4; -"KP_5",0xFFB5; -"KP_6",0xFFB6; -"KP_7",0xFFB7; -"KP_8",0xFFB8; -"KP_9",0xFFB9; -"F1",0xFFBE; -"F2",0xFFBF; -"F3",0xFFC0; -"F4",0xFFC1; -"F5",0xFFC2; -"F6",0xFFC3; -"F7",0xFFC4; -"F8",0xFFC5; -"F9",0xFFC6; -"F10",0xFFC7; -"F11",0xFFC8; -"L1",0xFFC8; -"F12",0xFFC9; -"L2",0xFFC9; -"F13",0xFFCA; -"L3",0xFFCA; -"F14",0xFFCB; -"L4",0xFFCB; -"F15",0xFFCC; -"L5",0xFFCC; -"F16",0xFFCD; -"L6",0xFFCD; -"F17",0xFFCE; -"L7",0xFFCE; -"F18",0xFFCF; -"L8",0xFFCF; -"F19",0xFFD0; -"L9",0xFFD0; -"F20",0xFFD1; -"L10",0xFFD1; -"F21",0xFFD2; -"R1",0xFFD2; -"F22",0xFFD3; -"R2",0xFFD3; -"F23",0xFFD4; -"R3",0xFFD4; -"F24",0xFFD5; -"R4",0xFFD5; -"F25",0xFFD6; -"R5",0xFFD6; -"F26",0xFFD7; -"R6",0xFFD7; -"F27",0xFFD8; -"R7",0xFFD8; -"F28",0xFFD9; -"R8",0xFFD9; -"F29",0xFFDA; -"R9",0xFFDA; -"F30",0xFFDB; -"R10",0xFFDB; -"F31",0xFFDC; -"R11",0xFFDC; -"F32",0xFFDD; -"R12",0xFFDD; -"F33",0xFFDE; -"R13",0xFFDE; -"F34",0xFFDF; -"R14",0xFFDF; -"F35",0xFFE0; -"R15",0xFFE0; -"Shift_L",0xFFE1; -"Shift_R",0xFFE2; -"Control_L",0xFFE3; -"Control_R",0xFFE4; -"Caps_Lock",0xFFE5; -"Shift_Lock",0xFFE6; -"Meta_L",0xFFE7; -"Meta_R",0xFFE8; -"Alt_L",0xFFE9; -"Alt_R",0xFFEA; -"Super_L",0xFFEB; -"Super_R",0xFFEC; -"Hyper_L",0xFFED; -"Hyper_R",0xFFEE; -"ISO_Lock",0xFE01; -"ISO_Level2_Latch",0xFE02; -"ISO_Level3_Shift",0xFE03; -"ISO_Level3_Latch",0xFE04; -"ISO_Level3_Lock",0xFE05; -"ISO_Group_Shift",0xFF7E; -"ISO_Group_Latch",0xFE06; -"ISO_Group_Lock",0xFE07; -"ISO_Next_Group",0xFE08; -"ISO_Next_Group_Lock",0xFE09; -"ISO_Prev_Group",0xFE0A; -"ISO_Prev_Group_Lock",0xFE0B; -"ISO_First_Group",0xFE0C; -"ISO_First_Group_Lock",0xFE0D; -"ISO_Last_Group",0xFE0E; -"ISO_Last_Group_Lock",0xFE0F; -"ISO_Left_Tab",0xFE20; -"ISO_Move_Line_Up",0xFE21; -"ISO_Move_Line_Down",0xFE22; -"ISO_Partial_Line_Up",0xFE23; -"ISO_Partial_Line_Down",0xFE24; -"ISO_Partial_Space_Left",0xFE25; -"ISO_Partial_Space_Right",0xFE26; -"ISO_Set_Margin_Left",0xFE27; -"ISO_Set_Margin_Right",0xFE28; -"ISO_Release_Margin_Left",0xFE29; -"ISO_Release_Margin_Right",0xFE2A; -"ISO_Release_Both_Margins",0xFE2B; -"ISO_Fast_Cursor_Left",0xFE2C; -"ISO_Fast_Cursor_Right",0xFE2D; -"ISO_Fast_Cursor_Up",0xFE2E; -"ISO_Fast_Cursor_Down",0xFE2F; -"ISO_Continuous_Underline",0xFE30; -"ISO_Discontinuous_Underline",0xFE31; -"ISO_Emphasize",0xFE32; -"ISO_Center_Object",0xFE33; -"ISO_Enter",0xFE34; -"dead_grave",0xFE50; -"dead_acute",0xFE51; -"dead_circumflex",0xFE52; -"dead_tilde",0xFE53; -"dead_macron",0xFE54; -"dead_breve",0xFE55; -"dead_abovedot",0xFE56; -"dead_diaeresis",0xFE57; -"dead_abovering",0xFE58; -"dead_doubleacute",0xFE59; -"dead_caron",0xFE5A; -"dead_cedilla",0xFE5B; -"dead_ogonek",0xFE5C; -"dead_iota",0xFE5D; -"dead_voiced_sound",0xFE5E; -"dead_semivoiced_sound",0xFE5F; -"dead_belowdot",0xFE60; -"First_Virtual_Screen",0xFED0; -"Prev_Virtual_Screen",0xFED1; -"Next_Virtual_Screen",0xFED2; -"Last_Virtual_Screen",0xFED4; -"Terminate_Server",0xFED5; -"AccessX_Enable",0xFE70; -"AccessX_Feedback_Enable",0xFE71; -"RepeatKeys_Enable",0xFE72; -"SlowKeys_Enable",0xFE73; -"BounceKeys_Enable",0xFE74; -"StickyKeys_Enable",0xFE75; -"MouseKeys_Enable",0xFE76; -"MouseKeys_Accel_Enable",0xFE77; -"Overlay1_Enable",0xFE78; -"Overlay2_Enable",0xFE79; -"AudibleBell_Enable",0xFE7A; -"Pointer_Left",0xFEE0; -"Pointer_Right",0xFEE1; -"Pointer_Up",0xFEE2; -"Pointer_Down",0xFEE3; -"Pointer_UpLeft",0xFEE4; -"Pointer_UpRight",0xFEE5; -"Pointer_DownLeft",0xFEE6; -"Pointer_DownRight",0xFEE7; -"Pointer_Button_Dflt",0xFEE8; -"Pointer_Button1",0xFEE9; -"Pointer_Button2",0xFEEA; -"Pointer_Button3",0xFEEB; -"Pointer_Button4",0xFEEC; -"Pointer_Button5",0xFEED; -"Pointer_DblClick_Dflt",0xFEEE; -"Pointer_DblClick1",0xFEEF; -"Pointer_DblClick2",0xFEF0; -"Pointer_DblClick3",0xFEF1; -"Pointer_DblClick4",0xFEF2; -"Pointer_DblClick5",0xFEF3; -"Pointer_Drag_Dflt",0xFEF4; -"Pointer_Drag1",0xFEF5; -"Pointer_Drag2",0xFEF6; -"Pointer_Drag3",0xFEF7; -"Pointer_Drag4",0xFEF8; -"Pointer_Drag5",0xFEFD; -"Pointer_EnableKeys",0xFEF9; -"Pointer_Accelerate",0xFEFA; -"Pointer_DfltBtnNext",0xFEFB; -"Pointer_DfltBtnPrev",0xFEFC; -"3270_Duplicate",0xFD01; -"3270_FieldMark",0xFD02; -"3270_Right2",0xFD03; -"3270_Left2",0xFD04; -"3270_BackTab",0xFD05; -"3270_EraseEOF",0xFD06; -"3270_EraseInput",0xFD07; -"3270_Reset",0xFD08; -"3270_Quit",0xFD09; -"3270_PA1",0xFD0A; -"3270_PA2",0xFD0B; -"3270_PA3",0xFD0C; -"3270_Test",0xFD0D; -"3270_Attn",0xFD0E; -"3270_CursorBlink",0xFD0F; -"3270_AltCursor",0xFD10; -"3270_KeyClick",0xFD11; -"3270_Jump",0xFD12; -"3270_Ident",0xFD13; -"3270_Rule",0xFD14; -"3270_Copy",0xFD15; -"3270_Play",0xFD16; -"3270_Setup",0xFD17; -"3270_Record",0xFD18; -"3270_ChangeScreen",0xFD19; -"3270_DeleteWord",0xFD1A; -"3270_ExSelect",0xFD1B; -"3270_CursorSelect",0xFD1C; -"3270_PrintScreen",0xFD1D; -"3270_Enter",0xFD1E; -"space",0x020; -"exclam",0x021; -"quotedbl",0x022; -"numbersign",0x023; -"dollar",0x024; -"percent",0x025; -"ampersand",0x026; -"apostrophe",0x027; -"quoteright",0x027; -"parenleft",0x028; -"parenright",0x029; -"asterisk",0x02a; -"plus",0x02b; -"comma",0x02c; -"minus",0x02d; -"period",0x02e; -"slash",0x02f; -"0",0x030; -"1",0x031; -"2",0x032; -"3",0x033; -"4",0x034; -"5",0x035; -"6",0x036; -"7",0x037; -"8",0x038; -"9",0x039; -"colon",0x03a; -"semicolon",0x03b; -"less",0x03c; -"equal",0x03d; -"greater",0x03e; -"question",0x03f; -"at",0x040; -"A",0x041; -"B",0x042; -"C",0x043; -"D",0x044; -"E",0x045; -"F",0x046; -"G",0x047; -"H",0x048; -"I",0x049; -"J",0x04a; -"K",0x04b; -"L",0x04c; -"M",0x04d; -"N",0x04e; -"O",0x04f; -"P",0x050; -"Q",0x051; -"R",0x052; -"S",0x053; -"T",0x054; -"U",0x055; -"V",0x056; -"W",0x057; -"X",0x058; -"Y",0x059; -"Z",0x05a; -"bracketleft",0x05b; -"backslash",0x05c; -"bracketright",0x05d; -"asciicircum",0x05e; -"underscore",0x05f; -"grave",0x060; -"quoteleft",0x060; -"a",0x061; -"b",0x062; -"c",0x063; -"d",0x064; -"e",0x065; -"f",0x066; -"g",0x067; -"h",0x068; -"i",0x069; -"j",0x06a; -"k",0x06b; -"l",0x06c; -"m",0x06d; -"n",0x06e; -"o",0x06f; -"p",0x070; -"q",0x071; -"r",0x072; -"s",0x073; -"t",0x074; -"u",0x075; -"v",0x076; -"w",0x077; -"x",0x078; -"y",0x079; -"z",0x07a; -"braceleft",0x07b; -"bar",0x07c; -"braceright",0x07d; -"asciitilde",0x07e; -"nobreakspace",0x0a0; -"exclamdown",0x0a1; -"cent",0x0a2; -"sterling",0x0a3; -"currency",0x0a4; -"yen",0x0a5; -"brokenbar",0x0a6; -"section",0x0a7; -"diaeresis",0x0a8; -"copyright",0x0a9; -"ordfeminine",0x0aa; -"guillemotleft",0x0ab; -"notsign",0x0ac; -"hyphen",0x0ad; -"registered",0x0ae; -"macron",0x0af; -"degree",0x0b0; -"plusminus",0x0b1; -"twosuperior",0x0b2; -"threesuperior",0x0b3; -"acute",0x0b4; -"mu",0x0b5; -"paragraph",0x0b6; -"periodcentered",0x0b7; -"cedilla",0x0b8; -"onesuperior",0x0b9; -"masculine",0x0ba; -"guillemotright",0x0bb; -"onequarter",0x0bc; -"onehalf",0x0bd; -"threequarters",0x0be; -"questiondown",0x0bf; -"Agrave",0x0c0; -"Aacute",0x0c1; -"Acircumflex",0x0c2; -"Atilde",0x0c3; -"Adiaeresis",0x0c4; -"Aring",0x0c5; -"AE",0x0c6; -"Ccedilla",0x0c7; -"Egrave",0x0c8; -"Eacute",0x0c9; -"Ecircumflex",0x0ca; -"Ediaeresis",0x0cb; -"Igrave",0x0cc; -"Iacute",0x0cd; -"Icircumflex",0x0ce; -"Idiaeresis",0x0cf; -"ETH",0x0d0; -"Eth",0x0d0; -"Ntilde",0x0d1; -"Ograve",0x0d2; -"Oacute",0x0d3; -"Ocircumflex",0x0d4; -"Otilde",0x0d5; -"Odiaeresis",0x0d6; -"multiply",0x0d7; -"Ooblique",0x0d8; -"Ugrave",0x0d9; -"Uacute",0x0da; -"Ucircumflex",0x0db; -"Udiaeresis",0x0dc; -"Yacute",0x0dd; -"THORN",0x0de; -"Thorn",0x0de; -"ssharp",0x0df; -"agrave",0x0e0; -"aacute",0x0e1; -"acircumflex",0x0e2; -"atilde",0x0e3; -"adiaeresis",0x0e4; -"aring",0x0e5; -"ae",0x0e6; -"ccedilla",0x0e7; -"egrave",0x0e8; -"eacute",0x0e9; -"ecircumflex",0x0ea; -"ediaeresis",0x0eb; -"igrave",0x0ec; -"iacute",0x0ed; -"icircumflex",0x0ee; -"idiaeresis",0x0ef; -"eth",0x0f0; -"ntilde",0x0f1; -"ograve",0x0f2; -"oacute",0x0f3; -"ocircumflex",0x0f4; -"otilde",0x0f5; -"odiaeresis",0x0f6; -"division",0x0f7; -"oslash",0x0f8; -"ugrave",0x0f9; -"uacute",0x0fa; -"ucircumflex",0x0fb; -"udiaeresis",0x0fc; -"yacute",0x0fd; -"thorn",0x0fe; -"ydiaeresis",0x0ff; -"Aogonek",0x1a1; -"breve",0x1a2; -"Lstroke",0x1a3; -"Lcaron",0x1a5; -"Sacute",0x1a6; -"Scaron",0x1a9; -"Scedilla",0x1aa; -"Tcaron",0x1ab; -"Zacute",0x1ac; -"Zcaron",0x1ae; -"Zabovedot",0x1af; -"aogonek",0x1b1; -"ogonek",0x1b2; -"lstroke",0x1b3; -"lcaron",0x1b5; -"sacute",0x1b6; -"caron",0x1b7; -"scaron",0x1b9; -"scedilla",0x1ba; -"tcaron",0x1bb; -"zacute",0x1bc; -"doubleacute",0x1bd; -"zcaron",0x1be; -"zabovedot",0x1bf; -"Racute",0x1c0; -"Abreve",0x1c3; -"Lacute",0x1c5; -"Cacute",0x1c6; -"Ccaron",0x1c8; -"Eogonek",0x1ca; -"Ecaron",0x1cc; -"Dcaron",0x1cf; -"Dstroke",0x1d0; -"Nacute",0x1d1; -"Ncaron",0x1d2; -"Odoubleacute",0x1d5; -"Rcaron",0x1d8; -"Uring",0x1d9; -"Udoubleacute",0x1db; -"Tcedilla",0x1de; -"racute",0x1e0; -"abreve",0x1e3; -"lacute",0x1e5; -"cacute",0x1e6; -"ccaron",0x1e8; -"eogonek",0x1ea; -"ecaron",0x1ec; -"dcaron",0x1ef; -"dstroke",0x1f0; -"nacute",0x1f1; -"ncaron",0x1f2; -"odoubleacute",0x1f5; -"udoubleacute",0x1fb; -"rcaron",0x1f8; -"uring",0x1f9; -"tcedilla",0x1fe; -"abovedot",0x1ff; -"Hstroke",0x2a1; -"Hcircumflex",0x2a6; -"Iabovedot",0x2a9; -"Gbreve",0x2ab; -"Jcircumflex",0x2ac; -"hstroke",0x2b1; -"hcircumflex",0x2b6; -"idotless",0x2b9; -"gbreve",0x2bb; -"jcircumflex",0x2bc; -"Cabovedot",0x2c5; -"Ccircumflex",0x2c6; -"Gabovedot",0x2d5; -"Gcircumflex",0x2d8; -"Ubreve",0x2dd; -"Scircumflex",0x2de; -"cabovedot",0x2e5; -"ccircumflex",0x2e6; -"gabovedot",0x2f5; -"gcircumflex",0x2f8; -"ubreve",0x2fd; -"scircumflex",0x2fe; -"kra",0x3a2; -"kappa",0x3a2; -"Rcedilla",0x3a3; -"Itilde",0x3a5; -"Lcedilla",0x3a6; -"Emacron",0x3aa; -"Gcedilla",0x3ab; -"Tslash",0x3ac; -"rcedilla",0x3b3; -"itilde",0x3b5; -"lcedilla",0x3b6; -"emacron",0x3ba; -"gcedilla",0x3bb; -"tslash",0x3bc; -"ENG",0x3bd; -"eng",0x3bf; -"Amacron",0x3c0; -"Iogonek",0x3c7; -"Eabovedot",0x3cc; -"Imacron",0x3cf; -"Ncedilla",0x3d1; -"Omacron",0x3d2; -"Kcedilla",0x3d3; -"Uogonek",0x3d9; -"Utilde",0x3dd; -"Umacron",0x3de; -"amacron",0x3e0; -"iogonek",0x3e7; -"eabovedot",0x3ec; -"imacron",0x3ef; -"ncedilla",0x3f1; -"omacron",0x3f2; -"kcedilla",0x3f3; -"uogonek",0x3f9; -"utilde",0x3fd; -"umacron",0x3fe; -"overline",0x47e; -"kana_fullstop",0x4a1; -"kana_openingbracket",0x4a2; -"kana_closingbracket",0x4a3; -"kana_comma",0x4a4; -"kana_conjunctive",0x4a5; -"kana_middledot",0x4a5; -"kana_WO",0x4a6; -"kana_a",0x4a7; -"kana_i",0x4a8; -"kana_u",0x4a9; -"kana_e",0x4aa; -"kana_o",0x4ab; -"kana_ya",0x4ac; -"kana_yu",0x4ad; -"kana_yo",0x4ae; -"kana_tsu",0x4af; -"kana_tu",0x4af; -"prolongedsound",0x4b0; -"kana_A",0x4b1; -"kana_I",0x4b2; -"kana_U",0x4b3; -"kana_E",0x4b4; -"kana_O",0x4b5; -"kana_KA",0x4b6; -"kana_KI",0x4b7; -"kana_KU",0x4b8; -"kana_KE",0x4b9; -"kana_KO",0x4ba; -"kana_SA",0x4bb; -"kana_SHI",0x4bc; -"kana_SU",0x4bd; -"kana_SE",0x4be; -"kana_SO",0x4bf; -"kana_TA",0x4c0; -"kana_CHI",0x4c1; -"kana_TI",0x4c1; -"kana_TSU",0x4c2; -"kana_TU",0x4c2; -"kana_TE",0x4c3; -"kana_TO",0x4c4; -"kana_NA",0x4c5; -"kana_NI",0x4c6; -"kana_NU",0x4c7; -"kana_NE",0x4c8; -"kana_NO",0x4c9; -"kana_HA",0x4ca; -"kana_HI",0x4cb; -"kana_FU",0x4cc; -"kana_HU",0x4cc; -"kana_HE",0x4cd; -"kana_HO",0x4ce; -"kana_MA",0x4cf; -"kana_MI",0x4d0; -"kana_MU",0x4d1; -"kana_ME",0x4d2; -"kana_MO",0x4d3; -"kana_YA",0x4d4; -"kana_YU",0x4d5; -"kana_YO",0x4d6; -"kana_RA",0x4d7; -"kana_RI",0x4d8; -"kana_RU",0x4d9; -"kana_RE",0x4da; -"kana_RO",0x4db; -"kana_WA",0x4dc; -"kana_N",0x4dd; -"voicedsound",0x4de; -"semivoicedsound",0x4df; -"kana_switch",0xFF7E; -"Arabic_comma",0x5ac; -"Arabic_semicolon",0x5bb; -"Arabic_question_mark",0x5bf; -"Arabic_hamza",0x5c1; -"Arabic_maddaonalef",0x5c2; -"Arabic_hamzaonalef",0x5c3; -"Arabic_hamzaonwaw",0x5c4; -"Arabic_hamzaunderalef",0x5c5; -"Arabic_hamzaonyeh",0x5c6; -"Arabic_alef",0x5c7; -"Arabic_beh",0x5c8; -"Arabic_tehmarbuta",0x5c9; -"Arabic_teh",0x5ca; -"Arabic_theh",0x5cb; -"Arabic_jeem",0x5cc; -"Arabic_hah",0x5cd; -"Arabic_khah",0x5ce; -"Arabic_dal",0x5cf; -"Arabic_thal",0x5d0; -"Arabic_ra",0x5d1; -"Arabic_zain",0x5d2; -"Arabic_seen",0x5d3; -"Arabic_sheen",0x5d4; -"Arabic_sad",0x5d5; -"Arabic_dad",0x5d6; -"Arabic_tah",0x5d7; -"Arabic_zah",0x5d8; -"Arabic_ain",0x5d9; -"Arabic_ghain",0x5da; -"Arabic_tatweel",0x5e0; -"Arabic_feh",0x5e1; -"Arabic_qaf",0x5e2; -"Arabic_kaf",0x5e3; -"Arabic_lam",0x5e4; -"Arabic_meem",0x5e5; -"Arabic_noon",0x5e6; -"Arabic_ha",0x5e7; -"Arabic_heh",0x5e7; -"Arabic_waw",0x5e8; -"Arabic_alefmaksura",0x5e9; -"Arabic_yeh",0x5ea; -"Arabic_fathatan",0x5eb; -"Arabic_dammatan",0x5ec; -"Arabic_kasratan",0x5ed; -"Arabic_fatha",0x5ee; -"Arabic_damma",0x5ef; -"Arabic_kasra",0x5f0; -"Arabic_shadda",0x5f1; -"Arabic_sukun",0x5f2; -"Arabic_switch",0xFF7E; -"Serbian_dje",0x6a1; -"Macedonia_gje",0x6a2; -"Cyrillic_io",0x6a3; -"Ukrainian_ie",0x6a4; -"Ukranian_je",0x6a4; -"Macedonia_dse",0x6a5; -"Ukrainian_i",0x6a6; -"Ukranian_i",0x6a6; -"Ukrainian_yi",0x6a7; -"Ukranian_yi",0x6a7; -"Cyrillic_je",0x6a8; -"Serbian_je",0x6a8; -"Cyrillic_lje",0x6a9; -"Serbian_lje",0x6a9; -"Cyrillic_nje",0x6aa; -"Serbian_nje",0x6aa; -"Serbian_tshe",0x6ab; -"Macedonia_kje",0x6ac; -"Byelorussian_shortu",0x6ae; -"Cyrillic_dzhe",0x6af; -"Serbian_dze",0x6af; -"numerosign",0x6b0; -"Serbian_DJE",0x6b1; -"Macedonia_GJE",0x6b2; -"Cyrillic_IO",0x6b3; -"Ukrainian_IE",0x6b4; -"Ukranian_JE",0x6b4; -"Macedonia_DSE",0x6b5; -"Ukrainian_I",0x6b6; -"Ukranian_I",0x6b6; -"Ukrainian_YI",0x6b7; -"Ukranian_YI",0x6b7; -"Cyrillic_JE",0x6b8; -"Serbian_JE",0x6b8; -"Cyrillic_LJE",0x6b9; -"Serbian_LJE",0x6b9; -"Cyrillic_NJE",0x6ba; -"Serbian_NJE",0x6ba; -"Serbian_TSHE",0x6bb; -"Macedonia_KJE",0x6bc; -"Byelorussian_SHORTU",0x6be; -"Cyrillic_DZHE",0x6bf; -"Serbian_DZE",0x6bf; -"Cyrillic_yu",0x6c0; -"Cyrillic_a",0x6c1; -"Cyrillic_be",0x6c2; -"Cyrillic_tse",0x6c3; -"Cyrillic_de",0x6c4; -"Cyrillic_ie",0x6c5; -"Cyrillic_ef",0x6c6; -"Cyrillic_ghe",0x6c7; -"Cyrillic_ha",0x6c8; -"Cyrillic_i",0x6c9; -"Cyrillic_shorti",0x6ca; -"Cyrillic_ka",0x6cb; -"Cyrillic_el",0x6cc; -"Cyrillic_em",0x6cd; -"Cyrillic_en",0x6ce; -"Cyrillic_o",0x6cf; -"Cyrillic_pe",0x6d0; -"Cyrillic_ya",0x6d1; -"Cyrillic_er",0x6d2; -"Cyrillic_es",0x6d3; -"Cyrillic_te",0x6d4; -"Cyrillic_u",0x6d5; -"Cyrillic_zhe",0x6d6; -"Cyrillic_ve",0x6d7; -"Cyrillic_softsign",0x6d8; -"Cyrillic_yeru",0x6d9; -"Cyrillic_ze",0x6da; -"Cyrillic_sha",0x6db; -"Cyrillic_e",0x6dc; -"Cyrillic_shcha",0x6dd; -"Cyrillic_che",0x6de; -"Cyrillic_hardsign",0x6df; -"Cyrillic_YU",0x6e0; -"Cyrillic_A",0x6e1; -"Cyrillic_BE",0x6e2; -"Cyrillic_TSE",0x6e3; -"Cyrillic_DE",0x6e4; -"Cyrillic_IE",0x6e5; -"Cyrillic_EF",0x6e6; -"Cyrillic_GHE",0x6e7; -"Cyrillic_HA",0x6e8; -"Cyrillic_I",0x6e9; -"Cyrillic_SHORTI",0x6ea; -"Cyrillic_KA",0x6eb; -"Cyrillic_EL",0x6ec; -"Cyrillic_EM",0x6ed; -"Cyrillic_EN",0x6ee; -"Cyrillic_O",0x6ef; -"Cyrillic_PE",0x6f0; -"Cyrillic_YA",0x6f1; -"Cyrillic_ER",0x6f2; -"Cyrillic_ES",0x6f3; -"Cyrillic_TE",0x6f4; -"Cyrillic_U",0x6f5; -"Cyrillic_ZHE",0x6f6; -"Cyrillic_VE",0x6f7; -"Cyrillic_SOFTSIGN",0x6f8; -"Cyrillic_YERU",0x6f9; -"Cyrillic_ZE",0x6fa; -"Cyrillic_SHA",0x6fb; -"Cyrillic_E",0x6fc; -"Cyrillic_SHCHA",0x6fd; -"Cyrillic_CHE",0x6fe; -"Cyrillic_HARDSIGN",0x6ff; -"Greek_ALPHAaccent",0x7a1; -"Greek_EPSILONaccent",0x7a2; -"Greek_ETAaccent",0x7a3; -"Greek_IOTAaccent",0x7a4; -"Greek_IOTAdiaeresis",0x7a5; -"Greek_OMICRONaccent",0x7a7; -"Greek_UPSILONaccent",0x7a8; -"Greek_UPSILONdieresis",0x7a9; -"Greek_OMEGAaccent",0x7ab; -"Greek_accentdieresis",0x7ae; -"Greek_horizbar",0x7af; -"Greek_alphaaccent",0x7b1; -"Greek_epsilonaccent",0x7b2; -"Greek_etaaccent",0x7b3; -"Greek_iotaaccent",0x7b4; -"Greek_iotadieresis",0x7b5; -"Greek_iotaaccentdieresis",0x7b6; -"Greek_omicronaccent",0x7b7; -"Greek_upsilonaccent",0x7b8; -"Greek_upsilondieresis",0x7b9; -"Greek_upsilonaccentdieresis",0x7ba; -"Greek_omegaaccent",0x7bb; -"Greek_ALPHA",0x7c1; -"Greek_BETA",0x7c2; -"Greek_GAMMA",0x7c3; -"Greek_DELTA",0x7c4; -"Greek_EPSILON",0x7c5; -"Greek_ZETA",0x7c6; -"Greek_ETA",0x7c7; -"Greek_THETA",0x7c8; -"Greek_IOTA",0x7c9; -"Greek_KAPPA",0x7ca; -"Greek_LAMDA",0x7cb; -"Greek_LAMBDA",0x7cb; -"Greek_MU",0x7cc; -"Greek_NU",0x7cd; -"Greek_XI",0x7ce; -"Greek_OMICRON",0x7cf; -"Greek_PI",0x7d0; -"Greek_RHO",0x7d1; -"Greek_SIGMA",0x7d2; -"Greek_TAU",0x7d4; -"Greek_UPSILON",0x7d5; -"Greek_PHI",0x7d6; -"Greek_CHI",0x7d7; -"Greek_PSI",0x7d8; -"Greek_OMEGA",0x7d9; -"Greek_alpha",0x7e1; -"Greek_beta",0x7e2; -"Greek_gamma",0x7e3; -"Greek_delta",0x7e4; -"Greek_epsilon",0x7e5; -"Greek_zeta",0x7e6; -"Greek_eta",0x7e7; -"Greek_theta",0x7e8; -"Greek_iota",0x7e9; -"Greek_kappa",0x7ea; -"Greek_lamda",0x7eb; -"Greek_lambda",0x7eb; -"Greek_mu",0x7ec; -"Greek_nu",0x7ed; -"Greek_xi",0x7ee; -"Greek_omicron",0x7ef; -"Greek_pi",0x7f0; -"Greek_rho",0x7f1; -"Greek_sigma",0x7f2; -"Greek_finalsmallsigma",0x7f3; -"Greek_tau",0x7f4; -"Greek_upsilon",0x7f5; -"Greek_phi",0x7f6; -"Greek_chi",0x7f7; -"Greek_psi",0x7f8; -"Greek_omega",0x7f9; -"Greek_switch",0xFF7E; -"leftradical",0x8a1; -"topleftradical",0x8a2; -"horizconnector",0x8a3; -"topintegral",0x8a4; -"botintegral",0x8a5; -"vertconnector",0x8a6; -"topleftsqbracket",0x8a7; -"botleftsqbracket",0x8a8; -"toprightsqbracket",0x8a9; -"botrightsqbracket",0x8aa; -"topleftparens",0x8ab; -"botleftparens",0x8ac; -"toprightparens",0x8ad; -"botrightparens",0x8ae; -"leftmiddlecurlybrace",0x8af; -"rightmiddlecurlybrace",0x8b0; -"topleftsummation",0x8b1; -"botleftsummation",0x8b2; -"topvertsummationconnector",0x8b3; -"botvertsummationconnector",0x8b4; -"toprightsummation",0x8b5; -"botrightsummation",0x8b6; -"rightmiddlesummation",0x8b7; -"lessthanequal",0x8bc; -"notequal",0x8bd; -"greaterthanequal",0x8be; -"integral",0x8bf; -"therefore",0x8c0; -"variation",0x8c1; -"infinity",0x8c2; -"nabla",0x8c5; -"approximate",0x8c8; -"similarequal",0x8c9; -"ifonlyif",0x8cd; -"implies",0x8ce; -"identical",0x8cf; -"radical",0x8d6; -"includedin",0x8da; -"includes",0x8db; -"intersection",0x8dc; -"union",0x8dd; -"logicaland",0x8de; -"logicalor",0x8df; -"partialderivative",0x8ef; -"function",0x8f6; -"leftarrow",0x8fb; -"uparrow",0x8fc; -"rightarrow",0x8fd; -"downarrow",0x8fe; -"blank",0x9df; -"soliddiamond",0x9e0; -"checkerboard",0x9e1; -"ht",0x9e2; -"ff",0x9e3; -"cr",0x9e4; -"lf",0x9e5; -"nl",0x9e8; -"vt",0x9e9; -"lowrightcorner",0x9ea; -"uprightcorner",0x9eb; -"upleftcorner",0x9ec; -"lowleftcorner",0x9ed; -"crossinglines",0x9ee; -"horizlinescan1",0x9ef; -"horizlinescan3",0x9f0; -"horizlinescan5",0x9f1; -"horizlinescan7",0x9f2; -"horizlinescan9",0x9f3; -"leftt",0x9f4; -"rightt",0x9f5; -"bott",0x9f6; -"topt",0x9f7; -"vertbar",0x9f8; -"emspace",0xaa1; -"enspace",0xaa2; -"em3space",0xaa3; -"em4space",0xaa4; -"digitspace",0xaa5; -"punctspace",0xaa6; -"thinspace",0xaa7; -"hairspace",0xaa8; -"emdash",0xaa9; -"endash",0xaaa; -"signifblank",0xaac; -"ellipsis",0xaae; -"doubbaselinedot",0xaaf; -"onethird",0xab0; -"twothirds",0xab1; -"onefifth",0xab2; -"twofifths",0xab3; -"threefifths",0xab4; -"fourfifths",0xab5; -"onesixth",0xab6; -"fivesixths",0xab7; -"careof",0xab8; -"figdash",0xabb; -"leftanglebracket",0xabc; -"decimalpoint",0xabd; -"rightanglebracket",0xabe; -"marker",0xabf; -"oneeighth",0xac3; -"threeeighths",0xac4; -"fiveeighths",0xac5; -"seveneighths",0xac6; -"trademark",0xac9; -"signaturemark",0xaca; -"trademarkincircle",0xacb; -"leftopentriangle",0xacc; -"rightopentriangle",0xacd; -"emopencircle",0xace; -"emopenrectangle",0xacf; -"leftsinglequotemark",0xad0; -"rightsinglequotemark",0xad1; -"leftdoublequotemark",0xad2; -"rightdoublequotemark",0xad3; -"prescription",0xad4; -"minutes",0xad6; -"seconds",0xad7; -"latincross",0xad9; -"hexagram",0xada; -"filledrectbullet",0xadb; -"filledlefttribullet",0xadc; -"filledrighttribullet",0xadd; -"emfilledcircle",0xade; -"emfilledrect",0xadf; -"enopencircbullet",0xae0; -"enopensquarebullet",0xae1; -"openrectbullet",0xae2; -"opentribulletup",0xae3; -"opentribulletdown",0xae4; -"openstar",0xae5; -"enfilledcircbullet",0xae6; -"enfilledsqbullet",0xae7; -"filledtribulletup",0xae8; -"filledtribulletdown",0xae9; -"leftpointer",0xaea; -"rightpointer",0xaeb; -"club",0xaec; -"diamond",0xaed; -"heart",0xaee; -"maltesecross",0xaf0; -"dagger",0xaf1; -"doubledagger",0xaf2; -"checkmark",0xaf3; -"ballotcross",0xaf4; -"musicalsharp",0xaf5; -"musicalflat",0xaf6; -"malesymbol",0xaf7; -"femalesymbol",0xaf8; -"telephone",0xaf9; -"telephonerecorder",0xafa; -"phonographcopyright",0xafb; -"caret",0xafc; -"singlelowquotemark",0xafd; -"doublelowquotemark",0xafe; -"cursor",0xaff; -"leftcaret",0xba3; -"rightcaret",0xba6; -"downcaret",0xba8; -"upcaret",0xba9; -"overbar",0xbc0; -"downtack",0xbc2; -"upshoe",0xbc3; -"downstile",0xbc4; -"underbar",0xbc6; -"jot",0xbca; -"quad",0xbcc; -"uptack",0xbce; -"circle",0xbcf; -"upstile",0xbd3; -"downshoe",0xbd6; -"rightshoe",0xbd8; -"leftshoe",0xbda; -"lefttack",0xbdc; -"righttack",0xbfc; -"hebrew_doublelowline",0xcdf; -"hebrew_aleph",0xce0; -"hebrew_bet",0xce1; -"hebrew_beth",0xce1; -"hebrew_gimel",0xce2; -"hebrew_gimmel",0xce2; -"hebrew_dalet",0xce3; -"hebrew_daleth",0xce3; -"hebrew_he",0xce4; -"hebrew_waw",0xce5; -"hebrew_zain",0xce6; -"hebrew_zayin",0xce6; -"hebrew_chet",0xce7; -"hebrew_het",0xce7; -"hebrew_tet",0xce8; -"hebrew_teth",0xce8; -"hebrew_yod",0xce9; -"hebrew_finalkaph",0xcea; -"hebrew_kaph",0xceb; -"hebrew_lamed",0xcec; -"hebrew_finalmem",0xced; -"hebrew_mem",0xcee; -"hebrew_finalnun",0xcef; -"hebrew_nun",0xcf0; -"hebrew_samech",0xcf1; -"hebrew_samekh",0xcf1; -"hebrew_ayin",0xcf2; -"hebrew_finalpe",0xcf3; -"hebrew_pe",0xcf4; -"hebrew_finalzade",0xcf5; -"hebrew_finalzadi",0xcf5; -"hebrew_zade",0xcf6; -"hebrew_zadi",0xcf6; -"hebrew_qoph",0xcf7; -"hebrew_kuf",0xcf7; -"hebrew_resh",0xcf8; -"hebrew_shin",0xcf9; -"hebrew_taw",0xcfa; -"hebrew_taf",0xcfa; -"Hebrew_switch",0xFF7E; -"Thai_kokai",0xda1; -"Thai_khokhai",0xda2; -"Thai_khokhuat",0xda3; -"Thai_khokhwai",0xda4; -"Thai_khokhon",0xda5; -"Thai_khorakhang",0xda6; -"Thai_ngongu",0xda7; -"Thai_chochan",0xda8; -"Thai_choching",0xda9; -"Thai_chochang",0xdaa; -"Thai_soso",0xdab; -"Thai_chochoe",0xdac; -"Thai_yoying",0xdad; -"Thai_dochada",0xdae; -"Thai_topatak",0xdaf; -"Thai_thothan",0xdb0; -"Thai_thonangmontho",0xdb1; -"Thai_thophuthao",0xdb2; -"Thai_nonen",0xdb3; -"Thai_dodek",0xdb4; -"Thai_totao",0xdb5; -"Thai_thothung",0xdb6; -"Thai_thothahan",0xdb7; -"Thai_thothong",0xdb8; -"Thai_nonu",0xdb9; -"Thai_bobaimai",0xdba; -"Thai_popla",0xdbb; -"Thai_phophung",0xdbc; -"Thai_fofa",0xdbd; -"Thai_phophan",0xdbe; -"Thai_fofan",0xdbf; -"Thai_phosamphao",0xdc0; -"Thai_moma",0xdc1; -"Thai_yoyak",0xdc2; -"Thai_rorua",0xdc3; -"Thai_ru",0xdc4; -"Thai_loling",0xdc5; -"Thai_lu",0xdc6; -"Thai_wowaen",0xdc7; -"Thai_sosala",0xdc8; -"Thai_sorusi",0xdc9; -"Thai_sosua",0xdca; -"Thai_hohip",0xdcb; -"Thai_lochula",0xdcc; -"Thai_oang",0xdcd; -"Thai_honokhuk",0xdce; -"Thai_paiyannoi",0xdcf; -"Thai_saraa",0xdd0; -"Thai_maihanakat",0xdd1; -"Thai_saraaa",0xdd2; -"Thai_saraam",0xdd3; -"Thai_sarai",0xdd4; -"Thai_saraii",0xdd5; -"Thai_saraue",0xdd6; -"Thai_sarauee",0xdd7; -"Thai_sarau",0xdd8; -"Thai_sarauu",0xdd9; -"Thai_phinthu",0xdda; -"Thai_maihanakat_maitho",0xdde; -"Thai_baht",0xddf; -"Thai_sarae",0xde0; -"Thai_saraae",0xde1; -"Thai_sarao",0xde2; -"Thai_saraaimaimuan",0xde3; -"Thai_saraaimaimalai",0xde4; -"Thai_lakkhangyao",0xde5; -"Thai_maiyamok",0xde6; -"Thai_maitaikhu",0xde7; -"Thai_maiek",0xde8; -"Thai_maitho",0xde9; -"Thai_maitri",0xdea; -"Thai_maichattawa",0xdeb; -"Thai_thanthakhat",0xdec; -"Thai_nikhahit",0xded; -"Thai_leksun",0xdf0; -"Thai_leknung",0xdf1; -"Thai_leksong",0xdf2; -"Thai_leksam",0xdf3; -"Thai_leksi",0xdf4; -"Thai_lekha",0xdf5; -"Thai_lekhok",0xdf6; -"Thai_lekchet",0xdf7; -"Thai_lekpaet",0xdf8; -"Thai_lekkao",0xdf9; -"Hangul",0xff31; -"Hangul_Start",0xff32; -"Hangul_End",0xff33; -"Hangul_Hanja",0xff34; -"Hangul_Jamo",0xff35; -"Hangul_Romaja",0xff36; -"Hangul_Codeinput",0xff37; -"Hangul_Jeonja",0xff38; -"Hangul_Banja",0xff39; -"Hangul_PreHanja",0xff3a; -"Hangul_PostHanja",0xff3b; -"Hangul_SingleCandidate",0xff3c; -"Hangul_MultipleCandidate",0xff3d; -"Hangul_PreviousCandidate",0xff3e; -"Hangul_Special",0xff3f; -"Hangul_switch",0xFF7E; -"Hangul_Kiyeog",0xea1; -"Hangul_SsangKiyeog",0xea2; -"Hangul_KiyeogSios",0xea3; -"Hangul_Nieun",0xea4; -"Hangul_NieunJieuj",0xea5; -"Hangul_NieunHieuh",0xea6; -"Hangul_Dikeud",0xea7; -"Hangul_SsangDikeud",0xea8; -"Hangul_Rieul",0xea9; -"Hangul_RieulKiyeog",0xeaa; -"Hangul_RieulMieum",0xeab; -"Hangul_RieulPieub",0xeac; -"Hangul_RieulSios",0xead; -"Hangul_RieulTieut",0xeae; -"Hangul_RieulPhieuf",0xeaf; -"Hangul_RieulHieuh",0xeb0; -"Hangul_Mieum",0xeb1; -"Hangul_Pieub",0xeb2; -"Hangul_SsangPieub",0xeb3; -"Hangul_PieubSios",0xeb4; -"Hangul_Sios",0xeb5; -"Hangul_SsangSios",0xeb6; -"Hangul_Ieung",0xeb7; -"Hangul_Jieuj",0xeb8; -"Hangul_SsangJieuj",0xeb9; -"Hangul_Cieuc",0xeba; -"Hangul_Khieuq",0xebb; -"Hangul_Tieut",0xebc; -"Hangul_Phieuf",0xebd; -"Hangul_Hieuh",0xebe; -"Hangul_A",0xebf; -"Hangul_AE",0xec0; -"Hangul_YA",0xec1; -"Hangul_YAE",0xec2; -"Hangul_EO",0xec3; -"Hangul_E",0xec4; -"Hangul_YEO",0xec5; -"Hangul_YE",0xec6; -"Hangul_O",0xec7; -"Hangul_WA",0xec8; -"Hangul_WAE",0xec9; -"Hangul_OE",0xeca; -"Hangul_YO",0xecb; -"Hangul_U",0xecc; -"Hangul_WEO",0xecd; -"Hangul_WE",0xece; -"Hangul_WI",0xecf; -"Hangul_YU",0xed0; -"Hangul_EU",0xed1; -"Hangul_YI",0xed2; -"Hangul_I",0xed3; -"Hangul_J_Kiyeog",0xed4; -"Hangul_J_SsangKiyeog",0xed5; -"Hangul_J_KiyeogSios",0xed6; -"Hangul_J_Nieun",0xed7; -"Hangul_J_NieunJieuj",0xed8; -"Hangul_J_NieunHieuh",0xed9; -"Hangul_J_Dikeud",0xeda; -"Hangul_J_Rieul",0xedb; -"Hangul_J_RieulKiyeog",0xedc; -"Hangul_J_RieulMieum",0xedd; -"Hangul_J_RieulPieub",0xede; -"Hangul_J_RieulSios",0xedf; -"Hangul_J_RieulTieut",0xee0; -"Hangul_J_RieulPhieuf",0xee1; -"Hangul_J_RieulHieuh",0xee2; -"Hangul_J_Mieum",0xee3; -"Hangul_J_Pieub",0xee4; -"Hangul_J_PieubSios",0xee5; -"Hangul_J_Sios",0xee6; -"Hangul_J_SsangSios",0xee7; -"Hangul_J_Ieung",0xee8; -"Hangul_J_Jieuj",0xee9; -"Hangul_J_Cieuc",0xeea; -"Hangul_J_Khieuq",0xeeb; -"Hangul_J_Tieut",0xeec; -"Hangul_J_Phieuf",0xeed; -"Hangul_J_Hieuh",0xeee; -"Hangul_RieulYeorinHieuh",0xeef; -"Hangul_SunkyeongeumMieum",0xef0; -"Hangul_SunkyeongeumPieub",0xef1; -"Hangul_PanSios",0xef2; -"Hangul_KkogjiDalrinIeung",0xef3; -"Hangul_SunkyeongeumPhieuf",0xef4; -"Hangul_YeorinHieuh",0xef5; -"Hangul_AraeA",0xef6; -"Hangul_AraeAE",0xef7; -"Hangul_J_PanSios",0xef8; -"Hangul_J_KkogjiDalrinIeung",0xef9; -"Hangul_J_YeorinHieuh",0xefa; -"Korean_Won",0xeff; -] -let keysym_to_name = [ -0xFFFFFF,"VoidSymbol"; -0xFF08,"BackSpace"; -0xFF09,"Tab"; -0xFF0A,"Linefeed"; -0xFF0B,"Clear"; -0xFF0D,"Return"; -0xFF13,"Pause"; -0xFF14,"Scroll_Lock"; -0xFF15,"Sys_Req"; -0xFF1B,"Escape"; -0xFFFF,"Delete"; -0xFF20,"Multi_key"; -0xFF21,"Kanji"; -0xFF22,"Muhenkan"; -0xFF23,"Henkan_Mode"; -0xFF23,"Henkan"; -0xFF24,"Romaji"; -0xFF25,"Hiragana"; -0xFF26,"Katakana"; -0xFF27,"Hiragana_Katakana"; -0xFF28,"Zenkaku"; -0xFF29,"Hankaku"; -0xFF2A,"Zenkaku_Hankaku"; -0xFF2B,"Touroku"; -0xFF2C,"Massyo"; -0xFF2D,"Kana_Lock"; -0xFF2E,"Kana_Shift"; -0xFF2F,"Eisu_Shift"; -0xFF30,"Eisu_toggle"; -0xFF50,"Home"; -0xFF51,"Left"; -0xFF52,"Up"; -0xFF53,"Right"; -0xFF54,"Down"; -0xFF55,"Prior"; -0xFF55,"Page_Up"; -0xFF56,"Next"; -0xFF56,"Page_Down"; -0xFF57,"End"; -0xFF58,"Begin"; -0xFF60,"Select"; -0xFF61,"Print"; -0xFF62,"Execute"; -0xFF63,"Insert"; -0xFF65,"Undo"; -0xFF66,"Redo"; -0xFF67,"Menu"; -0xFF68,"Find"; -0xFF69,"Cancel"; -0xFF6A,"Help"; -0xFF6B,"Break"; -0xFF7E,"Mode_switch"; -0xFF7E,"script_switch"; -0xFF7F,"Num_Lock"; -0xFF80,"KP_Space"; -0xFF89,"KP_Tab"; -0xFF8D,"KP_Enter"; -0xFF91,"KP_F1"; -0xFF92,"KP_F2"; -0xFF93,"KP_F3"; -0xFF94,"KP_F4"; -0xFF95,"KP_Home"; -0xFF96,"KP_Left"; -0xFF97,"KP_Up"; -0xFF98,"KP_Right"; -0xFF99,"KP_Down"; -0xFF9A,"KP_Prior"; -0xFF9A,"KP_Page_Up"; -0xFF9B,"KP_Next"; -0xFF9B,"KP_Page_Down"; -0xFF9C,"KP_End"; -0xFF9D,"KP_Begin"; -0xFF9E,"KP_Insert"; -0xFF9F,"KP_Delete"; -0xFFBD,"KP_Equal"; -0xFFAA,"KP_Multiply"; -0xFFAB,"KP_Add"; -0xFFAC,"KP_Separator"; -0xFFAD,"KP_Subtract"; -0xFFAE,"KP_Decimal"; -0xFFAF,"KP_Divide"; -0xFFB0,"KP_0"; -0xFFB1,"KP_1"; -0xFFB2,"KP_2"; -0xFFB3,"KP_3"; -0xFFB4,"KP_4"; -0xFFB5,"KP_5"; -0xFFB6,"KP_6"; -0xFFB7,"KP_7"; -0xFFB8,"KP_8"; -0xFFB9,"KP_9"; -0xFFBE,"F1"; -0xFFBF,"F2"; -0xFFC0,"F3"; -0xFFC1,"F4"; -0xFFC2,"F5"; -0xFFC3,"F6"; -0xFFC4,"F7"; -0xFFC5,"F8"; -0xFFC6,"F9"; -0xFFC7,"F10"; -0xFFC8,"F11"; -0xFFC8,"L1"; -0xFFC9,"F12"; -0xFFC9,"L2"; -0xFFCA,"F13"; -0xFFCA,"L3"; -0xFFCB,"F14"; -0xFFCB,"L4"; -0xFFCC,"F15"; -0xFFCC,"L5"; -0xFFCD,"F16"; -0xFFCD,"L6"; -0xFFCE,"F17"; -0xFFCE,"L7"; -0xFFCF,"F18"; -0xFFCF,"L8"; -0xFFD0,"F19"; -0xFFD0,"L9"; -0xFFD1,"F20"; -0xFFD1,"L10"; -0xFFD2,"F21"; -0xFFD2,"R1"; -0xFFD3,"F22"; -0xFFD3,"R2"; -0xFFD4,"F23"; -0xFFD4,"R3"; -0xFFD5,"F24"; -0xFFD5,"R4"; -0xFFD6,"F25"; -0xFFD6,"R5"; -0xFFD7,"F26"; -0xFFD7,"R6"; -0xFFD8,"F27"; -0xFFD8,"R7"; -0xFFD9,"F28"; -0xFFD9,"R8"; -0xFFDA,"F29"; -0xFFDA,"R9"; -0xFFDB,"F30"; -0xFFDB,"R10"; -0xFFDC,"F31"; -0xFFDC,"R11"; -0xFFDD,"F32"; -0xFFDD,"R12"; -0xFFDE,"F33"; -0xFFDE,"R13"; -0xFFDF,"F34"; -0xFFDF,"R14"; -0xFFE0,"F35"; -0xFFE0,"R15"; -0xFFE1,"Shift_L"; -0xFFE2,"Shift_R"; -0xFFE3,"Control_L"; -0xFFE4,"Control_R"; -0xFFE5,"Caps_Lock"; -0xFFE6,"Shift_Lock"; -0xFFE7,"Meta_L"; -0xFFE8,"Meta_R"; -0xFFE9,"Alt_L"; -0xFFEA,"Alt_R"; -0xFFEB,"Super_L"; -0xFFEC,"Super_R"; -0xFFED,"Hyper_L"; -0xFFEE,"Hyper_R"; -0xFE01,"ISO_Lock"; -0xFE02,"ISO_Level2_Latch"; -0xFE03,"ISO_Level3_Shift"; -0xFE04,"ISO_Level3_Latch"; -0xFE05,"ISO_Level3_Lock"; -0xFF7E,"ISO_Group_Shift"; -0xFE06,"ISO_Group_Latch"; -0xFE07,"ISO_Group_Lock"; -0xFE08,"ISO_Next_Group"; -0xFE09,"ISO_Next_Group_Lock"; -0xFE0A,"ISO_Prev_Group"; -0xFE0B,"ISO_Prev_Group_Lock"; -0xFE0C,"ISO_First_Group"; -0xFE0D,"ISO_First_Group_Lock"; -0xFE0E,"ISO_Last_Group"; -0xFE0F,"ISO_Last_Group_Lock"; -0xFE20,"ISO_Left_Tab"; -0xFE21,"ISO_Move_Line_Up"; -0xFE22,"ISO_Move_Line_Down"; -0xFE23,"ISO_Partial_Line_Up"; -0xFE24,"ISO_Partial_Line_Down"; -0xFE25,"ISO_Partial_Space_Left"; -0xFE26,"ISO_Partial_Space_Right"; -0xFE27,"ISO_Set_Margin_Left"; -0xFE28,"ISO_Set_Margin_Right"; -0xFE29,"ISO_Release_Margin_Left"; -0xFE2A,"ISO_Release_Margin_Right"; -0xFE2B,"ISO_Release_Both_Margins"; -0xFE2C,"ISO_Fast_Cursor_Left"; -0xFE2D,"ISO_Fast_Cursor_Right"; -0xFE2E,"ISO_Fast_Cursor_Up"; -0xFE2F,"ISO_Fast_Cursor_Down"; -0xFE30,"ISO_Continuous_Underline"; -0xFE31,"ISO_Discontinuous_Underline"; -0xFE32,"ISO_Emphasize"; -0xFE33,"ISO_Center_Object"; -0xFE34,"ISO_Enter"; -0xFE50,"dead_grave"; -0xFE51,"dead_acute"; -0xFE52,"dead_circumflex"; -0xFE53,"dead_tilde"; -0xFE54,"dead_macron"; -0xFE55,"dead_breve"; -0xFE56,"dead_abovedot"; -0xFE57,"dead_diaeresis"; -0xFE58,"dead_abovering"; -0xFE59,"dead_doubleacute"; -0xFE5A,"dead_caron"; -0xFE5B,"dead_cedilla"; -0xFE5C,"dead_ogonek"; -0xFE5D,"dead_iota"; -0xFE5E,"dead_voiced_sound"; -0xFE5F,"dead_semivoiced_sound"; -0xFE60,"dead_belowdot"; -0xFED0,"First_Virtual_Screen"; -0xFED1,"Prev_Virtual_Screen"; -0xFED2,"Next_Virtual_Screen"; -0xFED4,"Last_Virtual_Screen"; -0xFED5,"Terminate_Server"; -0xFE70,"AccessX_Enable"; -0xFE71,"AccessX_Feedback_Enable"; -0xFE72,"RepeatKeys_Enable"; -0xFE73,"SlowKeys_Enable"; -0xFE74,"BounceKeys_Enable"; -0xFE75,"StickyKeys_Enable"; -0xFE76,"MouseKeys_Enable"; -0xFE77,"MouseKeys_Accel_Enable"; -0xFE78,"Overlay1_Enable"; -0xFE79,"Overlay2_Enable"; -0xFE7A,"AudibleBell_Enable"; -0xFEE0,"Pointer_Left"; -0xFEE1,"Pointer_Right"; -0xFEE2,"Pointer_Up"; -0xFEE3,"Pointer_Down"; -0xFEE4,"Pointer_UpLeft"; -0xFEE5,"Pointer_UpRight"; -0xFEE6,"Pointer_DownLeft"; -0xFEE7,"Pointer_DownRight"; -0xFEE8,"Pointer_Button_Dflt"; -0xFEE9,"Pointer_Button1"; -0xFEEA,"Pointer_Button2"; -0xFEEB,"Pointer_Button3"; -0xFEEC,"Pointer_Button4"; -0xFEED,"Pointer_Button5"; -0xFEEE,"Pointer_DblClick_Dflt"; -0xFEEF,"Pointer_DblClick1"; -0xFEF0,"Pointer_DblClick2"; -0xFEF1,"Pointer_DblClick3"; -0xFEF2,"Pointer_DblClick4"; -0xFEF3,"Pointer_DblClick5"; -0xFEF4,"Pointer_Drag_Dflt"; -0xFEF5,"Pointer_Drag1"; -0xFEF6,"Pointer_Drag2"; -0xFEF7,"Pointer_Drag3"; -0xFEF8,"Pointer_Drag4"; -0xFEFD,"Pointer_Drag5"; -0xFEF9,"Pointer_EnableKeys"; -0xFEFA,"Pointer_Accelerate"; -0xFEFB,"Pointer_DfltBtnNext"; -0xFEFC,"Pointer_DfltBtnPrev"; -0xFD01,"3270_Duplicate"; -0xFD02,"3270_FieldMark"; -0xFD03,"3270_Right2"; -0xFD04,"3270_Left2"; -0xFD05,"3270_BackTab"; -0xFD06,"3270_EraseEOF"; -0xFD07,"3270_EraseInput"; -0xFD08,"3270_Reset"; -0xFD09,"3270_Quit"; -0xFD0A,"3270_PA1"; -0xFD0B,"3270_PA2"; -0xFD0C,"3270_PA3"; -0xFD0D,"3270_Test"; -0xFD0E,"3270_Attn"; -0xFD0F,"3270_CursorBlink"; -0xFD10,"3270_AltCursor"; -0xFD11,"3270_KeyClick"; -0xFD12,"3270_Jump"; -0xFD13,"3270_Ident"; -0xFD14,"3270_Rule"; -0xFD15,"3270_Copy"; -0xFD16,"3270_Play"; -0xFD17,"3270_Setup"; -0xFD18,"3270_Record"; -0xFD19,"3270_ChangeScreen"; -0xFD1A,"3270_DeleteWord"; -0xFD1B,"3270_ExSelect"; -0xFD1C,"3270_CursorSelect"; -0xFD1D,"3270_PrintScreen"; -0xFD1E,"3270_Enter"; -0x020,"space"; -0x021,"exclam"; -0x022,"quotedbl"; -0x023,"numbersign"; -0x024,"dollar"; -0x025,"percent"; -0x026,"ampersand"; -0x027,"apostrophe"; -0x027,"quoteright"; -0x028,"parenleft"; -0x029,"parenright"; -0x02a,"asterisk"; -0x02b,"plus"; -0x02c,"comma"; -0x02d,"minus"; -0x02e,"period"; -0x02f,"slash"; -0x030,"0"; -0x031,"1"; -0x032,"2"; -0x033,"3"; -0x034,"4"; -0x035,"5"; -0x036,"6"; -0x037,"7"; -0x038,"8"; -0x039,"9"; -0x03a,"colon"; -0x03b,"semicolon"; -0x03c,"less"; -0x03d,"equal"; -0x03e,"greater"; -0x03f,"question"; -0x040,"at"; -0x041,"A"; -0x042,"B"; -0x043,"C"; -0x044,"D"; -0x045,"E"; -0x046,"F"; -0x047,"G"; -0x048,"H"; -0x049,"I"; -0x04a,"J"; -0x04b,"K"; -0x04c,"L"; -0x04d,"M"; -0x04e,"N"; -0x04f,"O"; -0x050,"P"; -0x051,"Q"; -0x052,"R"; -0x053,"S"; -0x054,"T"; -0x055,"U"; -0x056,"V"; -0x057,"W"; -0x058,"X"; -0x059,"Y"; -0x05a,"Z"; -0x05b,"bracketleft"; -0x05c,"backslash"; -0x05d,"bracketright"; -0x05e,"asciicircum"; -0x05f,"underscore"; -0x060,"grave"; -0x060,"quoteleft"; -0x061,"a"; -0x062,"b"; -0x063,"c"; -0x064,"d"; -0x065,"e"; -0x066,"f"; -0x067,"g"; -0x068,"h"; -0x069,"i"; -0x06a,"j"; -0x06b,"k"; -0x06c,"l"; -0x06d,"m"; -0x06e,"n"; -0x06f,"o"; -0x070,"p"; -0x071,"q"; -0x072,"r"; -0x073,"s"; -0x074,"t"; -0x075,"u"; -0x076,"v"; -0x077,"w"; -0x078,"x"; -0x079,"y"; -0x07a,"z"; -0x07b,"braceleft"; -0x07c,"bar"; -0x07d,"braceright"; -0x07e,"asciitilde"; -0x0a0,"nobreakspace"; -0x0a1,"exclamdown"; -0x0a2,"cent"; -0x0a3,"sterling"; -0x0a4,"currency"; -0x0a5,"yen"; -0x0a6,"brokenbar"; -0x0a7,"section"; -0x0a8,"diaeresis"; -0x0a9,"copyright"; -0x0aa,"ordfeminine"; -0x0ab,"guillemotleft"; -0x0ac,"notsign"; -0x0ad,"hyphen"; -0x0ae,"registered"; -0x0af,"macron"; -0x0b0,"degree"; -0x0b1,"plusminus"; -0x0b2,"twosuperior"; -0x0b3,"threesuperior"; -0x0b4,"acute"; -0x0b5,"mu"; -0x0b6,"paragraph"; -0x0b7,"periodcentered"; -0x0b8,"cedilla"; -0x0b9,"onesuperior"; -0x0ba,"masculine"; -0x0bb,"guillemotright"; -0x0bc,"onequarter"; -0x0bd,"onehalf"; -0x0be,"threequarters"; -0x0bf,"questiondown"; -0x0c0,"Agrave"; -0x0c1,"Aacute"; -0x0c2,"Acircumflex"; -0x0c3,"Atilde"; -0x0c4,"Adiaeresis"; -0x0c5,"Aring"; -0x0c6,"AE"; -0x0c7,"Ccedilla"; -0x0c8,"Egrave"; -0x0c9,"Eacute"; -0x0ca,"Ecircumflex"; -0x0cb,"Ediaeresis"; -0x0cc,"Igrave"; -0x0cd,"Iacute"; -0x0ce,"Icircumflex"; -0x0cf,"Idiaeresis"; -0x0d0,"ETH"; -0x0d0,"Eth"; -0x0d1,"Ntilde"; -0x0d2,"Ograve"; -0x0d3,"Oacute"; -0x0d4,"Ocircumflex"; -0x0d5,"Otilde"; -0x0d6,"Odiaeresis"; -0x0d7,"multiply"; -0x0d8,"Ooblique"; -0x0d9,"Ugrave"; -0x0da,"Uacute"; -0x0db,"Ucircumflex"; -0x0dc,"Udiaeresis"; -0x0dd,"Yacute"; -0x0de,"THORN"; -0x0de,"Thorn"; -0x0df,"ssharp"; -0x0e0,"agrave"; -0x0e1,"aacute"; -0x0e2,"acircumflex"; -0x0e3,"atilde"; -0x0e4,"adiaeresis"; -0x0e5,"aring"; -0x0e6,"ae"; -0x0e7,"ccedilla"; -0x0e8,"egrave"; -0x0e9,"eacute"; -0x0ea,"ecircumflex"; -0x0eb,"ediaeresis"; -0x0ec,"igrave"; -0x0ed,"iacute"; -0x0ee,"icircumflex"; -0x0ef,"idiaeresis"; -0x0f0,"eth"; -0x0f1,"ntilde"; -0x0f2,"ograve"; -0x0f3,"oacute"; -0x0f4,"ocircumflex"; -0x0f5,"otilde"; -0x0f6,"odiaeresis"; -0x0f7,"division"; -0x0f8,"oslash"; -0x0f9,"ugrave"; -0x0fa,"uacute"; -0x0fb,"ucircumflex"; -0x0fc,"udiaeresis"; -0x0fd,"yacute"; -0x0fe,"thorn"; -0x0ff,"ydiaeresis"; -0x1a1,"Aogonek"; -0x1a2,"breve"; -0x1a3,"Lstroke"; -0x1a5,"Lcaron"; -0x1a6,"Sacute"; -0x1a9,"Scaron"; -0x1aa,"Scedilla"; -0x1ab,"Tcaron"; -0x1ac,"Zacute"; -0x1ae,"Zcaron"; -0x1af,"Zabovedot"; -0x1b1,"aogonek"; -0x1b2,"ogonek"; -0x1b3,"lstroke"; -0x1b5,"lcaron"; -0x1b6,"sacute"; -0x1b7,"caron"; -0x1b9,"scaron"; -0x1ba,"scedilla"; -0x1bb,"tcaron"; -0x1bc,"zacute"; -0x1bd,"doubleacute"; -0x1be,"zcaron"; -0x1bf,"zabovedot"; -0x1c0,"Racute"; -0x1c3,"Abreve"; -0x1c5,"Lacute"; -0x1c6,"Cacute"; -0x1c8,"Ccaron"; -0x1ca,"Eogonek"; -0x1cc,"Ecaron"; -0x1cf,"Dcaron"; -0x1d0,"Dstroke"; -0x1d1,"Nacute"; -0x1d2,"Ncaron"; -0x1d5,"Odoubleacute"; -0x1d8,"Rcaron"; -0x1d9,"Uring"; -0x1db,"Udoubleacute"; -0x1de,"Tcedilla"; -0x1e0,"racute"; -0x1e3,"abreve"; -0x1e5,"lacute"; -0x1e6,"cacute"; -0x1e8,"ccaron"; -0x1ea,"eogonek"; -0x1ec,"ecaron"; -0x1ef,"dcaron"; -0x1f0,"dstroke"; -0x1f1,"nacute"; -0x1f2,"ncaron"; -0x1f5,"odoubleacute"; -0x1fb,"udoubleacute"; -0x1f8,"rcaron"; -0x1f9,"uring"; -0x1fe,"tcedilla"; -0x1ff,"abovedot"; -0x2a1,"Hstroke"; -0x2a6,"Hcircumflex"; -0x2a9,"Iabovedot"; -0x2ab,"Gbreve"; -0x2ac,"Jcircumflex"; -0x2b1,"hstroke"; -0x2b6,"hcircumflex"; -0x2b9,"idotless"; -0x2bb,"gbreve"; -0x2bc,"jcircumflex"; -0x2c5,"Cabovedot"; -0x2c6,"Ccircumflex"; -0x2d5,"Gabovedot"; -0x2d8,"Gcircumflex"; -0x2dd,"Ubreve"; -0x2de,"Scircumflex"; -0x2e5,"cabovedot"; -0x2e6,"ccircumflex"; -0x2f5,"gabovedot"; -0x2f8,"gcircumflex"; -0x2fd,"ubreve"; -0x2fe,"scircumflex"; -0x3a2,"kra"; -0x3a2,"kappa"; -0x3a3,"Rcedilla"; -0x3a5,"Itilde"; -0x3a6,"Lcedilla"; -0x3aa,"Emacron"; -0x3ab,"Gcedilla"; -0x3ac,"Tslash"; -0x3b3,"rcedilla"; -0x3b5,"itilde"; -0x3b6,"lcedilla"; -0x3ba,"emacron"; -0x3bb,"gcedilla"; -0x3bc,"tslash"; -0x3bd,"ENG"; -0x3bf,"eng"; -0x3c0,"Amacron"; -0x3c7,"Iogonek"; -0x3cc,"Eabovedot"; -0x3cf,"Imacron"; -0x3d1,"Ncedilla"; -0x3d2,"Omacron"; -0x3d3,"Kcedilla"; -0x3d9,"Uogonek"; -0x3dd,"Utilde"; -0x3de,"Umacron"; -0x3e0,"amacron"; -0x3e7,"iogonek"; -0x3ec,"eabovedot"; -0x3ef,"imacron"; -0x3f1,"ncedilla"; -0x3f2,"omacron"; -0x3f3,"kcedilla"; -0x3f9,"uogonek"; -0x3fd,"utilde"; -0x3fe,"umacron"; -0x47e,"overline"; -0x4a1,"kana_fullstop"; -0x4a2,"kana_openingbracket"; -0x4a3,"kana_closingbracket"; -0x4a4,"kana_comma"; -0x4a5,"kana_conjunctive"; -0x4a5,"kana_middledot"; -0x4a6,"kana_WO"; -0x4a7,"kana_a"; -0x4a8,"kana_i"; -0x4a9,"kana_u"; -0x4aa,"kana_e"; -0x4ab,"kana_o"; -0x4ac,"kana_ya"; -0x4ad,"kana_yu"; -0x4ae,"kana_yo"; -0x4af,"kana_tsu"; -0x4af,"kana_tu"; -0x4b0,"prolongedsound"; -0x4b1,"kana_A"; -0x4b2,"kana_I"; -0x4b3,"kana_U"; -0x4b4,"kana_E"; -0x4b5,"kana_O"; -0x4b6,"kana_KA"; -0x4b7,"kana_KI"; -0x4b8,"kana_KU"; -0x4b9,"kana_KE"; -0x4ba,"kana_KO"; -0x4bb,"kana_SA"; -0x4bc,"kana_SHI"; -0x4bd,"kana_SU"; -0x4be,"kana_SE"; -0x4bf,"kana_SO"; -0x4c0,"kana_TA"; -0x4c1,"kana_CHI"; -0x4c1,"kana_TI"; -0x4c2,"kana_TSU"; -0x4c2,"kana_TU"; -0x4c3,"kana_TE"; -0x4c4,"kana_TO"; -0x4c5,"kana_NA"; -0x4c6,"kana_NI"; -0x4c7,"kana_NU"; -0x4c8,"kana_NE"; -0x4c9,"kana_NO"; -0x4ca,"kana_HA"; -0x4cb,"kana_HI"; -0x4cc,"kana_FU"; -0x4cc,"kana_HU"; -0x4cd,"kana_HE"; -0x4ce,"kana_HO"; -0x4cf,"kana_MA"; -0x4d0,"kana_MI"; -0x4d1,"kana_MU"; -0x4d2,"kana_ME"; -0x4d3,"kana_MO"; -0x4d4,"kana_YA"; -0x4d5,"kana_YU"; -0x4d6,"kana_YO"; -0x4d7,"kana_RA"; -0x4d8,"kana_RI"; -0x4d9,"kana_RU"; -0x4da,"kana_RE"; -0x4db,"kana_RO"; -0x4dc,"kana_WA"; -0x4dd,"kana_N"; -0x4de,"voicedsound"; -0x4df,"semivoicedsound"; -0xFF7E,"kana_switch"; -0x5ac,"Arabic_comma"; -0x5bb,"Arabic_semicolon"; -0x5bf,"Arabic_question_mark"; -0x5c1,"Arabic_hamza"; -0x5c2,"Arabic_maddaonalef"; -0x5c3,"Arabic_hamzaonalef"; -0x5c4,"Arabic_hamzaonwaw"; -0x5c5,"Arabic_hamzaunderalef"; -0x5c6,"Arabic_hamzaonyeh"; -0x5c7,"Arabic_alef"; -0x5c8,"Arabic_beh"; -0x5c9,"Arabic_tehmarbuta"; -0x5ca,"Arabic_teh"; -0x5cb,"Arabic_theh"; -0x5cc,"Arabic_jeem"; -0x5cd,"Arabic_hah"; -0x5ce,"Arabic_khah"; -0x5cf,"Arabic_dal"; -0x5d0,"Arabic_thal"; -0x5d1,"Arabic_ra"; -0x5d2,"Arabic_zain"; -0x5d3,"Arabic_seen"; -0x5d4,"Arabic_sheen"; -0x5d5,"Arabic_sad"; -0x5d6,"Arabic_dad"; -0x5d7,"Arabic_tah"; -0x5d8,"Arabic_zah"; -0x5d9,"Arabic_ain"; -0x5da,"Arabic_ghain"; -0x5e0,"Arabic_tatweel"; -0x5e1,"Arabic_feh"; -0x5e2,"Arabic_qaf"; -0x5e3,"Arabic_kaf"; -0x5e4,"Arabic_lam"; -0x5e5,"Arabic_meem"; -0x5e6,"Arabic_noon"; -0x5e7,"Arabic_ha"; -0x5e7,"Arabic_heh"; -0x5e8,"Arabic_waw"; -0x5e9,"Arabic_alefmaksura"; -0x5ea,"Arabic_yeh"; -0x5eb,"Arabic_fathatan"; -0x5ec,"Arabic_dammatan"; -0x5ed,"Arabic_kasratan"; -0x5ee,"Arabic_fatha"; -0x5ef,"Arabic_damma"; -0x5f0,"Arabic_kasra"; -0x5f1,"Arabic_shadda"; -0x5f2,"Arabic_sukun"; -0xFF7E,"Arabic_switch"; -0x6a1,"Serbian_dje"; -0x6a2,"Macedonia_gje"; -0x6a3,"Cyrillic_io"; -0x6a4,"Ukrainian_ie"; -0x6a4,"Ukranian_je"; -0x6a5,"Macedonia_dse"; -0x6a6,"Ukrainian_i"; -0x6a6,"Ukranian_i"; -0x6a7,"Ukrainian_yi"; -0x6a7,"Ukranian_yi"; -0x6a8,"Cyrillic_je"; -0x6a8,"Serbian_je"; -0x6a9,"Cyrillic_lje"; -0x6a9,"Serbian_lje"; -0x6aa,"Cyrillic_nje"; -0x6aa,"Serbian_nje"; -0x6ab,"Serbian_tshe"; -0x6ac,"Macedonia_kje"; -0x6ae,"Byelorussian_shortu"; -0x6af,"Cyrillic_dzhe"; -0x6af,"Serbian_dze"; -0x6b0,"numerosign"; -0x6b1,"Serbian_DJE"; -0x6b2,"Macedonia_GJE"; -0x6b3,"Cyrillic_IO"; -0x6b4,"Ukrainian_IE"; -0x6b4,"Ukranian_JE"; -0x6b5,"Macedonia_DSE"; -0x6b6,"Ukrainian_I"; -0x6b6,"Ukranian_I"; -0x6b7,"Ukrainian_YI"; -0x6b7,"Ukranian_YI"; -0x6b8,"Cyrillic_JE"; -0x6b8,"Serbian_JE"; -0x6b9,"Cyrillic_LJE"; -0x6b9,"Serbian_LJE"; -0x6ba,"Cyrillic_NJE"; -0x6ba,"Serbian_NJE"; -0x6bb,"Serbian_TSHE"; -0x6bc,"Macedonia_KJE"; -0x6be,"Byelorussian_SHORTU"; -0x6bf,"Cyrillic_DZHE"; -0x6bf,"Serbian_DZE"; -0x6c0,"Cyrillic_yu"; -0x6c1,"Cyrillic_a"; -0x6c2,"Cyrillic_be"; -0x6c3,"Cyrillic_tse"; -0x6c4,"Cyrillic_de"; -0x6c5,"Cyrillic_ie"; -0x6c6,"Cyrillic_ef"; -0x6c7,"Cyrillic_ghe"; -0x6c8,"Cyrillic_ha"; -0x6c9,"Cyrillic_i"; -0x6ca,"Cyrillic_shorti"; -0x6cb,"Cyrillic_ka"; -0x6cc,"Cyrillic_el"; -0x6cd,"Cyrillic_em"; -0x6ce,"Cyrillic_en"; -0x6cf,"Cyrillic_o"; -0x6d0,"Cyrillic_pe"; -0x6d1,"Cyrillic_ya"; -0x6d2,"Cyrillic_er"; -0x6d3,"Cyrillic_es"; -0x6d4,"Cyrillic_te"; -0x6d5,"Cyrillic_u"; -0x6d6,"Cyrillic_zhe"; -0x6d7,"Cyrillic_ve"; -0x6d8,"Cyrillic_softsign"; -0x6d9,"Cyrillic_yeru"; -0x6da,"Cyrillic_ze"; -0x6db,"Cyrillic_sha"; -0x6dc,"Cyrillic_e"; -0x6dd,"Cyrillic_shcha"; -0x6de,"Cyrillic_che"; -0x6df,"Cyrillic_hardsign"; -0x6e0,"Cyrillic_YU"; -0x6e1,"Cyrillic_A"; -0x6e2,"Cyrillic_BE"; -0x6e3,"Cyrillic_TSE"; -0x6e4,"Cyrillic_DE"; -0x6e5,"Cyrillic_IE"; -0x6e6,"Cyrillic_EF"; -0x6e7,"Cyrillic_GHE"; -0x6e8,"Cyrillic_HA"; -0x6e9,"Cyrillic_I"; -0x6ea,"Cyrillic_SHORTI"; -0x6eb,"Cyrillic_KA"; -0x6ec,"Cyrillic_EL"; -0x6ed,"Cyrillic_EM"; -0x6ee,"Cyrillic_EN"; -0x6ef,"Cyrillic_O"; -0x6f0,"Cyrillic_PE"; -0x6f1,"Cyrillic_YA"; -0x6f2,"Cyrillic_ER"; -0x6f3,"Cyrillic_ES"; -0x6f4,"Cyrillic_TE"; -0x6f5,"Cyrillic_U"; -0x6f6,"Cyrillic_ZHE"; -0x6f7,"Cyrillic_VE"; -0x6f8,"Cyrillic_SOFTSIGN"; -0x6f9,"Cyrillic_YERU"; -0x6fa,"Cyrillic_ZE"; -0x6fb,"Cyrillic_SHA"; -0x6fc,"Cyrillic_E"; -0x6fd,"Cyrillic_SHCHA"; -0x6fe,"Cyrillic_CHE"; -0x6ff,"Cyrillic_HARDSIGN"; -0x7a1,"Greek_ALPHAaccent"; -0x7a2,"Greek_EPSILONaccent"; -0x7a3,"Greek_ETAaccent"; -0x7a4,"Greek_IOTAaccent"; -0x7a5,"Greek_IOTAdiaeresis"; -0x7a7,"Greek_OMICRONaccent"; -0x7a8,"Greek_UPSILONaccent"; -0x7a9,"Greek_UPSILONdieresis"; -0x7ab,"Greek_OMEGAaccent"; -0x7ae,"Greek_accentdieresis"; -0x7af,"Greek_horizbar"; -0x7b1,"Greek_alphaaccent"; -0x7b2,"Greek_epsilonaccent"; -0x7b3,"Greek_etaaccent"; -0x7b4,"Greek_iotaaccent"; -0x7b5,"Greek_iotadieresis"; -0x7b6,"Greek_iotaaccentdieresis"; -0x7b7,"Greek_omicronaccent"; -0x7b8,"Greek_upsilonaccent"; -0x7b9,"Greek_upsilondieresis"; -0x7ba,"Greek_upsilonaccentdieresis"; -0x7bb,"Greek_omegaaccent"; -0x7c1,"Greek_ALPHA"; -0x7c2,"Greek_BETA"; -0x7c3,"Greek_GAMMA"; -0x7c4,"Greek_DELTA"; -0x7c5,"Greek_EPSILON"; -0x7c6,"Greek_ZETA"; -0x7c7,"Greek_ETA"; -0x7c8,"Greek_THETA"; -0x7c9,"Greek_IOTA"; -0x7ca,"Greek_KAPPA"; -0x7cb,"Greek_LAMDA"; -0x7cb,"Greek_LAMBDA"; -0x7cc,"Greek_MU"; -0x7cd,"Greek_NU"; -0x7ce,"Greek_XI"; -0x7cf,"Greek_OMICRON"; -0x7d0,"Greek_PI"; -0x7d1,"Greek_RHO"; -0x7d2,"Greek_SIGMA"; -0x7d4,"Greek_TAU"; -0x7d5,"Greek_UPSILON"; -0x7d6,"Greek_PHI"; -0x7d7,"Greek_CHI"; -0x7d8,"Greek_PSI"; -0x7d9,"Greek_OMEGA"; -0x7e1,"Greek_alpha"; -0x7e2,"Greek_beta"; -0x7e3,"Greek_gamma"; -0x7e4,"Greek_delta"; -0x7e5,"Greek_epsilon"; -0x7e6,"Greek_zeta"; -0x7e7,"Greek_eta"; -0x7e8,"Greek_theta"; -0x7e9,"Greek_iota"; -0x7ea,"Greek_kappa"; -0x7eb,"Greek_lamda"; -0x7eb,"Greek_lambda"; -0x7ec,"Greek_mu"; -0x7ed,"Greek_nu"; -0x7ee,"Greek_xi"; -0x7ef,"Greek_omicron"; -0x7f0,"Greek_pi"; -0x7f1,"Greek_rho"; -0x7f2,"Greek_sigma"; -0x7f3,"Greek_finalsmallsigma"; -0x7f4,"Greek_tau"; -0x7f5,"Greek_upsilon"; -0x7f6,"Greek_phi"; -0x7f7,"Greek_chi"; -0x7f8,"Greek_psi"; -0x7f9,"Greek_omega"; -0xFF7E,"Greek_switch"; -0x8a1,"leftradical"; -0x8a2,"topleftradical"; -0x8a3,"horizconnector"; -0x8a4,"topintegral"; -0x8a5,"botintegral"; -0x8a6,"vertconnector"; -0x8a7,"topleftsqbracket"; -0x8a8,"botleftsqbracket"; -0x8a9,"toprightsqbracket"; -0x8aa,"botrightsqbracket"; -0x8ab,"topleftparens"; -0x8ac,"botleftparens"; -0x8ad,"toprightparens"; -0x8ae,"botrightparens"; -0x8af,"leftmiddlecurlybrace"; -0x8b0,"rightmiddlecurlybrace"; -0x8b1,"topleftsummation"; -0x8b2,"botleftsummation"; -0x8b3,"topvertsummationconnector"; -0x8b4,"botvertsummationconnector"; -0x8b5,"toprightsummation"; -0x8b6,"botrightsummation"; -0x8b7,"rightmiddlesummation"; -0x8bc,"lessthanequal"; -0x8bd,"notequal"; -0x8be,"greaterthanequal"; -0x8bf,"integral"; -0x8c0,"therefore"; -0x8c1,"variation"; -0x8c2,"infinity"; -0x8c5,"nabla"; -0x8c8,"approximate"; -0x8c9,"similarequal"; -0x8cd,"ifonlyif"; -0x8ce,"implies"; -0x8cf,"identical"; -0x8d6,"radical"; -0x8da,"includedin"; -0x8db,"includes"; -0x8dc,"intersection"; -0x8dd,"union"; -0x8de,"logicaland"; -0x8df,"logicalor"; -0x8ef,"partialderivative"; -0x8f6,"function"; -0x8fb,"leftarrow"; -0x8fc,"uparrow"; -0x8fd,"rightarrow"; -0x8fe,"downarrow"; -0x9df,"blank"; -0x9e0,"soliddiamond"; -0x9e1,"checkerboard"; -0x9e2,"ht"; -0x9e3,"ff"; -0x9e4,"cr"; -0x9e5,"lf"; -0x9e8,"nl"; -0x9e9,"vt"; -0x9ea,"lowrightcorner"; -0x9eb,"uprightcorner"; -0x9ec,"upleftcorner"; -0x9ed,"lowleftcorner"; -0x9ee,"crossinglines"; -0x9ef,"horizlinescan1"; -0x9f0,"horizlinescan3"; -0x9f1,"horizlinescan5"; -0x9f2,"horizlinescan7"; -0x9f3,"horizlinescan9"; -0x9f4,"leftt"; -0x9f5,"rightt"; -0x9f6,"bott"; -0x9f7,"topt"; -0x9f8,"vertbar"; -0xaa1,"emspace"; -0xaa2,"enspace"; -0xaa3,"em3space"; -0xaa4,"em4space"; -0xaa5,"digitspace"; -0xaa6,"punctspace"; -0xaa7,"thinspace"; -0xaa8,"hairspace"; -0xaa9,"emdash"; -0xaaa,"endash"; -0xaac,"signifblank"; -0xaae,"ellipsis"; -0xaaf,"doubbaselinedot"; -0xab0,"onethird"; -0xab1,"twothirds"; -0xab2,"onefifth"; -0xab3,"twofifths"; -0xab4,"threefifths"; -0xab5,"fourfifths"; -0xab6,"onesixth"; -0xab7,"fivesixths"; -0xab8,"careof"; -0xabb,"figdash"; -0xabc,"leftanglebracket"; -0xabd,"decimalpoint"; -0xabe,"rightanglebracket"; -0xabf,"marker"; -0xac3,"oneeighth"; -0xac4,"threeeighths"; -0xac5,"fiveeighths"; -0xac6,"seveneighths"; -0xac9,"trademark"; -0xaca,"signaturemark"; -0xacb,"trademarkincircle"; -0xacc,"leftopentriangle"; -0xacd,"rightopentriangle"; -0xace,"emopencircle"; -0xacf,"emopenrectangle"; -0xad0,"leftsinglequotemark"; -0xad1,"rightsinglequotemark"; -0xad2,"leftdoublequotemark"; -0xad3,"rightdoublequotemark"; -0xad4,"prescription"; -0xad6,"minutes"; -0xad7,"seconds"; -0xad9,"latincross"; -0xada,"hexagram"; -0xadb,"filledrectbullet"; -0xadc,"filledlefttribullet"; -0xadd,"filledrighttribullet"; -0xade,"emfilledcircle"; -0xadf,"emfilledrect"; -0xae0,"enopencircbullet"; -0xae1,"enopensquarebullet"; -0xae2,"openrectbullet"; -0xae3,"opentribulletup"; -0xae4,"opentribulletdown"; -0xae5,"openstar"; -0xae6,"enfilledcircbullet"; -0xae7,"enfilledsqbullet"; -0xae8,"filledtribulletup"; -0xae9,"filledtribulletdown"; -0xaea,"leftpointer"; -0xaeb,"rightpointer"; -0xaec,"club"; -0xaed,"diamond"; -0xaee,"heart"; -0xaf0,"maltesecross"; -0xaf1,"dagger"; -0xaf2,"doubledagger"; -0xaf3,"checkmark"; -0xaf4,"ballotcross"; -0xaf5,"musicalsharp"; -0xaf6,"musicalflat"; -0xaf7,"malesymbol"; -0xaf8,"femalesymbol"; -0xaf9,"telephone"; -0xafa,"telephonerecorder"; -0xafb,"phonographcopyright"; -0xafc,"caret"; -0xafd,"singlelowquotemark"; -0xafe,"doublelowquotemark"; -0xaff,"cursor"; -0xba3,"leftcaret"; -0xba6,"rightcaret"; -0xba8,"downcaret"; -0xba9,"upcaret"; -0xbc0,"overbar"; -0xbc2,"downtack"; -0xbc3,"upshoe"; -0xbc4,"downstile"; -0xbc6,"underbar"; -0xbca,"jot"; -0xbcc,"quad"; -0xbce,"uptack"; -0xbcf,"circle"; -0xbd3,"upstile"; -0xbd6,"downshoe"; -0xbd8,"rightshoe"; -0xbda,"leftshoe"; -0xbdc,"lefttack"; -0xbfc,"righttack"; -0xcdf,"hebrew_doublelowline"; -0xce0,"hebrew_aleph"; -0xce1,"hebrew_bet"; -0xce1,"hebrew_beth"; -0xce2,"hebrew_gimel"; -0xce2,"hebrew_gimmel"; -0xce3,"hebrew_dalet"; -0xce3,"hebrew_daleth"; -0xce4,"hebrew_he"; -0xce5,"hebrew_waw"; -0xce6,"hebrew_zain"; -0xce6,"hebrew_zayin"; -0xce7,"hebrew_chet"; -0xce7,"hebrew_het"; -0xce8,"hebrew_tet"; -0xce8,"hebrew_teth"; -0xce9,"hebrew_yod"; -0xcea,"hebrew_finalkaph"; -0xceb,"hebrew_kaph"; -0xcec,"hebrew_lamed"; -0xced,"hebrew_finalmem"; -0xcee,"hebrew_mem"; -0xcef,"hebrew_finalnun"; -0xcf0,"hebrew_nun"; -0xcf1,"hebrew_samech"; -0xcf1,"hebrew_samekh"; -0xcf2,"hebrew_ayin"; -0xcf3,"hebrew_finalpe"; -0xcf4,"hebrew_pe"; -0xcf5,"hebrew_finalzade"; -0xcf5,"hebrew_finalzadi"; -0xcf6,"hebrew_zade"; -0xcf6,"hebrew_zadi"; -0xcf7,"hebrew_qoph"; -0xcf7,"hebrew_kuf"; -0xcf8,"hebrew_resh"; -0xcf9,"hebrew_shin"; -0xcfa,"hebrew_taw"; -0xcfa,"hebrew_taf"; -0xFF7E,"Hebrew_switch"; -0xda1,"Thai_kokai"; -0xda2,"Thai_khokhai"; -0xda3,"Thai_khokhuat"; -0xda4,"Thai_khokhwai"; -0xda5,"Thai_khokhon"; -0xda6,"Thai_khorakhang"; -0xda7,"Thai_ngongu"; -0xda8,"Thai_chochan"; -0xda9,"Thai_choching"; -0xdaa,"Thai_chochang"; -0xdab,"Thai_soso"; -0xdac,"Thai_chochoe"; -0xdad,"Thai_yoying"; -0xdae,"Thai_dochada"; -0xdaf,"Thai_topatak"; -0xdb0,"Thai_thothan"; -0xdb1,"Thai_thonangmontho"; -0xdb2,"Thai_thophuthao"; -0xdb3,"Thai_nonen"; -0xdb4,"Thai_dodek"; -0xdb5,"Thai_totao"; -0xdb6,"Thai_thothung"; -0xdb7,"Thai_thothahan"; -0xdb8,"Thai_thothong"; -0xdb9,"Thai_nonu"; -0xdba,"Thai_bobaimai"; -0xdbb,"Thai_popla"; -0xdbc,"Thai_phophung"; -0xdbd,"Thai_fofa"; -0xdbe,"Thai_phophan"; -0xdbf,"Thai_fofan"; -0xdc0,"Thai_phosamphao"; -0xdc1,"Thai_moma"; -0xdc2,"Thai_yoyak"; -0xdc3,"Thai_rorua"; -0xdc4,"Thai_ru"; -0xdc5,"Thai_loling"; -0xdc6,"Thai_lu"; -0xdc7,"Thai_wowaen"; -0xdc8,"Thai_sosala"; -0xdc9,"Thai_sorusi"; -0xdca,"Thai_sosua"; -0xdcb,"Thai_hohip"; -0xdcc,"Thai_lochula"; -0xdcd,"Thai_oang"; -0xdce,"Thai_honokhuk"; -0xdcf,"Thai_paiyannoi"; -0xdd0,"Thai_saraa"; -0xdd1,"Thai_maihanakat"; -0xdd2,"Thai_saraaa"; -0xdd3,"Thai_saraam"; -0xdd4,"Thai_sarai"; -0xdd5,"Thai_saraii"; -0xdd6,"Thai_saraue"; -0xdd7,"Thai_sarauee"; -0xdd8,"Thai_sarau"; -0xdd9,"Thai_sarauu"; -0xdda,"Thai_phinthu"; -0xdde,"Thai_maihanakat_maitho"; -0xddf,"Thai_baht"; -0xde0,"Thai_sarae"; -0xde1,"Thai_saraae"; -0xde2,"Thai_sarao"; -0xde3,"Thai_saraaimaimuan"; -0xde4,"Thai_saraaimaimalai"; -0xde5,"Thai_lakkhangyao"; -0xde6,"Thai_maiyamok"; -0xde7,"Thai_maitaikhu"; -0xde8,"Thai_maiek"; -0xde9,"Thai_maitho"; -0xdea,"Thai_maitri"; -0xdeb,"Thai_maichattawa"; -0xdec,"Thai_thanthakhat"; -0xded,"Thai_nikhahit"; -0xdf0,"Thai_leksun"; -0xdf1,"Thai_leknung"; -0xdf2,"Thai_leksong"; -0xdf3,"Thai_leksam"; -0xdf4,"Thai_leksi"; -0xdf5,"Thai_lekha"; -0xdf6,"Thai_lekhok"; -0xdf7,"Thai_lekchet"; -0xdf8,"Thai_lekpaet"; -0xdf9,"Thai_lekkao"; -0xff31,"Hangul"; -0xff32,"Hangul_Start"; -0xff33,"Hangul_End"; -0xff34,"Hangul_Hanja"; -0xff35,"Hangul_Jamo"; -0xff36,"Hangul_Romaja"; -0xff37,"Hangul_Codeinput"; -0xff38,"Hangul_Jeonja"; -0xff39,"Hangul_Banja"; -0xff3a,"Hangul_PreHanja"; -0xff3b,"Hangul_PostHanja"; -0xff3c,"Hangul_SingleCandidate"; -0xff3d,"Hangul_MultipleCandidate"; -0xff3e,"Hangul_PreviousCandidate"; -0xff3f,"Hangul_Special"; -0xFF7E,"Hangul_switch"; -0xea1,"Hangul_Kiyeog"; -0xea2,"Hangul_SsangKiyeog"; -0xea3,"Hangul_KiyeogSios"; -0xea4,"Hangul_Nieun"; -0xea5,"Hangul_NieunJieuj"; -0xea6,"Hangul_NieunHieuh"; -0xea7,"Hangul_Dikeud"; -0xea8,"Hangul_SsangDikeud"; -0xea9,"Hangul_Rieul"; -0xeaa,"Hangul_RieulKiyeog"; -0xeab,"Hangul_RieulMieum"; -0xeac,"Hangul_RieulPieub"; -0xead,"Hangul_RieulSios"; -0xeae,"Hangul_RieulTieut"; -0xeaf,"Hangul_RieulPhieuf"; -0xeb0,"Hangul_RieulHieuh"; -0xeb1,"Hangul_Mieum"; -0xeb2,"Hangul_Pieub"; -0xeb3,"Hangul_SsangPieub"; -0xeb4,"Hangul_PieubSios"; -0xeb5,"Hangul_Sios"; -0xeb6,"Hangul_SsangSios"; -0xeb7,"Hangul_Ieung"; -0xeb8,"Hangul_Jieuj"; -0xeb9,"Hangul_SsangJieuj"; -0xeba,"Hangul_Cieuc"; -0xebb,"Hangul_Khieuq"; -0xebc,"Hangul_Tieut"; -0xebd,"Hangul_Phieuf"; -0xebe,"Hangul_Hieuh"; -0xebf,"Hangul_A"; -0xec0,"Hangul_AE"; -0xec1,"Hangul_YA"; -0xec2,"Hangul_YAE"; -0xec3,"Hangul_EO"; -0xec4,"Hangul_E"; -0xec5,"Hangul_YEO"; -0xec6,"Hangul_YE"; -0xec7,"Hangul_O"; -0xec8,"Hangul_WA"; -0xec9,"Hangul_WAE"; -0xeca,"Hangul_OE"; -0xecb,"Hangul_YO"; -0xecc,"Hangul_U"; -0xecd,"Hangul_WEO"; -0xece,"Hangul_WE"; -0xecf,"Hangul_WI"; -0xed0,"Hangul_YU"; -0xed1,"Hangul_EU"; -0xed2,"Hangul_YI"; -0xed3,"Hangul_I"; -0xed4,"Hangul_J_Kiyeog"; -0xed5,"Hangul_J_SsangKiyeog"; -0xed6,"Hangul_J_KiyeogSios"; -0xed7,"Hangul_J_Nieun"; -0xed8,"Hangul_J_NieunJieuj"; -0xed9,"Hangul_J_NieunHieuh"; -0xeda,"Hangul_J_Dikeud"; -0xedb,"Hangul_J_Rieul"; -0xedc,"Hangul_J_RieulKiyeog"; -0xedd,"Hangul_J_RieulMieum"; -0xede,"Hangul_J_RieulPieub"; -0xedf,"Hangul_J_RieulSios"; -0xee0,"Hangul_J_RieulTieut"; -0xee1,"Hangul_J_RieulPhieuf"; -0xee2,"Hangul_J_RieulHieuh"; -0xee3,"Hangul_J_Mieum"; -0xee4,"Hangul_J_Pieub"; -0xee5,"Hangul_J_PieubSios"; -0xee6,"Hangul_J_Sios"; -0xee7,"Hangul_J_SsangSios"; -0xee8,"Hangul_J_Ieung"; -0xee9,"Hangul_J_Jieuj"; -0xeea,"Hangul_J_Cieuc"; -0xeeb,"Hangul_J_Khieuq"; -0xeec,"Hangul_J_Tieut"; -0xeed,"Hangul_J_Phieuf"; -0xeee,"Hangul_J_Hieuh"; -0xeef,"Hangul_RieulYeorinHieuh"; -0xef0,"Hangul_SunkyeongeumMieum"; -0xef1,"Hangul_SunkyeongeumPieub"; -0xef2,"Hangul_PanSios"; -0xef3,"Hangul_KkogjiDalrinIeung"; -0xef4,"Hangul_SunkyeongeumPhieuf"; -0xef5,"Hangul_YeorinHieuh"; -0xef6,"Hangul_AraeA"; -0xef7,"Hangul_AraeAE"; -0xef8,"Hangul_J_PanSios"; -0xef9,"Hangul_J_KkogjiDalrinIeung"; -0xefa,"Hangul_J_YeorinHieuh"; -0xeff,"Korean_Won"; -] diff --git a/ide/utils/configwin_types.ml b/ide/utils/configwin_types.mli index ace751c64e..9e339d135d 100644 --- a/ide/utils/configwin_types.ml +++ b/ide/utils/configwin_types.mli @@ -25,113 +25,6 @@ (** This module contains the types used in Configwin. *) -open Config_file - -let name_to_keysym = - ("Button1", Configwin_keys.xk_Pointer_Button1) :: - ("Button2", Configwin_keys.xk_Pointer_Button2) :: - ("Button3", Configwin_keys.xk_Pointer_Button3) :: - ("Button4", Configwin_keys.xk_Pointer_Button4) :: - ("Button5", Configwin_keys.xk_Pointer_Button5) :: - Configwin_keys.name_to_keysym - -let string_to_key s = - let mask = ref [] in - let key = try - let pos = String.rindex s '-' in - for i = 0 to pos - 1 do - let m = match s.[i] with - 'C' -> `CONTROL - | 'S' -> `SHIFT - | 'L' -> `LOCK - | 'M' -> `MOD1 - | 'A' -> `MOD1 - | '1' -> `MOD1 - | '2' -> `MOD2 - | '3' -> `MOD3 - | '4' -> `MOD4 - | '5' -> `MOD5 - | _ -> - Minilib.log s; - raise Not_found - in - mask := m :: !mask - done; - String.sub s (pos+1) (String.length s - pos - 1) - with _ -> - s - in - try - !mask, List.assoc key name_to_keysym - with - e -> - Minilib.log s; - raise e - -let key_to_string (m, k) = - let s = List.assoc k Configwin_keys.keysym_to_name in - match m with - [] -> s - | _ -> - let rec iter m s = - match m with - [] -> s - | c :: m -> - iter m (( - match c with - `CONTROL -> "C" - | `SHIFT -> "S" - | `LOCK -> "L" - | `MOD1 -> "A" - | `MOD2 -> "2" - | `MOD3 -> "3" - | `MOD4 -> "4" - | `MOD5 -> "5" - | _ -> raise Not_found - ) ^ s) - in - iter m ("-" ^ s) - -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 "" - -let value_to_key v = - match v with - Raw.String s -> string_to_key s - | _ -> - Minilib.log "value_to_key"; - raise Not_found - -let key_to_value k = - Raw.String (key_to_string k) - -let key_cp_wrapper = - { - to_raw = key_to_value ; - of_raw = value_to_key ; - } - -(** A class to define key options, with the {!Config_file} module. *) -class key_cp = - [(Gdk.Tags.modifier list * int)] Config_file.cp_custom_type key_cp_wrapper - (** This type represents a string or filename parameter, or any other type, depending on the given conversion functions. *) type 'a string_param = { @@ -188,49 +81,6 @@ type custom_param = { custom_framed : string option ; (** optional label for an optional frame *) } ;; -type color_param = { - color_label : string; (** the label of the parameter *) - mutable color_value : string; (** the current value of the parameter *) - color_editable : bool ; (** indicates if the value can be changed *) - color_f_apply : (string -> unit) ; (** the function to call to apply the new value of the parameter *) - color_help : string option ; (** optional help string *) - color_expand : bool ; (** expand the entry widget or not *) - } ;; - -type date_param = { - date_label : string ; (** the label of the parameter *) - mutable date_value : int * int * int ; (** day, month, year *) - date_editable : bool ; (** indicates if the value can be changed *) - date_f_string : (int * int * int) -> string ; - (** the function used to display the current value (day, month, year) *) - date_f_apply : ((int * int * int) -> unit) ; - (** the function to call to apply the new value (day, month, year) of the parameter *) - date_help : string option ; (** optional help string *) - date_expand : bool ; (** expand the entry widget or not *) - } ;; - -type font_param = { - font_label : string ; (** the label of the parameter *) - mutable font_value : string ; (** the font name *) - font_editable : bool ; (** indicates if the value can be changed *) - font_f_apply : (string -> unit) ; - (** the function to call to apply the new value of the parameter *) - font_help : string option ; (** optional help string *) - font_expand : bool ; (** expand the entry widget or not *) - } ;; - - -type hotkey_param = { - hk_label : string ; (** the label of the parameter *) - mutable hk_value : (Gdk.Tags.modifier list * int) ; - (** The value, as a list of modifiers and a key code *) - hk_editable : bool ; (** indicates if the value can be changed *) - hk_f_apply : ((Gdk.Tags.modifier list * int) -> unit) ; - (** the function to call to apply the new value of the paramter *) - hk_help : string option ; (** optional help string *) - hk_expand : bool ; (** expand or not *) - } - type modifiers_param = { md_label : string ; (** the label of the parameter *) mutable md_value : Gdk.Tags.modifier list ; @@ -248,17 +98,11 @@ type modifiers_param = { type parameter_kind = String_param of string string_param | List_param of (GData.tooltips -> <box: GObj.widget ; apply : unit>) - | Filename_param of string string_param | Bool_param of bool_param | Text_param of string string_param | Combo_param of combo_param | Custom_param of custom_param - | Color_param of color_param - | Date_param of date_param - | Font_param of font_param - | Hotkey_param of hotkey_param | Modifiers_param of modifiers_param - | Html_param of string string_param ;; (** This type represents the structure of the configuration window. *) @@ -275,28 +119,3 @@ type return_button = | Return_cancel (** The user closed the window with the cancel button or the window manager but never clicked on the apply button.*) - -(** {2 Bindings in the html editor} *) - -type html_binding = { - mutable html_key : (Gdk.Tags.modifier list * int) ; - mutable html_begin : string ; - mutable html_end : string ; - } - -let htmlbinding_cp_wrapper = - let w = Config_file.tuple3_wrappers - key_cp_wrapper - Config_file.string_wrappers - Config_file.string_wrappers - in - { - to_raw = (fun v -> w.to_raw (v.html_key, v.html_begin, v.html_end)) ; - of_raw = - (fun r -> let (k,b,e) = w.of_raw r in - { html_key = k ; html_begin = b ; html_end = e } - ) ; - } - -class htmlbinding_cp = - [html_binding] Config_file.option_cp htmlbinding_cp_wrapper diff --git a/ide/utils/editable_cells.ml b/ide/utils/editable_cells.ml deleted file mode 100644 index 33968b8dd0..0000000000 --- a/ide/utils/editable_cells.ml +++ /dev/null @@ -1,113 +0,0 @@ -open Gobject - -let create l = - let hbox = GPack.hbox () in - let scw = GBin.scrolled_window - ~hpolicy:`AUTOMATIC - ~vpolicy:`AUTOMATIC - ~packing:(hbox#pack ~expand:true) () in - - let columns = new GTree.column_list in - let command_col = columns#add Data.string in - let coq_col = columns#add Data.string in - let store = GTree.list_store columns - in - -(* populate the store *) - let _ = List.iter (fun (x,y) -> - let row = store#append () in - store#set ~row ~column:command_col x; - store#set ~row ~column:coq_col y) - l - in - let view = GTree.view ~model:store ~packing:scw#add_with_viewport () in - - (* Alternate colors for the rows *) - view#set_rules_hint true; - - let renderer_comm = GTree.cell_renderer_text [`EDITABLE true] in - ignore (renderer_comm#connect#edited - ~callback:(fun (path:Gtk.tree_path) (s:string) -> - store#set - ~row:(store#get_iter path) - ~column:command_col s)); - let first = - GTree.view_column ~title:"Coq Command to try" - ~renderer:(renderer_comm,["text",command_col]) - () - in ignore (view#append_column first); - - let renderer_coq = GTree.cell_renderer_text [`EDITABLE true] in - ignore(renderer_coq#connect#edited - ~callback:(fun (path:Gtk.tree_path) (s:string) -> - store#set - ~row:(store#get_iter path) - ~column:coq_col s)); - let second = - GTree.view_column ~title:"Coq Command to insert" - ~renderer:(renderer_coq,["text",coq_col]) - () - in ignore (view#append_column second); - - let vbox = GPack.button_box `VERTICAL ~packing:hbox#pack ~layout:`SPREAD () - in - let up = GButton.button ~stock:`GO_UP ~label:"Up" ~packing:(vbox#pack ~expand:true ~fill:false) () in - let down = GButton.button - ~stock:`GO_DOWN - ~label:"Down" - ~packing:(vbox#pack ~expand:true ~fill:false) () - in - let add = GButton.button ~stock:`ADD - ~label:"Add" - ~packing:(vbox#pack ~expand:true ~fill:false) - () - in - let remove = GButton.button ~stock:`REMOVE - ~label:"Remove" - ~packing:(vbox#pack ~expand:true ~fill:false) () - in - - ignore (add#connect#clicked - ~callback:(fun b -> - let n = store#append () in - view#selection#select_iter n)); - ignore (remove#connect#clicked - ~callback:(fun b -> match view#selection#get_selected_rows with - | [] -> () - | path::_ -> - let iter = store#get_iter path in - ignore (store#remove iter); - )); - ignore (up#connect#clicked - ~callback:(fun b -> - match view#selection#get_selected_rows with - | [] -> () - | path::_ -> - let iter = store#get_iter path in - ignore (GtkTree.TreePath.prev path); - let upiter = store#get_iter path in - ignore (store#swap iter upiter); - )); - ignore (down#connect#clicked - ~callback:(fun b -> - match view#selection#get_selected_rows with - | [] -> () - | path::_ -> - let iter = store#get_iter path in - GtkTree.TreePath.next path; - try let upiter = store#get_iter path in - ignore (store#swap iter upiter) - with _ -> () - )); - let get_data () = - let start_path = GtkTree.TreePath.from_string "0" in - let start_iter = store#get_iter start_path in - let rec all acc = - let new_acc = (store#get ~row:start_iter ~column:command_col, - store#get ~row:start_iter ~column:coq_col)::acc - in - if store#iter_next start_iter then all new_acc else List.rev new_acc - in all [] - in - (hbox,get_data) - diff --git a/ide/utils/okey.ml b/ide/utils/okey.ml deleted file mode 100644 index 580f1fbcb3..0000000000 --- a/ide/utils/okey.ml +++ /dev/null @@ -1,196 +0,0 @@ -(*********************************************************************************) -(* 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 modifier = Gdk.Tags.modifier - -type handler = { - cond : (unit -> bool) ; - cback : (unit -> unit) ; - } - -type handler_spec = int * int * Gdk.keysym - (** mods * mask * key *) - -let int_of_modifier = function - `SHIFT -> 1 - | `LOCK -> 2 - | `CONTROL -> 4 - | `MOD1 -> 8 - | `MOD2 -> 16 - | `MOD3 -> 32 - | `MOD4 -> 64 - | `MOD5 -> 128 - | `BUTTON1 -> 256 - | `BUTTON2 -> 512 - | `BUTTON3 -> 1024 - | `BUTTON4 -> 2048 - | `BUTTON5 -> 4096 - | `HYPER -> 1 lsl 22 - | `META -> 1 lsl 20 - | `RELEASE -> 1 lsl 30 - | `SUPER -> 1 lsl 21 - -let print_modifier l = - List.iter - (fun m -> - print_string - (((function - `SHIFT -> "SHIFT" - | `LOCK -> "LOCK" - | `CONTROL -> "CONTROL" - | `MOD1 -> "MOD1" - | `MOD2 -> "MOD2" - | `MOD3 -> "MOD3" - | `MOD4 -> "MOD4" - | `MOD5 -> "MOD5" - | `BUTTON1 -> "B1" - | `BUTTON2 -> "B2" - | `BUTTON3 -> "B3" - | `BUTTON4 -> "B4" - | `BUTTON5 -> "B5" - | `HYPER -> "HYPER" - | `META -> "META" - | `RELEASE -> "" - | `SUPER -> "SUPER") - m)^" ") - ) - l; - print_newline () - -let int_of_modifiers l = - List.fold_left (fun acc -> fun m -> acc + (int_of_modifier m)) 0 l - -module H = - struct - type t = handler_spec * handler - let equal (m,k) (mods, mask, key) = - (k = key) && ((m land mask) = mods) - - let filter_with_mask mods mask key l = - List.filter (fun a -> (fst a) <> (mods, mask, key)) l - - let find_handlers mods key l = - List.map snd - (List.filter - (fun ((m,ma,k),_) -> equal (mods,key) (m,ma,k)) - l - ) - - end - -let (table : (int, H.t list ref) Hashtbl.t) = Hashtbl.create 13 - -let key_press w ev = - let key = GdkEvent.Key.keyval ev in - let modifiers = GdkEvent.Key.state ev in - try - let (r : H.t list ref) = Hashtbl.find table (Oo.id w) in - let l = H.find_handlers (int_of_modifiers modifiers) key !r in - match l with - [] -> false - | _ -> - List.iter - (fun h -> - if h.cond () then - try h.cback () - with e -> Minilib.log (Printexc.to_string e) - else () - ) - l; - true - with - Not_found -> - false - -let associate_key_press w = - ignore ((w#event#connect#key_press ~callback: (key_press w)) : GtkSignal.id) - -let default_modifiers = ref ([] : modifier list) -let default_mask = ref ([`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK] : modifier list) - -let set_default_modifiers l = default_modifiers := l -let set_default_mask l = default_mask := l - -let remove_widget (w : < event : GObj.event_ops ; ..>) () = - try - let r = Hashtbl.find table (Oo.id w) in - r := [] - with - Not_found -> - () - -let add1 ?(remove=false) w - ?(cond=(fun () -> true)) - ?(mods= !default_modifiers) - ?(mask= !default_mask) - k callback = - - let r = - try Hashtbl.find table (Oo.id w) - with Not_found -> - let r = ref [] in - Hashtbl.add table (Oo.id w) r; - ignore (w#connect#destroy ~callback: (remove_widget w)); - associate_key_press w; - r - in - let n_mods = int_of_modifiers mods in - let n_mask = lnot (int_of_modifiers mask) in - let new_h = { cond = cond ; cback = callback } in - if remove then - ( - let l = H.filter_with_mask n_mods n_mask k !r in - r := ((n_mods, n_mask, k), new_h) :: l - ) - else - r := ((n_mods, n_mask, k), new_h) :: !r - -let add w - ?(cond=(fun () -> true)) - ?(mods= !default_modifiers) - ?(mask= !default_mask) - k callback = - add1 w ~cond ~mods ~mask k callback - -let add_list w - ?(cond=(fun () -> true)) - ?(mods= !default_modifiers) - ?(mask= !default_mask) - k_list callback = - List.iter (fun k -> add w ~cond ~mods ~mask k callback) k_list - -let set w - ?(cond=(fun () -> true)) - ?(mods= !default_modifiers) - ?(mask= !default_mask) - k callback = - add1 ~remove: true w ~cond ~mods ~mask k callback - -let set_list w - ?(cond=(fun () -> true)) - ?(mods= !default_modifiers) - ?(mask= !default_mask) - k_list callback = - List.iter (fun k -> set w ~cond ~mods ~mask k callback) k_list diff --git a/ide/utils/okey.mli b/ide/utils/okey.mli deleted file mode 100644 index 84ea4df449..0000000000 --- a/ide/utils/okey.mli +++ /dev/null @@ -1,115 +0,0 @@ -(*********************************************************************************) -(* 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 *) -(* *) -(*********************************************************************************) - -(** Okey interface. - - Once the lib is compiled and installed, you can use it by referencing - it with the [Okey] module. You must add [okey.cmo] or [okey.cmx] - on the commande line when you link. -*) - -type modifier = Gdk.Tags.modifier - -(** Set the default modifier list. The first default value is [[]].*) -val set_default_modifiers : modifier list -> unit - -(** Set the default modifier mask. The first default value is - [[`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK]]. - The mask defines the modifiers not taken into account - when looking for the handler of a key press event. -*) -val set_default_mask : modifier list -> unit - -(** [add widget key callback] associates the [callback] function to the event - "key_press" with the given [key] for the given [widget]. - - @param remove when true, the previous handlers for the given key and modifier - list are not kept. - @param cond this function is a guard: the [callback] function is not called - if the [cond] function returns [false]. - The default [cond] function always returns [true]. - - @param mods the list of modifiers. If not given, the default modifiers - are used. - You can set the default modifiers with function {!Okey.set_default_modifiers}. - - @param mask the list of modifiers which must not be taken - into account to trigger the given handler. [mods] - and [mask] must not have common modifiers. If not given, the default mask - is used. - You can set the default modifiers mask with function {!Okey.set_default_mask}. -*) -val add : - < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; - event : GObj.event_ops; get_oid : int; .. > -> - ?cond: (unit -> bool) -> - ?mods: modifier list -> - ?mask: modifier list -> - Gdk.keysym -> - (unit -> unit) -> - unit - -(** It calls {!Okey.add} for each given key.*) -val add_list : - < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; - event : GObj.event_ops; get_oid : int; .. > -> - ?cond: (unit -> bool) -> - ?mods: modifier list -> - ?mask: modifier list -> - Gdk.keysym list -> - (unit -> unit) -> - unit - -(** Like {!Okey.add} but the previous handlers for the - given modifiers and key are not kept.*) -val set : - < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; - event : GObj.event_ops; get_oid : int; .. > -> - ?cond: (unit -> bool) -> - ?mods: modifier list -> - ?mask: modifier list -> - Gdk.keysym -> - (unit -> unit) -> - unit - -(** It calls {!Okey.set} for each given key.*) -val set_list : - < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; - event : GObj.event_ops; get_oid : int; .. > -> - ?cond: (unit -> bool) -> - ?mods: modifier list -> - ?mask: modifier list -> - Gdk.keysym list -> - (unit -> unit) -> - unit - -(** Remove the handlers associated to the given widget. - This is automatically done when a widget is destroyed but - you can do it yourself. *) -val remove_widget : - < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; - event : GObj.event_ops; get_oid : int; .. > -> - unit -> - unit diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml index 7dad92ed6f..946aaf010d 100644 --- a/ide/wg_Command.ml +++ b/ide/wg_Command.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -85,9 +85,11 @@ object(self) ~packing:(vbox#pack ~fill:true ~expand:true) () in let result = GText.view ~packing:r_bin#add () in views <- (frame#coerce, result, combo#entry) :: views; - result#misc#modify_font current.text_font; - let clr = Tags.color_of_string current.background_color in - result#misc#modify_base [`NORMAL, `COLOR clr]; + let cb clr = result#misc#modify_base [`NORMAL, `NAME clr] in + let _ = background_color#connect#changed cb in + let _ = result#misc#connect#realize (fun () -> cb background_color#get) in + let cb ft = result#misc#modify_font (Pango.Font.from_string ft) in + stick text_font result cb; result#misc#set_can_focus true; (* false causes problems for selection *) result#set_editable false; let callback () = @@ -98,11 +100,14 @@ object(self) if Str.string_match (Str.regexp "\\. *$") com 0 then com else com ^ " " ^ arg ^" . " in - let log level message = result#buffer#insert (message^"\n") in + let log level message = + Ideutils.insert_xml result#buffer message; + result#buffer#insert "\n"; + in let process = Coq.bind (Coq.query ~logger:log (phrase,Stateid.dummy)) (function | Interface.Fail (_,l,str) -> - result#buffer#insert str; + Ideutils.insert_xml result#buffer str; notebook#set_page ~tab_label:(new_tab_lbl "Error") frame#coerce; Coq.return () | Interface.Good res -> @@ -144,13 +149,9 @@ object(self) method visible = frame#visible - - method refresh_font () = - let iter (_,view,_) = view#misc#modify_font current.text_font in - List.iter iter views - method refresh_color () = - let clr = Tags.color_of_string current.background_color in + method private refresh_color clr = + let clr = Tags.color_of_string clr in let iter (_,view,_) = view#misc#modify_base [`NORMAL, `COLOR clr] in List.iter iter views @@ -158,6 +159,8 @@ object(self) self#new_page_maker; self#new_query_aux ~grab_now:false (); frame#misc#hide (); + let _ = background_color#connect#changed 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 diff --git a/ide/wg_Command.mli b/ide/wg_Command.mli index 91a8f26cac..fa50ba5fdd 100644 --- a/ide/wg_Command.mli +++ b/ide/wg_Command.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,8 +10,6 @@ class command_window : string -> Coq.coqtop -> object method new_query : ?command:string -> ?term:string -> unit -> unit method pack_in : (GObj.widget -> unit) -> unit - method refresh_font : unit -> unit - method refresh_color : unit -> unit method show : unit method hide : unit method visible : bool diff --git a/ide/wg_Completion.ml b/ide/wg_Completion.ml index 3f5ae4bd55..aeae3e1fdb 100644 --- a/ide/wg_Completion.ml +++ b/ide/wg_Completion.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -86,7 +86,7 @@ let signals = [ end_s#disconnect; ] in object (self : 'a) - inherit GUtil.ml_signals signals as super + 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 @@ -258,7 +258,7 @@ object (self) method private refresh_style () = let (renderer, _) = renderer in - let font = Preferences.current.Preferences.text_font in + let font = Pango.Font.from_string Preferences.text_font#get in renderer#set_properties [`FONT_DESC font; `XPAD 10] method private coordinates pos = diff --git a/ide/wg_Completion.mli b/ide/wg_Completion.mli index c3cb230d79..dd496aa5f5 100644 --- a/ide/wg_Completion.mli +++ b/ide/wg_Completion.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_Detachable.ml b/ide/wg_Detachable.ml index 53c634d7e2..3d1b63dfae 100644 --- a/ide/wg_Detachable.ml +++ b/ide/wg_Detachable.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_Detachable.mli b/ide/wg_Detachable.mli index 71f85ad828..a7e8f46763 100644 --- a/ide/wg_Detachable.mli +++ b/ide/wg_Detachable.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_Find.ml b/ide/wg_Find.ml index b6f63a3ba1..3d847ddcc1 100644 --- a/ide/wg_Find.ml +++ b/ide/wg_Find.ml @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -type mode = [ `FIND | `REPLACE ] +let b2c = Ideutils.byte_offset_to_char_offset class finder name (view : GText.view) = @@ -61,8 +61,10 @@ class finder name (view : GText.view) = 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 () @@ -85,8 +87,8 @@ class finder name (view : GText.view) = try let i = Str.search_backward regexp text (String.length text - 1) in let j = Str.match_end () in - Some(view#buffer#start_iter#forward_chars i, - view#buffer#start_iter#forward_chars j) + 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 = @@ -95,7 +97,7 @@ class finder name (view : GText.view) = try let i = Str.search_forward regexp text 0 in let j = Str.match_end () in - Some(starti#forward_chars i, starti#forward_chars j) + Some(starti#forward_chars (b2c text i), starti#forward_chars (b2c text j)) with Not_found -> None method replace_all () = @@ -115,7 +117,9 @@ class finder name (view : GText.view) = let () = view#buffer#delete_mark (`MARK stop_mark) in replace_at next in - replace_at view#buffer#start_iter + let () = view#buffer#begin_user_action () in + let () = replace_at view#buffer#start_iter in + view#buffer#end_user_action () method private set_not_found () = find_entry#misc#modify_base [`NORMAL, `NAME "#F7E6E6"]; diff --git a/ide/wg_Find.mli b/ide/wg_Find.mli index 7811fc43ef..1ef1c4d499 100644 --- a/ide/wg_Find.mli +++ b/ide/wg_Find.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index 9acda53fc3..0330b8eff1 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -1,22 +1,40 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +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 : string -> unit - method set : string -> unit - method push : Pp.message_level -> string -> unit + method add : Richpp.richpp -> unit + method add_string : string -> unit + method set : Richpp.richpp -> unit + method push : Ideutils.logger (** same as [add], but with an explicit level instead of [Notice] *) method buffer : GText.buffer (** for more advanced text edition *) - method modify_font : Pango.font_description -> unit end let message_view () : message_view = @@ -25,6 +43,7 @@ let message_view () : message_view = ~tag_table:Tags.Message.table () in let text_buffer = new GText.buffer buffer#as_buffer 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 @@ -32,32 +51,52 @@ let message_view () : message_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 (); + let cb clr = view#misc#modify_base [`NORMAL, `NAME clr] in + let _ = background_color#connect#changed cb in + let _ = view#misc#connect#realize (fun () -> cb background_color#get) in + let cb ft = view#misc#modify_font (Pango.Font.from_string ft) in + stick text_font view cb; object (self) inherit GObj.widget box#as_widget + val push = new GUtil.signal () + + method connect = + new message_view_signals_impl box#as_widget push + method clear = - buffer#set_text "" + buffer#set_text ""; + buffer#move_mark (`MARK mark) ~where:buffer#start_iter method push level msg = let tags = match level with - | Pp.Error -> [Tags.Message.error] - | Pp.Warning -> [Tags.Message.warning] + | Feedback.Error -> [Tags.Message.error] + | Feedback.Warning -> [Tags.Message.warning] | _ -> [] in - if msg <> "" then begin - buffer#insert ~tags msg; - buffer#insert ~tags "\n" + let rec non_empty = function + | Xml_datatype.PCData "" -> false + | Xml_datatype.PCData _ -> true + | Xml_datatype.Element (_, _, children) -> List.exists non_empty children + in + if non_empty (Richpp.repr msg) then begin + let mark = `MARK mark in + Ideutils.insert_xml ~mark buffer ~tags msg; + buffer#insert ~iter:(buffer#get_iter_at_mark mark) "\n"; + push#call (level, msg) end - method add msg = self#push Pp.Notice msg + method add msg = self#push Feedback.Notice msg + + method add_string s = self#add (Richpp.richpp_of_string s) method set msg = self#clear; self#add msg method buffer = text_buffer - method modify_font fd = view#misc#modify_font fd - end diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli index cd3f00c97d..2d34533dee 100644 --- a/ide/wg_MessageView.mli +++ b/ide/wg_MessageView.mli @@ -1,22 +1,30 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +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 : string -> unit - method set : string -> unit - method push : Pp.message_level -> string -> unit + method add : Richpp.richpp -> unit + method add_string : string -> unit + method set : Richpp.richpp -> unit + method push : Ideutils.logger (** same as [add], but with an explicit level instead of [Notice] *) method buffer : GText.buffer (** for more advanced text edition *) - method modify_font : Pango.font_description -> unit end val message_view : unit -> message_view diff --git a/ide/wg_Notebook.ml b/ide/wg_Notebook.ml index 0611c3f396..08d7d19833 100644 --- a/ide/wg_Notebook.ml +++ b/ide/wg_Notebook.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_Notebook.mli b/ide/wg_Notebook.mli index 15a2ba41e9..34eb1d11e3 100644 --- a/ide/wg_Notebook.mli +++ b/ide/wg_Notebook.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index 7e7a311ed0..47c86045a5 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -1,14 +1,19 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Util +open Preferences +open Ideutils + class type proof_view = object inherit GObj.widget + method buffer : GText.buffer method refresh : unit -> unit method clear : unit -> unit method set_goals : Interface.goals option -> unit @@ -79,26 +84,28 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with let () = hook_tag_cb tag hint sel_cb on_hover in [tag], hints in - let () = proof#buffer#insert ~tags (hyp ^ "\n") in + let () = insert_xml ~tags proof#buffer 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 tags = Tags.Proof.goal :: if goal_hints <> [] then + 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 1 goals_cnt); - proof#buffer#insert ~tags cur_goal; + insert_xml proof#buffer cur_goal; proof#buffer#insert "\n" in (* Insert remaining goals (no hypotheses) *) let fold_goal i _ { Interface.goal_ccl = g } = proof#buffer#insert (goal_str i goals_cnt); - proof#buffer#insert (g ^ "\n") + insert_xml proof#buffer g; + proof#buffer#insert "\n" in let () = Util.List.fold_left_i fold_goal 2 () rem_goals in @@ -107,17 +114,6 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with (Some Tags.Proof.goal))); ignore(proof#scroll_to_mark ~use_align:true ~yalign:0.95 `INSERT) -let mode_cesar (proof : #GText.view_skel) = function - | [] -> assert false - | { Interface.goal_hyp = hyps; Interface.goal_ccl = cur_goal; } :: _ -> - proof#buffer#insert " *** Declarative Mode ***\n"; - List.iter - (fun hyp -> proof#buffer#insert (hyp^"\n")) - hyps; - proof#buffer#insert "______________________________________\n"; - proof#buffer#insert ("thesis := \n "^cur_goal^"\n"); - ignore (proof#scroll_to_iter (proof#buffer#get_iter_at_mark `INSERT)) - let rec flatten = function | [] -> [] | (lg, rg) :: l -> @@ -137,36 +133,43 @@ let display mode (view : #GText.view_skel) goals hints evars = view#buffer#insert "No more subgoals." | [], [], [], _ :: _ -> (* A proof has been finished, but not concluded *) - view#buffer#insert "No more subgoals but non-instantiated existential variables:\n\n"; + 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 + 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, however there are goals you gave up. You need to go back and solve them:\n\n"; + view#buffer#insert "No more subgoals, but there are some goals you gave up:\n\n"; let iter goal = - let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in - view#buffer#insert msg + insert_xml view#buffer goal.Interface.goal_ccl; + view#buffer#insert "\n" in - List.iter iter given_up_goals + 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 = - let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in - view#buffer#insert msg + insert_xml view#buffer goal.Interface.goal_ccl; + view#buffer#insert "\n" in List.iter iter shelved_goals | _, _, _, _ -> (* No foreground proofs, but still unfocused ones *) - view#buffer#insert "This subproof is complete, but there are still unfocused goals:\n\n"; - let iter goal = - let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in - view#buffer#insert msg + let total = List.length bg in + let goal_str index = Printf.sprintf + "______________________________________(%d/%d)\n" index total in - List.iter iter bg + 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 goal.Interface.goal_ccl; + view#buffer#insert "\n" + in + List.iteri iter bg end | Some { Interface.fg_goals = fg } -> mode view fg hints @@ -176,16 +179,26 @@ let proof_view () = ~highlight_matching_brackets:true ~tag_table:Tags.Proof.table () in + let text_buffer = new GText.buffer buffer#as_buffer in let view = GSourceView2.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 + let cb clr = view#misc#modify_base [`NORMAL, `NAME clr] in + let _ = background_color#connect#changed cb in + let _ = view#misc#connect#realize (fun () -> cb background_color#get) in + let cb ft = view#misc#modify_font (Pango.Font.from_string ft) in + stick text_font view cb; + object inherit GObj.widget view#as_widget val mutable goals = None val mutable evars = None + method buffer = text_buffer + method clear () = buffer#set_text "" method set_goals gls = goals <- gls diff --git a/ide/wg_ProofView.mli b/ide/wg_ProofView.mli index 1fbf9900ca..b6eae48b39 100644 --- a/ide/wg_ProofView.mli +++ b/ide/wg_ProofView.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,6 +9,7 @@ class type proof_view = object inherit GObj.widget + method buffer : GText.buffer method refresh : unit -> unit method clear : unit -> unit method set_goals : Interface.goals option -> unit diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml index 1f3990708a..218cedb363 100644 --- a/ide/wg_ScriptView.ml +++ b/ide/wg_ScriptView.ml @@ -1,11 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Preferences + type insert_action = { ins_val : string; ins_off : int; @@ -139,7 +141,7 @@ object(self) (** We don't care about atomicity. Return: 1. `OK when there was no error, `FAIL otherwise - 2. `NOOP if no write occured, `WRITE otherwise + 2. `NOOP if no write occurred, `WRITE otherwise *) method private process_action = function | Insert ins -> @@ -186,11 +188,19 @@ object(self) method undo () = Minilib.log "UNDO"; - self#with_lock_undo self#perform_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 self#perform_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 *) @@ -277,7 +287,7 @@ let completion = new Wg_Completion.complete_model ct view#buffer in let popup = new Wg_Completion.complete_popup completion (view :> GText.view) in object (self) - inherit GSourceView2.source_view (Gobject.unsafe_cast tv) as super + inherit GSourceView2.source_view (Gobject.unsafe_cast tv) val undo_manager = new undo_manager view#buffer @@ -410,6 +420,7 @@ object (self) self#buffer#end_user_action () initializer + let () = Gtk_parsing.fix_double_click self in let supersed cb _ = let _ = cb () in GtkSignal.stop_emit() @@ -447,6 +458,33 @@ object (self) if not proceed then GtkSignal.stop_emit () in let _ = GtkSignal.connect ~sgn:move_line_signal ~callback obj in + (** Plug on preferences *) + let cb clr = self#misc#modify_base [`NORMAL, `NAME clr] in + let _ = background_color#connect#changed cb in + let _ = self#misc#connect#realize (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 (Pango.Font.from_string ft) in + stick text_font self cb; + () end diff --git a/ide/wg_ScriptView.mli b/ide/wg_ScriptView.mli index 6e54c4452f..6cce5e5b43 100644 --- a/ide/wg_ScriptView.mli +++ b/ide/wg_ScriptView.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_Segment.ml b/ide/wg_Segment.ml index 8520727a71..dbc1740ef6 100644 --- a/ide/wg_Segment.ml +++ b/ide/wg_Segment.ml @@ -1,62 +1,23 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) open Util +open Preferences type color = GDraw.color -module Segment : -sig - type +'a t - val length : 'a t -> int - val resize : 'a t -> int -> 'a t - val empty : 'a t - val add : int -> 'a -> 'a t -> 'a t - val remove : int -> 'a t -> 'a t - val fold : ('a -> 'a -> bool) -> (int -> int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b -end = -struct - type 'a t = { - length : int; - content : 'a Int.Map.t; - } - - let empty = { length = 0; content = Int.Map.empty } - - let length s = s.length - - let resize s len = - if s.length <= len then { s with length = len } - else - let filter i v = i < len in - { length = len; content = Int.Map.filter filter s.content } - - let add i v s = - if i < s.length then - { s with content = Int.Map.add i v s.content } - else s - - let remove i s = { s with content = Int.Map.remove i s.content } - - let fold eq f s accu = - let make k v (cur, accu) = match cur with - | None -> Some (k, k, v), accu - | Some (i, j, w) -> - if k = j + 1 && eq v w then Some (i, k, w), accu - else Some (k, k, v), (i, j, w) :: accu - in - let p, segments = Int.Map.fold make s.content (None, []) in - let segments = match p with - | None -> segments - | Some p -> p :: segments - in - List.fold_left (fun accu (i, j, v) -> f i j v accu) accu segments +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 @@ -70,18 +31,37 @@ let color_eq (c1 : GDraw.color) (c2 : GDraw.color) = match c1, c2 with | `WHITE, `WHITE -> true | _ -> false +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.image ~packing:box#add () in +let eventbox = GBin.event_box ~packing:box#add () in +let draw = GMisc.image ~packing:eventbox#add () in object (self) inherit GObj.widget box#as_widget val mutable width = 1 val mutable height = 20 - val mutable data = Segment.empty + val mutable model : model option = None val mutable default : color = `WHITE val mutable pixmap : GDraw.pixmap = GDraw.pixmap ~width:1 ~height:1 () + val clicked = new GUtil.signal () + val mutable need_refresh = false + val refresh_timer = Ideutils.mktimer () initializer box#misc#set_size_request ~height (); @@ -96,20 +76,41 @@ object (self) end in let _ = box#misc#connect#size_allocate cb in + let clicked_cb ev = match model with + | None -> true + | Some md -> + let x = GdkEvent.Button.x ev in + let (width, _) = pixmap#size in + let len = md#length in + let idx = f2i ((x *. i2f len) /. i2f width) in + let () = clicked#call idx in + true + in + let _ = eventbox#event#connect#button_press clicked_cb in + let cb show = if show then self#misc#show () else self#misc#hide () in + stick show_progress_bar self cb; (** Initial pixmap *) - draw#set_pixmap pixmap - - method length = Segment.length data - - method set_length len = - data <- Segment.resize data len; - if self#misc#visible then self#refresh () + draw#set_pixmap pixmap; + refresh_timer.Ideutils.run ~ms:300 + ~callback:(fun () -> if need_refresh then self#refresh (); true) + + method set_model md = + model <- Some md; + let changed_cb = function + | `INSERT | `REMOVE -> + if self#misc#visible then need_refresh <- true + | `SET (i, color) -> + if self#misc#visible then self#fill_range color i (i + 1) + in + md#changed changed_cb - method private fill_range color i j = + method private fill_range 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 (Segment.length data) 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 @@ -117,14 +118,6 @@ object (self) pixmap#rectangle ~x ~y:0 ~width:w ~height ~filled:true (); draw#set_mask None; - method add i color = - data <- Segment.add i color data; - if self#misc#visible then self#fill_range color i (i + 1) - - method remove i = - data <- Segment.remove i data; - if self#misc#visible then self#fill_range default i (i + 1) - method set_default_color color = default <- color method default_color = default @@ -133,11 +126,27 @@ object (self) draw#set_pixmap pixmap; self#refresh (); - method private refresh () = + method private refresh () = match model with + | None -> () + | Some md -> + need_refresh <- false; pixmap#set_foreground default; pixmap#rectangle ~x:0 ~y:0 ~width ~height ~filled:true (); - let fold i j v () = self#fill_range v i (j + 1) in - Segment.fold color_eq fold data (); + 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 v i (j + 1)) segments; draw#set_mask None; + method connect = + new segment_signals_impl box#as_widget clicked + end diff --git a/ide/wg_Segment.mli b/ide/wg_Segment.mli index ecb4514750..29cbbedacf 100644 --- a/ide/wg_Segment.mli +++ b/ide/wg_Segment.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,14 +8,28 @@ 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 length : int - method set_length : int -> unit + method set_model : model -> unit + method connect : segment_signals method default_color : color method set_default_color : color -> unit - method add : int -> color -> unit - method remove : int -> unit end diff --git a/ide/xml_lexer.mli b/ide/xml_lexer.mli new file mode 100644 index 0000000000..e61cb055f7 --- /dev/null +++ b/ide/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/xml_lexer.mll b/ide/xml_lexer.mll new file mode 100644 index 0000000000..290f2c89ab --- /dev/null +++ b/ide/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 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/xml_parser.ml b/ide/xml_parser.ml new file mode 100644 index 0000000000..8db3f9e8ba --- /dev/null +++ b/ide/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/xml_parser.mli b/ide/xml_parser.mli new file mode 100644 index 0000000000..ac2eab352f --- /dev/null +++ b/ide/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/xml_printer.ml b/ide/xml_printer.ml new file mode 100644 index 0000000000..40ab4ce9cb --- /dev/null +++ b/ide/xml_printer.ml @@ -0,0 +1,145 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +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/xml_printer.mli b/ide/xml_printer.mli new file mode 100644 index 0000000000..f24f51fff5 --- /dev/null +++ b/ide/xml_printer.mli @@ -0,0 +1,29 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +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/xmlprotocol.ml b/ide/xmlprotocol.ml index d337a911d8..aecb317bcb 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,7 +10,7 @@ (** WARNING: TO BE UPDATED WHEN MODIFIED! *) -let protocol_version = "20140312" +let protocol_version = "20150913" (** * Interface of calls to Coq by CoqIde *) @@ -39,7 +39,7 @@ let to_search_cst = do_match "search_cst" (fun s args -> match s with | "subtype_pattern" -> SubType_Pattern (to_string (singleton args)) | "in_module" -> In_Module (to_list to_string (singleton args)) | "include_blacklist" -> Include_Blacklist - | _ -> raise Marshal_error) + | x -> raise (Marshal_error("search",PCData x))) let of_coq_object f ans = let prefix = of_list of_string ans.coq_object_prefix in @@ -56,17 +56,19 @@ let to_coq_object f = function coq_object_qualid = qualid; coq_object_object = obj; } -| _ -> raise Marshal_error +| 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)) - | _ -> raise Marshal_error) + | "stringoptvalue" -> StringOptValue (to_option to_string (singleton args)) + | x -> raise (Marshal_error("*value",PCData x))) let of_option_state s = Element ("option_state", [], [ @@ -80,8 +82,20 @@ let to_option_state = function opt_depr = to_bool depr; opt_name = to_string name; opt_value = to_option_value value } - | _ -> raise Marshal_error + | 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 of_richpp x = Element ("richpp", [], [Richpp.repr x]) +let to_richpp xml = match xml with + | Element ("richpp", [], [x]) -> Richpp.richpp_of_xml x + | x -> raise Serialize.(Marshal_error("richpp",x)) let of_value f = function | Good x -> Element ("value", ["val", "good"], [f x]) @@ -89,8 +103,9 @@ let of_value f = function let loc = match loc with | None -> [] | Some (s, e) -> [("loc_s", string_of_int s); ("loc_e", string_of_int e)] in - let id = Stateid.to_xml id in - Element ("value", ["val", "fail"] @ loc, [id;PCData msg]) + let id = of_stateid id in + Element ("value", ["val", "fail"] @ loc, [id; of_richpp msg]) + let to_value f = function | Element ("value", attrs, l) -> let ans = massoc "val" attrs in @@ -101,13 +116,14 @@ let to_value f = function 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 + with Marshal_error _ | Failure _ -> None in - let id = Stateid.of_xml (List.hd l) in - let msg = raw_string (List.tl l) 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_richpp msg in Fail (id, loc, msg) - else raise Marshal_error -| _ -> raise Marshal_error + 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 @@ -123,25 +139,25 @@ let to_status = function status_proofname = to_option to_string name; status_allproofs = to_list to_string prfs; status_proofnum = to_int pnum; } - | _ -> raise Marshal_error + | 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; } - | _ -> raise Marshal_error + | x -> raise (Marshal_error("evar",x)) let of_goal g = - let hyp = of_list of_string g.goal_hyp in - let ccl = of_string g.goal_ccl in + let hyp = of_list of_richpp g.goal_hyp in + let ccl = of_richpp g.goal_ccl in let id = of_string g.goal_id in Element ("goal", [], [id; hyp; ccl]) let to_goal = function | Element ("goal", [], [id; hyp; ccl]) -> - let hyp = to_list to_string hyp in - let ccl = to_string ccl in + let hyp = to_list to_richpp hyp in + let ccl = to_richpp ccl in let id = to_string id in { goal_hyp = hyp; goal_ccl = ccl; goal_id = id; } - | _ -> raise Marshal_error + | x -> raise (Marshal_error("goal",x)) let of_goals g = let of_glist = of_list of_goal in @@ -159,7 +175,7 @@ let to_goals = function let given_up = to_list to_goal given_up in { fg_goals = fg; bg_goals = bg; shelved_goals = shelf; given_up_goals = given_up } - | _ -> raise Marshal_error + | x -> raise (Marshal_error("goals",x)) let of_coq_info info = let version = of_string info.coqtop_version in @@ -173,7 +189,7 @@ let to_coq_info = function protocol_version = to_string protocol; release_date = to_string release; compile_date = to_string compile; } - | _ -> raise Marshal_error + | x -> raise (Marshal_error("coq_info",x)) end include Xml_marshalling @@ -218,22 +234,31 @@ module ReifType : sig end = struct - type value_type = - | Unit | String | Int | Bool | Xml + 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 of value_type - | List of value_type - | Pair of value_type * value_type - | Union of value_type * value_type + | 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 | Evar | State | Option_state | Option_value | Coq_info - | Coq_object of value_type - | State_id - | Search_cst + | 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 + | Search_cst : search_constraint val_t - type 'a val_t = value_type + type value_type = Value_type : 'a val_t -> value_type - let erase (x : 'a val_t) : value_type = x + let erase (x : 'a val_t) = Value_type x let unit_t = Unit let string_t = String @@ -257,48 +282,48 @@ end = struct let search_cst_t = Search_cst let of_value_type (ty : 'a val_t) : 'a -> xml = - let rec convert ty : 'a -> xml = match ty with - | Unit -> Obj.magic of_unit - | Bool -> Obj.magic of_bool - | Xml -> Obj.magic (fun x -> x) - | String -> Obj.magic of_string - | Int -> Obj.magic of_int - | State -> Obj.magic of_status - | Option_state -> Obj.magic of_option_state - | Option_value -> Obj.magic of_option_value - | Coq_info -> Obj.magic of_coq_info - | Goals -> Obj.magic of_goals - | Evar -> Obj.magic of_evar - | List t -> Obj.magic (of_list (convert t)) - | Option t -> Obj.magic (of_option (convert t)) - | Coq_object t -> Obj.magic (of_coq_object (convert t)) - | Pair (t1,t2) -> Obj.magic (of_pair (convert t1) (convert t2)) - | Union (t1,t2) -> Obj.magic (of_union (convert t1) (convert t2)) - | State_id -> Obj.magic Stateid.to_xml - | Search_cst -> Obj.magic of_search_cst + 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 + | Search_cst -> of_search_cst in convert ty let to_value_type (ty : 'a val_t) : xml -> 'a = - let rec convert ty : xml -> 'a = match ty with - | Unit -> Obj.magic to_unit - | Bool -> Obj.magic to_bool - | Xml -> Obj.magic (fun x -> x) - | String -> Obj.magic to_string - | Int -> Obj.magic to_int - | State -> Obj.magic to_status - | Option_state -> Obj.magic to_option_state - | Option_value -> Obj.magic to_option_value - | Coq_info -> Obj.magic to_coq_info - | Goals -> Obj.magic to_goals - | Evar -> Obj.magic to_evar - | List t -> Obj.magic (to_list (convert t)) - | Option t -> Obj.magic (to_option (convert t)) - | Coq_object t -> Obj.magic (to_coq_object (convert t)) - | Pair (t1,t2) -> Obj.magic (to_pair (convert t1) (convert t2)) - | Union (t1,t2) -> Obj.magic (to_union (convert t1) (convert t2)) - | State_id -> Obj.magic Stateid.of_xml - | Search_cst -> Obj.magic to_search_cst + 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 + | Search_cst -> to_search_cst in convert ty @@ -318,10 +343,9 @@ end = struct (List.length lg + List.length rg) pr_focus l in Printf.sprintf "Still focussed: [%a]." pr_focus g.bg_goals else - let pr_menu s = s in let pr_goal { goal_hyp = hyps; goal_ccl = goal } = - "[" ^ String.concat "; " (List.map pr_menu hyps) ^ " |- " ^ - pr_menu goal ^ "]" in + "[" ^ String.concat "; " (List.map Richpp.raw_print hyps) ^ " |- " ^ + Richpp.raw_print goal ^ "]" in String.concat " " (List.map pr_goal g.fg_goals) let pr_evar (e : evar) = "[" ^ e.evar_info ^ "]" let pr_status (s : status) = @@ -337,6 +361,8 @@ end = struct | 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" @@ -346,6 +372,7 @@ end = struct 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 @@ -354,30 +381,30 @@ end = struct | In_Module s -> "In_Module " ^ String.concat "." s | Include_Blacklist -> "Include_Blacklist" - let rec print = function - | Unit -> Obj.magic pr_unit - | Bool -> Obj.magic pr_bool - | String -> Obj.magic pr_string - | Xml -> Obj.magic Xml_printer.to_string_fmt - | Int -> Obj.magic pr_int - | State -> Obj.magic pr_status - | Option_state -> Obj.magic pr_option_state - | Option_value -> Obj.magic pr_option_value - | Search_cst -> Obj.magic pr_search_cst - | Coq_info -> Obj.magic pr_coq_info - | Goals -> Obj.magic pr_goal - | Evar -> Obj.magic pr_evar - | List t -> Obj.magic (pr_list (print t)) - | Option t -> Obj.magic (pr_option (print t)) - | Coq_object t -> Obj.magic pr_coq_object - | Pair (t1,t2) -> Obj.magic (pr_pair (print t1) (print t2)) - | Union (t1,t2) -> Obj.magic (pr_union (print t1) (print t2)) - | State_id -> Obj.magic pr_int + 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 (* This is to break if a rename/refactoring makes the strings below outdated *) type 'a exists = bool - let rec print_type = function + let rec print_val_t : type a. a val_t -> string = function | Unit -> "unit" | Bool -> "bool" | String -> "string" @@ -390,33 +417,35 @@ end = struct | Coq_info -> assert(true : coq_info exists); "Interface.coq_info" | Goals -> assert(true : goals exists); "Interface.goals" | Evar -> assert(true : evar exists); "Interface.evar" - | List t -> Printf.sprintf "(%s list)" (print_type t) - | Option t -> Printf.sprintf "(%s option)" (print_type t) + | 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_type t) - | Pair (t1,t2) -> Printf.sprintf "(%s * %s)" (print_type t1) (print_type t2) + 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_type t1) (print_type t2) + Printf.sprintf "((%s, %s) CSig.union)" (print_val_t t1) (print_val_t t2) | State_id -> assert(true : Stateid.t exists); "Stateid.t" + 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_type Unit) (pr_xml (of_unit ())); - Printf.printf "%s:\n\n%s\n%s\n\n" (print_type Bool) + 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_type String) (pr_xml (of_string "hello")); - Printf.printf "%s:\n\n%s\n\n" (print_type Int) (pr_xml (of_int 256)); - Printf.printf "%s:\n\n%s\n\n" (print_type State_id) (pr_xml (Stateid.to_xml Stateid.initial)); - Printf.printf "%s:\n\n%s\n\n" (print_type (List Int)) (pr_xml (of_list of_int [3;4;5])); - Printf.printf "%s:\n\n%s\n%s\n\n" (print_type (Option Int)) + 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_type (Pair (Bool,Int))) + 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_type (Union (Bool,Int))) + 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_type Option_state) + 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) })); @@ -492,27 +521,27 @@ let calls = [| |] type 'a call = - | Add of add_sty - | Edit_at of edit_at_sty - | Query of query_sty - | Goal of goals_sty - | Evars of evars_sty - | Hints of hints_sty - | Status of status_sty - | Search of search_sty - | GetOptions of get_options_sty - | SetOptions of set_options_sty - | MkCases of mkcases_sty - | Quit of quit_sty - | About of about_sty - | Init of init_sty - | StopWorker of stop_worker_sty + | 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 (* retrocompatibility *) - | Interp of interp_sty - | PrintAst of print_ast_sty - | Annotate of annotate_sty + | Interp : interp_sty -> interp_rty call + | PrintAst : print_ast_sty -> print_ast_rty call + | Annotate : annotate_sty -> annotate_rty call -let id_of_call = function +let id_of_call : type a. a call -> int = function | Add _ -> 0 | Edit_at _ -> 1 | Query _ -> 2 @@ -534,7 +563,7 @@ let id_of_call = function let str_of_call c = pi1 calls.(id_of_call c) -type unknown +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 @@ -555,8 +584,8 @@ let stop_worker x : stop_worker_rty call = StopWorker x let print_ast x : print_ast_rty call = PrintAst x let annotate x : annotate_rty call = Annotate x -let abstract_eval_call handler (c : 'a call) : 'a value = - let mkGood x : 'a value = Good (Obj.magic x) in +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) @@ -578,51 +607,51 @@ let abstract_eval_call handler (c : 'a call) : 'a value = | PrintAst x -> mkGood (handler.print_ast x) | Annotate x -> mkGood (handler.annotate x) with any -> - let any = Errors.push any in + let any = CErrors.push any in Fail (handler.handle_exn any) (** brain dead code, edit if protocol messages are added/removed *) -let of_answer (q : 'a call) (v : 'a value) : xml = match q with - | Add _ -> of_value (of_value_type add_rty_t ) (Obj.magic v) - | Edit_at _ -> of_value (of_value_type edit_at_rty_t ) (Obj.magic v) - | Query _ -> of_value (of_value_type query_rty_t ) (Obj.magic v) - | Goal _ -> of_value (of_value_type goals_rty_t ) (Obj.magic v) - | Evars _ -> of_value (of_value_type evars_rty_t ) (Obj.magic v) - | Hints _ -> of_value (of_value_type hints_rty_t ) (Obj.magic v) - | Status _ -> of_value (of_value_type status_rty_t ) (Obj.magic v) - | Search _ -> of_value (of_value_type search_rty_t ) (Obj.magic v) - | GetOptions _ -> of_value (of_value_type get_options_rty_t) (Obj.magic v) - | SetOptions _ -> of_value (of_value_type set_options_rty_t) (Obj.magic v) - | MkCases _ -> of_value (of_value_type mkcases_rty_t ) (Obj.magic v) - | Quit _ -> of_value (of_value_type quit_rty_t ) (Obj.magic v) - | About _ -> of_value (of_value_type about_rty_t ) (Obj.magic v) - | Init _ -> of_value (of_value_type init_rty_t ) (Obj.magic v) - | Interp _ -> of_value (of_value_type interp_rty_t ) (Obj.magic v) - | StopWorker _ -> of_value (of_value_type stop_worker_rty_t) (Obj.magic v) - | PrintAst _ -> of_value (of_value_type print_ast_rty_t ) (Obj.magic v) - | Annotate _ -> of_value (of_value_type annotate_rty_t ) (Obj.magic v) - -let to_answer (q : 'a call) (x : xml) : 'a value = match q with - | Add _ -> Obj.magic (to_value (to_value_type add_rty_t ) x) - | Edit_at _ -> Obj.magic (to_value (to_value_type edit_at_rty_t ) x) - | Query _ -> Obj.magic (to_value (to_value_type query_rty_t ) x) - | Goal _ -> Obj.magic (to_value (to_value_type goals_rty_t ) x) - | Evars _ -> Obj.magic (to_value (to_value_type evars_rty_t ) x) - | Hints _ -> Obj.magic (to_value (to_value_type hints_rty_t ) x) - | Status _ -> Obj.magic (to_value (to_value_type status_rty_t ) x) - | Search _ -> Obj.magic (to_value (to_value_type search_rty_t ) x) - | GetOptions _ -> Obj.magic (to_value (to_value_type get_options_rty_t) x) - | SetOptions _ -> Obj.magic (to_value (to_value_type set_options_rty_t) x) - | MkCases _ -> Obj.magic (to_value (to_value_type mkcases_rty_t ) x) - | Quit _ -> Obj.magic (to_value (to_value_type quit_rty_t ) x) - | About _ -> Obj.magic (to_value (to_value_type about_rty_t ) x) - | Init _ -> Obj.magic (to_value (to_value_type init_rty_t ) x) - | Interp _ -> Obj.magic (to_value (to_value_type interp_rty_t ) x) - | StopWorker _ -> Obj.magic (to_value (to_value_type stop_worker_rty_t) x) - | PrintAst _ -> Obj.magic (to_value (to_value_type print_ast_rty_t ) x) - | Annotate _ -> Obj.magic (to_value (to_value_type annotate_rty_t ) x) - -let of_call (q : 'a call) : xml = +let 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 ) + | 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 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 ) + | 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) @@ -644,59 +673,59 @@ let of_call (q : 'a call) : xml = | 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 = +let to_call : xml -> unknown_call = do_match "call" (fun s a -> let mkCallArg vt a = to_value_type vt (singleton a) in match s with - | "Add" -> Add (mkCallArg add_sty_t a) - | "Edit_at" -> Edit_at (mkCallArg edit_at_sty_t a) - | "Query" -> Query (mkCallArg query_sty_t a) - | "Goal" -> Goal (mkCallArg goals_sty_t a) - | "Evars" -> Evars (mkCallArg evars_sty_t a) - | "Hints" -> Hints (mkCallArg hints_sty_t a) - | "Status" -> Status (mkCallArg status_sty_t a) - | "Search" -> Search (mkCallArg search_sty_t a) - | "GetOptions" -> GetOptions (mkCallArg get_options_sty_t a) - | "SetOptions" -> SetOptions (mkCallArg set_options_sty_t a) - | "MkCases" -> MkCases (mkCallArg mkcases_sty_t a) - | "Quit" -> Quit (mkCallArg quit_sty_t a) - | "About" -> About (mkCallArg about_sty_t a) - | "Init" -> Init (mkCallArg init_sty_t a) - | "Interp" -> Interp (mkCallArg interp_sty_t a) - | "StopWorker" -> StopWorker (mkCallArg stop_worker_sty_t a) - | "PrintAst" -> PrintAst (mkCallArg print_ast_sty_t a) - | "Annotate" -> Annotate (mkCallArg annotate_sty_t a) - | _ -> raise Marshal_error) + | "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)) + | "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^" ["^str^"]" + | Fail (id,None,str) -> "FAIL "^Stateid.to_string id^" ["^Richpp.raw_print str^"]" | Fail (id,Some(i,j),str) -> "FAIL "^Stateid.to_string id^ - " ("^string_of_int i^","^string_of_int j^")["^str^"]" + " ("^string_of_int i^","^string_of_int j^")["^Richpp.raw_print str^"]" let pr_value v = pr_value_gen (fun _ -> "FIXME") v -let pr_full_value call value = match call with - | Add _ -> pr_value_gen (print add_rty_t ) (Obj.magic value) - | Edit_at _ -> pr_value_gen (print edit_at_rty_t ) (Obj.magic value) - | Query _ -> pr_value_gen (print query_rty_t ) (Obj.magic value) - | Goal _ -> pr_value_gen (print goals_rty_t ) (Obj.magic value) - | Evars _ -> pr_value_gen (print evars_rty_t ) (Obj.magic value) - | Hints _ -> pr_value_gen (print hints_rty_t ) (Obj.magic value) - | Status _ -> pr_value_gen (print status_rty_t ) (Obj.magic value) - | Search _ -> pr_value_gen (print search_rty_t ) (Obj.magic value) - | GetOptions _ -> pr_value_gen (print get_options_rty_t) (Obj.magic value) - | SetOptions _ -> pr_value_gen (print set_options_rty_t) (Obj.magic value) - | MkCases _ -> pr_value_gen (print mkcases_rty_t ) (Obj.magic value) - | Quit _ -> pr_value_gen (print quit_rty_t ) (Obj.magic value) - | About _ -> pr_value_gen (print about_rty_t ) (Obj.magic value) - | Init _ -> pr_value_gen (print init_rty_t ) (Obj.magic value) - | Interp _ -> pr_value_gen (print interp_rty_t ) (Obj.magic value) - | StopWorker _ -> pr_value_gen (print stop_worker_rty_t) (Obj.magic value) - | PrintAst _ -> pr_value_gen (print print_ast_rty_t ) (Obj.magic value) - | Annotate _ -> pr_value_gen (print annotate_rty_t ) (Obj.magic value) -let pr_call call = +let 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 + | 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 @@ -731,7 +760,133 @@ let document to_string_fmt = (to_string_fmt (of_value (fun _ -> PCData "b") (Good ()))); Printf.printf "or:\n\n%s\n\nwhere the attributes loc_s and loc_c are optional.\n" (to_string_fmt (of_value (fun _ -> PCData "b") - (Fail (Stateid.initial,Some (15,34),"error message")))); + (Fail (Stateid.initial,Some (15,34),Richpp.richpp_of_string "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_richpp 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_richpp content) + | x -> raise (Marshal_error("message",x)) + +let is_message xml = + try begin match to_message xml with + | Message(l,c,m) -> Some (l,c,m) + | _ -> None + end with | Marshal_error _ -> None + +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) + | "goals", [loc;s] -> Goals (to_loc loc, to_string s) + | "custom", [loc;name;x]-> Custom (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)] + | Goals (loc,s) -> + constructor "feedback_content" "goals" [of_loc loc;of_string s] + | Custom (loc, name, x) -> + constructor "feedback_content" "custom" [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 = function + | Edit id -> ["object","edit"], of_edit_id id + | State 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.id in + let route = string_of_int msg.route in + Element ("feedback", obj @ ["route",route], [id;content]) + +let to_feedback xml = match xml with + | Element ("feedback", ["object","edit";"route",route], [id;content]) -> { + id = Edit(to_edit_id id); + route = int_of_string route; + contents = to_feedback_content content } + | Element ("feedback", ["object","state";"route",route], [id;content]) -> { + id = State(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/xmlprotocol.mli b/ide/xmlprotocol.mli index 2c8ebc655a..1bb9989704 100644 --- a/ide/xmlprotocol.mli +++ b/ide/xmlprotocol.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,7 +13,7 @@ open Xml_datatype type 'a call -type unknown +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 @@ -43,7 +43,7 @@ val protocol_version : string (** * XML data marshalling *) val of_call : 'a call -> xml -val to_call : xml -> unknown call +val to_call : xml -> unknown_call val of_answer : 'a call -> 'a value -> xml val to_answer : 'a call -> xml -> 'a value @@ -56,3 +56,17 @@ val document : (xml -> string) -> unit val pr_call : 'a call -> string val pr_value : 'a value -> string val pr_full_value : 'a call -> 'a value -> string + +(** * Serialization of rich documents *) +val of_richpp : Richpp.richpp -> Xml_datatype.xml +val to_richpp : Xml_datatype.xml -> Richpp.richpp + +(** * Serializaiton of feedback *) +val of_feedback : Feedback.feedback -> xml +val to_feedback : xml -> Feedback.feedback +val is_feedback : xml -> bool + +val is_message : xml -> (Feedback.level * Loc.t option * Richpp.richpp) option +val of_message : Feedback.level -> Loc.t option -> Richpp.richpp -> xml +(* val to_message : xml -> Feedback.message *) + |
