no uchar

Fixes: #167

.envrc

@@ -0,0 +1 @@
+use flake

.gitattributes

@@ -0,0 +1 @@
+test/stress_test.ml text diff

.github/CODEOWNERS

@@ -1,3 +0,0 @@
-# These are the default owners for everything in the repo. They will
-# be requested for review when someone opens a pull request.
-* @alainfrisch @Drup @pmetzger

.github/workflows/build.yml

@@ -1,69 +0,0 @@
-name: build
-
-on:
-  merge_group:
-  pull_request:
-  push:
-    branches:
-      - master
-  schedule:
-    # Prime the caches every Monday
-    - cron: 0 1 * * MON
-
-concurrency:
-  group: ${{ github.workflow }}-${{ github.ref }}
-  cancel-in-progress: true
-
-jobs:
-  build:
-    strategy:
-      fail-fast: false
-      matrix:
-        os:
-          - ubuntu-latest
-          - macos-latest
-          - windows-latest
-        ocaml-compiler:
-          - 4.14.x
-          - 5.x
-
-    runs-on: ${{ matrix.os }}
-
-    steps:
-      - name: Set git to use LF
-        run: |
-          git config --global core.autocrlf false
-          git config --global core.eol lf
-          git config --global core.ignorecase false
-
-      - name: Checkout code
-        uses: actions/checkout@v4
-
-      - name: Use OCaml ${{ matrix.ocaml-compiler }}
-        uses: ocaml/setup-ocaml@v3
-        with:
-          ocaml-compiler: ${{ matrix.ocaml-compiler }}
-          dune-cache: ${{ matrix.os == 'ubuntu-latest' }}
-
-      - run: opam install . --with-test
-
-      - run: opam exec -- make build
-
-      - run: opam exec -- make test
-
-      - run: opam exec -- git diff --exit-code
-
-  lint-fmt:
-    runs-on: ubuntu-latest
-    steps:
-      - name: Checkout code
-        uses: actions/checkout@v4
-
-      - name: Use OCaml 4.14.x
-        uses: ocaml/setup-ocaml@v3
-        with:
-          ocaml-compiler: 4.14.x
-          dune-cache: true
-
-      - name: Lint fmt
-        uses: ocaml/setup-ocaml/lint-fmt@v3

.github/workflows/changelog.yml

@@ -1,20 +0,0 @@
-name: Check changelog
-
-on:
-  pull_request:
-    branches:
-      - master
-    types:
-      - labeled
-      - opened
-      - reopened
-      - synchronize
-      - unlabeled
-
-jobs:
-  check-changelog:
-    name: Check changelog
-    runs-on: ubuntu-latest
-    steps:
-      - name: Check changelog
-        uses: tarides/changelog-check-action@v1

.github/workflows/doc.yml

@@ -1,28 +0,0 @@
-name: Doc build
-
-on:
-  push:
-    branches:
-      - master
-
-jobs:
-  build_doc:
-    runs-on: ubuntu-latest
-    steps:
-    - name: Checkout code
-      uses: actions/checkout@v4
-    - name: Setup OCaml
-      uses: ocaml/setup-ocaml@v3
-      with:
-        ocaml-compiler: 4.14.x
-    - name: Pin locally
-      run: opam pin -y add --no-action .
-    - name: Install locally
-      run: opam install -y --with-doc sedlex
-    - name: Build doc
-      run: opam exec dune build @doc
-    - name: Deploy doc
-      uses: JamesIves/github-pages-deploy-action@4.1.4
-      with:
-        branch: gh-pages
-        folder: _build/default/_doc/_html

.gitignore

@@ -19,3 +19,4 @@ examples/complement
 examples/tokenizer
 examples/subtraction
 _opam
+.direnv

.ocamlformat

@@ -1,4 +1,4 @@
-version=0.25.1
+version=0.29.0
 profile = conventional
 break-separators = after
 space-around-lists = false

.travis.yml

@@ -1,19 +0,0 @@
-language: c
-sudo: required
-install: test -e .travis.opam.sh || wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh
-script: bash -ex .travis-opam.sh
-env:
-  global:
-  - PACKAGE=sedlex
-  matrix:
-  - OCAML_VERSION=4.04
-  - OCAML_VERSION=4.05
-  - OCAML_VERSION=4.06
-  - OCAML_VERSION=4.07
-  - OCAML_VERSION=4.08
-  - OCAML_VERSION=4.09
-  - OCAML_VERSION=4.10
-  - OCAML_VERSION=4.11
-os:
-  - linux
-  - osx

CHANGES.md

@@ -1,3 +1,15 @@
+# 3.7 (2025-10-06)
+- Update to unicode 17.0.0
+
+# 3.6 (2025-01-05)
+- Fixed one of the ranges implementing
+  Implement Corrigendum #1: UTF-8 Shortest Form
+  for 4-bytes long characters (#171)
+
+# 3.5 (2025-05-29)
+- 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)
 

LICENSE

@@ -1,22 +1,6 @@
-The MIT License (MIT)
+it's proprietary. all rights reserved. if you use this code in a way i don't like i will personally
+make your car explode into hammers
 
-Copyright 2005, 2014 by Alain Frisch and LexiFi.
+Portions of this code are based on "sedlex", Copyright 2005, 2014 by Alain
-
+Frisch and LexiFi, released under the terms of the MIT license which can be
-Permission is hereby granted, free of charge, to any person obtaining
+found in <licenses/LICENSE.sedlex>
-a copy of this software and associated documentation files (the
-"Software"), to deal in the Software without restriction, including
-without limitation the rights to use, copy, modify, merge, publish,
-distribute, sublicense, and/or sell copies of the Software, and to
-permit persons to whom the Software is furnished to do so, subject to
-the following conditions:
-
-The above copyright notice and this permission notice shall be
-included in all copies or substantial portions of the Software.
-
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

Makefile

@@ -1,27 +0,0 @@
-# The package sedlex is released under the terms of an MIT-like license.
-# See the attached LICENSE file.
-# Copyright 2005, 2013 by Alain Frisch and LexiFi.
-
-INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),)
-
-.PHONY: build install uninstall clean doc test all
-
-build:
-	dune build @install
-
-install:
-	dune install $(INSTALL_ARGS)
-
-uninstall:
-	dune uninstall $(INSTALL_ARGS)
-
-clean:
-	dune clean
-
-doc:
-	dune build @doc
-
-test:
-	dune build @runtest
-
-all: build test doc

README.md

@@ -79,12 +79,25 @@ where:
 Unlike ocamllex, lexers work on stream of Unicode codepoints, not
 bytes.
 
+Like ocamllex, sedlex uses **longest match** with **first rule priority**:
+
+- The lexer always tries to match the longest possible prefix of the
+  input.  It does so by continuing to read characters as long as some
+  rule can still match a longer string, while remembering the last
+  position at which a rule did match.
+
+- When two or more rules match the same longest prefix (a tie), the
+  rule that appears first in the `match%sedlex` definition wins.  For
+  example, given the rules `| "if" -> ...` and `| Plus ('a'..'z') -> ...`,
+  the input `"if"` is matched by the first rule because it is listed
+  first, even though the second rule also accepts `"if"`.
+
 The actions can call functions from the Sedlexing module to extract
 (parts of) the matched lexeme, in the desired encoding.
 
 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 +116,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 +128,9 @@ with a length different from one.
 
 
 Note:
- - The OCaml source is assumed to be encoded in Latin1 (for string
+ - The OCaml source is assumed to be encoded in UTF-8.
-   and character literals).
+ - 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

dune-project

