Reorganize, code-gen UCNs

Author: WardBrian

src/common/Unicode.ml

@@ -0,0 +1,35 @@
+let pp_uchar ppf u =
+  let u_int = Uchar.to_int u in
+  if u_int < 128 then Fmt.string ppf (Char.chr u_int |> Char.escaped)
+  else Fmt.pf ppf "U+%04X" u_int
+
+let is_ascii s =
+  let rec loop max b i =
+    if i > max then true
+    else if Bytes.get_uint8 b i < 128 then loop max b (i + 1)
+    else false in
+  let b = Bytes.of_string s in
+  loop (Bytes.length b - 1) b 0
+
+let normalize = Uunf_string.normalize_utf_8 `NFKC
+
+let iter_uchars s f =
+  let len = String.length s in
+  let out = Buffer.create len in
+  let pos = ref 0 in
+  (* move through code point by code point *)
+  while !pos != len do
+    let decode = String.get_utf_8_uchar s !pos in
+    let char_length = Uchar.utf_decode_length decode in
+    let uchar = Uchar.utf_decode_uchar decode in
+    Buffer.add_utf_8_uchar out uchar;
+    f !pos uchar;
+    pos := !pos + char_length
+  done;
+  (* another sanity check *)
+  let s_after = Buffer.contents out in
+  if not (String.equal s s_after) then
+    Core.(
+      ICE.internal_compiler_error
+        [%message
+          "Failed to round-trip unicode string!" (s : string) (s_after : string)])

src/common/dune

@@ -1,7 +1,7 @@
 (library
  (name common)
  (public_name stanc.common)
- (libraries core fmt)
+ (libraries core fmt uunf)
  (instrumentation
   (backend bisect_ppx))
  (inline_tests)

src/driver/Entry.ml

@@ -31,7 +31,7 @@ let set_model_name model_name =
 
 let reset_mutable_states model_name (flags : Flags.t) =
   Common.Gensym.reset_danger_use_cautiously ();
-  Unicode.allow_unicode := flags.allow_unicode;
+  Identifiers.allow_unicode := flags.allow_unicode;
   Include_files.include_provider := flags.include_source;
   set_model_name model_name;
   Typechecker.check_that_all_functions_have_definition :=

src/frontend/Identifiers.ml

@@ -0,0 +1,45 @@
+open Common.Unicode
+
+let allow_unicode = ref false
+
+let error ~loc msg =
+  raise
+    (Errors.SyntaxError
+       (Errors.Lexing (msg, Preprocessor.location_of_position loc)))
+
+let validate_ascii_id ~loc id =
+  Debugging.lexer_logger ("ascii id: " ^ id);
+  let first = String.get_uint8 id 0 in
+  if
+    (first >= Char.code 'A' && first <= Char.code 'Z')
+    || (first >= Char.code 'a' && first <= Char.code 'z')
+  then id
+  else error ~loc "Invalid character found."
+
+(* Validation based on the
+   Unicode Standard Annex #31: Unicode Identifiers and Syntax
+   https://www.unicode.org/reports/tr31 *)
+
+let validate_utf8_id ~loc id =
+  if not !allow_unicode then
+    error ~loc
+      "Unicode identifiers are not supported without the (experimental) \
+       allow-unicode flag";
+  if not (String.is_valid_utf_8 id) then
+    error ~loc "Identifier is not valid UTF-8 string";
+  Debugging.lexer_logger ("unicode id: " ^ id);
+  (* normalize to NFKC as recommended *)
+  let id = normalize id in
+  let f pos uchar =
+    if pos == 0 then (
+      if not (Uucp.Id.is_xid_start uchar) then
+        error ~loc (Fmt.str "Invalid character: '%a'" pp_uchar uchar))
+    else if not (Uucp.Id.is_xid_continue uchar) then
+      error ~loc
+        (Fmt.str "Invalid character in identifier at offset %d: '%a'" pos
+           pp_uchar uchar) in
+  iter_uchars id f;
+  id
+
+let validate loc id =
+  if is_ascii id then validate_ascii_id ~loc id else validate_utf8_id ~loc id

src/frontend/Identifiers.mli

@@ -0,0 +1,2 @@
+val allow_unicode : bool ref
+val validate : Lexing.position -> string -> string

src/frontend/Unicode.ml

@@ -1,7 +1,7 @@
 (library
  (name frontend)
  (public_name stanc.frontend)
- (libraries core menhirLib uunf uucp yojson fmt middle stan_math_signatures)
+ (libraries core menhirLib uucp yojson fmt middle stan_math_signatures)
  (instrumentation
   (backend bisect_ppx))
  (inline_tests)

src/frontend/dune

@@ -231,7 +231,7 @@ rule token = parse
   | identifier as id          { lexer_logger ("identifier " ^ id) ;
                                 let loc = (lexeme_start_p lexbuf) in
                                 lexer_pos_logger loc;
-                                let canonical_id = Unicode.validate_identifier loc id in
+                                let canonical_id = Identifiers.validate loc id in
                                 Parser.IDENTIFIER (canonical_id) }
 (* End of file *)
   | eof                       { lexer_logger "eof" ;

src/frontend/lexer.mll

@@ -389,7 +389,14 @@ module Printing = struct
   open Fmt
 
   let trailing_space (t : 'a Fmt.t) : 'a Fmt.t = fun ppf -> pf ppf "%a@ " t
-  let pp_identifier ppf = string ppf
+
+  let pp_identifier ppf s =
+    if Common.Unicode.is_ascii s then string ppf s
+    else
+      (* so called "Universal character names" - not required on newer compilers
+         but hopefully more backward-compatible *)
+      let f _ c = Fmt.pf ppf "\\u%04X" (Uchar.to_scalar c) in
+      Common.Unicode.iter_uchars s f
 
   let rec pp_type_ ppf t =
     match t with
@@ -473,8 +480,8 @@ module Printing = struct
         pf ppf "<@,%a>" (list ~sep:comma pp_type_) types in
     match e with
     | Literal s -> pf ppf "%s" s
-    | Var id -> string ppf id
-    | VarRef id -> pf ppf "&%s" id
+    | Var id -> pp_identifier ppf id
+    | VarRef id -> pf ppf "&%a" pp_identifier id
     | Parens e -> pf ppf "(%a)" pp_expr e
     | Cast (t, e) -> pf ppf "@[(%a)@ %a@]" pp_type_ t pp_expr e
     | Constructor (t, es) ->
@@ -491,7 +498,7 @@ module Printing = struct
     | StreamInsertion (e, es) ->
         pf ppf "%a <<@[@ %a@]" pp_expr e (list ~sep:comma pp_expr) es
     | FunCall (fn, tys, es) ->
-        pf ppf "@[<hov 2>%s%a(@,%a@])" fn maybe_templates tys
+        pf ppf "@[<hov 2>%a%a(@,%a@])" pp_identifier fn maybe_templates tys
           (list ~sep:comma pp_expr) es
     | MethodCall (e, fn, tys, es) ->
         pf ppf "@[<hov 2>%a.%s%a(%a)@]" pp_expr e fn maybe_templates tys
@@ -519,8 +526,8 @@ module Printing = struct
           pf ppf "{@[<hov>%a@]}" (list ~sep:comma pp_expr) es in
     let static = if static then "static " else "" in
     let constexpr = if constexpr then "constexpr " else "" in
-    pf ppf "@[<hov 2>%s%s%a@ %s%a@]" static constexpr pp_type_ type_ name
-      pp_init init
+    pf ppf "@[<hov 2>%s%s%a@ %a%a@]" static constexpr pp_type_ type_
+      pp_identifier name pp_init init
 
   let rec pp_stmt ppf s =
     match s with