reject internal term names outright, and complete consts instead;
authorwenzelm
Thu Mar 06 16:12:26 2014 +0100 (2014-03-06)
changeset 5595694d384d621b0
parent 55955 e8f1bf005661
child 55957 cffb46aea3d1
reject internal term names outright, and complete consts instead;
more general Name_Space.check_reports;
more compact Markup.markup_report;
src/Pure/General/name_space.ML
src/Pure/Isar/args.ML
src/Pure/Isar/proof_context.ML
src/Pure/PIDE/markup.ML
src/Pure/Syntax/syntax_phases.ML
src/Pure/consts.ML
src/Pure/type.ML
     1.1 --- a/src/Pure/General/name_space.ML	Thu Mar 06 14:38:54 2014 +0100
     1.2 +++ b/src/Pure/General/name_space.ML	Thu Mar 06 16:12:26 2014 +0100
     1.3 @@ -56,7 +56,7 @@
     1.4    val declare: Context.generic -> bool -> binding -> T -> string * T
     1.5    type 'a table = T * 'a Symtab.table
     1.6    val check_reports: Context.generic -> 'a table ->
     1.7 -    xstring * Position.T -> (string * Position.report list) * 'a
     1.8 +    xstring * Position.T list -> (string * Position.report list) * 'a
     1.9    val check: Context.generic -> 'a table -> xstring * Position.T -> string * 'a
    1.10    val get: 'a table -> string -> 'a
    1.11    val define: Context.generic -> bool -> binding * 'a -> 'a table -> string * 'a table
    1.12 @@ -446,24 +446,27 @@
    1.13  
    1.14  type 'a table = T * 'a Symtab.table;
    1.15  
    1.16 -fun check_reports context (space, tab) (xname, pos) =
    1.17 +fun check_reports context (space, tab) (xname, ps) =
    1.18    let val name = intern space xname in
    1.19      (case Symtab.lookup tab name of
    1.20        SOME x =>
    1.21          let
    1.22            val reports =
    1.23 -            if Context_Position.is_reported_generic context pos
    1.24 -            then [(pos, markup space name)] else [];
    1.25 +            filter (Context_Position.is_reported_generic context) ps
    1.26 +            |> map (fn pos => (pos, markup space name));
    1.27          in ((name, reports), x) end
    1.28      | NONE =>
    1.29 -        error (undefined (kind_of space) name ^ Position.here pos ^
    1.30 -          Markup.markup Markup.report
    1.31 -            (Completion.reported_text (completion context space (xname, pos)))))
    1.32 +        let
    1.33 +          val completions = map (fn pos => completion context space (xname, pos)) ps;
    1.34 +        in
    1.35 +          error (undefined (kind_of space) name ^ Position.here_list ps ^
    1.36 +            implode (map (Markup.markup_report o Completion.reported_text) completions))
    1.37 +        end)
    1.38    end;
    1.39  
    1.40 -fun check context table arg =
    1.41 +fun check context table (xname, pos) =
    1.42    let
    1.43 -    val ((name, reports), x) = check_reports context table arg;
    1.44 +    val ((name, reports), x) = check_reports context table (xname, [pos]);
    1.45      val _ = Position.reports reports;
    1.46    in (name, x) end;
    1.47  
     2.1 --- a/src/Pure/Isar/args.ML	Thu Mar 06 14:38:54 2014 +0100
     2.2 +++ b/src/Pure/Isar/args.ML	Thu Mar 06 16:12:26 2014 +0100
     2.3 @@ -299,7 +299,7 @@
     2.4      | (_, (_, args2)) =>
     2.5          error ("Bad arguments for " ^ kind ^ " " ^ quote s ^ Position.here pos ^
     2.6            (if null args2 then "" else ":\n  " ^ space_implode " " (map Token.print args2)) ^
     2.7 -          Markup.markup Markup.report (reported_text ())))
     2.8 +          Markup.markup_report (reported_text ())))
     2.9    end;
    2.10  
    2.11  fun context_syntax kind scan src =
     3.1 --- a/src/Pure/Isar/proof_context.ML	Thu Mar 06 14:38:54 2014 +0100
     3.2 +++ b/src/Pure/Isar/proof_context.ML	Thu Mar 06 16:12:26 2014 +0100
     3.3 @@ -71,6 +71,7 @@
     3.4    val check_type_name: Proof.context -> {proper: bool, strict: bool} ->
     3.5      xstring * Position.T -> typ * Position.report list
     3.6    val read_type_name: Proof.context -> {proper: bool, strict: bool} -> string -> typ
     3.7 +  val consts_completion_message: Proof.context -> xstring * Position.T list -> string
     3.8    val check_const: Proof.context -> {proper: bool, strict: bool} ->
     3.9      xstring * Position.T -> term * Position.report list
    3.10    val read_const: Proof.context -> {proper: bool, strict: bool} -> string -> term
    3.11 @@ -384,9 +385,8 @@
    3.12      val name = Type.cert_class tsig (Type.intern_class tsig xname)
    3.13        handle TYPE (msg, _, _) =>
    3.14          error (msg ^ Position.here pos ^
    3.15 -          Markup.markup Markup.report
    3.16 -            (Completion.reported_text
    3.17 -              (Name_Space.completion (Context.Proof ctxt) class_space (xname, pos))));
    3.18 +          Markup.markup_report (Completion.reported_text
    3.19 +            (Name_Space.completion (Context.Proof ctxt) class_space (xname, pos))));
    3.20      val reports =
    3.21        if Context_Position.is_reported ctxt pos
    3.22        then [(pos, Name_Space.markup class_space name)] else [];
    3.23 @@ -469,8 +469,18 @@
    3.24  
    3.25  (* constant names *)
    3.26  
    3.27 +fun consts_completion_message ctxt (c, ps) =
    3.28 +  ps |> map (fn pos =>
    3.29 +    Name_Space.completion (Context.Proof ctxt) (Consts.space_of (consts_of ctxt)) (c, pos)
    3.30 +    |> Completion.reported_text)
    3.31 +  |> implode
    3.32 +  |> Markup.markup_report;
    3.33 +
    3.34  fun check_const ctxt {proper, strict} (c, pos) =
    3.35    let
    3.36 +    val _ =
    3.37 +      Name.reject_internal (c, [pos]) handle ERROR msg =>
    3.38 +        error (msg ^ consts_completion_message ctxt (c, [pos]));
    3.39      fun err msg = error (msg ^ Position.here pos);
    3.40      val consts = consts_of ctxt;
    3.41      val fixed = if proper then NONE else Variable.lookup_fixed ctxt c;
    3.42 @@ -478,7 +488,6 @@
    3.43        (case (fixed, Variable.lookup_const ctxt c) of
    3.44          (SOME x, NONE) =>
    3.45            let
    3.46 -            val _ = Name.reject_internal (c, [pos]);
    3.47              val reports =
    3.48                if Context_Position.is_reported ctxt pos then
    3.49                  [(pos, Markup.name x (if Name.is_skolem x then Markup.skolem else Markup.free))]
    3.50 @@ -491,7 +500,7 @@
    3.51                if Context_Position.is_reported ctxt pos
    3.52                then [(pos, Name_Space.markup (Consts.space_of consts) d)] else [];
    3.53            in (Const (d, T), reports) end
    3.54 -      | _ => Consts.check_const (Context.Proof ctxt) consts (c, pos));
    3.55 +      | _ => Consts.check_const (Context.Proof ctxt) consts (c, [pos]));
    3.56      val _ =
    3.57        (case (strict, t) of
    3.58          (true, Const (d, _)) =>
     4.1 --- a/src/Pure/PIDE/markup.ML	Thu Mar 06 14:38:54 2014 +0100
     4.2 +++ b/src/Pure/PIDE/markup.ML	Thu Mar 06 16:12:26 2014 +0100
     4.3 @@ -189,6 +189,7 @@
     4.4    val enclose: T -> Output.output -> Output.output
     4.5    val markup: T -> string -> string
     4.6    val markup_only: T -> string
     4.7 +  val markup_report: string -> string
     4.8  end;
     4.9  
    4.10  structure Markup: MARKUP =
    4.11 @@ -602,4 +603,7 @@
    4.12  
    4.13  fun markup_only m = markup m "";
    4.14  
    4.15 +fun markup_report "" = ""
    4.16 +  | markup_report txt = markup report txt;
    4.17 +
    4.18  end;
     5.1 --- a/src/Pure/Syntax/syntax_phases.ML	Thu Mar 06 14:38:54 2014 +0100
     5.2 +++ b/src/Pure/Syntax/syntax_phases.ML	Thu Mar 06 16:12:26 2014 +0100
     5.3 @@ -274,14 +274,15 @@
     5.4                      val _ = report ps (markup_const ctxt) c;
     5.5                    in Const (c, T) end)
     5.6            | decode ps _ _ (Free (a, T)) =
     5.7 -              (Name.reject_internal (a, ps);
     5.8 -               case (get_free a, get_const a) of
     5.9 -                (SOME x, _) => (report ps (markup_free ctxt) x; Free (x, T))
    5.10 -              | (_, (true, c)) => (report ps (markup_const ctxt) c; Const (c, T))
    5.11 -              | (_, (false, c)) =>
    5.12 -                  if Long_Name.is_qualified c
    5.13 -                  then (report ps (markup_const ctxt) c; Const (c, T))
    5.14 -                  else (report ps (markup_free ctxt) c; Free (c, T)))
    5.15 +              ((Name.reject_internal (a, ps) handle ERROR msg =>
    5.16 +                  error (msg ^ Proof_Context.consts_completion_message ctxt (a, ps)));
    5.17 +                (case (get_free a, get_const a) of
    5.18 +                  (SOME x, _) => (report ps (markup_free ctxt) x; Free (x, T))
    5.19 +                | (_, (true, c)) => (report ps (markup_const ctxt) c; Const (c, T))
    5.20 +                | (_, (false, c)) =>
    5.21 +                    if Long_Name.is_qualified c
    5.22 +                    then (report ps (markup_const ctxt) c; Const (c, T))
    5.23 +                    else (report ps (markup_free ctxt) c; Free (c, T))))
    5.24            | decode ps _ _ (Var (xi, T)) = (report ps markup_var xi; Var (xi, T))
    5.25            | decode ps _ bs (t as Bound i) =
    5.26                (case try (nth bs) i of
    5.27 @@ -322,8 +323,7 @@
    5.28  
    5.29      val pts = Syntax.parse syn root (filter Lexicon.is_proper toks)
    5.30        handle ERROR msg =>
    5.31 -        error (msg ^
    5.32 -          implode (map (Markup.markup Markup.report o Lexicon.reported_token_range ctxt) toks));
    5.33 +        error (msg ^ implode (map (Markup.markup_report o Lexicon.reported_token_range ctxt) toks));
    5.34      val len = length pts;
    5.35  
    5.36      val limit = Config.get ctxt Syntax.ambiguity_limit;
    5.37 @@ -355,7 +355,7 @@
    5.38  
    5.39  fun parse_failed ctxt pos msg kind =
    5.40    cat_error msg ("Failed to parse " ^ kind ^
    5.41 -    Markup.markup Markup.report (Context_Position.reported_text ctxt pos Markup.bad ""));
    5.42 +    Markup.markup_report (Context_Position.reported_text ctxt pos Markup.bad ""));
    5.43  
    5.44  fun parse_sort ctxt =
    5.45    Syntax.parse_token ctxt Term_XML.Decode.sort Markup.language_sort
     6.1 --- a/src/Pure/consts.ML	Thu Mar 06 14:38:54 2014 +0100
     6.2 +++ b/src/Pure/consts.ML	Thu Mar 06 16:12:26 2014 +0100
     6.3 @@ -25,7 +25,7 @@
     6.4    val extern: Proof.context -> T -> string -> xstring
     6.5    val intern_syntax: T -> xstring -> string
     6.6    val extern_syntax: Proof.context -> T -> string -> xstring
     6.7 -  val check_const: Context.generic -> T -> xstring * Position.T -> term * Position.report list
     6.8 +  val check_const: Context.generic -> T -> xstring * Position.T list -> term * Position.report list
     6.9    val certify: Context.pretty -> Type.tsig -> bool -> T -> term -> term  (*exception TYPE*)
    6.10    val typargs: T -> string * typ -> typ list
    6.11    val instance: T -> string * typ list -> typ
    6.12 @@ -143,11 +143,11 @@
    6.13  
    6.14  (* check_const *)
    6.15  
    6.16 -fun check_const context consts (xname, pos) =
    6.17 +fun check_const context consts (xname, ps) =
    6.18    let
    6.19      val Consts {decls, ...} = consts;
    6.20 -    val ((c, reports), _) = Name_Space.check_reports context decls (xname, pos);
    6.21 -    val T = type_scheme consts c handle TYPE (msg, _, _) => error (msg ^ Position.here pos);
    6.22 +    val ((c, reports), _) = Name_Space.check_reports context decls (xname, ps);
    6.23 +    val T = type_scheme consts c handle TYPE (msg, _, _) => error (msg ^ Position.here_list ps);
    6.24    in (Const (c, T), reports) end;
    6.25  
    6.26  
     7.1 --- a/src/Pure/type.ML	Thu Mar 06 14:38:54 2014 +0100
     7.2 +++ b/src/Pure/type.ML	Thu Mar 06 16:12:26 2014 +0100
     7.3 @@ -259,7 +259,8 @@
     7.4  
     7.5  fun lookup_type (TSig {types = (_, types), ...}) = Symtab.lookup types;
     7.6  
     7.7 -fun check_decl context (TSig {types, ...}) = Name_Space.check_reports context types;
     7.8 +fun check_decl context (TSig {types, ...}) (c, pos) =
     7.9 +  Name_Space.check_reports context types (c, [pos]);
    7.10  
    7.11  fun the_decl tsig (c, pos) =
    7.12    (case lookup_type tsig c of