@@ -1,18 +1,21 @@
-(lang dune 3.0)
+(lang dune 3.20)
-(version 3.4)
+
-(name sedlex)
+(version "3.7")
-(source (github ocaml-community/sedlex))
+
-(license MIT)
+(name noslop-sedlex)
-(authors "Alain Frisch <alain.frisch@lexifi.com>"
+(source (uri "https://git.lain.faith/noslop/noslop-sedlex.git"))
-         "https://github.com/ocaml-community/sedlex/graphs/contributors")
+(license "LicenseRef-Proprietary")
-(maintainers "Alain Frisch <alain.frisch@lexifi.com>")
+(authors "xenia <xenia@awoo.systems>")
-(homepage "https://github.com/ocaml-community/sedlex")
+(maintainers "xenia <xenia@awoo.systems")
+(homepage "https://git.lain.faith/noslop/noslop-sedlex.git")
+(maintenance_intent "(latest)")
+(documentation "https://git.lain.faith/noslop/noslop-sedlex/wiki")
 
 (generate_opam_files true)
 (executables_implicit_empty_intf true)
 
 (package
-  (name sedlex)
+  (name noslop-sedlex)
   (synopsis "An OCaml lexer generator for Unicode")
   (description "sedlex is a lexer generator for OCaml. It is similar to ocamllex, but supports
 Unicode. Unlike ocamllex, sedlex allows lexer specifications within regular

examples/dune

@@ -1,9 +1,8 @@
 (executables
  (names tokenizer regressions complement subtraction repeat performance)
- (libraries sedlex sedlex_ppx)
+ (libraries noslop-sedlex noslop-sedlex.ppx)
  (preprocess
-  (pps sedlex.ppx))
+  (pps noslop-sedlex.ppx)))
- (flags :standard -w +39))
 
 (rule
  (alias runtest)

examples/regressions.ml

@@ -3,7 +3,7 @@
 module CSet = Sedlex_ppx.Sedlex_cset
 module Unicode = Sedlex_ppx.Unicode
 
-let test_versions = ("15.0.0", "16.0.0")
+let test_versions = ("16.0.0", "17.0.0")
 
 let regressions =
   [ (* Example *)

flake.lock

@@ -0,0 +1,45 @@
+{
+  "nodes": {
+    "dragnpkgs": {
+      "inputs": {
+        "nixpkgs": "nixpkgs"
+      },
+      "locked": {
+        "lastModified": 1783018382,
+        "narHash": "sha256-Pw7GM1fh2AnQNCitswXTHPfsswiDnEjXPN17Ge8egz4=",
+        "ref": "nixos-26.05",
+        "rev": "085892ad486428b8e51b549539a5430f0c2da1a8",
+        "revCount": 247,
+        "type": "git",
+        "url": "https://git.lain.faith/haskal/dragnpkgs.git"
+      },
+      "original": {
+        "id": "dragnpkgs",
+        "type": "indirect"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1782847225,
+        "narHash": "sha256-JC9PjqKYG9ve5U8aDOLQipp3+KLANBHUvGdLZlxzdKI=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "95ca1e203c0750115fd4a6f17d5a245dfe6b1edd",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "ref": "nixos-26.05",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "dragnpkgs": "dragnpkgs"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

@@ -0,0 +1,23 @@
+{
+  description = "Flake for noslop-sedlex";
+
+  outputs = { self, dragnpkgs } @ inputs: dragnpkgs.lib.mkFlake {
+    packages.default = { ocamlPackages }: ocamlPackages.callPackage ./package.nix {};
+
+    devShells.default = { ocamlPackages, stdenv, mkShell }: mkShell {
+      packages = with ocamlPackages; [
+        ocaml
+        dune_3
+        utop
+        odoc
+        alcotest
+        ocamlformat
+      ] ++ (self.packages.${stdenv.hostPlatform.system}.default.propagatedBuildInputs)
+        ++ (self.packages.${stdenv.hostPlatform.system}.default.nativeBuildInputs);
+
+      shellHook = ''
+        export OCAMLRUNPARAM=b
+      '';
+    };
+  };
+}

licenses/LICENSE.sedlex

@@ -0,0 +1,22 @@
+The MIT License (MIT)
+
+Copyright 2005, 2014 by Alain Frisch and LexiFi.
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

noslop-sedlex.opam

@@ -1,23 +1,20 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "3.4"
+version: "3.7"
 synopsis: "An OCaml lexer generator for Unicode"
 description: """
 sedlex is a lexer generator for OCaml. It is similar to ocamllex, but supports
 Unicode. Unlike ocamllex, sedlex allows lexer specifications within regular
 OCaml source files. Lexing specific constructs are provided via a ppx syntax
 extension."""
-maintainer: ["Alain Frisch <alain.frisch@lexifi.com>"]
+maintainer: ["xenia <xenia@awoo.systems"]
-authors: [
+authors: ["xenia <xenia@awoo.systems>"]
-  "Alain Frisch <alain.frisch@lexifi.com>"
+license: "LicenseRef-Proprietary"
-  "https://github.com/ocaml-community/sedlex/graphs/contributors"
+homepage: "https://git.lain.faith/noslop/noslop-sedlex.git"
-]
+doc: "https://git.lain.faith/noslop/noslop-sedlex/wiki"
-license: "MIT"
-homepage: "https://github.com/ocaml-community/sedlex"
-bug-reports: "https://github.com/ocaml-community/sedlex/issues"
 depends: [
   "ocaml" {>= "4.08"}
-  "dune" {>= "3.0"}
+  "dune" {>= "3.20"}
   "ppxlib" {>= "0.26.0"}
   "gen"
   "ppx_expect" {with-test}
@@ -37,5 +34,5 @@ build: [
     "@doc" {with-doc}
   ]
 ]
-dev-repo: "git+https://github.com/ocaml-community/sedlex.git"
+dev-repo: "https://git.lain.faith/noslop/noslop-sedlex.git"
-doc: "https://ocaml-community.github.io/sedlex/index.html"
+x-maintenance-intent: ["(latest)"]

package.nix

@@ -0,0 +1,52 @@
+{
+  lib,
+  fetchurl,
+  buildDunePackage,
+  gen,
+  ppxlib,
+  ppx_expect,
+}: let
+  unicodeVersion = "17.0.0";
+  baseUrl = "https://www.unicode.org/Public/${unicodeVersion}";
+
+  DerivedCoreProperties = fetchurl {
+    url = "${baseUrl}/ucd/DerivedCoreProperties.txt";
+    hash = "sha256-JMf+0RlcSC+q79XB5+uCHF7h+23gfs26pktWqZ2iLAg=";
+  };
+  DerivedGeneralCategory = fetchurl {
+    url = "${baseUrl}/ucd/extracted/DerivedGeneralCategory.txt";
+    hash = "sha256-1i5bq3DKdPCZND9xIk+gUcsf3WGhq0XASIxEz8C2EC4=";
+  };
+  PropList = fetchurl {
+    url = "${baseUrl}/ucd/PropList.txt";
+    hash = "sha256-Ew3N3Kra8HEAi9/OHndD4E/fvJEIhvAX2fmskx2MZN0=";
+  };
+in
+buildDunePackage (finalAttrs: {
+  pname = "noslop-sedlex";
+  version = "3.7+DEV";
+
+  minimalOCamlVersion = "5.3";
+
+  src = ./.;
+
+  propagatedBuildInputs = [
+    gen
+    ppxlib
+  ];
+
+  preBuild = ''
+    rm src/generator/data/dune
+    ln -s ${DerivedCoreProperties} src/generator/data/DerivedCoreProperties.txt
+    ln -s ${DerivedGeneralCategory} src/generator/data/DerivedGeneralCategory.txt
+    ln -s ${PropList} src/generator/data/PropList.txt
+  '';
+
+  checkInputs = [
+    ppx_expect
+  ];
+
+  doCheck = true;
+
+  dontStrip = true;
+})

sedlex.opam.template

@@ -1 +0,0 @@
-doc: "https://ocaml-community.github.io/sedlex/index.html"

src/common/cset.ml

@@ -1,6 +1,5 @@
-(* The package sedlex is released under the terms of an MIT-like license. *)
-(* See the attached LICENSE file.                                         *)
 (* Copyright 2005, 2013 by Alain Frisch and LexiFi.                       *)
+(* Copyright 2026 by xenia <xenia@awoo.systems>                           *)
 
 (* Character sets are represented as lists of intervals.  The
    intervals must be non-overlapping and not collapsable, and the list

src/common/cset.mli

@@ -1,12 +1,11 @@
-(* The package sedlex is released under the terms of an MIT-like license. *)
-(* See the attached LICENSE file.                                         *)
 (* Copyright 2005, 2013 by Alain Frisch and LexiFi.                       *)
+(* Copyright 2026 by xenia <xenia@awoo.systems>                           *)
 
 (** Representation of sets of unicode code points. *)
 
-(** Character sets are represented as lists of intervals.  The
+(** Character sets are represented as lists of intervals. The intervals must be
-   intervals must be non-overlapping and not collapsable, and the list
+    non-overlapping and not collapsable, and the list must be ordered in
-   must be ordered in increasing order. *)
+    increasing order. *)
 type t = private (int * int) list
 
 val of_list : (int * int) list -> t

src/common/dune

@@ -1,3 +1,3 @@
 (library
  (name sedlex_utils)
- (public_name sedlex.utils))
+ (public_name noslop-sedlex.utils))

src/generator/data/base_url

@@ -1 +1 @@
-https://www.unicode.org/Public/16.0.0
+https://www.unicode.org/Public/17.0.0

src/generator/dune

@@ -1,3 +1,3 @@
 (executable
  (name gen_unicode)
- (libraries str sedlex.utils))
+ (libraries str noslop-sedlex.utils))

src/lib/dune

@@ -1,6 +1,5 @@
 (library
  (name sedlex)
- (public_name sedlex)
+ (public_name noslop-sedlex)
  (wrapped false)
- (libraries gen)
+ (libraries gen))
- (flags :standard -w +A-4-9 -safe-string))

src/lib/sedlexing.ml

@@ -1,6 +1,5 @@
-(* The package sedlex is released under the terms of an MIT-like license. *)
-(* See the attached LICENSE file.                                         *)
 (* Copyright 2005, 2013 by Alain Frisch and LexiFi.                       *)
+(* Copyright 2026 by xenia <xenia@awoo.systems>                           *)
 
 exception InvalidCodepoint of int
 exception MalFormed
@@ -436,6 +435,49 @@ module Utf8 = struct
       | '\240' .. '\247' -> 4
       | _ -> raise MalFormed
 
+    (* https://www.unicode.org/versions/corrigendum1.html *)
+    let check_two n1 n2 =
+      if n1 < 0xc2 || 0xdf < n1 then raise MalFormed;
+      if n2 < 0x80 || 0xbf < n2 then raise MalFormed;
+      if n2 lsr 6 != 0b10 then raise MalFormed;
+      ((n1 land 0x1f) lsl 6) lor (n2 land 0x3f)
+
+    let check_three n1 n2 n3 =
+      if n1 = 0xe0 then (
+        if n2 < 0xa0 || 0xbf < n2 then raise MalFormed;
+        if n3 < 0x80 || 0xbf < n3 then raise MalFormed)
+      else (
+        if n1 < 0xe1 || 0xef < n1 then raise MalFormed;
+        if n2 < 0x80 || 0xbf < n2 then raise MalFormed;
+        if n3 < 0x80 || 0xbf < n3 then raise MalFormed);
+      if n2 lsr 6 != 0b10 || n3 lsr 6 != 0b10 then raise MalFormed;
+      let p =
+        ((n1 land 0x0f) lsl 12) lor ((n2 land 0x3f) lsl 6) lor (n3 land 0x3f)
+      in
+      if p >= 0xd800 && p <= 0xdfff then raise MalFormed;
+      p
+
+    let check_four n1 n2 n3 n4 =
+      if n1 = 0xf0 then (
+        if n2 < 0x90 || 0xbf < n2 then raise MalFormed;
+        if n3 < 0x80 || 0xbf < n3 then raise MalFormed;
+        if n4 < 0x80 || 0xbf < n4 then raise MalFormed)
+      else if n1 = 0xf4 then (
+        if n2 < 0x80 || 0x8f < n2 then raise MalFormed;
+        if n3 < 0x80 || 0xbf < n3 then raise MalFormed;
+        if n4 < 0x80 || 0xbf < n4 then raise MalFormed)
+      else (
+        if n1 < 0xf1 || 0xf3 < n1 then raise MalFormed;
+        if n2 < 0x80 || 0xbf < n2 then raise MalFormed;
+        if n3 < 0x80 || 0xbf < n3 then raise MalFormed;
+        if n4 < 0x80 || 0xbf < n4 then raise MalFormed);
+      if n2 lsr 6 != 0b10 || n3 lsr 6 != 0b10 || n4 lsr 6 != 0b10 then
+        raise MalFormed;
+      ((n1 land 0x07) lsl 18)
+      lor ((n2 land 0x3f) lsl 12)
+      lor ((n3 land 0x3f) lsl 6)
+      lor (n4 land 0x3f)
+
     let next s i =
       let c1 = s.[i] in
       match width c1 with
@@ -443,31 +485,18 @@ module Utf8 = struct
         | 2 ->
             let n1 = Char.code c1 in
             let n2 = Char.code s.[i + 1] in
-            if n2 lsr 6 != 0b10 then raise MalFormed;
+            check_two n1 n2
-            ((n1 land 0x1f) lsl 6) lor (n2 land 0x3f)
         | 3 ->
             let n1 = Char.code c1 in
             let n2 = Char.code s.[i + 1] in
             let n3 = Char.code s.[i + 2] in
-            if n2 lsr 6 != 0b10 || n3 lsr 6 != 0b10 then raise MalFormed;
+            check_three n1 n2 n3
-            let p =
-              ((n1 land 0x0f) lsl 12)
-              lor ((n2 land 0x3f) lsl 6)
-              lor (n3 land 0x3f)
-            in
-            if p >= 0xd800 && p <= 0xdf00 then raise MalFormed;
-            p
         | 4 ->
             let n1 = Char.code c1 in
             let n2 = Char.code s.[i + 1] in
             let n3 = Char.code s.[i + 2] in
             let n4 = Char.code s.[i + 3] in
-            if n2 lsr 6 != 0b10 || n3 lsr 6 != 0b10 || n4 lsr 6 != 0b10 then
+            check_four n1 n2 n3 n4
-              raise MalFormed;
-            ((n1 land 0x07) lsl 18)
-            lor ((n2 land 0x3f) lsl 12)
-            lor ((n3 land 0x3f) lsl 6)
-            lor (n4 land 0x3f)
         | _ -> assert false
 
     let gen_from_char_gen s =
@@ -481,29 +510,18 @@ module Utf8 = struct
           | 2 ->
               let n1 = Char.code c1 in
               let n2 = next_or_fail () in
-              if n2 lsr 6 != 0b10 then raise MalFormed;
+              Uchar.of_int (check_two n1 n2)
-              Uchar.of_int (((n1 land 0x1f) lsl 6) lor (n2 land 0x3f))
           | 3 ->
               let n1 = Char.code c1 in
               let n2 = next_or_fail () in
               let n3 = next_or_fail () in
-              if n2 lsr 6 != 0b10 || n3 lsr 6 != 0b10 then raise MalFormed;
+              Uchar.of_int (check_three n1 n2 n3)
-              Uchar.of_int
-                (((n1 land 0x0f) lsl 12)
-                lor ((n2 land 0x3f) lsl 6)
-                lor (n3 land 0x3f))
           | 4 ->
               let n1 = Char.code c1 in
               let n2 = next_or_fail () in
               let n3 = next_or_fail () in
               let n4 = next_or_fail () in
-              if n2 lsr 6 != 0b10 || n3 lsr 6 != 0b10 || n4 lsr 6 != 0b10 then
+              Uchar.of_int (check_four n1 n2 n3 n4)
-                raise MalFormed;
-              Uchar.of_int
-                (((n1 land 0x07) lsl 18)
-                lor ((n2 land 0x3f) lsl 12)
-                lor ((n3 land 0x3f) lsl 6)
-                lor (n4 land 0x3f))
           | _ -> raise MalFormed
 
     (**************************)

src/lib/sedlexing.mli

@@ -1,171 +1,164 @@
-(* The package sedlex is released under the terms of an MIT-like license. *)
-(* See the attached LICENSE file.                                         *)
 (* Copyright 2005, 2013 by Alain Frisch and LexiFi.                       *)
+(* Copyright 2026 by xenia <xenia@awoo.systems>                           *)
 
 (** Runtime support for lexers generated by [sedlex]. *)
 
-(** This module is roughly equivalent to the module Lexing from the
+(** This module is roughly equivalent to the module Lexing from the OCaml
-    OCaml standard library, except that its lexbuffers handle Unicode
+    standard library, except that its lexbuffers handle Unicode code points
-    code points (OCaml type: {!Uchar.t} in the range [0..0x10ffff])
+    (OCaml type: {!Uchar.t} in the range [0..0x10ffff]) instead of bytes (OCaml
-    instead of bytes (OCaml type: [char]).
+    type: [char]).
 
     It is possible to have sedlex-generated lexers work on a custom
-    implementation for lex buffers. To do this, define a module [L]
+    implementation for lex buffers. To do this, define a module [L] which
-    which implements the [start], [next], [mark] and [backtrack]
+    implements the [start], [next], [mark] and [backtrack] functions (See the
-    functions (See the Internal Interface section below for a
+    Internal Interface section below for a specification). They need not work on
-    specification).  They need not work on a type named [lexbuf]: you
+    a type named [lexbuf]: you can use the type name you want. Then, just do in
-    can use the type name you want. Then, just do in your
+    your sedlex-processed source, bind this module to the name [Sedlexing] (for
-    sedlex-processed source, bind this module to the name [Sedlexing]
+    instance, with a local module definition: [let module Sedlexing = L in ...].
-    (for instance, with a local module definition: [let module Sedlexing
-    = L in ...].
 
-    Of course, you'll probably want to define functions like [lexeme] to
+    Of course, you'll probably want to define functions like [lexeme] to be used
-    be used in the lexers semantic actions.  *)
+    in the lexers semantic actions. *)
 
-(** The type of lexer buffers. A lexer buffer is the argument passed
+(** The type of lexer buffers. A lexer buffer is the argument passed to the
-          to the scanning functions defined by the generated lexers.
+    scanning functions defined by the generated lexers. The lexer buffer holds
-          The lexer buffer holds the internal information for the
+    the internal information for the scanners, including the code points of the
-          scanners, including the code points of the token currently scanned,
+    token currently scanned, its position from the beginning of the input
-          its position from the beginning of the input stream,
+    stream, and the current position of the lexer. *)
-          and the current position of the lexer. *)
 type lexbuf
 
-(** Raised by some functions to signal that some code point is not
+(** Raised by some functions to signal that some code point is not compatible
-        compatible with a specified encoding. *)
+    with a specified encoding. *)
 exception InvalidCodepoint of int
 
-(** Raised by functions in the [Utf8] and [Utf16] modules to report
+(** Raised by functions in the [Utf8] and [Utf16] modules to report strings
-        strings which do not comply to the encoding. *)
+    which do not comply to the encoding. *)
 exception MalFormed
 
 (** {6 Creating generic lexbufs} *)
 
-(** Create a generic lexer buffer.  When the lexer needs more
+(** Create a generic lexer buffer. When the lexer needs more characters, it will
-        characters, it will call the given function, giving it an array of
+    call the given function, giving it an array of Uchars [a], a position [pos]
-        Uchars [a], a position [pos] and a code point count [n].  The
+    and a code point count [n]. The function should put [n] code points or less
-        function should put [n] code points or less in [a], starting at
+    in [a], starting at position [pos], and return the number of characters
-        position [pos], and return the number of characters provided. A
+    provided. A return value of 0 means end of input. [bytes_per_char] argument
-        return value of 0 means end of input. [bytes_per_char] argument is
+    is optional. If unspecified, byte positions are the same as code point
-        optional. If unspecified, byte positions are the same as code point
     position. *)
 val create :
   ?bytes_per_char:(Uchar.t -> int) ->
   (Uchar.t array -> int -> int -> int) ->
   lexbuf
 
-(** set the initial tracked input position, in code point, for [lexbuf].
+(** set the initial tracked input position, in code point, for [lexbuf]. If
-        If unspecified, byte postion is set to the same value as code
+    unspecified, byte postion is set to the same value as code point position.
-        point position. *)
+*)
 val set_position :
   ?bytes_position:Lexing.position -> lexbuf -> Lexing.position -> unit
 
-(** [set_filename lexbuf file] sets the filename to [file] in
+(** [set_filename lexbuf file] sets the filename to [file] in [lexbuf]. It also
-        [lexbuf]. It also sets the {!Lexing.pos_fname} field in
+    sets the {!Lexing.pos_fname} field in returned {!Lexing.position} records.
-        returned {!Lexing.position} records. *)
+*)
 val set_filename : lexbuf -> string -> unit
 
 (** Create a lexbuf from a stream of Unicode code points. [bytes_per_char] is
-    optional. If unspecified, byte positions are the same as code point positions. *)
+    optional. If unspecified, byte positions are the same as code point
+    positions. *)
 val from_gen : ?bytes_per_char:(Uchar.t -> int) -> Uchar.t Gen.t -> lexbuf
 
 (** Create a lexbuf from an array of Unicode code points. [bytes_per_char] is
-    optional. If unspecified, byte positions are the same as code point positions. *)
+    optional. If unspecified, byte positions are the same as code point
+    positions. *)
 val from_int_array : ?bytes_per_char:(Uchar.t -> int) -> int array -> lexbuf
 
 (** Create a lexbuf from an array of Unicode code points. [bytes_per_char] is
-    optional. If unspecified, byte positions are the same as code point positions. *)
+    optional. If unspecified, byte positions are the same as code point
+    positions. *)
 val from_uchar_array :
   ?bytes_per_char:(Uchar.t -> int) -> Uchar.t array -> lexbuf
 
 (** {6 Interface for lexers semantic actions} *)
 
-(** The following functions can be called from the semantic actions of
+(** The following functions can be called from the semantic actions of lexer
-    lexer definitions.  They give access to the character string matched
+    definitions. They give access to the character string matched by the regular
-    by the regular expression associated with the semantic action. *)
+    expression associated with the semantic action. *)
 
-(** [Sedlexing.lexeme_start lexbuf] returns the offset in the
+(** [Sedlexing.lexeme_start lexbuf] returns the offset in the input stream of
-        input stream of the first code point of the matched string.
+    the first code point of the matched string. The first code point of the
-        The first code point of the stream has offset 0. *)
+    stream has offset 0. *)
 val lexeme_start : lexbuf -> int
 
-(** [Sedlexing.lexeme_start lexbuf] returns the offset in the
+(** [Sedlexing.lexeme_start lexbuf] returns the offset in the input stream of
-        input stream of the first byte of the matched string.
+    the first byte of the matched string. The first code point of the stream has
-        The first code point of the stream has offset 0. *)
+    offset 0. *)
 val lexeme_bytes_start : lexbuf -> int
 
-(** [Sedlexing.lexeme_end lexbuf] returns the offset in the input
+(** [Sedlexing.lexeme_end lexbuf] returns the offset in the input stream of the
-        stream of the character following the last code point of the
+    character following the last code point of the matched string. The first
-        matched string. The first character of the stream has offset
+    character of the stream has offset 0. *)
-        0. *)
 val lexeme_end : lexbuf -> int
 
-(** [Sedlexing.lexeme_end lexbuf] returns the offset in the input
+(** [Sedlexing.lexeme_end lexbuf] returns the offset in the input stream of the
-        stream of the byte following the last code point of the
+    byte following the last code point of the matched string. The first
-        matched string. The first character of the stream has offset
+    character of the stream has offset 0. *)
-        0. *)
 val lexeme_bytes_end : lexbuf -> int
 
 (** [Sedlexing.loc lexbuf] returns the pair
-        [(Sedlexing.lexeme_start lexbuf,Sedlexing.lexeme_end
+    [(Sedlexing.lexeme_start lexbuf,Sedlexing.lexeme_end lexbuf)]. *)
-        lexbuf)]. *)
 val loc : lexbuf -> int * int
 
 (** [Sedlexing.bytes_loc lexbuf] returns the pair
-        [(Sedlexing.lexeme_bytes_start lexbuf,Sedlexing.lexeme_bytes_end
+    [(Sedlexing.lexeme_bytes_start lexbuf,Sedlexing.lexeme_bytes_end lexbuf)].
-        lexbuf)]. *)
+*)
 val bytes_loc : lexbuf -> int * int
 
 (** [Sedlexing.lexeme_length lexbuf] returns the difference
-        [(Sedlexing.lexeme_end lexbuf) - (Sedlexing.lexeme_start
+    [(Sedlexing.lexeme_end lexbuf) - (Sedlexing.lexeme_start lexbuf)], that is,
-        lexbuf)], that is, the length (in code points) of the matched
+    the length (in code points) of the matched string. *)
-        string. *)
 val lexeme_length : lexbuf -> int
 
 (** [Sedlexing.lexeme_length lexbuf] returns the difference
     [(Sedlexing.lexeme_bytes_end lexbuf) - (Sedlexing.lexeme_bytes_start
-        lexbuf)], that is, the length (in bytes) of the matched
+     lexbuf)], that is, the length (in bytes) of the matched string. *)
-        string. *)
 val lexeme_bytes_length : lexbuf -> int
 
