semantic completion for @{system_option};
authorwenzelm
Wed, 25 Mar 2015 14:39:40 +0100
changeset 59812 675d0c692c41
parent 59811 6b0d9e8ac227
child 59813 6320064f22bb
semantic completion for @{system_option};
src/Pure/General/completion.ML
src/Pure/General/name_space.ML
src/Pure/ML/ml_antiquotations.ML
src/Pure/System/options.ML
--- a/src/Pure/General/completion.ML	Wed Mar 25 13:45:52 2015 +0100
+++ b/src/Pure/General/completion.ML	Wed Mar 25 14:39:40 2015 +0100
@@ -9,6 +9,7 @@
   type T
   val names: Position.T -> (string * (string * string)) list -> T
   val none: T
+  val make: string * Position.T -> ((string -> bool) -> (string * (string * string)) list) -> T
   val reported_text: T -> string
   val suppress_abbrevs: string -> Markup.T list
 end;
@@ -16,12 +17,12 @@
 structure Completion: COMPLETION =
 struct
 
+(* completion of names *)
+
 abstype T =
   Completion of {pos: Position.T, total: int, names: (string * (string * string)) list}
 with
 
-(* completion of names *)
-
 fun dest (Completion args) = args;
 
 fun names pos names =
@@ -34,6 +35,11 @@
 
 val none = names Position.none [];
 
+fun make (name, pos) make_names =
+  if Position.is_reported pos andalso name <> "" andalso name <> "_"
+  then names pos (make_names (String.isPrefix (Name.clean name)))
+  else none;
+
 fun reported_text completion =
   let val {pos, total, names} = dest completion in
     if Position.is_reported pos andalso not (null names) then
--- a/src/Pure/General/name_space.ML	Wed Mar 25 13:45:52 2015 +0100
+++ b/src/Pure/General/name_space.ML	Wed Mar 25 14:39:40 2015 +0100
@@ -232,7 +232,7 @@
 (* completion *)
 
 fun completion context space (xname, pos) =
-  if Position.is_reported pos andalso xname <> "" andalso xname <> "_" then
+  Completion.make (xname, pos) (fn completed =>
     let
       fun result_ord ((xname1, (_, name1)), (xname2, (_, name2))) =
         (case bool_ord (apply2 Long_Name.is_local (name2, name1)) of
@@ -241,21 +241,18 @@
               EQUAL => string_ord (xname1, xname2)
             | ord => ord)
         | ord => ord);
-      val x = Name.clean xname;
       val Name_Space {kind, internals, ...} = space;
       val ext = extern_shortest (Context.proof_of context) space;
-      val names =
-        Change_Table.fold
-          (fn (a, (name :: _, _)) =>
-              if String.isPrefix x a andalso not (is_concealed space name)
-              then
-                let val a' = ext name
-                in if a = a' then cons (a', (kind, name)) else I end
-              else I
-            | _ => I) internals []
-        |> sort_distinct result_ord;
-    in Completion.names pos names end
-  else Completion.none;
+    in
+      Change_Table.fold
+        (fn (a, (name :: _, _)) =>
+            if completed a andalso not (is_concealed space name) then
+              let val a' = ext name
+              in if a = a' then cons (a', (kind, name)) else I end
+            else I
+          | _ => I) internals []
+      |> sort_distinct result_ord
+    end);
 
 
 (* merge *)
--- a/src/Pure/ML/ml_antiquotations.ML	Wed Mar 25 13:45:52 2015 +0100
+++ b/src/Pure/ML/ml_antiquotations.ML	Wed Mar 25 14:39:40 2015 +0100
@@ -37,8 +37,19 @@
 val _ = Theory.setup
  (ML_Antiquotation.value @{binding system_option}
     (Args.context -- Scan.lift (Parse.position Args.name) >> (fn (ctxt, (name, pos)) =>
-      (Context_Position.report ctxt pos (Options.default_markup (name, pos));
-        ML_Syntax.print_string name))) #>
+      let
+        val markup =
+          Options.default_markup (name, pos) handle ERROR msg =>
+            let
+              val completion =
+                Completion.make (name, pos) (fn completed =>
+                    Options.names (Options.default ())
+                    |> filter completed
+                    |> map (fn a => (a, ("system_option", a))));
+              val report = Markup.markup_report (Completion.reported_text completion);
+            in cat_error msg report end;
+        val _ = Context_Position.report ctxt pos markup;
+      in ML_Syntax.print_string name end)) #>
 
   ML_Antiquotation.value @{binding theory}
     (Args.context -- Scan.lift (Parse.position Args.name) >> (fn (ctxt, (name, pos)) =>
--- a/src/Pure/System/options.ML	Wed Mar 25 13:45:52 2015 +0100
+++ b/src/Pure/System/options.ML	Wed Mar 25 14:39:40 2015 +0100
@@ -13,6 +13,7 @@
   val unknownT: string
   type T
   val empty: T
+  val names: T -> string list
   val markup: T -> string * Position.T -> Markup.T
   val typ: T -> string -> string
   val bool: T -> string -> bool
@@ -59,6 +60,8 @@
 
 val empty = Options Symtab.empty;
 
+fun names (Options tab) = sort_strings (Symtab.keys tab);
+
 
 (* check *)