src/Pure/name.ML
changeset 28860 b1d46059d502
parent 28821 78a6ed46ad04
child 28863 32e83a854e5e
equal deleted inserted replaced
28859:d50b523c55db 28860:b1d46059d502
    26   val names: context -> string -> 'a list -> (string * 'a) list
    26   val names: context -> string -> 'a list -> (string * 'a) list
    27   val invent_list: string list -> string -> int -> string list
    27   val invent_list: string list -> string -> int -> string list
    28   val variants: string list -> context -> string list * context
    28   val variants: string list -> context -> string list * context
    29   val variant_list: string list -> string list -> string list
    29   val variant_list: string list -> string list -> string list
    30   val variant: string list -> string -> string
    30   val variant: string list -> string -> string
    31   type binding
    31 
    32   val binding_pos: string * Position.T -> binding
    32   include NAME_BINDING
    33   val binding: string -> binding
       
    34   val no_binding: binding
       
    35   val prefix_of: binding -> (string * bool) list
       
    36   val name_of: binding -> string
       
    37   val name_with_prefix: binding -> string (*FIXME*)
       
    38   val is_nothing: binding -> bool
       
    39   val pos_of: binding -> Position.T
       
    40   val add_prefix: bool -> string -> binding -> binding
    33   val add_prefix: bool -> string -> binding -> binding
    41   val map_prefix: ((string * bool) list -> binding -> binding) -> binding -> binding
    34   val map_prefix: ((string * bool) list -> binding -> binding) -> binding -> binding
    42   val map_name: (string -> string) -> binding -> binding
    35   val name_of: binding -> string (*FIMXE legacy*)
    43   val qualified: string -> binding -> binding
    36   val map_name: (string -> string) -> binding -> binding (*FIMXE legacy*)
    44   val namify: NameSpace.naming -> binding -> NameSpace.naming * string
    37   val qualified: string -> binding -> binding (*FIMXE legacy*)
    45   val output: binding -> string
    38   val display: binding -> string
       
    39   val namify: NameSpace.naming -> binding -> NameSpace.naming * string (*FIMXE legacy*)
    46 end;
    40 end;
    47 
    41 
    48 structure Name: NAME =
    42 structure Name: NAME =
    49 struct
    43 struct
       
    44 
       
    45 open NameSpace;
    50 
    46 
    51 (** common defaults **)
    47 (** common defaults **)
    52 
    48 
    53 val uu = "uu";
    49 val uu = "uu";
    54 val aT = "'a";
    50 val aT = "'a";
   153 
   149 
   154 fun variant_list used names = #1 (make_context used |> variants names);
   150 fun variant_list used names = #1 (make_context used |> variants names);
   155 fun variant used = singleton (variant_list used);
   151 fun variant used = singleton (variant_list used);
   156 
   152 
   157 
   153 
   158 
       
   159 (** generic name bindings **)
   154 (** generic name bindings **)
   160 
   155 
   161 datatype binding = Binding of ((string * bool) list * string) * Position.T;
   156 fun add_prefix sticky prfx b = if prfx = "" then error "empty name prefix"
       
   157   else (map_binding o apfst) (cons (prfx, sticky)) b;
   162 
   158 
   163 fun prefix_of (Binding ((prefix, _), _)) = prefix;
   159 val prefix_of = fst o dest_binding;
   164 fun name_of (Binding ((_, name), _)) = name;
   160 val name_of = snd o dest_binding;
   165 fun pos_of (Binding (_, pos)) = pos;
   161 val map_name = map_binding o apsnd;
   166 
       
   167 fun binding_pos (name, pos) = Binding (([], name), pos);
       
   168 fun binding name = binding_pos (name, Position.none);
       
   169 val no_binding = binding "";
       
   170 
       
   171 fun map_binding f (Binding bnd) = Binding (f bnd);
       
   172 
       
   173 fun add_prefix sticky prfx binding = if prfx = "" then error "empty name prefix"
       
   174   else (map_binding o apfst o apfst) (cons (prfx, sticky)) binding;
       
   175 
       
   176 fun map_prefix f (Binding ((prefix, name), pos)) =
       
   177   f prefix (binding_pos (name, pos));
       
   178 
       
   179 val map_name = map_binding o apfst o apsnd;
       
   180 val qualified = map_name o NameSpace.qualified;
   162 val qualified = map_name o NameSpace.qualified;
   181 
   163 
   182 fun is_nothing (Binding ((_, name), _)) = name = "";
   164 fun map_prefix f b =
       
   165   let
       
   166     val (prefix, name) = dest_binding b;
       
   167     val pos = pos_of b;
       
   168   in f prefix (binding_pos (name, pos)) end;
   183 
   169 
   184 fun name_with_prefix (Binding ((prefix, name), _)) =
   170 fun namify naming b =
   185   NameSpace.implode (map_filter
   171   let
   186     (fn (prfx, sticky) => if sticky then SOME prfx else NONE) prefix @ [name]);
   172     val (prefix, name) = dest_binding b
       
   173     fun mk_prefix (prfx, true) = sticky_prefix prfx
       
   174       | mk_prefix (prfx, false) = add_path prfx;
       
   175     val naming' = fold mk_prefix prefix naming;
       
   176   in (naming', full naming' name) end;
   187 
   177 
   188 fun namify naming (Binding ((prefix, name), _)) =
   178 fun display b =
   189   let
   179   let
   190     fun mk_prefix (prfx, true) = NameSpace.sticky_prefix prfx
   180     val (prefix, name) = dest_binding b
   191       | mk_prefix (prfx, false) = NameSpace.add_path prfx;
   181     fun mk_prefix (prfx, true) = prfx
   192     val naming' = fold mk_prefix prefix naming;
   182       | mk_prefix (prfx, false) = enclose "(" ")" prfx
   193   in (naming', NameSpace.full naming' name) end;
   183   in if not (! NameSpace.long_names) orelse null prefix orelse name = "" then name
   194 
   184     else NameSpace.implode (map mk_prefix prefix) ^ ":" ^ name
   195 fun output (Binding ((prefix, name), _)) =
   185   end;
   196   if null prefix orelse name = "" then name
       
   197   else NameSpace.implode (map fst prefix) ^ " / " ^ name;
       
   198 
   186 
   199 end;
   187 end;