-(** [Sedlexing.lexing_positions lexbuf] returns the start and end
+(** [Sedlexing.lexing_positions lexbuf] returns the start and end positions, in
-        positions, in code points, of the current token, using a record of type
+    code points, of the current token, using a record of type [Lexing.position].
-        [Lexing.position]. This is intended for consumption
+    This is intended for consumption by parsers like those generated by
-        by parsers like those generated by [Menhir]. *)
+    [Menhir]. *)
 val lexing_positions : lexbuf -> Lexing.position * Lexing.position
 
-(** [Sedlexing.lexing_position_start lexbuf] returns the start
+(** [Sedlexing.lexing_position_start lexbuf] returns the start position, in code
-        position, in code points, of the current token. *)
+    points, of the current token. *)
 val lexing_position_start : lexbuf -> Lexing.position
 
-(** [Sedlexing.lexing_position_curr lexbuf] returns the end
+(** [Sedlexing.lexing_position_curr lexbuf] returns the end position, in code
-        position, in code points, of the current token. *)
+    points, of the current token. *)
 val lexing_position_curr : lexbuf -> Lexing.position
 
 (** [Sedlexing.lexing_bytes_positions lexbuf] returns the start and end
     positions, in bytes, of the current token, using a record of type
-        [Lexing.position]. This is intended for consumption
+    [Lexing.position]. This is intended for consumption by parsers like those
-        by parsers like those generated by [Menhir]. *)
+    generated by [Menhir]. *)
 val lexing_bytes_positions : lexbuf -> Lexing.position * Lexing.position
 
