Fix bug and generalise.

This commit fixes a regression introduced by the previous commit,
wherein numeric labels wouldn't get looked up correctly in
`Label.{Map,Set}`.

This commit also generalises `fresh` such that it can be used locally
within a binding context. Furthermore, it changes the syntax such that
it no longer introduces encloses a list of bindings, but instead uses
the standard block-structured scope of Links.

core/desugarLabels.ml

@@ -4,7 +4,7 @@ open Sugartypes
 module Env = Label.Env
 
 let visitor =
-    object (self)
+    object (_self)
     inherit SugarTraversals.map as super
 
     val mutable label_env : Env.t = Env.empty
@@ -18,12 +18,10 @@ let visitor =
             | _             -> failwith ("The local label " ^ Label.show lbl ^ " is not bound")
 
     method! bindingnode = function
-        | FreshLabel (labels, decls) ->
+        | FreshLabel labels ->
             let labels = List.map Label.bind_local labels in
             label_env <- Env.bind_labels labels label_env ;
-            let decls = List.map self#binding decls in
-            label_env <- Env.unbind_labels labels label_env ;
-            FreshLabel(labels, decls)
+            FreshLabel labels
         | b -> super#bindingnode b
 
     end
@@ -33,9 +31,11 @@ let program p = visitor#program p
 let sentence = function
   | Definitions bs ->
       let bs' = visitor#list (fun o b -> o#binding b) bs in
-        Definitions bs'
-  | Expression  p  -> Expression p
-  | Directive   d  -> Directive d
+      Definitions bs'
+  | Expression p ->
+      let p' = visitor#phrase p in
+      Expression p'
+  | Directive d -> Directive d
 
 module Untyped = struct
     open Transform.Untyped

core/label.ml

@@ -1,6 +1,13 @@
 open Utility
 open CommonTypes
 
