Ident: handle tight prefix symbols inside Ident

src/core/ident.ml

@@ -50,9 +50,10 @@ let attr_compare a1 a2 = Pervasives.compare a1.attr_tag a2.attr_tag
 (** Naming convention *)
 
 type notation =
-  | SNword   of string
-  | SNinfix  of string
-  | SNprefix of string
+  | SNword   of string  (* plus *)
+  | SNinfix  of string  (* + *)
+  | SNtight  of string  (* ! *)
+  | SNprefix of string  (* -_ *)
   | SNget    of string  (* [] *)
   | SNset    of string  (* []<- *)
   | SNupdate of string  (* [<-] *)
@@ -71,35 +72,24 @@ let op_cut    s = "mixfix [..]" ^ s
 let op_lcut   s = "mixfix [.._]" ^ s
 let op_rcut   s = "mixfix [_..]" ^ s
 
-let op_equ  = op_infix "="
-let op_neq  = op_infix "<>"
-
-let sn_encode = function
-  | SNinfix s ->  op_infix s
-  | SNprefix s -> op_prefix s
-  | SNget s ->    op_get s
-  | SNset s ->    op_set s
-  | SNupdate s -> op_update s
-  | SNcut s ->    op_cut s
-  | SNlcut s ->   op_lcut s
-  | SNrcut s ->   op_rcut s
-  | SNword s ->   s
+let op_equ   = op_infix "="
+let op_neq   = op_infix "<>"
+let op_tight = op_prefix
 
 let print_sn fmt w =
   let lspace p = if p.[0] = '*' then " " else "" in
   let rspace p = if p.[String.length p - 1] = '*' then " " else "" in
-  match w with (* infix/prefix never empty, mixfix never have stars *)
-  | SNinfix p ->  Format.fprintf fmt "(%s%s%s)" (lspace p) p (rspace p)
-  | SNprefix p when p.[0] = '!' || p.[0] = '?' ->
-                  Format.fprintf fmt "(%s%s)" p (rspace p)
+  match w with (* infix/prefix never empty, mixfix cannot have stars *)
+  | SNinfix  p -> Format.fprintf fmt "(%s%s%s)" (lspace p) p (rspace p)
+  | SNtight  p -> Format.fprintf fmt "(%s%s)" p (rspace p)
   | SNprefix p -> Format.fprintf fmt "(%s%s_)" (lspace p) p
-  | SNget p ->    Format.fprintf fmt "([]%s)" p
-  | SNset p ->    Format.fprintf fmt "([]%s<-)" p
+  | SNget    p -> Format.fprintf fmt "([]%s)" p
+  | SNset    p -> Format.fprintf fmt "([]%s<-)" p
   | SNupdate p -> Format.fprintf fmt "([<-]%s)" p