-(** [Sedlexing.lexing_bytes_position_start lexbuf] returns the start
+(** [Sedlexing.lexing_bytes_position_start lexbuf] returns the start position,
-        position, in bytes, of the current token. *)
+    in bytes, of the current token. *)
 val lexing_bytes_position_start : lexbuf -> Lexing.position
 
-(** [Sedlexing.lexing_bytes_position_curr lexbuf] returns the end
+(** [Sedlexing.lexing_bytes_position_curr lexbuf] returns the end position, in
-        position, in bytes, of the current token. *)
+    bytes, of the current token. *)
 val lexing_bytes_position_curr : lexbuf -> Lexing.position
 
-(** [Sedlexing.new_line lexbuf] increments the line count and
+(** [Sedlexing.new_line lexbuf] increments the line count and sets the beginning
-        sets the beginning of line to the current position, as though
+    of line to the current position, as though a newline character had been
-        a newline character had been encountered in the input. *)
+    encountered in the input. *)
 val new_line : lexbuf -> unit
 
-(** [Sedlexing.lexeme lexbuf] returns the string matched by the
+(** [Sedlexing.lexeme lexbuf] returns the string matched by the regular
-        regular expression as an array of Unicode code point. *)
+    expression as an array of Unicode code point. *)
 val lexeme : lexbuf -> Uchar.t array
 