+let show_unique_labels_idents =
+  Settings.(flag ~default:false "show_unique_labels_idents"
+            |> privilege `User
+            |> synopsis "Show the internal numeric identifier for each unique label"
+            |> convert parse_bool
+            |> sync)
+
 let internal_error message =
   Errors.internal_error ~filename:"label.ml" ~message
 let local_error show lbl =
@@ -43,7 +50,10 @@ module Label = struct
     type label = t
 
     let show = function
-        | Local (name, id) -> "`" ^ name ^ "<" ^ Uid.show id ^ ">"
+        | Local (name, id) ->
+          if Settings.get show_unique_labels_idents
+          then Printf.sprintf "`%s<%s>" name (Uid.show id)
+          else Printf.sprintf "`%s" name
         | Global name -> name
         | Number n -> string_of_int n
 
@@ -54,21 +64,25 @@ module Label = struct
         | Number n -> string_of_int n
       end
 
-    let make_local ?(uid=Uid.Free) name = Local (name, uid)
-
-    let make_global name = Global name
-
-    let make ?(local=false) name =
-        if local
-        then make_local name
-        else make_global name
-
     let of_int i = Number i
 
     let to_int = function
         | Number n -> n
+        | Global i -> int_of_string i
         | l -> raise (local_error show l)
 
+    let make_local ?(uid=Uid.Free) name = Local (name, uid)
+
+    let make_global name = Global name
+
+    let make textual_name =
+      let is_digit ch =
+        Char.code ch >= 48 && Char.code ch <= 57
+      in
+      if String.for_all is_digit textual_name
+      then of_int (int_of_string textual_name)
+      else make_global textual_name
+
     let name = function
         | Local (name,_) ->  "`"^name
         | Global name -> name
@@ -79,9 +93,12 @@ module Label = struct
         | Local (_, uid), Local (_, uid') -> Uid.compare uid uid'
         | Global g, Global g' -> String.compare g g'
         | Local _, Global _ -> 1
-        | Number n, Number n' -> Int.compare n n'
         | Local _, Number _ -> 1
-        | _, _ -> -1
+        | Global _, Number _ -> 1
+        | Number _, Global _ -> -1
+        | Number _, Local _ -> -1
+        | Global _, Local _ -> -1
+        | Number n, Number m -> Int.compare n m
 
     let equal lbl lbl' = compare lbl lbl' = 0
 
@@ -109,8 +126,8 @@ module Label = struct
         | None         , Local (name, _)        -> Local (name, Uid.new_uid ())
         | _ -> raise (not_local_error show lbl)
 
-    let one = Number 1
-    let two = Number 2
+    let one = of_int 1
+    let two = of_int 2
     let return = make_global "return"
 end
 

core/label.mli

@@ -1,11 +1,11 @@
-open CommonTypes
+val show_unique_labels_idents : bool Settings.setting
 
 module Uid : sig
   type t = Id of Int.t | Free
 end
 
-type local = Name.t * Uid.t
-type global = Name.t
+type local = string * Uid.t
+type global = string
 
 type t =
     | Local of local
@@ -14,18 +14,18 @@ type t =
    [@@deriving show]
 type label = t
 
-val make_local : ?uid:Uid.t -> Name.t -> t
-val make_global : Name.t -> t
-val make : ?local:bool -> Name.t -> t
+val make_local : ?uid:Uid.t -> string -> t
+val make_global : string -> t
+val make : string -> t
 
 val of_int : Int.t -> t
 val to_int : t -> Int.t
-val name : t -> Name.t
+val name : t -> string
 
 val compare : t -> t -> int
 val equal : t -> t -> bool
 val textual_equal : t -> t -> bool
-val name_is : t -> Name.t -> bool
+val name_is : t -> string -> bool
 
 val is_local : t -> bool
 val is_global : t -> bool

core/parser.mly

@@ -300,7 +300,7 @@ let parse_foreign_language pos lang =
 
 let any = any_pat dp
 let local_label = Label.make_local
-let label = Label.make_global
+let label = Label.make
 %}
 
 %token EOF
@@ -456,8 +456,7 @@ nofun_declaration:
 | typedecl SEMICOLON                                           { $1 }
 | links_module | links_open SEMICOLON                          { $1 }
 | pollute = boption(OPEN) IMPORT CONSTRUCTOR SEMICOLON         { import ~ppos:$loc($2) ~pollute [$3] }
-| FRESH separated_nonempty_list(COMMA, BTCONSTRUCTOR)
-    LBRACE declarations RBRACE                                 { with_pos $loc (FreshLabel(List.map local_label $2, $4))}
+| FRESH separated_nonempty_list(COMMA, BTCONSTRUCTOR) SEMICOLON { with_pos $loc (FreshLabel (List.map local_label $2))}
 
 alien_datatype:
 | VARIABLE COLON datatype SEMICOLON                            { (binder ~ppos:$loc($1) $1, datatype $3) }
@@ -983,6 +982,7 @@ binding:
 | fun_kind VARIABLE arg_lists perhaps_location switch_funlit_body               { switch_fun_binding ~ppos:$loc None ($1, $2, $3, $4, $5) }
 | typedecl SEMICOLON | links_module
 | links_open SEMICOLON                                         { $1 }
+| FRESH separated_nonempty_list(COMMA, BTCONSTRUCTOR) SEMICOLON { with_pos $loc (FreshLabel (List.map local_label $2))}
 
 mutual_binding_block:
 | MUTUAL LBRACE mutual_bindings RBRACE                         { MutualBindings.flatten $3 }
@@ -1189,7 +1189,7 @@ field_label:
 | CONSTRUCTOR                                                  { label $1 }
 | VARIABLE                                                     { label $1 }
 | STRING                                                       { label $1 }
-| UINTEGER                                                     { label (string_of_int $1) }
+| UINTEGER                                                     { Label.Number $1 }
 
 rfields:
 | fields_def(rfield, COMMA, row_var, kinded_row_var)                  { $1 }

core/sugarTraversals.ml

@@ -805,10 +805,9 @@ class map =
          in
          let language = o#foreign_language (Alien.language alien) in
          AlienBlock (Alien.modify ~language ~declarations alien)
-      | FreshLabel(_x, _x_i1) ->
-        let _x = o#list (fun o -> o#label) _x in
-        let _x_i1 = o#list (fun o -> o#binding) _x_i1 in
-        FreshLabel(_x,_x_i1)
+      | FreshLabel ls ->
+        let ls = o#list (fun o -> o#label) ls in
+        FreshLabel ls
 
     method binding : binding -> binding =
       fun p ->
@@ -1594,9 +1593,8 @@ class fold =
              let o = o#binder b in
              o#datatype' dt)
            (Alien.declarations alien)
-      | FreshLabel(_x, _x_i1) ->
-        let o = o#list (fun o -> o#label) _x in
-        let o = o#list (fun o -> o#binding) _x_i1 in
+      | FreshLabel ls ->
+        let o = o#list (fun o -> o#label) ls in
         o
 
     method binding : binding -> 'self_type =
@@ -2551,10 +2549,9 @@ class fold_map =
              (Alien.declarations alien)
          in
          o, AlienBlock (Alien.modify ~language:lang ~declarations alien)
-      | FreshLabel(_x, _x_i1) ->
-        let o, _x = o#list (fun o -> o#label) _x in
-        let o, _x_i1 = o#list (fun o -> o#binding) _x_i1 in
-        o, FreshLabel(_x,_x_i1)
+      | FreshLabel ls ->
+        let (o, ls) = o#list (fun o -> o#label) ls in
+        (o, FreshLabel ls)
 
 
     method binding : binding -> ('self_type * binding) =

core/sugartoir.ml

@@ -1334,8 +1334,7 @@ struct
                    let xt = Binder.to_type binder in
                    I.alien (Var.make_info xt x scope, Alien.object_name alien, Alien.language alien,
                             fun v -> eval_bindings scope (extend [x] [(v, xt)] env) bs e)
-                | FreshLabel (_, decls) -> (* TODO: is that right ? ignore local labels *)
-                    eval_bindings scope env (decls @ bs) e
+                | FreshLabel _ -> eval_bindings scope env bs e (* TODO: is that right ? ignore local labels *)
                 | Aliases _
                 | Infix _ ->
                     (* Ignore type alias and infix declarations - they

core/sugartypes.ml

@@ -244,7 +244,6 @@ module Pattern = struct
     | Cons     of with_pos * with_pos
     | List     of with_pos list
     | Variant  of Label.t * with_pos option
-    (* | Effect   of Label.t * with_pos list * with_pos *)
     | Operation of Label.t * with_pos list * with_pos
     | Negative of Label.t list
     | Record   of (Label.t * with_pos) list * with_pos option
@@ -535,7 +534,7 @@ and bindingnode =
   | Exp     of phrase
   | Module  of { binder: Binder.with_pos; members: binding list }
   | AlienBlock of Alien.multi Alien.t
-  | FreshLabel of Label.t list * binding list
+  | FreshLabel of Label.t list
 and binding = bindingnode WithPos.t
 and block_body = binding list * phrase
 and cp_phrasenode =
@@ -818,12 +817,7 @@ struct
     | Import _
     | Open _
     | Aliases _ -> empty, empty
-    | FreshLabel (_, decls) ->
-        List.fold_left
-          (fun (b,f) decl -> let b', f' = binding decl in
-              StringSet.union b b', StringSet.union f f')
-          (StringSet.empty, StringSet.empty)
-          decls
+    | FreshLabel _ -> empty, empty
     (* This is technically a declaration, thus the name should
        probably be treated as bound rather than free. *)
     | Infix { name; _ } -> empty, singleton name

core/transformSugar.ml

@@ -905,11 +905,9 @@ class transform (env : Types.typing_environment) =
       | (Infix _) as node ->
          (o, node)
       | Exp e -> let (o, e, _) = o#phrase e in (o, Exp e)
-      | FreshLabel(labels, decls) ->
+      | FreshLabel ls ->
           (* do we wanna do something with labels ? *)
-          let o, decls = ListUtils.fold_left_map
-            (fun o d -> o#binding d) o decls in
-          (o, FreshLabel(labels, decls))
+          (o, FreshLabel ls)
       | AlienBlock _ -> assert false
       | Module _ -> assert false
       | Import _ -> assert false