-  | SNcut p ->    Format.fprintf fmt "([..]%s)" p
-  | SNlcut p ->   Format.fprintf fmt "([.._]%s)" p
-  | SNrcut p ->   Format.fprintf fmt "([_..]%s)" p
-  | SNword p ->   Format.pp_print_string fmt p
+  | SNcut    p -> Format.fprintf fmt "([..]%s)" p
+  | SNlcut   p -> Format.fprintf fmt "([.._]%s)" p
+  | SNrcut   p -> Format.fprintf fmt "([_..]%s)" p
+  | SNword   p -> Format.pp_print_string fmt p
 
 (* The function below recognizes the following strings as notations:
       "infix " (opchar+ [']* as p) (['_] [^'_] .* as q)
@@ -132,8 +122,10 @@ let sn_decode s =
     if i = l || s.[i] = '_' then i else pred i in
   let m = skip_quote l in
   if l = k && k < 8 then SNword s (* null infix/prefix *) else
-  let w = if k = 6 then SNinfix  (String.sub s 6 (m - 6)) else
-          if k = 7 then SNprefix (String.sub s 7 (m - 7)) else
+  let w = if k = 6 then SNinfix (String.sub s 6 (m - 6)) else
+          if k = 7 then let op = String.sub s 7 (m - 7) in
+                        if s.[7] = '!' || s.[7] = '?' then
+                          SNtight op else SNprefix op else
           let p = if l < m then String.sub s l (m - l) else "" in
           match String.sub s 8 (l - 8) with
           | "]"   -> SNget p | "]<-"  -> SNset p  | "<-]"  -> SNupdate p
@@ -224,19 +216,12 @@ let find_unique indices name =
   let specname ind =
     (* If the symbol is infix/prefix *and* the name has not been
        sanitized for provers, we don't want to disambiguate with
-       a number but with a symbol: "+" becomes "+'" "+''" etc.
+       a number but with a quote symbol: "+" becomes "+'" "+''" etc.
        This allows to parse the ident again (for transformations). *)
     if ind <= 0 then name else
     match sn_decode name with
-    | SNinfix s -> op_infix (s ^ String.make ind '\'')
-    | SNprefix s -> op_prefix (s ^ String.make ind '\'')
-    | SNget s -> op_get (s ^ String.make ind '\'')
-    | SNset s -> op_set (s ^ String.make ind '\'')
-    | SNupdate s -> op_update (s ^ String.make ind '\'')
-    | SNcut s -> op_cut (s ^ String.make ind '\'')
-    | SNlcut s -> op_lcut (s ^ String.make ind '\'')
-    | SNrcut s -> op_rcut (s ^ String.make ind '\'')
-    | SNword _ -> name ^ string_of_int ind in
+    | SNword _ -> name ^ string_of_int ind
+    | _        -> name ^ String.make ind '\'' in
   let testname ind = Hstr.mem indices (specname ind) in
   let rec advance ind =
     if testname ind then advance (succ ind) else ind in

src/core/ident.mli

@@ -32,9 +32,10 @@ val list_attributes : unit -> string list
 (** {2 Naming convention} *)
 
 type notation =
-  | SNword   of string
-  | SNinfix  of string
-  | SNprefix of string
+  | SNword   of string  (* plus *)
+  | SNinfix  of string  (* + *)
+  | SNtight  of string  (* ! *)
+  | SNprefix of string  (* -_ *)
   | SNget    of string  (* [] *)
   | SNset    of string  (* []<- *)
   | SNupdate of string  (* [<-] *)
@@ -42,18 +43,8 @@ type notation =
   | SNlcut   of string  (* [.._] *)
   | SNrcut   of string  (* [_..] *)
 
-val sn_encode : notation -> string
-(* encode the symbol name as a string *)
-
-val sn_decode : string -> notation
-(* decode the string as a symbol name *)
-
-val print_decoded : Format.formatter -> string -> unit
-(* decode the string as a symbol name and pretty-print it *)
-
-(* specialized encoders *)
-
 val op_infix  : string -> string
+val op_tight  : string -> string
 val op_prefix : string -> string
 val op_get    : string -> string
 val op_set    : string -> string
@@ -64,6 +55,12 @@ val op_rcut   : string -> string
 val op_equ    : string
 val op_neq    : string
 
+val sn_decode : string -> notation
+(* decode the string as a symbol name *)
+
+val print_decoded : Format.formatter -> string -> unit
+(* decode the string as a symbol name and pretty-print it *)
+
 (** {2 Identifiers} *)
 
 type ident = private {

src/core/pretty.ml

@@ -131,11 +131,6 @@ let print_vs fmt vs =
 
 let forget_var vs = forget_id iprinter vs.vs_name
 
-(* pretty-print infix and prefix logic symbols *)
-
-let tight_op s =
-  s <> "" && (let c = String.get s 0 in c = '!' || c = '?')
-
 (* theory names always start with an upper case letter *)
 let print_th fmt th =
   let sanitizer = Strings.capitalize in
@@ -256,7 +251,7 @@ and print_app pri ls fmt tl =
   if tl = [] then print_ls fmt ls else
   let s = id_unique iprinter ls.ls_name in
   match Ident.sn_decode s, tl with
-  | Ident.SNprefix s, [t1] when tight_op s ->
+  | Ident.SNtight s, [t1] ->
       fprintf fmt (protect_on (pri > 8) "@[%s%a@]")
         s (print_lterm 8) t1
   | Ident.SNprefix s, [t1] ->

src/mlw/expr.ml

@@ -1171,9 +1171,6 @@ let forget_let_defn = function
   | LDsym (s,_) -> forget_rs s
   | LDrec rdl -> List.iter (fun fd -> forget_rs fd.rec_sym) rdl
 
-let tight_op s =
-  s <> "" && (let c = String.get s 0 in c = '!' || c = '?')
-
 let print_rs fmt s = match s.rs_logic with
   | RLnone | RLlemma ->
       Ident.print_decoded fmt (id_unique sprinter s.rs_name)
@@ -1231,7 +1228,7 @@ let print_capp pri s fmt vl =
   if vl = [] then print_rs fmt s else
   let p = id_unique sprinter s.rs_name in
   match Ident.sn_decode p, vl with
-  | Ident.SNprefix o, [t1] when tight_op o ->
+  | Ident.SNtight o, [t1] ->
       fprintf fmt (protect_on (pri > 7) "%s%a") o print_pv t1
   | Ident.SNprefix o, [t1] ->
       fprintf fmt (protect_on (pri > 4) "%s %a") o print_pv t1