-(** [Sedlexing.lexeme_char lexbuf pos] returns code point number [pos] in
+(** [Sedlexing.lexeme_char lexbuf pos] returns code point number [pos] in the
-        the matched string. *)
+    matched string. *)
 val lexeme_char : lexbuf -> int -> Uchar.t
 
 (** [Sedlexing.sub_lexeme lexbuf pos len] returns a substring of the string
@@ -173,56 +166,52 @@ val lexeme_char : lexbuf -> int -> Uchar.t
 val sub_lexeme : lexbuf -> int -> int -> Uchar.t array
 
 (** [Sedlexing.rollback lexbuf] puts [lexbuf] back in its configuration before
-    the last lexeme was matched. It is then possible to use another
+    the last lexeme was matched. It is then possible to use another lexer to
-    lexer to parse the same characters again. The other functions
+    parse the same characters again. The other functions above in this section
-    above in this section should not be used in the semantic action
+    should not be used in the semantic action after a call to
-    after a call to [Sedlexing.rollback]. *)
+    [Sedlexing.rollback]. *)
 val rollback : lexbuf -> unit
 
 (** {6 Internal interface} *)
 
-(** These functions are used internally by the lexers. They could be used
+(** These functions are used internally by the lexers. They could be used to
-    to write lexers by hand, or with a lexer generator different from
+    write lexers by hand, or with a lexer generator different from [sedlex]. The
-    [sedlex]. The lexer buffers have a unique internal slot that can store
+    lexer buffers have a unique internal slot that can store an integer. They
-    an integer. They also store a "backtrack" position.
+    also store a "backtrack" position. *)
- *)
 
-(** [start t] informs the lexer buffer that any
+(** [start t] informs the lexer buffer that any code points until the current
-    code points until the current position can be discarded.
+    position can be discarded. The current position become the "start" position
-    The current position become the "start" position as returned
+    as returned by [Sedlexing.lexeme_start]. Moreover, the internal slot is set
-    by [Sedlexing.lexeme_start]. Moreover, the internal slot is set to
+    to [-1] and the backtrack position is set to the current position. *)
-    [-1] and the backtrack position is set to the current position.
- *)
 val start : lexbuf -> unit
 
-(** [next lexbuf] extracts the next code point from the
+(** [next lexbuf] extracts the next code point from the lexer buffer and
-    lexer buffer and increments to current position. If the input stream
+    increments to current position. If the input stream is exhausted, the
-    is exhausted, the function returns [None].
+    function returns [None]. If a ['\n'] is encountered, the tracked line number
-    If a ['\n'] is encountered, the tracked line number is incremented. *)
+    is incremented. *)
 val next : lexbuf -> Uchar.t option
 
-(** [__private__next_int lexbuf] extracts the next code point from the
+(** [__private__next_int lexbuf] extracts the next code point from the lexer
-    lexer buffer and increments to current position. If the input stream
+    buffer and increments to current position. If the input stream is exhausted,
-    is exhausted, the function returns -1.
+    the function returns -1. If a ['\n'] is encountered, the tracked line number
-    If a ['\n'] is encountered, the tracked line number is incremented.
+    is incremented.
 
-    This is a private API, it should not be used by code using this module's
+    This is a private API, it should not be used by code using this module's API
-    API and can be removed at any time. *)
+    and can be removed at any time. *)
 val __private__next_int : lexbuf -> int
 
-(** [mark lexbuf i] stores the integer [i] in the internal
+(** [mark lexbuf i] stores the integer [i] in the internal slot. The backtrack
-    slot. The backtrack position is set to the current position. *)
+    position is set to the current position. *)
 val mark : lexbuf -> int -> unit
 
-(** [backtrack lexbuf] returns the value stored in the
+(** [backtrack lexbuf] returns the value stored in the internal slot of the
-    internal slot of the buffer, and performs backtracking
+    buffer, and performs backtracking (the current position is set to the value
-    (the current position is set to the value of the backtrack position). *)
+    of the backtrack position). *)
 val backtrack : lexbuf -> int
 
-(** [with_tokenizer tokenizer lexbuf] given a lexer and a lexbuf,
+(** [with_tokenizer tokenizer lexbuf] given a lexer and a lexbuf, returns a
-    returns a generator of tokens annotated with positions.
+    generator of tokens annotated with positions. This generator can be used
-    This generator can be used with the Menir parser generator's
+    with the Menir parser generator's incremental API. *)
-    incremental API. *)
 val with_tokenizer :
   (lexbuf -> 'token) ->
   lexbuf ->
@@ -232,30 +221,30 @@ val with_tokenizer :
 (** {6 Support for common encodings} *)
 
 module Latin1 : sig
-  (** Create a lexbuf from a Latin1 encoded stream (ie a stream
+  (** Create a lexbuf from a Latin1 encoded stream (ie a stream of Unicode code
-          of Unicode code points in the range [0..255]) *)
+      points in the range [0..255]) *)
   val from_gen : char Gen.t -> lexbuf
 
-  (** Create a lexbuf from a Latin1 encoded input channel.
+  (** Create a lexbuf from a Latin1 encoded input channel. The client is
-          The client is responsible for closing the channel. *)
+      responsible for closing the channel. *)
   val from_channel : in_channel -> lexbuf
 
   (** Create a lexbuf from a Latin1 encoded string. *)
   val from_string : string -> lexbuf
 
-  (** As [Sedlexing.lexeme] with a result encoded in Latin1.  This
+  (** As [Sedlexing.lexeme] with a result encoded in Latin1. This function
-          function throws an exception [InvalidCodepoint] if it is not
+      throws an exception [InvalidCodepoint] if it is not possible to encode the
-          possible to encode the result in Latin1. *)
+      result in Latin1. *)
   val lexeme : lexbuf -> string
 
-  (** As [Sedlexing.sub_lexeme] with a result encoded in Latin1.
+  (** As [Sedlexing.sub_lexeme] with a result encoded in Latin1. This function
-          This function throws an exception [InvalidCodepoint] if it
+      throws an exception [InvalidCodepoint] if it is not possible to encode the
-          is not possible to encode the result in Latin1. *)
+      result in Latin1. *)
   val sub_lexeme : lexbuf -> int -> int -> string
 
-  (** As [Sedlexing.lexeme_char] with a result encoded in Latin1.
+  (** As [Sedlexing.lexeme_char] with a result encoded in Latin1. This function
-          This function throws an exception [InvalidCodepoint] if it
+      throws an exception [InvalidCodepoint] if it is not possible to encode the
-          is not possible to encode the result in Latin1. *)
+      result in Latin1. *)
   val lexeme_char : lexbuf -> int -> char
 end
 
@@ -274,19 +263,24 @@ 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
   type byte_order = Little_endian | Big_endian
 
-  (** [Utf16.from_gen s opt_bo] creates a lexbuf from an UTF-16
+  (** [Utf16.from_gen s opt_bo] creates a lexbuf from an UTF-16 encoded stream.
-          encoded stream. If [opt_bo] matches with [None] the function
+      If [opt_bo] matches with [None] the function expects a BOM (Byte Order
-          expects a BOM (Byte Order Mark), and takes the byte order as
+      Mark), and takes the byte order as [Utf16.Big_endian] if it cannot find
-          [Utf16.Big_endian] if it cannot find one. When [opt_bo]
+      one. When [opt_bo] matches with [Some bo], [bo] is taken as byte order. In
-          matches with [Some bo], [bo] is taken as byte order. In this
+      this case a leading BOM is kept in the stream - the lexer has to ignore it
-          case a leading BOM is kept in the stream - the lexer has to
+      and a `wrong' BOM ([0xfffe]) will raise Utf16.InvalidCodepoint. *)
-          ignore it and a `wrong' BOM ([0xfffe]) will raise
-          Utf16.InvalidCodepoint.  *)
   val from_gen : char Gen.t -> byte_order option -> lexbuf
 
   (** Works as [Utf16.from_gen] with an [in_channel]. *)
@@ -295,13 +289,12 @@ module Utf16 : sig
   (** Works as [Utf16.from_gen] with a [string]. *)
   val from_string : string -> byte_order option -> lexbuf
 
-  (** [utf16_lexeme lb bo bom] as [Sedlexing.lexeme] with a result
+  (** [utf16_lexeme lb bo bom] as [Sedlexing.lexeme] with a result encoded in
-          encoded in UTF-16 in byte_order [bo] and starting with a BOM
+      UTF-16 in byte_order [bo] and starting with a BOM if [bom = true]. *)
-          if [bom = true].  *)
   val lexeme : lexbuf -> byte_order -> bool -> string
 
-  (** [sub_lexeme lb pos len bo bom] as
+  (** [sub_lexeme lb pos len bo bom] as [Sedlexing.sub_lexeme] with a result
-          [Sedlexing.sub_lexeme] with a result encoded in UTF-16 with
+      encoded in UTF-16 with byte order [bo] and starting with a BOM if
-          byte order [bo] and starting with a BOM if [bom=true] *)
+      [bom=true] *)
   val sub_lexeme : lexbuf -> int -> int -> byte_order -> bool -> string
 end

src/syntax/dune

@@ -1,13 +1,11 @@
 (library
  (name sedlex_ppx)
- (public_name sedlex.ppx)
+ (public_name noslop-sedlex.ppx)
  (kind ppx_rewriter)
- (libraries ppxlib sedlex sedlex.utils)
+ (libraries ppxlib noslop-sedlex noslop-sedlex.utils)
- (ppx_runtime_libraries sedlex)
+ (ppx_runtime_libraries noslop-sedlex)
  (preprocess
-  (pps ppxlib.metaquot))
+  (pps ppxlib.metaquot)))
- (flags
-  (:standard -w -9)))
 
 (rule
  (targets unicode.ml)

src/syntax/iso.mli

@@ -3,8 +3,7 @@
 
 open Sedlex_cset
 
-(** Letters to be used in identifiers, as specified
+(** Letters to be used in identifiers, as specified by ISO .... *)
-    by ISO .... *)
 
 (* Data provided by John M. Skaller *)
 

src/syntax/ppx_sedlex.ml

@@ -1,6 +1,5 @@
-(* The package sedlex is released under the terms of an MIT-like license. *)
-(* See the attached LICENSE file.                                         *)
 (* Copyright 2005, 2013 by Alain Frisch and LexiFi.                       *)
+(* Copyright 2026 by xenia <xenia@awoo.systems>                           *)
 
 open Ppxlib
 open Ast_builder.Default
@@ -13,7 +12,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
@@ -199,14 +197,14 @@ let best_final final =
 let state_fun state = Printf.sprintf "__sedlex_state_%i" state
 
 let call_state lexbuf auto state =
-  let trans, final = auto.(state) in
+  let { Sedlex.trans; finals } = auto.(state) in
   if Array.length trans = 0 then (
-    match best_final final with
+    match best_final finals with
       | Some i -> eint ~loc:default_loc i
       | None -> assert false)
   else appfun (state_fun state) [lexbuf]
 
-let gen_state (lexbuf_name, lexbuf) auto i (trans, final) =
+let gen_state (lexbuf_name, lexbuf) auto i { Sedlex.trans; finals } =
   let loc = default_loc in
   let partition = Array.map fst trans in
   let cases =
@@ -236,7 +234,7 @@ let gen_state (lexbuf_name, lexbuf) auto i (trans, final) =
         ~expr:(Exp.fun_ ~loc Nolabel None lhs body);
     ]
   in
-  match best_final final with
+  match best_final finals with
     | None -> ret (body ())
     | Some _ when Array.length trans = 0 -> []
     | Some i ->
@@ -250,25 +248,19 @@ let gen_recflag auto =
      in states with no further transitions. *)
   try
     Array.iter
