Add utf8 support for string literal (#127)

Author: hhugo

CHANGES.md

@@ -1,5 +1,6 @@
 # dev
 - Implement Corrigendum #1: UTF-8 Shortest Form
+- Add utf8 support for string literal (#127)
 
 # 3.4 (2025-03-28)
 - Make the library compatibility with ppxlib.0.36 (#166)

README.md

@@ -84,7 +84,7 @@ The actions can call functions from the Sedlexing module to extract
 
 Regular expressions are syntactically OCaml patterns:
 
-- `"...."` (string constant): recognize the specified string
+- `"...."` (string constant): recognize the specified string.
 - `'....'` (character constant) : recognize the specified character
 - `i` (integer constant) : recognize the specified codepoint
 - `'...' .. '...'`: character range
@@ -103,6 +103,9 @@ Regular expressions are syntactically OCaml patterns:
   and recognize the set of items in `R1` but not in `R2` ("subtract")
 - `Intersect (R1,R2)` : assume that `R` is a single-character length regexp (see
   below) and recognize the set of items which are in both `R1` and `R2`
+- `Utf8 R` : string literals inside R are assumed to be utf-8 encoded.
+- `Latin1 R` : string literals inside R are assumed to be latin1 encoded.
+- `Ascii R` : string literals inside R are assumed to be ascii encoded.
 - `lid` (lowercase identifier) : reference a named regexp (see below)
 
 A single-character length regexp is a regexp which does not contain (after
@@ -112,8 +115,9 @@ with a length different from one.
 
 
 Note:
- - The OCaml source is assumed to be encoded in Latin1 (for string
-   and character literals).
+ - The OCaml source is assumed to be encoded in UTF-8.
+ - Strings and chars litterals will be interpreted in ASCII unless otherwise
+   specified by the `Latin1`,`Ascii` and `Utf8` constructors in patterns.
 
 
 It is possible to define named regular expressions with the following

src/lib/sedlexing.mli

@@ -274,6 +274,13 @@ module Utf8 : sig
 
   (** As [Sedlexing.sub_lexeme] with a result encoded in UTF-8. *)
   val sub_lexeme : lexbuf -> int -> int -> string
+
+  module Helper : sig
+    val width : char -> int
+    val check_two : int -> int -> int
+    val check_three : int -> int -> int -> int
+    val check_four : int -> int -> int -> int -> int
+  end
 end
 
 module Utf16 : sig

src/syntax/ppx_sedlex.ml

@@ -13,7 +13,6 @@ module Cset = Sedlex_cset
 (* Decision tree for partitions *)
 
 let default_loc = Location.none
-let lident_loc ~loc s = { loc; txt = lident s }
 
 type decision_tree =
   | Lte of int * decision_tree * decision_tree
@@ -286,48 +285,86 @@ let codepoint i =
     failwith (Printf.sprintf "Invalid Unicode code point: %i" i);
   i
 
-let regexp_for_char c = Sedlex.chars (Cset.singleton (Char.code c))
-
-let regexp_for_string s =
-  let rec aux n =
-    if n = String.length s then Sedlex.eps
-    else Sedlex.seq (regexp_for_char s.[n]) (aux (succ n))
-  in
-  aux 0
-
-let err loc s =
-  raise (Location.Error (Location.Error.createf ~loc "Sedlex: %s" s))
+let char c = Cset.singleton (Char.code c)
+let uchar c = Cset.singleton (Uchar.to_int c)
+
+let err loc fmt =
+  Printf.ksprintf
+    (fun s ->
+      raise (Location.Error (Location.Error.createf ~loc "Sedlex: %s" s)))
+    fmt
+
+type encoding = Utf8 | Latin1 | Ascii
+
+let string_of_encoding = function
+  | Utf8 -> "UTF-8"
+  | Latin1 -> "Latin-1"
+  | Ascii -> "ASCII"
+
+let rev_csets_of_string ~loc ~encoding s =
+  match encoding with
+    | Utf8 ->
+        Utf8.fold
+          ~f:(fun acc _ x ->
+            match x with
+              | `Malformed _ ->
+                  err loc "Malformed %s string" (string_of_encoding encoding)
+              | `Uchar c -> uchar c :: acc)
+          [] s
+    | Latin1 ->
+        let l = ref [] in
+        for i = 0 to String.length s - 1 do
+          l := char s.[i] :: !l
+        done;
+        !l
+    | Ascii ->
+        let l = ref [] in
+        for i = 0 to String.length s - 1 do
+          match s.[i] with
+            | '\x00' .. '\x7F' as c -> l := char c :: !l
+            | _ -> err loc "Malformed %s string" (string_of_encoding encoding)
+        done;
+        !l
 
 let rec repeat r = function
   | 0, 0 -> Sedlex.eps
   | 0, m -> Sedlex.alt Sedlex.eps (Sedlex.seq r (repeat r (0, m - 1)))
   | n, m -> Sedlex.seq r (repeat r (n - 1, m - 1))
 
 let regexp_of_pattern env =
-  let rec char_pair_op func name p tuple =
+  let rec char_pair_op func name ~encoding p tuple =
     (* Construct something like Sub(a,b) *)
     match tuple with
       | Some { ppat_desc = Ppat_tuple [p0; p1] } -> begin
-          match func (aux p0) (aux p1) with
+          match func (aux ~encoding p0) (aux ~encoding p1) with
             | Some r -> r
             | None ->
-                err p.ppat_loc @@ "the " ^ name
-                ^ " operator can only applied to single-character length \
-                   regexps"
+                err p.ppat_loc
+                  "the %s operator can only applied to single-character \
+                   length regexps"
+                  name
         end
       | _ ->
-          err p.ppat_loc @@ "the " ^ name
-          ^ " operator requires two arguments, like " ^ name ^ "(a,b)"
-  and aux p =
+          err p.ppat_loc "the %s operator requires two arguments, like %s(a,b)"
+            name name
+  and aux ~encoding p =
     (* interpret one pattern node *)
     match p.ppat_desc with
-      | Ppat_or (p1, p2) -> Sedlex.alt (aux p1) (aux p2)
+      | Ppat_or (p1, p2) -> Sedlex.alt (aux ~encoding p1) (aux ~encoding p2)
       | Ppat_tuple (p :: pl) ->
-          List.fold_left (fun r p -> Sedlex.seq r (aux p)) (aux p) pl
+          List.fold_left
+            (fun r p -> Sedlex.seq r (aux ~encoding p))
+            (aux ~encoding p) pl
       | Ppat_construct ({ txt = Lident "Star" }, Some (_, p)) ->
-          Sedlex.rep (aux p)
+          Sedlex.rep (aux ~encoding p)
       | Ppat_construct ({ txt = Lident "Plus" }, Some (_, p)) ->
-          Sedlex.plus (aux p)
+          Sedlex.plus (aux ~encoding p)
+      | Ppat_construct ({ txt = Lident "Utf8" }, Some (_, p)) ->
+          aux ~encoding:Utf8 p
+      | Ppat_construct ({ txt = Lident "Latin1" }, Some (_, p)) ->
+          aux ~encoding:Latin1 p
+      | Ppat_construct ({ txt = Lident "Ascii" }, Some (_, p)) ->
+          aux ~encoding:Ascii p
       | Ppat_construct
           ( { txt = Lident "Rep" },
             Some
@@ -347,19 +384,19 @@ let regexp_of_pattern env =
             | Pconst_integer (i1, _), Pconst_integer (i2, _) ->
                 let i1 = int_of_string i1 in
                 let i2 = int_of_string i2 in
-                if 0 <= i1 && i1 <= i2 then repeat (aux p0) (i1, i2)
+                if 0 <= i1 && i1 <= i2 then repeat (aux ~encoding p0) (i1, i2)
                 else err p.ppat_loc "Invalid range for Rep operator"
             | _ ->
                 err p.ppat_loc "Rep must take an integer constant or interval"
         end
       | Ppat_construct ({ txt = Lident "Rep" }, _) ->
           err p.ppat_loc "the Rep operator takes 2 arguments"
       | Ppat_construct ({ txt = Lident "Opt" }, Some (_, p)) ->
-          Sedlex.alt Sedlex.eps (aux p)
+          Sedlex.alt Sedlex.eps (aux ~encoding p)
       | Ppat_construct ({ txt = Lident "Compl" }, arg) -> begin
           match arg with
             | Some (_, p0) -> begin
-                match Sedlex.compl (aux p0) with
+                match Sedlex.compl (aux ~encoding p0) with
                   | Some r -> r
                   | None ->
                       err p.ppat_loc
@@ -369,10 +406,10 @@ let regexp_of_pattern env =
             | _ -> err p.ppat_loc "the Compl operator requires an argument"
         end
       | Ppat_construct ({ txt = Lident "Sub" }, arg) ->
-          char_pair_op Sedlex.subtract "Sub" p
+          char_pair_op ~encoding Sedlex.subtract "Sub" p
             (Option.map (fun (_, arg) -> arg) arg)
       | Ppat_construct ({ txt = Lident "Intersect" }, arg) ->
-          char_pair_op Sedlex.intersection "Intersect" p
+          char_pair_op ~encoding Sedlex.intersection "Intersect" p
             (Option.map (fun (_, arg) -> arg) arg)
       | Ppat_construct ({ txt = Lident "Chars" }, arg) -> (
           let const =
@@ -382,16 +419,26 @@ let regexp_of_pattern env =
           in
           match const with
             | Some (Pconst_string (s, _, _)) ->
-                let c = ref Cset.empty in
-                for i = 0 to String.length s - 1 do
-                  c := Cset.union !c (Cset.singleton (Char.code s.[i]))
-                done;
-                Sedlex.chars !c
+                let l = rev_csets_of_string ~loc:p.ppat_loc ~encoding s in
+                let chars = List.fold_left Cset.union Cset.empty l in
+                Sedlex.chars chars
             | _ ->
                 err p.ppat_loc "the Chars operator requires a string argument")
       | Ppat_interval (i_start, i_end) -> begin
           match (i_start, i_end) with
             | Pconst_char c1, Pconst_char c2 ->
+                let valid =
+                  match encoding with
+                    (* utf8 char interval can only match ascii because
+                       of the OCaml lexer. *)
+                    | Ascii | Utf8 -> (
+                        function '\x00' .. '\x7f' -> true | _ -> false)
+                    | Latin1 -> ( function _ -> true)
+                in
+                if not (valid c1 && valid c2) then
+                  err p.ppat_loc
+                    "this pattern is not a valid %s interval regexp"
+                    (string_of_encoding encoding);
                 Sedlex.chars (Cset.interval (Char.code c1) (Char.code c2))
             | Pconst_integer (i1, _), Pconst_integer (i2, _) ->
                 Sedlex.chars
@@ -402,20 +449,23 @@ let regexp_of_pattern env =
         end
       | Ppat_constant const -> begin
           match const with
-            | Pconst_string (s, _, _) -> regexp_for_string s
-            | Pconst_char c -> regexp_for_char c
+            | Pconst_string (s, _, _) ->
+                let rev_l = rev_csets_of_string s ~loc:p.ppat_loc ~encoding in
+                List.fold_left
+                  (fun acc cset -> Sedlex.seq (Sedlex.chars cset) acc)
+                  Sedlex.eps rev_l
+            | Pconst_char c -> Sedlex.chars (char c)
             | Pconst_integer (i, _) ->
                 Sedlex.chars (Cset.singleton (codepoint (int_of_string i)))
             | _ -> err p.ppat_loc "this pattern is not a valid regexp"
         end
       | Ppat_var { txt = x } -> begin
           try StringMap.find x env
-          with Not_found ->
-            err p.ppat_loc (Printf.sprintf "unbound regexp %s" x)
+          with Not_found -> err p.ppat_loc "unbound regexp %s" x
         end
       | _ -> err p.ppat_loc "this pattern is not a valid regexp"
   in
-  aux
+  aux ~encoding:Ascii
 
 let previous = ref []
 let regexps = ref []
@@ -468,7 +518,7 @@ let mapper =
             (this#define_regexp name p)#expression body
         | [%expr [%sedlex [%e? _]]] ->
             err e.pexp_loc
-              "the %sedlex extension is only recognized on match expressions"
+              "the %%sedlex extension is only recognized on match expressions"
         | _ -> super#expression e
 
     val toplevel = true

src/syntax/utf8.ml

@@ -0,0 +1,49 @@
+open Sedlexing
+
+let unsafe_byte s j = Char.code (String.unsafe_get s j)
+let malformed s j l = `Malformed (String.sub s j l)
+
+let r_utf_8 s j l =
+  (* assert (0 <= j && 0 <= l && j + l <= String.length s); *)
+  let uchar c = `Uchar (Uchar.unsafe_of_int c) in
+  match l with
+    | 1 -> uchar (unsafe_byte s j)
+    | 2 -> (
+        let b0 = unsafe_byte s j in
+        let b1 = unsafe_byte s (j + 1) in
+        match Utf8.Helper.check_two b0 b1 with
+          | i -> uchar i
+          | exception MalFormed -> malformed s j l)
+    | 3 -> (
+        let b0 = unsafe_byte s j in
+        let b1 = unsafe_byte s (j + 1) in
+        let b2 = unsafe_byte s (j + 2) in
+        match Utf8.Helper.check_three b0 b1 b2 with
+          | i -> uchar i
+          | exception MalFormed -> malformed s j l)
+    | 4 -> (
+        let b0 = unsafe_byte s j in
+        let b1 = unsafe_byte s (j + 1) in
+        let b2 = unsafe_byte s (j + 2) in
+        let b3 = unsafe_byte s (j + 3) in
+        match Utf8.Helper.check_four b0 b1 b2 b3 with
+          | i -> uchar i
+          | exception MalFormed -> malformed s j l)
+    | _ -> assert false
+
+let fold ~f acc s =
+  let rec loop acc f s i last =
+    if i > last then acc
+    else (
+      match Utf8.Helper.width (String.unsafe_get s i) with
+        | exception MalFormed ->
+            loop (f acc i (malformed s i 1)) f s (i + 1) last
+        | need ->
+            let rem = last - i + 1 in
+            if rem < need then f acc i (malformed s i rem)
+            else loop (f acc i (r_utf_8 s i need)) f s (i + need) last)
+  in
+  let pos = 0 in
+  let len = String.length s in
+  let last = pos + len - 1 in
+  loop acc f s pos last

src/syntax/utf8.mli

@@ -0,0 +1,5 @@
+val fold :
+  f:('a -> int -> [> `Malformed of string | `Uchar of Uchar.t ] -> 'a) ->
+  'a ->
+  string ->
+  'a

test/utf8.ml

@@ -0,0 +1,33 @@
+open Printf
+
+let next_tok buf =
+  let open Sedlexing.Utf8 in
+  match%sedlex buf with
+    | "a", Utf8 (Chars "+-×÷") -> sprintf "with Chars: %s" (lexeme buf)
+    | "b", Utf8 ("+" | "-" | "×" | "÷") ->
+        sprintf "with or_pattern: %s" (lexeme buf)
+    | Latin1 "\xc0", Utf8 "À", Ascii (Utf8 (Latin1 (Utf8 (Chars "À")))) ->
+        sprintf "mixed encoding: %s" (lexeme buf)
+    | Ascii (Star '\x00' .. '\x7f') -> sprintf "only ascii: %s" (lexeme buf)
+    | Utf8 (Star '\x00' .. '\x7f') ->
+        assert false
+        (* utf8 char interval can only match ascii because of the OCaml lexer. The regexp above should match instead  *)
+    | Latin1 (Star '\x00' .. '\xff') -> sprintf "only latin1: %s" (lexeme buf)
+    | _ -> failwith (sprintf "Unexpected character: %s" (lexeme buf))
+
+let%expect_test _ =
+  Sedlexing.Utf8.from_string "a+" |> next_tok |> print_string;
+  [%expect {| with Chars: a+ |}];
+  Sedlexing.Utf8.from_string "a÷" |> next_tok |> print_string;
+  [%expect {| with Chars: a÷ |}];
+  Sedlexing.Utf8.from_string "b+" |> next_tok |> print_string;
+  [%expect {| with or_pattern: b+ |}];
+  Sedlexing.Utf8.from_string "b÷" |> next_tok |> print_string;
+  [%expect {| with or_pattern: b÷ |}];
+  Sedlexing.Utf8.from_string "ÀÀÀ" |> next_tok |> print_string;
+  [%expect {| mixed encoding: ÀÀÀ |}];
+  Sedlexing.Utf8.from_string "az\x7f"
+  |> next_tok |> String.escaped |> print_string;
+  [%expect {| only ascii: az\127 |}];
+  Sedlexing.Utf8.from_string "az\u{c0}" |> next_tok |> print_string;
+  [%expect {| only latin1: azÀ |}]