-      (fun (trans_i, _) ->
+      (fun { Sedlex.trans; _ } ->
         Array.iter
           (fun (_, j) ->
-            let trans_j, _ = auto.(j) in
+            if Array.length auto.(j).Sedlex.trans > 0 then raise Exit)
-            if Array.length trans_j > 0 then raise Exit)
+          trans)
-          trans_i)
       auto;
     Nonrecursive
   with Exit -> Recursive
 
-let gen_definition ((_, lexbuf) as lexbuf_with_name) l error =
+let gen_definition ((_, lexbuf) as lexbuf_with_name) auto l error =
   let loc = default_loc in
-  let brs = Array.of_list l in
-  let auto = Sedlex.compile (Array.map fst brs) in
   let cases =
-    Array.to_list
+    List.mapi (fun i (_, e) -> case ~lhs:(pint ~loc i) ~guard:None ~rhs:e) l
-      (Array.mapi
-         (fun i (_, e) -> case ~lhs:(pint ~loc i) ~guard:None ~rhs:e)
-         brs)
   in
   let states = Array.mapi (gen_state lexbuf_with_name auto) auto in
   let states = List.flatten (Array.to_list states) in
@@ -286,17 +278,46 @@ 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 char c = Cset.singleton (Char.code c)
+let uchar c = Cset.singleton (Uchar.to_int c)
 
-let regexp_for_string s =
+let err loc fmt =
-  let rec aux n =
+  Printf.ksprintf
-    if n = String.length s then Sedlex.eps
+    (fun s ->
-    else Sedlex.seq (regexp_for_char s.[n]) (aux (succ n))
+      raise (Location.Error (Location.Error.createf ~loc "Sedlex: %s" s)))
-  in
+    fmt
-  aux 0
 
-let err loc s =
+type encoding = Utf8 | Latin1 | Ascii
-  raise (Location.Error (Location.Error.createf ~loc "Sedlex: %s" s))
+
+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
@@ -304,32 +325,41 @@ let rec repeat r = function
   | 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 ~loc tuple =
     (* Construct something like Sub(a,b) *)
       match tuple with
-      | Some { ppat_desc = Ppat_tuple [p0; p1] } -> begin
+      | Some { ppat_desc = Ppat_tuple [p0; p1]; _ } ->
-          match func (aux p0) (aux p1) with
+          begin match func (aux ~encoding p0) (aux ~encoding p1) with
             | Some r -> r
             | None ->
-                err p.ppat_loc @@ "the " ^ name
+                err loc
-                ^ " operator can only applied to single-character length \
+                  "the %s operator can only applied to single-character length \
                    regexps"
+                  name
           end
       | _ ->
-          err p.ppat_loc @@ "the " ^ name
+          err loc "the %s operator requires two arguments, like %s(a,b)" name
-          ^ " operator requires two arguments, like " ^ name ^ "(a,b)"
+            name
-  and aux p =
+  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
-      | Ppat_construct ({ txt = Lident "Star" }, Some (_, p)) ->
+            (fun r p -> Sedlex.seq r (aux ~encoding p))
-          Sedlex.rep (aux p)
+            (aux ~encoding p) pl
-      | Ppat_construct ({ txt = Lident "Plus" }, Some (_, p)) ->
+      | Ppat_construct ({ txt = Lident "Star"; _ }, Some (_, p)) ->
-          Sedlex.plus (aux p)
+          Sedlex.rep (aux ~encoding p)
+      | Ppat_construct ({ txt = Lident "Plus"; _ }, Some (_, 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" },
+          ( { txt = Lident "Rep"; _ },
             Some
               ( _,
                 {
@@ -340,26 +370,28 @@ let regexp_of_pattern env =
                         {
                           ppat_desc =
                             Ppat_constant (i1 as i2) | Ppat_interval (i1, i2);
+                          _;
                         };
                       ];
-                } ) ) -> begin
+                  _;
-          match (i1, i2) with
+                } ) ) ->
+          begin match (i1, i2) with
             | 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" }, _) ->
+      | Ppat_construct ({ txt = Lident "Rep"; _ }, _) ->
           err p.ppat_loc "the Rep operator takes 2 arguments"
-      | Ppat_construct ({ txt = Lident "Opt" }, Some (_, p)) ->
+      | 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
+      | Ppat_construct ({ txt = Lident "Compl"; _ }, arg) ->
-          match arg with
+          begin match arg with
-            | Some (_, p0) -> begin
+            | Some (_, p0) ->
-                match Sedlex.compl (aux p0) with
+                begin match Sedlex.compl (aux ~encoding p0) with
                   | Some r -> r
                   | None ->
                       err p.ppat_loc
@@ -368,30 +400,40 @@ let regexp_of_pattern env =
                 end
             | _ -> err p.ppat_loc "the Compl operator requires an argument"
           end
-      | Ppat_construct ({ txt = Lident "Sub" }, arg) ->
+      | Ppat_construct ({ txt = Lident "Sub"; _ }, arg) ->
-          char_pair_op Sedlex.subtract "Sub" p
+          char_pair_op ~encoding Sedlex.subtract "Sub" ~loc:p.ppat_loc
             (Option.map (fun (_, arg) -> arg) arg)
-      | Ppat_construct ({ txt = Lident "Intersect" }, arg) ->
+      | Ppat_construct ({ txt = Lident "Intersect"; _ }, arg) ->
-          char_pair_op Sedlex.intersection "Intersect" p
+          char_pair_op ~encoding Sedlex.intersection "Intersect" ~loc:p.ppat_loc
             (Option.map (fun (_, arg) -> arg) arg)
-      | Ppat_construct ({ txt = Lident "Chars" }, arg) -> (
+      | Ppat_construct ({ txt = Lident "Chars"; _ }, arg) -> (
           let const =
             match arg with
-              | Some (_, { ppat_desc = Ppat_constant const }) -> Some const
+              | Some (_, { ppat_desc = Ppat_constant const; _ }) -> Some const
               | _ -> None
           in
           match const with
             | Some (Pconst_string (s, _, _)) ->
-                let c = ref Cset.empty in
+                let l = rev_csets_of_string ~loc:p.ppat_loc ~encoding s in
-                for i = 0 to String.length s - 1 do
+                let chars = List.fold_left Cset.union Cset.empty l in
-                  c := Cset.union !c (Cset.singleton (Char.code s.[i]))
+                Sedlex.chars chars
-                done;
-                Sedlex.chars !c
             | _ ->
                 err p.ppat_loc "the Chars operator requires a string argument")
-      | Ppat_interval (i_start, i_end) -> begin
+      | Ppat_interval (i_start, i_end) ->
-          match (i_start, i_end) with
+          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
@@ -400,22 +442,65 @@ let regexp_of_pattern env =
                      (codepoint (int_of_string i2)))
             | _ -> err p.ppat_loc "this pattern is not a valid interval regexp"
           end
-      | Ppat_constant const -> begin
+      | Ppat_constant const ->
-          match const with
+          begin match const with
-            | Pconst_string (s, _, _) -> regexp_for_string s
+            | Pconst_string (s, _, _) ->
-            | Pconst_char c -> regexp_for_char c
+                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
+      | Ppat_var { txt = x; _ } ->
-          try StringMap.find x env
+          begin try StringMap.find x env
-          with Not_found ->
+          with Not_found -> err p.ppat_loc "unbound regexp %s" x
-            err p.ppat_loc (Printf.sprintf "unbound regexp %s" x)
           end
       | _ -> err p.ppat_loc "this pattern is not a valid regexp"
   in
-  aux
+  aux ~encoding:Ascii
+
+let handle_sedlex_match ~env ~map_rhs match_expr =
+  let lexbuf =
+    match match_expr with
+      | { pexp_desc = Pexp_match (lexbuf, _); _ } -> (
+          match lexbuf with
+            | { pexp_desc = Pexp_ident { txt = Lident txt; _ }; _ } ->
+                (txt, lexbuf)
+            | _ ->
+                err lexbuf.pexp_loc
+                  "the matched expression must be a single identifier")
+      | _ ->
+          err match_expr.pexp_loc
+            "the %%sedlex extension is only recognized on match expressions"
+  in
+  let cases =
+    match match_expr with
+      | { pexp_desc = Pexp_match (_, cases); _ } -> cases
+      | _ -> assert false
+  in
+  let cases = List.rev cases in
+  let error =
+    match List.hd cases with
+      | { pc_lhs = [%pat? _]; pc_rhs = e; pc_guard = None } -> map_rhs e
+      | { pc_lhs = p; _ } ->
+          err p.ppat_loc "the last branch must be a catch-all error case"
+  in
+  let cases = List.rev (List.tl cases) in
+  let cases =
+    List.map
+      (function
+        | { pc_lhs = p; pc_rhs = e; pc_guard = None } ->
+            (regexp_of_pattern env p, map_rhs e)
+        | { pc_guard = Some e; _ } ->
+            err e.pexp_loc "'when' guards are not supported")
+      cases
+  in
+  let brs = Array.of_list cases in
+  let auto = Sedlex.compile (Array.map fst brs) in
+  (gen_definition lexbuf auto cases error, auto)
 
 let previous = ref []
 let regexps = ref []
@@ -431,44 +516,18 @@ let mapper =
 
     method! expression e =
       match e with
-        | [%expr [%sedlex [%e? { pexp_desc = Pexp_match (lexbuf, cases) }]]] ->
+        | [%expr [%sedlex [%e? { pexp_desc = Pexp_match _; _ } as match_expr]]]
-            let lexbuf =
+          ->
-              match lexbuf with
+            fst (handle_sedlex_match ~env ~map_rhs:this#expression match_expr)
-                | { pexp_desc = Pexp_ident { txt = Lident txt } } ->
-                    (txt, lexbuf)
-                | _ ->
-                    err lexbuf.pexp_loc
-                      "the matched expression must be a single identifier"
-            in
-            let cases = List.rev cases in
-            let error =
-              match List.hd cases with
-                | { pc_lhs = [%pat? _]; pc_rhs = e; pc_guard = None } ->
-                    this#expression e
-                | { pc_lhs = p } ->
-                    err p.ppat_loc
-                      "the last branch must be a catch-all error case"
-            in
-            let cases = List.rev (List.tl cases) in
-            let cases =
-              List.map
-                (function
-                  | { pc_lhs = p; pc_rhs = e; pc_guard = None } ->
-                      (regexp_of_pattern env p, this#expression e)
-                  | { pc_guard = Some e } ->
-                      err e.pexp_loc "'when' guards are not supported")
-                cases
-            in
-            gen_definition lexbuf cases error
         | [%expr
-            let [%p? { ppat_desc = Ppat_var { txt = name } }] =
+            let [%p? { ppat_desc = Ppat_var { txt = name; _ }; _ }] =
               [%sedlex.regexp? [%p? p]]
             in
             [%e? body]] ->
             (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
@@ -481,7 +540,7 @@ let mapper =
           (List.map
              (function
                | [%stri
-                   let [%p? { ppat_desc = Ppat_var { txt = name } }] =
+                   let [%p? { ppat_desc = Ppat_var { txt = name; _ }; _ }] =
                      [%sedlex.regexp? [%p? p]]] as i ->
                    regexps := i :: !regexps;
                    mapper := !mapper#define_regexp name p;
@@ -506,7 +565,7 @@ let mapper =
 let pre_handler cookies =
   previous :=
     match Driver.Cookies.get cookies "sedlex.regexps" Ast_pattern.__ with
-      | Some { pexp_desc = Pexp_extension (_, PStr l) } -> l
+      | Some { pexp_desc = Pexp_extension (_, PStr l); _ } -> l
       | Some _ -> assert false
       | None -> []
 

src/syntax/sedlex.ml

@@ -1,6 +1,5 @@
-(* The package sedlex is released under the terms of an MIT-like license. *)
-(* See the attached LICENSE file.                                         *)
 (* Copyright 2005, 2013 by Alain Frisch and LexiFi.                       *)
+(* Copyright 2026 by xenia <xenia@awoo.systems>                           *)
 
 module Cset = Sedlex_cset
 
@@ -25,7 +24,7 @@ let new_node () =
 let seq r1 r2 succ = r1 (r2 succ)
 
 let is_chars final = function
-  | { eps = []; trans = [(c, f)] } when f == final -> Some c
+  | { eps = []; trans = [(c, f)]; _ } when f == final -> Some c
   | _ -> None
 
 let chars c succ =
@@ -117,6 +116,9 @@ let transition (state : state) =
   Array.sort (fun (c1, _) (c2, _) -> compare c1 c2) t;
   t
 
+type dfa_state = { trans : (Cset.t * int) array; finals : bool array }
+type dfa = dfa_state array
+
 let compile rs =
   let rs = Array.map compile_re rs in
   let counter = ref 0 in
@@ -131,7 +133,7 @@ let compile rs =
       let trans = transition state in
       let trans = Array.map (fun (p, t) -> (p, aux t)) trans in
       let finals = Array.map (fun (_, f) -> List.memq f state) rs in
-      Hashtbl.add states_def i (trans, finals);
+      Hashtbl.add states_def i { trans; finals };
       i
   in
   let init = ref [] in
@@ -139,3 +141,56 @@ let compile rs =
   let i = aux !init in
   assert (i = 0);
   Array.init !counter (Hashtbl.find states_def)
+
+let cset_to_label cset =
+  let escape_dot c =
+    match c with
+      | '"' -> "\\\""
+      | '\\' -> "\\\\"
+      | '<' -> "\\<"
+      | '>' -> "\\>"
+      | _ -> String.make 1 c
+  in
+  let format_interval (lo, hi) =
+    if lo = -1 && hi = -1 then "EOF"
+    else if lo = hi then
+      if lo >= 32 && lo <= 126 then "'" ^ escape_dot (Char.chr lo) ^ "'"
+      else Printf.sprintf "U+%04X" lo
+    else if lo >= 32 && lo <= 126 && hi >= 32 && hi <= 126 then
+      "'" ^ escape_dot (Char.chr lo) ^ "'-'" ^ escape_dot (Char.chr hi) ^ "'"
+    else Printf.sprintf "U+%04X-U+%04X" lo hi
+  in
+  String.concat ", "
+    (List.map format_interval (cset : Cset.t :> (int * int) list))
+
+let dfa_to_dot dfa =
+  let buf = Buffer.create 1024 in
+  let bprintf = Printf.bprintf in
+  bprintf buf "digraph {\n";
+  bprintf buf "  rankdir=LR;\n";
+  bprintf buf "  node [shape=circle];\n\n";
+  bprintf buf "  _start [shape=point];\n";
+  bprintf buf "  _start -> state0;\n\n";
+  Array.iteri
+    (fun i { trans; finals } ->
+      let accepted =
+        let acc = ref [] in
+        for r = Array.length finals - 1 downto 0 do
+          if finals.(r) then acc := r :: !acc
+        done;
+        !acc
+      in
+      (match accepted with
+        | [] -> bprintf buf "  state%d [label=\"%d\"];\n" i i
+        | rules ->
+            bprintf buf
+              "  state%d [label=\"%d\\n[rule %s]\", shape=doublecircle];\n" i i
+              (String.concat "," (List.map string_of_int rules)));
+      Array.iter
+        (fun (cset, target) ->
+          let label = cset_to_label cset in
+          bprintf buf "  state%d -> state%d [label=\"%s\"];\n" i target label)
+        trans)
+    dfa;
+  bprintf buf "}\n";
+  Buffer.contents buf

src/syntax/sedlex.mli

@@ -1,6 +1,5 @@
-(* The package sedlex is released under the terms of an MIT-like license. *)
-(* See the attached LICENSE file.                                         *)
 (* Copyright 2005, 2013 by Alain Frisch and LexiFi.                       *)
+(* Copyright 2026 by xenia <xenia@awoo.systems>                           *)
 
 type regexp
 
@@ -22,4 +21,8 @@ val intersection : regexp -> regexp -> regexp option
 (* If each argument is a single [chars] regexp, returns a regexp
    which matches the intersection set.  Otherwise returns [None]. *)
 
-val compile : regexp array -> ((Sedlex_cset.t * int) array * bool array) array
+type dfa_state = { trans : (Sedlex_cset.t * int) array; finals : bool array }
+type dfa = dfa_state array
+
+val compile : regexp array -> dfa
+val dfa_to_dot : dfa -> string

src/syntax/sedlex_cset.ml

@@ -1,5 +1,4 @@
-(* The package sedlex is released under the terms of an MIT-like license. *)
-(* See the attached LICENSE file.                                         *)
 (* Copyright 2005, 2013 by Alain Frisch and LexiFi.                       *)
+(* Copyright 2026 by xenia <xenia@awoo.systems>                           *)
 
 include Sedlex_utils.Cset

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/codegen/dune

@@ -0,0 +1,8 @@
+(library
+ (name sedlex_gen_test)
+ (libraries noslop-sedlex)
+ (inline_tests)
+ (enabled_if
+  (>= %{ocaml_version} 4.14))
+ (preprocess
+  (pps ppx_sedlex_test ppx_expect)))

test/codegen/test_gen.ml

@@ -0,0 +1,120 @@
+let%expect_test "simple string match" =
+  (match%sedlex_test buf with "ab" | "de" -> () | _ -> ());
+  [%expect
+    {|
+    DOT:
+    digraph {
+      rankdir=LR;
+      node [shape=circle];
+
+      _start [shape=point];
+      _start -> state0;
+
+      state0 [label="0"];
+      state0 -> state1 [label="'a'"];
+      state0 -> state3 [label="'d'"];
+      state1 [label="1"];
+      state1 -> state2 [label="'b'"];
+      state2 [label="2\n[rule 0]", shape=doublecircle];
+      state3 [label="3"];
+      state3 -> state2 [label="'e'"];
+    }
+    CODE:
+    let rec __sedlex_state_0 buf =
+      match __sedlex_partition_1 (Sedlexing.__private__next_int buf) with
+      | 0 -> __sedlex_state_1 buf
+      | 1 -> __sedlex_state_3 buf
+      | _ -> Sedlexing.backtrack buf
+    and __sedlex_state_1 buf =
+      match __sedlex_partition_2 (Sedlexing.__private__next_int buf) with
+      | 0 -> 0
+      | _ -> Sedlexing.backtrack buf
+    and __sedlex_state_3 buf =
+      match __sedlex_partition_3 (Sedlexing.__private__next_int buf) with
+      | 0 -> 0
+      | _ -> Sedlexing.backtrack buf in
+    Sedlexing.start buf; (match __sedlex_state_0 buf with | 0 -> () | _ -> ())
+    |}]
+
+let%expect_test "character class" =
+  (match%sedlex_test buf with Plus 'a' .. 'z' -> () | _ -> ());
+  [%expect
+    {|
+    DOT:
+    digraph {
+      rankdir=LR;
+      node [shape=circle];
+
+      _start [shape=point];
+      _start -> state0;
+
+      state0 [label="0"];
+      state0 -> state1 [label="'a'-'z'"];
+      state1 [label="1\n[rule 0]", shape=doublecircle];
+      state1 -> state1 [label="'a'-'z'"];
+    }
+    CODE:
+    let rec __sedlex_state_0 buf =
+      match __sedlex_partition_1 (Sedlexing.__private__next_int buf) with
+      | 0 -> __sedlex_state_1 buf
+      | _ -> Sedlexing.backtrack buf
+    and __sedlex_state_1 buf =
+      Sedlexing.mark buf 0;
+      (match __sedlex_partition_1 (Sedlexing.__private__next_int buf) with
+       | 0 -> __sedlex_state_1 buf
+       | _ -> Sedlexing.backtrack buf) in
+    Sedlexing.start buf; (match __sedlex_state_0 buf with | 0 -> () | _ -> ())
+    |}]
+
+let%expect_test "multi-rule" =
+  (match%sedlex_test buf with
+    | "ab" -> ()
+    | "de" -> ()
+    | Plus '0' .. '9' -> ()
+    | _ -> ());
+  [%expect
+    {|
+    DOT:
+    digraph {
+      rankdir=LR;
+      node [shape=circle];
+
+      _start [shape=point];
+      _start -> state0;
+
+      state0 [label="0"];
+      state0 -> state1 [label="'0'-'9'"];
+      state0 -> state2 [label="'a'"];
+      state0 -> state4 [label="'d'"];
+      state1 [label="1\n[rule 2]", shape=doublecircle];
+      state1 -> state1 [label="'0'-'9'"];
+      state2 [label="2"];
+      state2 -> state3 [label="'b'"];
+      state3 [label="3\n[rule 0]", shape=doublecircle];
+      state4 [label="4"];
+      state4 -> state5 [label="'e'"];
+      state5 [label="5\n[rule 1]", shape=doublecircle];
+    }
+    CODE:
+    let rec __sedlex_state_0 buf =
+      match __sedlex_partition_1 (Sedlexing.__private__next_int buf) with
+      | 0 -> __sedlex_state_1 buf
+      | 1 -> __sedlex_state_2 buf
+      | 2 -> __sedlex_state_4 buf
+      | _ -> Sedlexing.backtrack buf
+    and __sedlex_state_1 buf =
+      Sedlexing.mark buf 2;
+      (match __sedlex_partition_2 (Sedlexing.__private__next_int buf) with
+       | 0 -> __sedlex_state_1 buf
+       | _ -> Sedlexing.backtrack buf)
+    and __sedlex_state_2 buf =
+      match __sedlex_partition_3 (Sedlexing.__private__next_int buf) with
+      | 0 -> 0
+      | _ -> Sedlexing.backtrack buf
+    and __sedlex_state_4 buf =
+      match __sedlex_partition_4 (Sedlexing.__private__next_int buf) with
+      | 0 -> 1
+      | _ -> Sedlexing.backtrack buf in
+    Sedlexing.start buf;
+    (match __sedlex_state_0 buf with | 0 -> () | 1 -> () | 2 -> () | _ -> ())
+    |}]

test/dune

@@ -1,8 +1,9 @@
 (library
  (name sedlex_test)
- (libraries sedlex)
+ (libraries noslop-sedlex)
- (inline_tests)
+ (inline_tests
+  (deps UTF-8-test.txt))
  (enabled_if
   (>= %{ocaml_version} 4.14))
  (preprocess
-  (pps sedlex.ppx ppx_expect)))
+  (pps noslop-sedlex.ppx ppx_expect)))

test/ppx_test/dune

@@ -0,0 +1,6 @@
+(library
+ (name ppx_sedlex_test)
+ (kind ppx_rewriter)
+ (libraries ppxlib noslop-sedlex.ppx)
+ (preprocess
+  (pps ppxlib.metaquot)))

test/ppx_test/ppx_sedlex_test.ml

@@ -0,0 +1,36 @@
+open Ppxlib
+module P = Sedlex_ppx.Ppx_sedlex
+module S = Sedlex_ppx.Sedlex
+
+let reset_state () =
+  P.partition_counter := 0;
+  P.table_counter := 0;
+  Hashtbl.clear P.partitions;
+  Hashtbl.clear P.tables
+
+let clear_tables () =
+  Hashtbl.clear P.partitions;
+  Hashtbl.clear P.tables
+
+let expand ~ctxt:_ expr =
+  reset_state ();
+  let loc = Location.none in
+  let code_expr, auto =
+    P.handle_sedlex_match ~env:P.builtin_regexps ~map_rhs:Fun.id expr
+  in
+  let code_str = Pprintast.string_of_expression code_expr in
+  let dot_str = S.dfa_to_dot auto in
+  clear_tables ();
+  [%expr
+    print_string "DOT:\n";
+    print_string [%e Ast_builder.Default.estring ~loc dot_str];
+    print_string "CODE:\n";
+    print_string [%e Ast_builder.Default.estring ~loc code_str];
+    print_newline ()]
+
+let ext =
+  Extension.V3.declare "sedlex_test" Extension.Context.expression
+    Ast_pattern.(single_expr_payload __)
+    expand
+
+let () = Driver.register_transformation "sedlex_test" ~extensions:[ext]

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À |}]