no uchar

Fixes: #167

.envrc

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

.gitattributes

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

.gitignore

@@ -8,7 +8,15 @@
 *.cmxs
 *.cmxa
 *.exe
+*.install
+*.merlin
+.*sw*
+_build
 libdoc
 src/syntax/ppx_sedlex
+src/generator/data/*.txt
 examples/complement
 examples/tokenizer
+examples/subtraction
+_opam
+.direnv

.merlin

@@ -0,0 +1,5 @@
+PKG compiler-libs ppx_tools ppx_tools.metaquot
+
+SRC src/**
+
+B src/**

.ocamlformat

@@ -0,0 +1,10 @@
+version=0.29.0
+profile = conventional
+break-separators = after
+space-around-lists = false
+doc-comments = before
+match-indent = 2
+match-indent-nested = always
+parens-ite
+exp-grouping = preserve
+module-item-spacing = compact

CHANGES

@@ -1,50 +0,0 @@
-1.99.2
-     * First official release of sedlex
-
-1.99.1
-     * Support for new Ast_mapper registration API, follow OCaml trunk after
-       the inclusion of the extension_point branch
-
-1.99
-     * First version of sedlex.  The history below refers to ulex, the ancestor
-       or sedlex implemented with Camlp4.
-
---------------------------------------------------------------------------
-
-1.1
-     * Generate (more) globally unique identifiers to avoid conflicts when open'ing another module
-       processed by ulex (issue reported by Gerd Stolpmann)
-
-1.0
-     * Update to the new Camlp4 and to ocamlbuild (release for OCaml 3.10
-       only), by Nicolas Pouillard.
-
-0.8
-     * Really make it work with OCaml 3.09.
-     * Support for Utf-16.
-
-0.7 released May 24 2005
-     * Bug fixes
-     * Update to OCaml 3.09 (currently CVS). Still works with OCaml 3.08.
-     * MIT-like license (used to LGPL)
-
-0.5 release Jul. 8 2004
-     * Document how to use a custom implementation for lex buffers
-     * Update to OCaml 3.08
-
-0.4 released Jan. 10 2004
-     * Bug fix (accept 1114111 as valid Unicode code point)
-     * Add the rollback function
-
-0.3 released Oct. 8 2003
-     * Bug fix
-     * Add a new predefined class for ISO identifiers
-
-0.2 released Sep. 22 2003
-     * Changed the names of predefined regexp
-     * Fix max_code = 0x10ffff
-     * Lexers that changes encoding on the fly
-     * Documentation of the interface Ulexing
-
-0.1 released Sep. 20 2003
-     * Initial release

CHANGES.md

@@ -0,0 +1,128 @@
+# 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)
+
+# 3.3 (2024-10-29)
+- Add support for unicode `16.0.0` (#157)
+- Add API for retrieving start and stop positions separately (#155)
+
+# 3.2 (2023-06-28):
+- Restore compatibility with OCaml 4.08
+- Use `Sedlexing.{Utf8,Utf16}.from_gen` to initialize UTF8 (resp. UTF16) lexing buffers from
+  string.
+- Delay raising Malformed until actually reading the malformed part of the imput. (#140)
+- Count lines in all cases (#130). Previously, certain functions for initiating the
+  lexical buffer would disable lines counting.
+- Check and fix invariants from Cset. The codebase was not respecting
+  invariants documented in the Cset module which could break code
+  relying on it. The code generated by sedlex.ppx could be affected.
+- Do not rely on comments from unicode UCD files
+- Add API to track position in bytes. Should be opt-in and backward compatible. (#146)
+
+# 3.1:
+- Fix directly nested sedlex matches (@smuenzel, PR #117, fixes: #12)
+- Use explicit stdlib in generated code (@hhugo, PR #122, fixes: #115)
+- Preserve location of lexbuf (@hhugo, PR #118, fixes: #19)
+- Don't use gen to consume channels (@hhugo, PR #124, fixes: #45)
+- New expect_test testsuite (@hhugo, PR #124)
+- Properly recognize malformed truncated input (@hhugo, PR #124)
+- Raise `Malformed` instead of `Invalid_arg` (@hhugo, PR #126, fixes: #91)
+- Updated unicode support to `15.0.0`
+
+# 3.0:
+- Dropped `Stream` api which was removed in `4.14.0` ahead of the `5.0`
+  release.
+
+2.6:
+- Adapted to ppxlib `0.26`, thanks to @pitag-ha
+
+2.5:
+- Fix exponential compilation time, thanks to @mnxn for reporting in #97
+  and @fangyi-zhou for fixing in #106
+- Update unicode support for `14.0.0`.
+
+# 2.4
+- Update `dune` support to `2.8`, add auto-generated `opam` files.
+- Optimize generated code, thanks to @bobzhang
+- Update unicode version to 13.0.0
+
+# 2.3
+- Switch to ppxlib
+
+# 2.2
+- Support for OCaml 4.08
+
+# 2.1
+- GPR#78: Auto-generate unicode data
+
+# 2.0
+- GPR#70: Switch to dune, opam v2
+- GPR#60: Breaking change: switch from int codepoints to Uchar.t
+  codepoints
+- GPR#59: Track lexing position
+
+# 1.99.4
+- GPR#47: Switch to ocaml-migrate-parsetree (contributed by Adrien Guatto)
+- GPR#42: Added 'Rep' (repeat operator) (contributed by jpathy)
+
+# 1.99.3
+- Update to work with 4.03 (4.02 still supported)
+
+# 1.99.2
+- First official release of sedlex
+
+# 1.99.1
+- Support for new Ast_mapper registration API, follow OCaml trunk after
+  the inclusion of the extension_point branch
+
+# 1.99
+- First version of sedlex.  The history below refers to ulex, the ancestor
+  or sedlex implemented with Camlp4.
+
+# 1.1
+- Generate (more) globally unique identifiers to avoid conflicts when open'ing another module
+  processed by ulex (issue reported by Gerd Stolpmann)
+
+# 1.0
+- Update to the new Camlp4 and to ocamlbuild (release for OCaml 3.10
+  only), by Nicolas Pouillard.
+
+# 0.8
+- Really make it work with OCaml 3.09.
+- Support for Utf-16.
+
+# 0.7 released May 24 2005
+- Bug fixes
+- Update to OCaml 3.09 (currently CVS). Still works with OCaml 3.08.
+- MIT-like license (used to LGPL)
+
+# 0.5 release Jul. 8 2004
+- Document how to use a custom implementation for lex buffers
+- Update to OCaml 3.08
+
+# 0.4 released Jan. 10 2004
+- Bug fix (accept 1114111 as valid Unicode code point)
+- Add the rollback function-
+# 0.3 released Oct. 8 2003
+- Bug fix
+- Add a new predefined class for ISO identifiers
+
+# 0.2 released Sep. 22 2003
+- Changed the names of predefined regexp
+- Fix max_code = 0x10ffff
+- Lexers that changes encoding on the fly
+- Documentation of the interface Ulexing
+
+# 0.1 released Sep. 20 2003
+- Initial release

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.
-
-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.
+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
+found in <licenses/LICENSE.sedlex>

META

@@ -1,13 +0,0 @@
-version = "1.99.2"
-description = "Runtime support for sedlex"
-archive(byte) = "sedlexing.cma"
-archive(native) = "sedlexing.cmxa"
-ppx = "./ppx_sedlex"
-
-package "ppx" (
-  version = "1.99.2"
-  description = "ppx implementation of sedlex"
-  requires = "ppx_tools"
-  archive(byte) = "sedlex.cma"
-  archive(native) = "sedlex.cmxa"
-)

Makefile

@@ -1,74 +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.
-
-include $(shell ocamlc -where)/Makefile.config
-
-VERSION=1.99.2
-# Don't forget to change META file as well
-
-.PHONY: all opt clean test install package
-
-all:
-	(cd src/lib && make all doc)
-	(cd src/syntax && make all)
-
-opt:
-	(cd src/syntax && make opt)
-	(cd src/lib && make opt)
-
-clean:
-	rm -f *~ *.cm* *.a *.lib *.o *.obj
-	(cd src/lib && make clean)
-	(cd src/syntax && make clean)
-	(cd examples && make clean)
-	rm -rf libdoc
-
-test: clean all opt
-	cd examples && make test
-
-INSTALL=META src/syntax/sedlex.cma src/syntax/ppx_sedlex$(EXE) src/lib/sedlexing.cma src/lib/sedlexing.cmi
-
-INSTALL_OPT=src/syntax/sedlex.cmxs src/syntax/sedlex$(EXT_LIB) src/syntax/sedlex.cmxa src/syntax/ppx_sedlex.opt$(EXE) src/lib/sedlexing.cmx src/lib/sedlexing$(EXT_LIB) src/lib/sedlexing.cmxa
-
-install:
-	ocamlfind install sedlex $(INSTALL) $(INSTALL_OPT)
-
-install_byteonly:
-	ocamlfind install sedlex $(INSTALL)
-
-uninstall:
-	ocamlfind remove sedlex
-
-PACKAGE = sedlex-$(VERSION)
-DISTRIB = \
-  CHANGES LICENSE META README.md Makefile \
-  examples/Makefile \
-  examples/tokenizer.ml \
-  src/lib/Makefile \
-  src/lib/sedlexing.ml \
-  src/lib/sedlexing.mli \
-  src/syntax/Makefile \
-  src/syntax/cset.ml \
-  src/syntax/cset.mli \
-  src/syntax/sedlex.ml \
-  src/syntax/sedlex.mli \
-  src/syntax/sedlex_ppx.ml \
-  src/syntax/unicode63.ml \
-  src/syntax/unicode63.mli
-
-
-package: clean
-	rm -rf sedlex.tar.gz
-	tar czf sedlex.tar.gz $(DISTRIB)
-	rm -Rf $(PACKAGE)
-	mkdir $(PACKAGE)
-	cd $(PACKAGE) && tar xzf ../sedlex.tar.gz
-	tar czf $(PACKAGE).tar.gz $(PACKAGE)
-	rm -Rf $(PACKAGE) sedlex.tar.gz
-
-
-TARGET=foo:bar/sedlex_dara
-upload:
-	scp $(PACKAGE).tar.gz README CHANGES $(TARGET)/
-	rsync -avz libdoc $(TARGET)

README.md

@@ -1,10 +1,17 @@
 # sedlex
 
+[![build](https://github.com/ocaml-community/sedlex/actions/workflows/build.yml/badge.svg)](https://github.com/ocaml-community/sedlex/actions/workflows/build.yml)
+
 Unicode-friendly lexer generator for OCaml.
 
 This package is licensed by LexiFi under the terms of the MIT license.
 
-Contact: alain.frisch@lexifi.com
+sedlex was originally written by Alain Frisch
+<alain.frisch@lexifi.com> and is now maintained as part of the
+ocaml-community repositories on github.
+
+## API
+The API is documented [here](https://ocaml-community.github.io/sedlex).
 
 ## Overview
 
@@ -40,7 +47,7 @@ if you use camlp4 or camlp5, with the standard or revised syntax.
 sedlex adds a new kind of expression to OCaml: lexer definitions.
 The syntax for the new construction is:
 
-```
+```ocaml
   match%sedlex lexbuf with
   | R1 -> e1
   ...
@@ -50,7 +57,7 @@ The syntax for the new construction is:
 
 or:
 
-```
+```ocaml
   [%sedlex match lexbuf with 
   | R1 -> e1
   ...
@@ -64,49 +71,72 @@ Guard expressions are not allowed.)
 
 where:
 - lexbuf is an arbitrary lowercase identifier, which must refer to
-  an existing value of type [Sedlexing.lexbuf].
+  an existing value of type `Sedlexing.lexbuf`.
 - the Ri are regular expressions (see below);
 - the ei and def are OCaml expressions (called actions) of the same type
-  (the type for the whole lexer definitioon).
+  (the type for the whole lexer definition).
 
 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
-- '....' (character constant) : recognize the specified character
-- i (integer constant) : recognize the specified codepoint
-- '...' .. '...': character range
-- i1 .. i2: range between two codepoints
-- R1 | R2 : alternation
-- R1, R2, ..., Rn : concatenation
-- Star R : Kleene star (0 or more repetition)
-- Plus R : equivalent to R, R*
-- Opt R : equivalent to ("" | R)
-- Chars "..." : recognize any character in the string
-- Compl R : assume that R is a single-character regexp (see below)
+- `"...."` (string constant): recognize the specified string.
+- `'....'` (character constant) : recognize the specified character
+- `i` (integer constant) : recognize the specified codepoint
+- `'...' .. '...'`: character range
+- `i1 .. i2`: range between two codepoints
+- `R1 | R2` : alternation
+- `R, R2, ..., Rn` : concatenation
+- `Star R` : Kleene star (0 or more repetition)
+- `Plus R` : equivalent to `R, R*`
+- `Opt R` : equivalent to `("" | R)`
+- `Rep (R, n)` : equivalent to `R{n}`
+- `Rep (R, n .. m)` : equivalent to `R{n, m}`
+- `Chars "..."` : recognize any character in the string
+- `Compl R` : assume that R is a single-character length regexp (see below)
   and recognize the complement set
-- lid (lowercase identifier) : reference a named regexp (see below)
+- `Sub (R1,R2)` : assume that R is a single-character length regexp (see below)
+  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 regexp is a regexp which does not contain (after expansion
-of references) concatenation, Star, Plus, Opt or string constants with a
-length different from one.
+A single-character length regexp is a regexp which does not contain (after
+expansion of references) concatenation, Star, Plus, Opt or string constants
+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
 construction, that can appear in place of a structure item:
 
-```
+```ocaml
   let lid = [%sedlex.regexp? R]
 ```
 
@@ -116,7 +146,7 @@ after the definition.
 
 The same syntax can be used for local binding:
 
-```
+```ocaml
   let lid = [%sedlex.regexp? R] in
   body
 ```
@@ -166,11 +196,10 @@ The quick way:
 
 
 Otherwise, the first thing to do is to compile and install sedlex.
-You need a recent version of OCaml.
+You need a recent version of OCaml and [dune](https://dune.build/).
 
 ```
-  make all
-  make opt (* optional *)
+  make
 ```
 
 ### With findlib
@@ -178,7 +207,7 @@ You need a recent version of OCaml.
 If you have findlib, you can use it to install and use sedlex.
 The name of the findlib package is "sedlex".
 
-Installation (after "make all" and "make opt"):
+Installation (after "make"):
 
 ```
   make install
@@ -187,13 +216,13 @@ Installation (after "make all" and "make opt"):
 Compilation of OCaml files with lexer specifications:
 
 ```
-  ocamlfind ocamlc -c -package sedlex my_file.ml
+  ocamlfind ocamlc -c -package sedlex.ppx my_file.ml
 ```
 
 When linking, you must also include the sedlex package:
 
 ```
-  ocamlfind ocamlc -o my_prog -linkpkg -package sedlex my_file.cmo
+  ocamlfind ocamlc -o my_prog -linkpkg -package sedlex.ppx my_file.cmo
 ```
 
 
@@ -209,6 +238,17 @@ source file through -ppx rewriter ppx_sedlex. Moreover, you need to
 link the application with the runtime support library for sedlex
 (sedlexing.cma / sedlexing.cmxa).
 
+### With utop
+
+Once sedlex is installed as per above, simply type
+
+```
+#require "sedlex.ppx";;
+```
+
+## Examples
+
+The `examples/` subdirectory contains several samples of sedlex in use.
 
 ## Contributors
 
@@ -217,3 +257,7 @@ link the application with the runtime support library for sedlex
 - Peter Zotov:
   - improvements to the build system
   - switched parts of ppx_sedlex to using concrete syntax (with ppx_metaquot)
+- Steffen Smolka: port to dune
+- Romain Beauxis:
+  - Implementation of the unicode table extractors
+  - General maintenance

dune-project

@@ -0,0 +1,29 @@
+(lang dune 3.20)
+
+(version "3.7")
+
+(name noslop-sedlex)
+(source (uri "https://git.lain.faith/noslop/noslop-sedlex.git"))
+(license "LicenseRef-Proprietary")
+(authors "xenia <xenia@awoo.systems>")
+(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 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
+OCaml source files. Lexing specific constructs are provided via a ppx syntax
+extension.")
+ (depends
+   (ocaml (>= 4.08))
+   dune
+   (ppxlib (>= 0.26.0))
+   gen
+   (ppx_expect :with-test)))

examples/Makefile

@@ -1,28 +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.
-
-include $(shell ocamlc -where)/Makefile.config
-
-.PHONY: test
-test: tokenizer$(EXE) complement$(EXE)
-	./tokenizer$(EXE)
-	./complement$(EXE)
-
-tokenizer$(EXE): tokenizer.ml
-	ocamlc -ppx "../src/syntax/ppx_sedlex$(EXE)" -I ../src/lib -o tokenizer$(EXE) sedlexing.cma tokenizer.ml
-
-complement$(EXE): complement.ml
-	ocamlc -ppx "../src/syntax/ppx_sedlex$(EXE)" -I ../src/lib -o complement$(EXE) sedlexing.cma complement.ml
-
-.PHONY: with_driver
-with_driver: tokenizer.ml
-	ocamlc -ppx "ppx_driver ../src/syntax/sedlex.cma" -I ../src/lib -o tokenizer$(EXE) sedlexing.cma tokenizer.ml
-
-.PHONY: with_findlib
-with_findlib: tokenizer.ml
-	ocamlfind ocamlc -c -package sedlex tokenizer.ml
-	ocamlfind ocamlc -o tokenizer$(EXE) -linkpkg -package sedlex tokenizer.cmo
-
-clean:
-	rm -f *~ *.cm* *.a *.lib *.o *.obj tokenizer$(EXE) complement$(EXE)

examples/complement.ml

@@ -1,11 +1,17 @@
-let ucase = [%sedlex.regexp? 'A'..'Z']
-let lcase = [%sedlex.regexp? 'a'..'z']
+let ucase = [%sedlex.regexp? 'A' .. 'Z']
+let lcase = [%sedlex.regexp? 'a' .. 'z']
 
 let rec token buf =
   match%sedlex buf with
-  | lcase -> print_char 'L';token buf
-  | Compl (ucase | lcase) -> print_char '?'; token buf
-  | ucase -> print_char 'U';token buf
+    | lcase ->
+        print_char 'L';
+        token buf
+    | Compl (ucase | lcase) ->
+        print_char '?';
+        token buf
+    | ucase ->
+        print_char 'U';
+        token buf
     | eof -> print_endline "."
     | _ -> assert false
 

examples/dune

@@ -0,0 +1,47 @@
+(executables
+ (names tokenizer regressions complement subtraction repeat performance)
+ (libraries noslop-sedlex noslop-sedlex.ppx)
+ (preprocess
+  (pps noslop-sedlex.ppx)))
+
+(rule
+ (alias runtest)
+ (deps
+  (:< tokenizer.exe))
+ (action
+  (run %{<})))
+
+(rule
+ (alias runtest)
+ (deps
+  (:< regressions.exe))
+ (action
+  (run %{<})))
+
+(rule
+ (alias runtest)
+ (deps
+  (:< complement.exe))
+ (action
+  (run %{<})))
+
+(rule
+ (alias runtest)
+ (deps
+  (:< subtraction.exe))
+ (action
+  (run %{<})))
+
+(rule
+ (alias runtest)
+ (deps
+  (:< repeat.exe))
+ (action
+  (run %{<})))
+
+(rule
+ (alias runtest)
+ (deps
+  (:< performance.exe))
+ (action
+  (run %{<})))

examples/performance.ml

@@ -0,0 +1,23 @@
+let rec token buf =
+  match%sedlex buf with any -> token buf | eof -> () | _ -> assert false
+
+let time f x =
+  let rec acc f x = function
+    | 0 -> f x
+    | n ->
+        f x |> ignore;
+        acc f x (n - 1)
+  in
+  let t = Sys.time () in
+  let fx = acc f x 10 in
+  Printf.printf "Execution time: %fs\n" (Sys.time () -. t);
+  fx
+
+let () =
+  let long_str = String.make 1000000 '\n' in
+  let token_from _ =
+    let lexbuf = Sedlexing.Latin1.from_string long_str in
+    (* let () = Sedlexing.set_curr_p lexbuf Lexing.dummy_pos in *)
+    token lexbuf
+  in
+  time token_from long_str

examples/regressions.ml

@@ -0,0 +1,58 @@
+(* This test that unicode_old.ml is a strict sub-set of new unicode.ml. *)
+
+module CSet = Sedlex_ppx.Sedlex_cset
+module Unicode = Sedlex_ppx.Unicode
+
+let test_versions = ("16.0.0", "17.0.0")
+
+let regressions =
+  [ (* Example *)
+    (* ("lt", CSet.union (CSet.singleton 0x1c5) (CSet.singleton (0x0001))) *) ]
+
+let compare name (old_ : CSet.t) (new_ : CSet.t) =
+  let diff = CSet.difference old_ new_ in
+  let regressions =
+    match List.assoc name regressions with
+      | exception Not_found -> CSet.empty
+      | x -> x
+  in
+  let regressions_intersect = CSet.intersection regressions old_ in
+  let regressions = CSet.difference regressions regressions_intersect in
+  let regressions_useless = CSet.difference regressions new_ in
+  let diff = CSet.difference diff regressions in
+  Seq.iter
+    (fun x ->
+      Printf.printf
+        "Invalid regression for 0x%x in %s: already present in old set.\n" x
+        name)
+    (CSet.to_seq regressions_intersect);
+  Seq.iter
+    (fun x ->
+      Printf.printf "Invalid regression for 0x%x in %s: absent in new set.\n" x
+        name)
+    (CSet.to_seq regressions_useless);
+  Seq.iter
+    (fun x -> Printf.printf "Code point 0x%x missing in %s!\n" x name)
+    (CSet.to_seq diff)
+
+let test new_l (name, old_l) =
+  (* Cn is for unassigned code points, which are allowed to be
+   * used in future version. *)
+  let old_l = Sedlex_utils.Cset.to_list old_l in
+  if name <> "cn" then (
+    let old_l =
+      List.fold_left
+        (fun acc (a, b) -> CSet.union acc (CSet.interval a b))
+        CSet.empty old_l
+    in
+    compare name old_l (List.assoc name new_l))
+
+let () =
+  if (Unicode_old.version, Unicode.version) <> test_versions then
+    failwith
+      (Printf.sprintf "Test written for versions: %s => %s\n%!"
+         Unicode_old.version Unicode.version);
+  Printf.printf "Testing Unicode regression: %s => %s\n%!" Unicode_old.version
+    Unicode.version;
+  List.iter (test Unicode.Categories.list) Unicode_old.Categories.list;
+  List.iter (test Unicode.Properties.list) Unicode_old.Properties.list

examples/repeat.ml

@@ -0,0 +1,26 @@
+let rec token buf =
+  match%sedlex buf with
+    | white_space ->
+        print_endline "\tWhitespace";
+        token buf
+    | 'a', Rep (white_space, 1) ->
+        print_endline "a\n\tWhitespace";
+        token buf
+    | Rep ("bc", 2) ->
+        print_endline "bcbc";
+        token buf
+    | Rep ("d", 1 .. 1) ->
+        print_endline "d";
+        token buf
+    | Rep ("ef", 1 .. 3) ->
+        Printf.printf "%s\n" (Sedlexing.Utf8.lexeme buf);
+        token buf
+    | eof -> print_endline "\tEnd"
+    | any ->
+        print_endline "Other";
+        token buf
+    | _ -> failwith "Internal failure: Reached impossible place"
+
+let () =
+  let lexbuf = Sedlexing.Utf8.from_string "a bcbc d ef efef efefef" in
+  token lexbuf

examples/subtraction.ml

@@ -0,0 +1,23 @@
+let rec token buf =
+  match%sedlex buf with
+    | white_space ->
+        print_endline "\tWhitespace";
+        token buf
+    | Sub (Chars "ab", "b") ->
+        print_endline "a";
+        token buf
+    | Chars "ab" | "c" ->
+        print_endline "abc";
+        token buf
+    | Intersect ("d", Chars "abd") ->
+        print_endline "d";
+        token buf
+    | eof -> print_endline "\tEnd"
+    | any ->
+        print_endline "Other";
+        token buf
+    | _ -> failwith "Internal failure: Reached impossible place"
+
+let () =
+  let lexbuf = Sedlexing.Utf8.from_string "a b c d e" in
+  token lexbuf

examples/tokenizer.ml

@@ -1,13 +1,19 @@
-let digit = [%sedlex.regexp? '0'..'9']
+let digit = [%sedlex.regexp? '0' .. '9']
 let number = [%sedlex.regexp? Plus digit]
 
 let rec token buf =
-  let letter = [%sedlex.regexp? 'a'..'z'|'A'..'Z'] in
+  let letter = [%sedlex.regexp? 'a' .. 'z' | 'A' .. 'Z'] in
   match%sedlex buf with
-  | number -> Printf.printf "Number %s\n" (Sedlexing.Latin1.lexeme buf); token buf
-  | letter, Star ('A'..'Z' | 'a'..'z' | digit) -> Printf.printf "Ident %s\n" (Sedlexing.Latin1.lexeme buf); token buf
+    | number ->
+        Printf.printf "Number %s\n" (Sedlexing.Latin1.lexeme buf);
+        token buf
+    | letter, Star ('A' .. 'Z' | 'a' .. 'z' | digit) ->
+        Printf.printf "Ident %s\n" (Sedlexing.Latin1.lexeme buf);
+        token buf
     | Plus xml_blank -> token buf
-  | Plus (Chars "+*-/") -> Printf.printf "Op %s\n" (Sedlexing.Latin1.lexeme buf); token buf
+    | Plus (Chars "+*-/") ->
+        Printf.printf "Op %s\n" (Sedlexing.Latin1.lexeme buf);
+        token buf
     | 128 .. 255 -> print_endline "Non ASCII"
     | eof -> print_endline "EOF"
     | _ -> failwith "Unexpected character"

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

@@ -0,0 +1,38 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+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: ["xenia <xenia@awoo.systems"]
+authors: ["xenia <xenia@awoo.systems>"]
+license: "LicenseRef-Proprietary"
+homepage: "https://git.lain.faith/noslop/noslop-sedlex.git"
+doc: "https://git.lain.faith/noslop/noslop-sedlex/wiki"
+depends: [
+  "ocaml" {>= "4.08"}
+  "dune" {>= "3.20"}
+  "ppxlib" {>= "0.26.0"}
+  "gen"
+  "ppx_expect" {with-test}
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "https://git.lain.faith/noslop/noslop-sedlex.git"
+x-maintenance-intent: ["(latest)"]

opam

@@ -1,12 +0,0 @@
-opam-version: "1"
-maintainer: "alain.frisch@lexifi.com"
-build: [
-  [make "all"]
-  [make "opt"]
-  [make "install"]
-]
-remove: [["ocamlfind" "remove" "sedlex"]]
-depends: ["ocamlfind" {>= "1.5.0"}
-          "ppx_tools" {>= "0.99"}
-         ]
-ocaml-version: [>= "4.02.0"]

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;
+})

src/common/cset.ml

@@ -0,0 +1,78 @@
+(* 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
+   must be ordered in increasing order. *)
+
+type t = (int * int) list
+
+let rec range_to_seq a b next () =
+  if a = b then Seq.Cons (a, next) else Seq.Cons (a, range_to_seq (a + 1) b next)
+
+let rec to_seq x () =
+  match x with [] -> Seq.Nil | (a, b) :: xs -> range_to_seq a b (to_seq xs) ()
+
+let check_invariant l =
+  let rec loop prev = function
+    | [] -> ()
+    | (a, b) :: xs ->
+        if a < prev then
+          failwith
+            (Printf.sprintf
+               "Sedlex_cset.of_list: not in increasing order or overlapping. \
+                [_-%d]-[%d-%d]"
+               prev a b);
+        if a = prev then
+          failwith
+            (Printf.sprintf
+               "Sedlex_cset.of_list: adjacent range. [_-%d]-[%d-%d]" prev a b);
+        if a > b then
+          failwith
+            (Printf.sprintf "Sedlex_cset.of_list: malformed range. [%d-%d]" a b);
+        loop b xs
+  in
+  loop (-1) l
+
+let of_list l =
+  check_invariant l;
+  l
+
+let to_list l = l
+let max_code = 0x10ffff (* must be < max_int *)
+let min_code = -1
+let empty = []
+let singleton i = [(i, i)]
+let is_empty = function [] -> true | _ -> false
+let interval i j = if i <= j then [(i, j)] else [(j, i)]
+let eof = singleton (-1)
+let any = interval 0 max_code
+
+let rec union c1 c2 =
+  match (c1, c2) with
+    | [], _ -> c2
+    | _, [] -> c1
+    | ((i1, j1) as s1) :: r1, (i2, j2) :: r2 ->
+        if i1 <= i2 then
+          if j1 + 1 < i2 then s1 :: union r1 c2
+          else if j1 < j2 then union r1 ((i1, j2) :: r2)
+          else union c1 r2
+        else union c2 c1
+
+let union_list : t list -> t = function
+  | [] -> empty
+  | [x] -> x
+  | l ->
+      List.concat l
+      |> List.sort (fun a b -> compare b a)
+      |> List.fold_left (fun (acc : t) (x : int * int) -> union [x] acc) empty
+
+let complement c =
+  let rec aux start = function
+    | [] -> if start <= max_code then [(start, max_code)] else []
+    | (i, j) :: l -> (start, i - 1) :: aux (succ j) l
+  in
+  match c with (-1, j) :: l -> aux (succ j) l | l -> aux (-1) l
+
+let intersection c1 c2 = complement (union (complement c1) (complement c2))
+let difference c1 c2 = complement (union (complement c1) c2)

src/common/cset.mli

@@ -0,0 +1,25 @@
+(* 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 intervals must be
+    non-overlapping and not collapsable, and the list must be ordered in
+    increasing order. *)
+type t = private (int * int) list
+
+val of_list : (int * int) list -> t
+val to_list : t -> (int * int) list
+val min_code : int
+val max_code : int
+val empty : t
+val any : t
+val union : t -> t -> t
+val union_list : t list -> t
+val difference : t -> t -> t
+val intersection : t -> t -> t
+val is_empty : t -> bool
+val eof : t
+val singleton : int -> t
+val interval : int -> int -> t
+val to_seq : t -> int Seq.t

src/common/dune

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

src/generator/README.md

@@ -0,0 +1,28 @@
+# Unicode specification extraction
+
+The file `src/syntax/unicode.ml` is generated using the data available at
+[unicode.org](https://www.unicode.org/Public/).
+
+The rule with `targets unicode.ml` at `src/syntax/dune` is the main entry point for this process.
+It specifies how `unicode.ml` should be generated when running `dune @build` and triggers:
+* download of data files at `src/generator/data`
+* build of `src/generator/gen_unicode.exe`
+* generation `unicode.ml` and places a copy in the source tree and a copy in the build tree
+
+The rule is ignored when using the `--ignore-promoted-rules` option. This option is also implied
+when using `-p`/`--for-release-of-packages` which is used for production build so production build
+do not download the text data and re-generate `unicode.ml`.
+
+However, each development build re-generates a `unicode.ml` file which is placed into the source
+tree and, thus, can be easily commited when it is updated.
+
+See: [dune documentation](https://dune.readthedocs.io/en/latest/dune-files.html#modes) for more
+information.
+
+## Update to new Unicode versions
+
+To update the supported version, update the URL at `src/generator/data/base_url`. Make sure to
+not include a trailing new line so that it is properly read in `src/generator/data/dune`.
+
+Finally, place a copy of the old `unicode.ml` at `examples/unicode_old.ml` and update 
+`test_versions` and `regressions` in `examples/regressions.ml`.

src/generator/data/base_url

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

src/generator/data/dune

@@ -0,0 +1,35 @@
+(rule
+ (target DerivedCoreProperties.txt)
+ (deps base_url)
+ (action
+  (run
+   curl
+   -L
+   -s
+   %{read:base_url}/ucd/DerivedCoreProperties.txt
+   -o
+   %{target})))
+
+(rule
+ (target DerivedGeneralCategory.txt)
+ (deps base_url)
+ (action
+  (run
+   curl
+   -L
+   -s
+   %{read:base_url}/ucd/extracted/DerivedGeneralCategory.txt
+   -o
+   %{target})))
+
+(rule
+ (target PropList.txt)
+ (deps base_url)
+ (action
+  (run curl -L -s %{read:base_url}/ucd/PropList.txt -o %{target})))
+
+(rule
+ (target UnicodeData.txt)
+ (deps base_url)
+ (action
+  (run curl -L -s %{read:base_url}/ucd/UnicodeData.txt -o %{target})))

src/generator/dune

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

src/generator/gen_unicode.ml

@@ -0,0 +1,209 @@
+(* This file generates unicode data from
+ * the files exported at https://www.unicode.org/Public/<unicode version>
+ * and stored at src/generator/data. *)
+open Sedlex_utils
+module SSet = Set.Make (String)
+
+let target = Sys.argv.(1)
+let categories = Hashtbl.create 1024
+let labels = Hashtbl.create 1024
+
+(* Drop comments and split semi-column separated fields *)
+let parse_line l =
+  let l =
+    match String.index_opt l '#' with None -> l | Some i -> String.sub l 0 i
+  in
+  String.split_on_char ';' l |> List.map String.trim
+
+let parse_code s =
+  try int_of_string (Printf.sprintf "0x%s" s)
+  with _ -> failwith (Printf.sprintf "invalid code %s" s)
+
+let parse_category x = String.lowercase_ascii (String.trim x)
+let parse_prop x = String.lowercase_ascii (String.trim x)
+
+let parse_interval s =
+  match String.split_on_char '.' (String.trim s) with
+    | [] -> assert false
+    | [x] ->
+        let x = parse_code x in
+        Cset.singleton x
+    | [x; ""; y] ->
+        let x = parse_code x and y = parse_code y in
+        Cset.interval x y
+    | _ -> failwith (Printf.sprintf "invalid interval %s" s)
+
+let print_elements ch hashtbl cats =
+  let cats_set = SSet.of_list cats in
+  let all_keys = SSet.of_seq (Hashtbl.to_seq_keys hashtbl) in
+  let missing = SSet.diff cats_set all_keys in
+  let ignoring = SSet.diff all_keys cats_set in
+  let len = List.length cats in
+  List.iter
+    (fun c ->
+      let entries =
+        List.map
+          (fun (b, e) -> Printf.sprintf "0x%x, 0x%x" b e)
+          (Cset.union_list (Hashtbl.find_all hashtbl c) :> (int * int) list)
+      in
+      Printf.fprintf ch "  let %s = Sedlex_cset.of_list\n    [" c;
+      List.iteri
+        (fun i x ->
+          if i > 0 then
+            if i mod 5 = 0 then Printf.fprintf ch ";\n     "
+            else Printf.fprintf ch "; ";
+          Printf.fprintf ch "%s" x)
+        entries;
+      Printf.fprintf ch "]\n\n")
+    cats;
+  Printf.fprintf ch "  let list = [\n";
+  List.iteri
+    (fun pos c ->
+      Printf.fprintf ch "    (%S, %s)%s\n" c c
+        (if pos == len - 1 then "" else ";"))
+    cats;
+  Printf.fprintf ch "  ]\n\n";
+  if not (SSet.is_empty ignoring) then (
+    Printf.fprintf ch "(* ignoring:\n";
+    SSet.iter (fun s -> Printf.fprintf ch "  - %s\n" s) ignoring;
+    Printf.fprintf ch "*)\n");
+  if not (SSet.is_empty missing) then (
+    Printf.fprintf ch "(* missing:\n";
+    SSet.iter (fun s -> Printf.fprintf ch "  - %s\n" s) missing;
+    Printf.fprintf ch "*)\n")
+
+let files =
+  [
+    ( "PropList.txt",
+      fun s ->
+        match parse_line s with
+          | [""] -> ()
+          | [interval; prop] ->
+              let interval = parse_interval interval in
+              let prop = parse_prop prop in
+              Hashtbl.add labels prop interval
+          | _ -> assert false );
+    ( "DerivedCoreProperties.txt",
+      fun s ->
+        match parse_line s with
+          | [""] -> ()
+          | [interval; prop] ->
+              let interval = parse_interval interval in
+              let prop = parse_prop prop in
+              Hashtbl.add labels prop interval
+          | [_interval; "InCB"; ("Extend" | "Consonant" | "Linker")] ->
+              (* TODO: support non-binary properties? *)
+              ()
+          | _ -> assert false );
+    ( "DerivedGeneralCategory.txt",
+      fun s ->
+        match parse_line s with
+          | [""] -> ()
+          | [interval; cat] ->
+              let interval = parse_interval interval in
+              let cat = parse_category cat in
+              Hashtbl.add categories cat interval
+          | _ -> assert false );
+    ( "UnicodeData.txt",
+      fun s ->
+        match parse_line s with
+          | [""] -> ()
+          | interval :: _ :: cat :: _ ->
+              let interval = parse_interval interval in
+              let cat = parse_category cat in
+              Hashtbl.add categories cat interval
+          | _ -> assert false );
+  ]
+
+let read_version fname =
+  let version_rex =
+    Str.regexp "^# PropList-\\([0-9]+\\.[0-9]+\\.[0-9]+\\)\\.txt"
+  in
+  let ch = open_in_bin fname in
+  let s = input_line ch in
+  close_in ch;
+  ignore (Str.string_match version_rex s 0);
+  Str.matched_group 1 s
+
+let exported_categories =
+  [
+    "cc";
+    "cf";
+    "cn";
+    "co";
+    "cs";
+    "ll";
+    "lm";
+    "lo";
+    "lt";
+    "lu";
+    "mc";
+    "me";
+    "mn";
+    "nd";
+    "nl";
+    "no";
+    "pc";
+    "pd";
+    "pe";
+    "pf";
+    "pi";
+    "po";
+    "ps";
+    "sc";
+    "sk";
+    "sm";
+    "so";
+    "zl";
+    "zp";
+    "zs";
+  ]
+
+let exported_properties =
+  [
+    "alphabetic";
+    "ascii_hex_digit";
+    "hex_digit";
+    "id_continue";
+    "id_start";
+    "lowercase";
+    "math";
+    "other_alphabetic";
+    "other_lowercase";
+    "other_math";
+    "other_uppercase";
+    "uppercase";
+    "white_space";
+    "xid_continue";
+    "xid_start";
+  ]
+
+let () =
+  let base_dir =
+    Filename.concat (Filename.dirname Sys.executable_name) "data"
+  in
+  let version = read_version (Filename.concat base_dir "PropList.txt") in
+  List.iter
+    (fun (fname, fn) ->
+      let ch = open_in_bin (Filename.concat base_dir fname) in
+      try
+        while true do
+          let ret = input_line ch in
+          fn ret
+        done
+      with End_of_file -> close_in ch)
+    files;
+  let ch = open_out_bin target in
+  Printf.fprintf ch {|[@@@ocamlformat "disable"]|};
+  Printf.fprintf ch "\n\n";
+  Printf.fprintf ch
+    "(* This file was automatically generated, do not edit. *)\n";
+  Printf.fprintf ch "(* Edit gen_unicode.ml.inc instead. *)\n\n";
+  Printf.fprintf ch "\n\nlet version = %S\n\n" version;
+  Printf.fprintf ch "module Categories = struct\n\n";
+  print_elements ch categories exported_categories;
+  Printf.fprintf ch "end\n\n";
+  Printf.fprintf ch "module Properties = struct\n\n";
+  print_elements ch labels exported_properties;
+  Printf.fprintf ch "end\n";
+  close_out ch

src/lib/Makefile

@@ -1,26 +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.
-
-MODS=sedlexing.cmo
-
-all: sedlexing.cma
-opt: sedlexing.cmxa
-
-sedlexing.cma: $(MODS:.cmo=.mli) $(MODS:.cmo=.ml)
-	ocamlc -w +A-4-9 -safe-string -c $(MODS:.cmo=.mli) $(MODS:.cmo=.ml)
-	ocamlc -a -o sedlexing.cma $(MODS)
-
-sedlexing.cmxa: $(MODS:.cmo=.mli) $(MODS:.cmo=.ml)
-	ocamlopt -safe-string -c $(MODS:.cmo=.mli) $(MODS:.cmo=.ml)
-	ocamlopt -a -o sedlexing.cmxa $(MODS:.cmo=.cmx)
-
-doc:
-	rm -rf ../../libdoc
-	mkdir ../../libdoc
-	ocamldoc -html sedlexing.mli -d ../../libdoc
-
-
-
-clean:
-	rm -f *~ *.cm* *.a *.lib *.exe *.o *.obj

src/lib/dune

@@ -0,0 +1,5 @@
+(library
+ (name sedlex)
+ (public_name noslop-sedlex)
+ (wrapped false)
+ (libraries gen))

src/lib/sedlexing.ml

@@ -1,440 +1,658 @@
-(* 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
 
+module Uchar = struct
+  (* This for compatibility with ocaml < 4.14.0 *)
+  let utf_8_byte_length u =
+    match Uchar.to_int u with
+      | u when u < 0 -> assert false
+      | u when u <= 0x007F -> 1
+      | u when u <= 0x07FF -> 2
+      | u when u <= 0xFFFF -> 3
+      | u when u <= 0x10FFFF -> 4
+      | _ -> assert false
 
-let eof = -1
+  let utf_16_byte_length u =
+    match Uchar.to_int u with
+      | u when u < 0 -> assert false
+      | u when u <= 0xFFFF -> 2
+      | u when u <= 0x10FFFF -> 4
+      | _ -> assert false
+
+  let () =
+    ignore utf_8_byte_length;
+    ignore utf_16_byte_length
+
+  include Uchar
+
+  let of_int x =
+    if Uchar.is_valid x then Uchar.unsafe_of_int x else raise MalFormed
+end
+
+(* shadow polymorphic equal *)
+let ( = ) (a : int) b = a = b
+let ( >>| ) o f = match o with Some x -> Some (f x) | None -> None
 
 (* Absolute position from the beginning of the stream *)
 type apos = int
 
 type lexbuf = {
-  refill: (int array -> int -> int -> int);
-  mutable buf: int array;
-  mutable len: int;    (* Number of meaningful char in buffer *)
-  mutable offset: apos; (* Position of the first char in buffer
+  refill : Uchar.t array -> int -> int -> int;
+  bytes_per_char : Uchar.t -> int;
+  mutable buf : Uchar.t array;
+  mutable len : int;
+  (* Number of meaningful uchar in buffer *)
+  mutable offset : apos;
+  (* Number of meaningful bytes in buffer *)
+  mutable bytes_offset : apos;
+  (* Position of the first uchar in buffer
       in the input stream *)
-  mutable pos: int;
-  mutable start: int; (* First char we need to keep visible *)
-
-  mutable marked_pos: int;
-  mutable marked_val: int;
-
-  mutable finished: bool;
+  mutable pos : int;
+  (* Position of the first byte in buffer
+      in the input stream *)
+  mutable bytes_pos : int;
+  (* Position of the beginning of the line in the buffer, in uchar *)
+  mutable curr_bol : int;
+  (* Position of the beginning of the line in the buffer, in bytes *)
+  mutable curr_bytes_bol : int;
+  (* Index of the current line in the input stream. *)
+  mutable curr_line : int;
+  (* starting position, in uchar. *)
+  mutable start_pos : int;
+  (* starting position, in bytes. *)
+  mutable start_bytes_pos : int;
+  (* First uchar we need to keep visible *)
+  mutable start_bol : int;
+  (* First byte we need to keep visible *)
+  mutable start_bytes_bol : int;
+  (* start from 1 *)
+  mutable start_line : int;
+  mutable marked_pos : int;
+  mutable marked_bytes_pos : int;
+  mutable marked_bol : int;
+  mutable marked_bytes_bol : int;
+  mutable marked_line : int;
+  mutable marked_val : int;
+  mutable filename : string;
+  mutable finished : bool;
 }
 
 let chunk_size = 512
 
-let empty_lexbuf = {
+let empty_lexbuf bytes_per_char =
+  {
     refill = (fun _ _ _ -> assert false);
-  buf = [| |];
+    bytes_per_char;
+    buf = [||];
     len = 0;
     offset = 0;
+    bytes_offset = 0;
     pos = 0;
-  start = 0;
+    bytes_pos = 0;
+    curr_bol = 0;
+    curr_bytes_bol = 0;
+    curr_line = 1;
+    start_pos = 0;
+    start_bytes_pos = 0;
+    start_bol = 0;
+    start_bytes_bol = 0;
+    start_line = 0;
     marked_pos = 0;
+    marked_bytes_pos = 0;
+    marked_bol = 0;
+    marked_bytes_bol = 0;
+    marked_line = 0;
     marked_val = 0;
+    filename = "";
     finished = false;
-}
+  }
 
-let create f = {
-  empty_lexbuf with
-    refill = f;
-    buf = Array.create chunk_size 0;
-}
+let dummy_uchar = Uchar.of_int 0
+let nl_uchar = Uchar.of_int 10
 
-let from_stream s =
-  create (fun buf pos _len ->
-	    try buf.(pos) <- Stream.next s; 1
-	    with Stream.Failure -> 0)
+let create ?(bytes_per_char = fun _ -> 1) refill =
+  {
+    (empty_lexbuf bytes_per_char) with
+    refill;
+    buf = Array.make chunk_size dummy_uchar;
+  }
 
-let from_int_array a =
+let set_position ?bytes_position lexbuf position =
+  lexbuf.offset <- position.Lexing.pos_cnum - lexbuf.pos;
+  lexbuf.curr_bol <- position.Lexing.pos_bol;
+  lexbuf.curr_line <- position.Lexing.pos_lnum;
+  let bytes_position = Option.value ~default:position bytes_position in
+  lexbuf.bytes_offset <- bytes_position.Lexing.pos_cnum - lexbuf.bytes_pos;
+  lexbuf.curr_bytes_bol <- bytes_position.Lexing.pos_bol
+
+let set_filename lexbuf fname = lexbuf.filename <- fname
+
+let from_gen ?bytes_per_char gen =
+  let malformed = ref false in
+  let refill buf pos len =
+    let rec loop i =
+      if !malformed then raise MalFormed;
+      if i >= len then len
+      else (
+        match gen () with
+          | Some c ->
+              buf.(pos + i) <- c;
+              loop (i + 1)
+          | None -> i
+          | exception MalFormed when i <> 0 ->
+              malformed := true;
+              i)
+    in
+    loop 0
+  in
+  create ?bytes_per_char refill
+
+let from_int_array ?bytes_per_char a =
+  from_gen ?bytes_per_char
+    (Gen.init ~limit:(Array.length a) (fun i -> Uchar.of_int a.(i)))
+
+let from_uchar_array ?(bytes_per_char = fun _ -> 1) a =
   let len = Array.length a in
   {
-    empty_lexbuf with
+    (empty_lexbuf bytes_per_char) with
     buf = Array.init len (fun i -> a.(i));
-      len = len;
+    len;
     finished = true;
   }
 
-
 let refill lexbuf =
-  if lexbuf.len + chunk_size > Array.length lexbuf.buf
-  then begin
-    let s = lexbuf.start in
+  if lexbuf.len + chunk_size > Array.length lexbuf.buf then begin
+    let s = lexbuf.start_pos in
+    let s_bytes = lexbuf.start_bytes_pos in
     let ls = lexbuf.len - s in
     if ls + chunk_size <= Array.length lexbuf.buf then
       Array.blit lexbuf.buf s lexbuf.buf 0 ls
     else begin
       let newlen = (Array.length lexbuf.buf + chunk_size) * 2 in
-      let newbuf = Array.create newlen 0 in
+      let newbuf = Array.make newlen dummy_uchar in
       Array.blit lexbuf.buf s newbuf 0 ls;
       lexbuf.buf <- newbuf
     end;
     lexbuf.len <- ls;
     lexbuf.offset <- lexbuf.offset + s;
+    lexbuf.bytes_offset <- lexbuf.bytes_offset + s_bytes;
     lexbuf.pos <- lexbuf.pos - s;
+    lexbuf.bytes_pos <- lexbuf.bytes_pos - s_bytes;
     lexbuf.marked_pos <- lexbuf.marked_pos - s;
-    lexbuf.start <- 0
+    lexbuf.marked_bytes_pos <- lexbuf.marked_bytes_pos - s_bytes;
+    lexbuf.start_pos <- 0;
+    lexbuf.start_bytes_pos <- 0
   end;
   let n = lexbuf.refill lexbuf.buf lexbuf.pos chunk_size in
-  if (n = 0)
-  then begin
-    lexbuf.buf.(lexbuf.len) <- eof;
-    lexbuf.len <- lexbuf.len + 1;
+  if n = 0 then lexbuf.finished <- true else lexbuf.len <- lexbuf.len + n
+
+let new_line lexbuf =
+  lexbuf.curr_line <- lexbuf.curr_line + 1;
+  lexbuf.curr_bol <- lexbuf.pos + lexbuf.offset;
+  lexbuf.curr_bytes_bol <- lexbuf.bytes_pos + lexbuf.bytes_offset
+
+let[@inline always] next_aux some none lexbuf =
+  if (not lexbuf.finished) && lexbuf.pos = lexbuf.len then refill lexbuf;
+  if lexbuf.finished && lexbuf.pos = lexbuf.len then none
+  else begin
+    let ret = lexbuf.buf.(lexbuf.pos) in
+    lexbuf.pos <- lexbuf.pos + 1;
+    lexbuf.bytes_pos <- lexbuf.bytes_pos + lexbuf.bytes_per_char ret;
+    if Uchar.equal ret nl_uchar then new_line lexbuf;
+    some ret
   end
-  else lexbuf.len <- lexbuf.len + n
 
-let next lexbuf =
-  let i =
-    if lexbuf.pos = lexbuf.len then
-      if lexbuf.finished then eof
-      else (refill lexbuf; lexbuf.buf.(lexbuf.pos))
-    else lexbuf.buf.(lexbuf.pos)
-  in
-  if i = eof then lexbuf.finished <- true else lexbuf.pos <- lexbuf.pos + 1;
-  i
-
-let start lexbuf =
-  lexbuf.start <- lexbuf.pos;
-  lexbuf.marked_pos <- lexbuf.pos;
-  lexbuf.marked_val <- (-1)
+let next lexbuf = (next_aux [@inlined]) (fun x -> Some x) None lexbuf
+let __private__next_int lexbuf = (next_aux [@inlined]) Uchar.to_int (-1) lexbuf
 
 let mark lexbuf i =
   lexbuf.marked_pos <- lexbuf.pos;
+  lexbuf.marked_bytes_pos <- lexbuf.bytes_pos;
+  lexbuf.marked_bol <- lexbuf.curr_bol;
+  lexbuf.marked_bytes_bol <- lexbuf.curr_bytes_bol;
+  lexbuf.marked_line <- lexbuf.curr_line;
   lexbuf.marked_val <- i
 
+let start lexbuf =
+  lexbuf.start_pos <- lexbuf.pos;
+  lexbuf.start_bytes_pos <- lexbuf.bytes_pos;
+  lexbuf.start_bol <- lexbuf.curr_bol;
+  lexbuf.start_bytes_bol <- lexbuf.curr_bytes_bol;
+  lexbuf.start_line <- lexbuf.curr_line;
+  mark lexbuf (-1)
+
 let backtrack lexbuf =
   lexbuf.pos <- lexbuf.marked_pos;
+  lexbuf.bytes_pos <- lexbuf.marked_bytes_pos;
+  lexbuf.curr_bol <- lexbuf.marked_bol;
+  lexbuf.curr_bytes_bol <- lexbuf.marked_bytes_bol;
+  lexbuf.curr_line <- lexbuf.marked_line;
   lexbuf.marked_val
 
 let rollback lexbuf =
-  lexbuf.pos <- lexbuf.start
+  lexbuf.pos <- lexbuf.start_pos;
+  lexbuf.bytes_pos <- lexbuf.start_bytes_pos;
+  lexbuf.curr_bol <- lexbuf.start_bol;
+  lexbuf.curr_bytes_bol <- lexbuf.start_bytes_bol;
+  lexbuf.curr_line <- lexbuf.start_line
 
-let lexeme_start lexbuf = lexbuf.start + lexbuf.offset
+let lexeme_start lexbuf = lexbuf.start_pos + lexbuf.offset
+let lexeme_bytes_start lexbuf = lexbuf.start_bytes_pos + lexbuf.bytes_offset
 let lexeme_end lexbuf = lexbuf.pos + lexbuf.offset
+let lexeme_bytes_end lexbuf = lexbuf.bytes_pos + lexbuf.bytes_offset
+let loc lexbuf = (lexbuf.start_pos + lexbuf.offset, lexbuf.pos + lexbuf.offset)
 
-let loc lexbuf = (lexbuf.start + lexbuf.offset, lexbuf.pos + lexbuf.offset)
+let bytes_loc lexbuf =
+  ( lexbuf.start_bytes_pos + lexbuf.bytes_offset,
+    lexbuf.bytes_pos + lexbuf.bytes_offset )
 
-let lexeme_length lexbuf = lexbuf.pos - lexbuf.start
+let lexeme_length lexbuf = lexbuf.pos - lexbuf.start_pos
+let lexeme_bytes_length lexbuf = lexbuf.bytes_pos - lexbuf.start_bytes_pos
 
 let sub_lexeme lexbuf pos len =
-  Array.sub lexbuf.buf (lexbuf.start + pos) len
+  Array.sub lexbuf.buf (lexbuf.start_pos + pos) len
 
 let lexeme lexbuf =
-  Array.sub lexbuf.buf (lexbuf.start) (lexbuf.pos - lexbuf.start)
+  Array.sub lexbuf.buf lexbuf.start_pos (lexbuf.pos - lexbuf.start_pos)
 
-let lexeme_char lexbuf pos =
-  lexbuf.buf.(lexbuf.start + pos)
+let lexeme_char lexbuf pos = lexbuf.buf.(lexbuf.start_pos + pos)
 
+let lexing_position_start lexbuf =
+  {
+    Lexing.pos_fname = lexbuf.filename;
+    pos_lnum = lexbuf.start_line;
+    pos_cnum = lexbuf.start_pos + lexbuf.offset;
+    pos_bol = lexbuf.start_bol;
+  }
+
+let lexing_position_curr lexbuf =
+  {
+    Lexing.pos_fname = lexbuf.filename;
+    pos_lnum = lexbuf.curr_line;
+    pos_cnum = lexbuf.pos + lexbuf.offset;
+    pos_bol = lexbuf.curr_bol;
+  }
+
+let lexing_positions lexbuf =
+  let start_p = lexing_position_start lexbuf
+  and curr_p = lexing_position_curr lexbuf in
+  (start_p, curr_p)
+
+let lexing_bytes_position_start lexbuf =
+  {
+    Lexing.pos_fname = lexbuf.filename;
+    pos_lnum = lexbuf.start_line;
+    pos_cnum = lexbuf.start_bytes_pos + lexbuf.bytes_offset;
+    pos_bol = lexbuf.start_bytes_bol;
+  }
+
+let lexing_bytes_position_curr lexbuf =
+  {
+    Lexing.pos_fname = lexbuf.filename;
+    pos_lnum = lexbuf.curr_line;
+    pos_cnum = lexbuf.bytes_pos + lexbuf.bytes_offset;
+    pos_bol = lexbuf.curr_bytes_bol;
+  }
+
+let lexing_bytes_positions lexbuf =
+  let start_p = lexing_bytes_position_start lexbuf
+  and curr_p = lexing_bytes_position_curr lexbuf in
+  (start_p, curr_p)
+
+let with_tokenizer lexer' lexbuf =
+  let lexer () =
+    let token = lexer' lexbuf in
+    let start_p, curr_p = lexing_positions lexbuf in
+    (token, start_p, curr_p)
+  in
+  lexer
+
+module Chan = struct
+  exception Missing_input
+
+  type t = {
+    b : Bytes.t;
+    ic : in_channel;
+    mutable len : int;
+    mutable pos : int;
+  }
+
+  let min_buffer_size = 64
+
+  let create ic len : t =
+    let len = max len min_buffer_size in
+    { b = Bytes.create len; ic; len = 0; pos = 0 }
+
+  let available (t : t) = t.len - t.pos
+
+  let rec ensure_bytes_available (t : t) ~can_refill n =
+    if available t >= n then ()
+    else if can_refill then (
+      let len = t.len - t.pos in
+      if len > 0 then Bytes.blit t.b t.pos t.b 0 len;
+      let read = input t.ic t.b len (Bytes.length t.b - len) in
+      t.len <- len + read;
+      t.pos <- 0;
+      if read = 0 then raise Missing_input
+      else ensure_bytes_available t ~can_refill n)
+    else raise Missing_input
+
+  let ensure_bytes_available t ~can_refill n =
+    (* [n] should not exceed the size of the buffer. Here we are
+       conservative and make sure it doesn't exceed the mininum size
+       for the buffer. *)
+    if n <= 0 || n > min_buffer_size then invalid_arg "Sedlexing.Chan.ensure";
+    ensure_bytes_available t ~can_refill n
+
+  let get (t : t) i = Bytes.get t.b (t.pos + i)
+
+  let advance (t : t) n =
+    if t.pos + n > t.len then invalid_arg "advance";
+    t.pos <- t.pos + n
+
+  let raw_buf (t : t) = t.b
+  let raw_pos (t : t) = t.pos
+end
+
+let make_from_channel ?bytes_per_char ic ~max_bytes_per_uchar
+    ~min_bytes_per_uchar ~read_uchar =
+  let t = Chan.create ic (chunk_size * max_bytes_per_uchar) in
+  let malformed = ref false in
+  let refill buf pos len =
+    let rec loop i =
+      if !malformed then raise MalFormed;
+      if i = len then i
+      else (
+        match
+          (* we refill our bytes buffer only if we haven't refilled any uchar yet. *)
+          let can_refill = i = 0 in
+          Chan.ensure_bytes_available t ~can_refill min_bytes_per_uchar;
+          read_uchar ~can_refill t
+        with
+          | c ->
+              buf.(pos + i) <- c;
+              loop (i + 1)
+          | exception MalFormed when i <> 0 ->
+              malformed := true;
+              i
+          | exception Chan.Missing_input ->
+              if i = 0 && Chan.available t > 0 then raise MalFormed;
+              i)
+    in
+    loop 0
+  in
+  create ?bytes_per_char refill
 
 module Latin1 = struct
-  let from_stream s =
-    create (fun buf pos _len ->
-      try buf.(pos) <- Char.code (Stream.next s); 1
-      with Stream.Failure -> 0)
-
+  let from_gen s =
+    from_gen ~bytes_per_char:(fun _ -> 1) (Gen.map Uchar.of_char s)
 
   let from_string s =
     let len = String.length s in
     {
-     empty_lexbuf with
-     buf = Array.init len (fun i -> Char.code s.[i]);
-     len = len;
+      (empty_lexbuf (fun _ -> 1)) with
+      buf = Array.init len (fun i -> Uchar.of_char s.[i]);
+      len;
       finished = true;
     }
 
   let from_channel ic =
-    from_stream (Stream.of_channel ic)
+    make_from_channel ic
+      ~bytes_per_char:(fun _ -> 1)
+      ~min_bytes_per_uchar:1 ~max_bytes_per_uchar:1
+      ~read_uchar:(fun ~can_refill:_ t ->
+        let c = Chan.get t 0 in
+        Chan.advance t 1;
+        Uchar.of_char c)
 
   let to_latin1 c =
-    if (c >= 0) && (c < 256)
-    then Char.chr c
-    else raise (InvalidCodepoint c)
+    if Uchar.is_char c then Uchar.to_char c
+    else raise (InvalidCodepoint (Uchar.to_int c))
 
-  let lexeme_char lexbuf pos =
-    to_latin1 (lexeme_char lexbuf pos)
+  let lexeme_char lexbuf pos = to_latin1 (lexeme_char lexbuf pos)
 
   let sub_lexeme lexbuf pos len =
     let s = Bytes.create len in
-    for i = 0 to len - 1 do Bytes.set s i (to_latin1 lexbuf.buf.(lexbuf.start + pos + i)) done;
+    for i = 0 to len - 1 do
+      Bytes.set s i (to_latin1 lexbuf.buf.(lexbuf.start_pos + pos + i))
+    done;
     Bytes.to_string s
 
-  let lexeme lexbuf =
-    sub_lexeme lexbuf 0 (lexbuf.pos - lexbuf.start)
+  let lexeme lexbuf = sub_lexeme lexbuf 0 (lexbuf.pos - lexbuf.start_pos)
 end
 
-
 module Utf8 = struct
   module Helper = struct
     (* http://www.faqs.org/rfcs/rfc3629.html *)
 
-    let width = Array.make 256 (-1)
-    let () =
-      for i = 0 to 127 do width.(i) <- 1 done;
-      for i = 192 to 223 do width.(i) <- 2 done;
-      for i = 224 to 239 do width.(i) <- 3 done;
-      for i = 240 to 247 do width.(i) <- 4 done
+    let width = function
+      | '\000' .. '\127' -> 1
+      | '\192' .. '\223' -> 2
+      | '\224' .. '\239' -> 3
+      | '\240' .. '\247' -> 4
+      | _ -> raise MalFormed
 
-    let next s i =
-      match s.[i] with
-      | '\000'..'\127' as c ->
-          Char.code c
-      | '\192'..'\223' as c ->
-	  let n1 = Char.code c in
-	  let n2 = Char.code s.[i+1] in
-          if (n2 lsr 6 != 0b10) then 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)
-      | '\224'..'\239' as c ->
-	  let n1 = Char.code c 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;
+
+    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 <= 0xdf00) then raise MalFormed;
+      if p >= 0xd800 && p <= 0xdfff then raise MalFormed;
       p
-      | '\240'..'\247' as c ->
-	  let n1 = Char.code c 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 raise MalFormed;
-          ((n1 land 0x07) lsl 18) lor ((n2 land 0x3f) lsl 12) lor
-          ((n3 land 0x3f) lsl 6) lor (n4 land 0x3f)
-      | _ -> raise MalFormed
 
+    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)
 
-(* With this implementation, a truncated code point will result
-   in Stream.Failure, not in MalFormed. *)
+    let next s i =
+      let c1 = s.[i] in
+      match width c1 with
+        | 1 -> Char.code c1
+        | 2 ->
+            let n1 = Char.code c1 in
+            let n2 = Char.code s.[i + 1] in
+            check_two n1 n2
+        | 3 ->
+            let n1 = Char.code c1 in
+            let n2 = Char.code s.[i + 1] in
+            let n3 = Char.code s.[i + 2] in
+            check_three n1 n2 n3
+        | 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
+            check_four n1 n2 n3 n4
+        | _ -> assert false
 
-    let from_stream s =
-      match Stream.next s with
-      | '\000'..'\127' as c ->
-          Char.code c
-      | '\192'..'\223' as c ->
-	  let n1 = Char.code c in
-	  let n2 = Char.code (Stream.next s) in
-          if (n2 lsr 6 != 0b10) then raise MalFormed;
-          ((n1 land 0x1f) lsl 6) lor (n2 land 0x3f)
-      | '\224'..'\239' as c ->
-	  let n1 = Char.code c in
-	  let n2 = Char.code (Stream.next s) in
-	  let n3 = Char.code (Stream.next s) in
-          if (n2 lsr 6 != 0b10) || (n3 lsr 6 != 0b10) then raise MalFormed;
-          ((n1 land 0x0f) lsl 12) lor ((n2 land 0x3f) lsl 6) lor (n3 land 0x3f)
-      | '\240'..'\247' as c ->
-	  let n1 = Char.code c in
-	  let n2 = Char.code (Stream.next s) in
-	  let n3 = Char.code (Stream.next s) in
-	  let n4 = Char.code (Stream.next s) in
-          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)
-      | _ -> raise MalFormed
-
-
-
-    let compute_len s pos bytes =
-      let rec aux n i =
-        if i >= pos + bytes then if i = pos + bytes then n else raise MalFormed
-        else
-          let w = width.(Char.code s.[i]) in
-          if w > 0 then aux (succ n) (i + w)
-          else raise MalFormed
+    let gen_from_char_gen s =
+      let next_or_fail () =
+        match Gen.next s with None -> raise MalFormed | Some x -> Char.code x
       in
-      aux 0 pos
+      fun () ->
+        Gen.next s >>| fun c1 ->
+        match width c1 with
+          | 1 -> Uchar.of_char c1
+          | 2 ->
+              let n1 = Char.code c1 in
+              let n2 = next_or_fail () in
+              Uchar.of_int (check_two n1 n2)
+          | 3 ->
+              let n1 = Char.code c1 in
+              let n2 = next_or_fail () in
+              let n3 = next_or_fail () in
+              Uchar.of_int (check_three n1 n2 n3)
+          | 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
+              Uchar.of_int (check_four n1 n2 n3 n4)
+          | _ -> raise MalFormed
 
-    let rec blit_to_int s spos a apos n =
-      if n > 0 then begin
-        a.(apos) <- next s spos;
-        blit_to_int s (spos + width.(Char.code s.[spos])) a (succ apos) (pred n)
-      end
+    (**************************)
 
-    let to_int_array s pos bytes =
-      let n = compute_len s pos bytes in
-      let a = Array.create n 0 in
-      blit_to_int s pos a 0 n;
-      a
-
-(**************************)
-
-    let store b p =
-      if p <= 0x7f then
-        Buffer.add_char b (Char.chr p)
-      else if p <= 0x7ff then (
-        Buffer.add_char b (Char.chr (0xc0 lor (p lsr 6)));
-        Buffer.add_char b (Char.chr (0x80 lor (p land 0x3f)))
-       )
-      else if p <= 0xffff then (
-        if (p >= 0xd800 && p < 0xe000) then raise MalFormed;
-        Buffer.add_char b (Char.chr (0xe0 lor (p lsr 12)));
-        Buffer.add_char b (Char.chr (0x80 lor ((p lsr 6) land 0x3f)));
-        Buffer.add_char b (Char.chr (0x80 lor (p land 0x3f)))
-       )
-      else if p <= 0x10ffff then (
-        Buffer.add_char b (Char.chr (0xf0 lor (p lsr 18)));
-        Buffer.add_char b (Char.chr (0x80 lor ((p lsr 12) land 0x3f)));
-        Buffer.add_char b (Char.chr (0x80 lor ((p lsr 6)  land 0x3f)));
-        Buffer.add_char b (Char.chr (0x80 lor (p land 0x3f)))
-       )
-      else raise MalFormed
-
-    let from_int_array a apos len =
-      let b = Buffer.create (len * 4) in
-      let rec aux apos len =
-        if len > 0 then (store b a.(apos); aux (succ apos) (pred len))
-        else Buffer.contents b in
-      aux apos len
-
-    let stream_from_char_stream s =
-      Stream.from
-        (fun _ ->
-          try Some (from_stream s)
-          with Stream.Failure -> None)
+    let to_buffer a apos len b =
+      for i = apos to apos + len - 1 do
+        Buffer.add_utf_8_uchar b a.(i)
+      done
   end
 
   let from_channel ic =
-    from_stream (Helper.stream_from_char_stream (Stream.of_channel ic))
+    make_from_channel ic ~bytes_per_char:Uchar.utf_8_byte_length
+      ~min_bytes_per_uchar:1 ~max_bytes_per_uchar:4
+      ~read_uchar:(fun ~can_refill t ->
+        let w = Helper.width (Chan.get t 0) in
+        Chan.ensure_bytes_available t ~can_refill w;
+        let c =
+          Helper.next (Bytes.unsafe_to_string (Chan.raw_buf t)) (Chan.raw_pos t)
+        in
+        Chan.advance t w;
+        Uchar.of_int c)
 
-  let from_stream s =
-    create (fun buf pos _len ->
-      try buf.(pos) <- Helper.from_stream s; 1
-      with Stream.Failure -> 0)
+  let from_gen s =
+    from_gen ~bytes_per_char:Uchar.utf_8_byte_length
+      (Helper.gen_from_char_gen s)
 
   let from_string s =
-    from_int_array (Helper.to_int_array s 0 (String.length s))
+    from_gen (Gen.init ~limit:(String.length s) (fun i -> String.get s i))
 
   let sub_lexeme lexbuf pos len =
-    Helper.from_int_array lexbuf.buf (lexbuf.start + pos) len
+    let buf = Buffer.create (len * 4) in
+    Helper.to_buffer lexbuf.buf (lexbuf.start_pos + pos) len buf;
+    Buffer.contents buf
 
-  let lexeme lexbuf =
-    sub_lexeme lexbuf 0 (lexbuf.pos - lexbuf.start)
+  let lexeme lexbuf = sub_lexeme lexbuf 0 (lexbuf.pos - lexbuf.start_pos)
 end
 
-
 module Utf16 = struct
   type byte_order = Little_endian | Big_endian
+
   module Helper = struct
     (* http://www.ietf.org/rfc/rfc2781.txt *)
 
-    let number_of_char_pair bo c1 c2 = match bo with
-    | Little_endian -> ((Char.code c2) lsl 8) + (Char.code c1)
-    | Big_endian -> ((Char.code c1) lsl 8) + (Char.code c2)
+    let number_of_pair bo c1 c2 =
+      match bo with
+        | Little_endian -> (c2 lsl 8) + c1
+        | Big_endian -> (c1 lsl 8) + c2
 
-    let char_pair_of_number bo num = match bo with
-    | Little_endian ->
-        (Char.chr (num land 0xFF), Char.chr ((num lsr 8) land 0xFF ))
-    | Big_endian ->
-        (Char.chr ((num lsr 8) land 0xFF), Char.chr (num land 0xFF))
-
-    let next_in_stream bo s =
-      let c1 = Stream.next s in
-      let c2 = Stream.next s in
-      number_of_char_pair bo c1 c2
-
-    let from_stream bo s w1 =
-      if w1 = 0xfffe then raise (InvalidCodepoint w1);
-      if w1 < 0xd800 || 0xdfff < w1 then w1
-      else if w1 <= 0xdbff
-      then
-        let w2 = next_in_stream bo s in
-        if w2 < 0xdc00 || w2 > 0xdfff then raise MalFormed;
-        let upper10 = (w1 land 0x3ff) lsl 10
-        and lower10 = w2 land 0x3ff in
-        0x10000 + upper10 + lower10
-      else raise MalFormed
-
-    let stream_from_char_stream opt_bo s =
-      let bo = ref opt_bo in
-      Stream.from
-        (fun _ ->
-          try
-            let c1 = Stream.next s in
-            let c2 = Stream.next s in
-            let o = match !bo with
+    let get_bo bo c1 c2 =
+      match !bo with
         | Some o -> o
         | None ->
-                let o = match (Char.code c1, Char.code c2) with
-                | (0xff,0xfe) -> Little_endian
-                | _ -> Big_endian in
-                bo := Some o;
-                o in
-            Some (from_stream o s (number_of_char_pair o c1 c2))
-          with Stream.Failure -> None)
-
-
-    let compute_len opt_bo str pos bytes =
-      let s = stream_from_char_stream opt_bo
-          (Stream.from (fun i -> if i + pos >= bytes then None
-          else Some (str.[i + pos])))
+            let o =
+              match (c1, c2) with
+                | 0xff, 0xfe -> Little_endian
+                | _ -> Big_endian
             in
-      let l = ref 0 in
-      Stream.iter (fun _ -> incr l) s ;
-      !l
+            bo := Some o;
+            o
 
-    let blit_to_int opt_bo s spos a apos bytes =
-      let s = stream_from_char_stream opt_bo
-          (Stream.from (fun i -> if i+spos >= bytes then None
-          else Some (s.[i + spos]))) in
-      let p = ref apos in
-      try while true do a.(!p) <- Stream.next s ; incr p done; assert false
-      with Stream.Failure -> ()
+    let gen_from_char_gen opt_bo s =
+      let next_or_fail () =
+        match Gen.next s with None -> raise MalFormed | Some x -> Char.code x
+      in
+      let bo = ref opt_bo in
+      fun () ->
+        Gen.next s >>| fun c1 ->
+        let n1 = Char.code c1 in
+        let n2 = next_or_fail () in
+        let o = get_bo bo n1 n2 in
+        let w1 = number_of_pair o n1 n2 in
+        if w1 = 0xfffe then raise (InvalidCodepoint w1);
+        if w1 < 0xd800 || 0xdfff < w1 then Uchar.of_int w1
+        else if w1 <= 0xdbff then (
+          let n3 = next_or_fail () in
+          let n4 = next_or_fail () in
+          let w2 = number_of_pair o n3 n4 in
+          if w2 < 0xdc00 || w2 > 0xdfff then raise MalFormed;
+          let upper10 = (w1 land 0x3ff) lsl 10 and lower10 = w2 land 0x3ff in
+          Uchar.of_int (0x10000 + upper10 + lower10))
+        else raise MalFormed
 
-    let to_int_array opt_bo s pos bytes =
-      let len = compute_len opt_bo s pos bytes in
-      let a = Array.create len 0 in
-      blit_to_int opt_bo s pos a 0 bytes ;
-      a
-
-    let store bo buf code =
-      if code < 0x10000
-      then (
-        let (c1,c2) = char_pair_of_number bo code in
-        Buffer.add_char buf c1;
-        Buffer.add_char buf c2
-       ) else (
-        let u' = code - 0x10000  in
-        let w1 = 0xd800 + (u' lsr 10)
-        and w2 = 0xdc00 + (u' land 0x3ff) in
-        let (c1,c2) = char_pair_of_number bo w1
-        and (c3,c4) = char_pair_of_number bo w2 in
-        Buffer.add_char buf c1;
-        Buffer.add_char buf c2;
-        Buffer.add_char buf c3;
-        Buffer.add_char buf c4
-       )
-
-    let from_int_array bo a apos len bom =
-      let b = Buffer.create (len * 4) in
-      if bom then store bo b 0xfeff ; (* first, store the BOM *)
-      let rec aux apos len =
-        if len > 0
-        then (store bo b a.(apos); aux (succ apos) (pred len))
-        else Buffer.contents b  in
-      aux apos len
+    let to_buffer bo a apos len bom b =
+      let store =
+        match bo with
+          | Big_endian -> Buffer.add_utf_16be_uchar b
+          | Little_endian -> Buffer.add_utf_16le_uchar b
+      in
+      if bom then store (Uchar.of_int 0xfeff);
+      (* first, store the BOM *)
+      for i = apos to apos + len - 1 do
+        store a.(i)
+      done
   end
 
-
-  let from_stream s opt_bo =
-    from_stream (Helper.stream_from_char_stream opt_bo s)
-
   let from_channel ic opt_bo =
-    from_stream ((Stream.of_channel ic)) opt_bo
+    let bo = ref opt_bo in
+    make_from_channel ic ~bytes_per_char:Uchar.utf_16_byte_length
+      ~min_bytes_per_uchar:2 ~max_bytes_per_uchar:4
+      ~read_uchar:(fun ~can_refill t ->
+        let n1 = Char.code (Chan.get t 0) in
+        let n2 = Char.code (Chan.get t 1) in
+        let o = Helper.get_bo bo n1 n2 in
+        let w1 = Helper.number_of_pair o n1 n2 in
+        if w1 = 0xfffe then raise (InvalidCodepoint w1);
+        if w1 < 0xd800 || 0xdfff < w1 then (
+          Chan.advance t 2;
+          Uchar.of_int w1)
+        else if w1 <= 0xdbff then (
+          Chan.ensure_bytes_available t ~can_refill 4;
+          let n3 = Char.code (Chan.get t 2) in
+          let n4 = Char.code (Chan.get t 3) in
+          let w2 = Helper.number_of_pair o n3 n4 in
+          if w2 < 0xdc00 || w2 > 0xdfff then raise MalFormed;
+          let upper10 = (w1 land 0x3ff) lsl 10 and lower10 = w2 land 0x3ff in
+          Chan.advance t 4;
+          Uchar.of_int (0x10000 + upper10 + lower10))
+        else raise MalFormed)
 
-  let from_string s opt_bo =
-    let a = Helper.to_int_array opt_bo s 0 (String.length s) in
-    from_int_array a
+  let from_gen s opt_bo =
+    from_gen ~bytes_per_char:Uchar.utf_16_byte_length
+      (Helper.gen_from_char_gen opt_bo s)
+
+  let from_string s =
+    from_gen (Gen.init ~limit:(String.length s) (fun i -> String.get s i))
 
   let sub_lexeme lb pos len bo bom =
-    Helper.from_int_array bo lb.buf (lb.start + pos) len bom
+    let buf = Buffer.create ((len * 4) + 2) in
+    (* +2 for the BOM *)
+    Helper.to_buffer bo lb.buf (lb.start_pos + pos) len bom buf;
+    Buffer.contents buf
 
-  let lexeme lb bo bom =
-    sub_lexeme lb 0 (lb.pos - lb.start) bo bom
+  let lexeme lb bo bom = sub_lexeme lb 0 (lb.pos - lb.start_pos) bo bom
 end

src/lib/sedlexing.mli

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

src/syntax/Makefile

@@ -1,30 +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.
-
-include $(shell ocamlc -where)/Makefile.config
-
-SRCS=cset.mli cset.ml unicode63.mli unicode63.ml sedlex.mli sedlex.ml ppx_sedlex.ml
-OCAMLC=ocamlfind ocamlc -package ppx_tools.metaquot -w +A-4-9 -annot
-OCAMLOPT=ocamlfind ocamlopt -package ppx_tools.metaquot -w +A-4-9 -annot
-
-all: ppx_sedlex$(EXE) sedlex.cma
-opt: ppx_sedlex.opt$(EXE) sedlex.cmxa sedlex.cmxs
-
-sedlex.cma: $(SRCS)
-	$(OCAMLC) -a -o sedlex.cma $(SRCS)
-
-sedlex.cmxa: $(SRCS)
-	$(OCAMLOPT) -a -o sedlex.cmxa $(SRCS)
-
-sedlex.cmxs: $(SRCS)
-	$(OCAMLOPT) -shared -o sedlex.cmxs $(SRCS)
-
-ppx_sedlex$(EXE): sedlex.cma
-	$(OCAMLC) -o $@ -linkpkg -linkall sedlex.cma
-
-ppx_sedlex.opt$(EXE): sedlex.cmxa
-	$(OCAMLOPT) -o $@ -linkpkg -linkall sedlex.cmxa
-
-clean:
-	rm -f *~ *.cm* *.a *.lib *.o *.obj *.annot ppx_sedlex$(EXE) ppx_sedlex.opt$(EXE)

src/syntax/cset.ml

@@ -1,399 +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.                       *)
-
-(* Character sets are represented as lists of intervals.  The
-   intervals must be non-overlapping and not collapsable, and the list
-   must be ordered in increasing order. *)
-
-type t = (int * int) list
-
-let max_code = 0x10ffff  (* must be < max_int *)
-let min_code = -1
-
-let empty = []
-let singleton i = [i,i]
-let is_empty = function [] -> true | _ -> false
-let interval i j = if i <= j then [i,j] else [j,i]
-let eof = singleton (-1)
-let any = interval 0 max_code
-
-let rec union c1 c2 =
-  match c1,c2 with
-  | [], _ -> c2
-  | _, [] -> c1
-  | ((i1, j1) as s1)::r1, (i2, j2)::r2 ->
-	if (i1 <= i2) then
-	  if j1 + 1 < i2 then s1::(union r1 c2)
-	  else if (j1 < j2) then union r1 ((i1, j2)::r2)
-	  else union c1 r2
-	else union c2 c1
-
-let complement c =
-  let rec aux start = function
-    | [] -> if start <= max_code then [start,max_code] else []
-    | (i, j)::l -> (start, i-1)::(aux (succ j) l)
-  in
-  match c with
-    | (-1,j)::l -> aux (succ j) l
-    | l -> aux (-1) l
-
-let intersection c1 c2 =
-  complement (union (complement c1) (complement c2))
-
-let difference c1 c2 =
-  complement (union (complement c1) c2)
-
-
-(* Unicode classes from XML *)
-
-let base_char =
-  [ 0x0041,0x005A; 0x0061,0x007A; 0x00C0,0x00D6; 0x00D8,0x00F6;
-    0x00F8,0x00FF; 0x0100,0x0131; 0x0134,0x013E; 0x0141,0x0148;
-    0x014A,0x017E; 0x0180,0x01C3; 0x01CD,0x01F0; 0x01F4,0x01F5;
-    0x01FA,0x0217; 0x0250,0x02A8; 0x02BB,0x02C1; 0x0386,0x0386;
-    0x0388,0x038A; 0x038C,0x038C; 0x038E,0x03A1; 0x03A3,0x03CE;
-    0x03D0,0x03D6; 0x03DA,0x03DA; 0x03DC,0x03DC; 0x03DE,0x03DE;
-    0x03E0,0x03E0; 0x03E2,0x03F3;
-    0x0401,0x040C; 0x040E,0x044F; 0x0451,0x045C; 0x045E,0x0481;
-    0x0490,0x04C4; 0x04C7,0x04C8; 0x04CB,0x04CC; 0x04D0,0x04EB;
-    0x04EE,0x04F5; 0x04F8,0x04F9; 0x0531,0x0556; 0x0559,0x0559;
-    0x0561,0x0586; 0x05D0,0x05EA; 0x05F0,0x05F2; 0x0621,0x063A;
-    0x0641,0x064A; 0x0671,0x06B7; 0x06BA,0x06BE; 0x06C0,0x06CE;
-    0x06D0,0x06D3; 0x06D5,0x06D5; 0x06E5,0x06E6; 0x0905,0x0939;
-    0x093D,0x093D;
-    0x0958,0x0961; 0x0985,0x098C; 0x098F,0x0990; 0x0993,0x09A8;
-    0x09AA,0x09B0; 0x09B2,0x09B2; 0x09B6,0x09B9; 0x09DC,0x09DD;
-    0x09DF,0x09E1; 0x09F0,0x09F1; 0x0A05,0x0A0A; 0x0A0F,0x0A10;
-    0x0A13,0x0A28; 0x0A2A,0x0A30; 0x0A32,0x0A33; 0x0A35,0x0A36;
-    0x0A38,0x0A39; 0x0A59,0x0A5C; 0x0A5E,0x0A5E; 0x0A72,0x0A74;
-    0x0A85,0x0A8B; 0x0A8D,0x0A8D; 0x0A8F,0x0A91; 0x0A93,0x0AA8;
-    0x0AAA,0x0AB0; 0x0AB2,0x0AB3; 0x0AB5,0x0AB9; 0x0ABD,0x0ABD;
-    0x0AE0,0x0AE0;
-    0x0B05,0x0B0C; 0x0B0F,0x0B10; 0x0B13,0x0B28; 0x0B2A,0x0B30;
-    0x0B32,0x0B33; 0x0B36,0x0B39; 0x0B3D,0x0B3D; 0x0B5C,0x0B5D;
-    0x0B5F,0x0B61; 0x0B85,0x0B8A; 0x0B8E,0x0B90; 0x0B92,0x0B95;
-    0x0B99,0x0B9A; 0x0B9C,0x0B9C; 0x0B9E,0x0B9F; 0x0BA3,0x0BA4;
-    0x0BA8,0x0BAA; 0x0BAE,0x0BB5; 0x0BB7,0x0BB9; 0x0C05,0x0C0C;
-    0x0C0E,0x0C10; 0x0C12,0x0C28; 0x0C2A,0x0C33; 0x0C35,0x0C39;
-    0x0C60,0x0C61; 0x0C85,0x0C8C; 0x0C8E,0x0C90; 0x0C92,0x0CA8;
-    0x0CAA,0x0CB3; 0x0CB5,0x0CB9; 0x0CDE,0x0CDE; 0x0CE0,0x0CE1;
-    0x0D05,0x0D0C; 0x0D0E,0x0D10; 0x0D12,0x0D28; 0x0D2A,0x0D39;
-    0x0D60,0x0D61; 0x0E01,0x0E2E; 0x0E30,0x0E30; 0x0E32,0x0E33;
-    0x0E40,0x0E45; 0x0E81,0x0E82; 0x0E84,0x0E84; 0x0E87,0x0E88;
-    0x0E8A,0x0E8A;
-    0x0E8D,0x0E8D; 0x0E94,0x0E97; 0x0E99,0x0E9F; 0x0EA1,0x0EA3;
-    0x0EA5,0x0EA5;
-    0x0EA7,0x0EA7; 0x0EAA,0x0EAB; 0x0EAD,0x0EAE; 0x0EB0,0x0EB0;
-    0x0EB2,0x0EB3;
-    0x0EBD,0x0EBD; 0x0EC0,0x0EC4; 0x0F40,0x0F47; 0x0F49,0x0F69;
-    0x10A0,0x10C5; 0x10D0,0x10F6; 0x1100,0x1100; 0x1102,0x1103;
-    0x1105,0x1107; 0x1109,0x1109; 0x110B,0x110C; 0x110E,0x1112;
-    0x113C,0x113C;
-    0x113E,0x113E; 0x1140,0x1140; 0x114C,0x114C; 0x114E,0x114E;
-    0x1150,0x1150; 0x1154,0x1155; 0x1159,0x1159;
-    0x115F,0x1161; 0x1163,0x1163; 0x1165,0x1165; 0x1167,0x1167;
-    0x1169,0x1169; 0x116D,0x116E;
-    0x1172,0x1173; 0x1175,0x1175; 0x119E,0x119E; 0x11A8,0x11A8;
-    0x11AB,0x11AB; 0x11AE,0x11AF;
-    0x11B7,0x11B8; 0x11BA,0x11BA; 0x11BC,0x11C2; 0x11EB,0x11EB;
-    0x11F0,0x11F0; 0x11F9,0x11F9;
-    0x1E00,0x1E9B; 0x1EA0,0x1EF9; 0x1F00,0x1F15; 0x1F18,0x1F1D;
-    0x1F20,0x1F45; 0x1F48,0x1F4D; 0x1F50,0x1F57; 0x1F59,0x1F59;
-    0x1F5B,0x1F5B;
-    0x1F5D,0x1F5D; 0x1F5F,0x1F7D; 0x1F80,0x1FB4; 0x1FB6,0x1FBC;
-    0x1FBE,0x1FBE;
-    0x1FC2,0x1FC4; 0x1FC6,0x1FCC; 0x1FD0,0x1FD3; 0x1FD6,0x1FDB;
-    0x1FE0,0x1FEC; 0x1FF2,0x1FF4; 0x1FF6,0x1FFC; 0x2126,0x2126;
-    0x212A,0x212B; 0x212E,0x212E; 0x2180,0x2182; 0x3041,0x3094;
-    0x30A1,0x30FA; 0x3105,0x312C; 0xAC00,0xD7A3 ]
-
-let ideographic =
-  [ 0x3007,0x3007; 0x3021,0x3029; 0x4E00,0x9FA5 ]
-
-let combining_char =
-  [ 0x0300,0x0345; 0x0360,0x0361; 0x0483,0x0486; 0x0591,0x05A1;
-    0x05A3,0x05B9; 0x05BB,0x05BD; 0x05BF,0x05BF; 0x05C1,0x05C2;
-    0x05C4,0x05C4; 0x064B,0x0652; 0x0670,0x0670; 0x06D6,0x06DC;
-    0x06DD,0x06DF; 0x06E0,0x06E4; 0x06E7,0x06E8; 0x06EA,0x06ED;
-    0x0901,0x0903; 0x093C,0x093C; 0x093E,0x094C; 0x094D,0x094D;
-    0x0951,0x0954; 0x0962,0x0963; 0x0981,0x0983; 0x09BC,0x09BC;
-    0x09BE,0x09BE; 0x09BF,0x09BF; 0x09C0,0x09C4; 0x09C7,0x09C8;
-    0x09CB,0x09CD; 0x09D7,0x09D7; 0x09E2,0x09E3; 0x0A02,0x0A02;
-    0x0A3C,0x0A3C; 0x0A3E,0x0A3E; 0x0A3F,0x0A3F; 0x0A40,0x0A42;
-    0x0A47,0x0A48; 0x0A4B,0x0A4D; 0x0A70,0x0A71; 0x0A81,0x0A83;
-    0x0ABC,0x0ABC; 0x0ABE,0x0AC5; 0x0AC7,0x0AC9; 0x0ACB,0x0ACD;
-    0x0B01,0x0B03; 0x0B3C,0x0B3C; 0x0B3E,0x0B43; 0x0B47,0x0B48;
-    0x0B4B,0x0B4D; 0x0B56,0x0B57; 0x0B82,0x0B83; 0x0BBE,0x0BC2;
-    0x0BC6,0x0BC8; 0x0BCA,0x0BCD; 0x0BD7,0x0BD7; 0x0C01,0x0C03;
-    0x0C3E,0x0C44; 0x0C46,0x0C48; 0x0C4A,0x0C4D; 0x0C55,0x0C56;
-    0x0C82,0x0C83; 0x0CBE,0x0CC4; 0x0CC6,0x0CC8; 0x0CCA,0x0CCD;
-    0x0CD5,0x0CD6; 0x0D02,0x0D03; 0x0D3E,0x0D43; 0x0D46,0x0D48;
-    0x0D4A,0x0D4D; 0x0D57,0x0D57; 0x0E31,0x0E31; 0x0E34,0x0E3A;
-    0x0E47,0x0E4E; 0x0EB1,0x0EB1; 0x0EB4,0x0EB9; 0x0EBB,0x0EBC;
-    0x0EC8,0x0ECD; 0x0F18,0x0F19; 0x0F35,0x0F35; 0x0F37,0x0F37;
-    0x0F39,0x0F39; 0x0F3E,0x0F3E; 0x0F3F,0x0F3F; 0x0F71,0x0F84;
-    0x0F86,0x0F8B; 0x0F90,0x0F95; 0x0F97,0x0F97; 0x0F99,0x0FAD;
-    0x0FB1,0x0FB7; 0x0FB9,0x0FB9; 0x20D0,0x20DC; 0x20E1,0x20E1;
-    0x302A,0x302F; 0x3099,0x3099; 0x309A,0x309A ]
-
-let digit =
-  [ 0x0030,0x0039;
-    0x0660,0x0669; 0x06F0,0x06F9; 0x0966,0x096F; 0x09E6,0x09EF;
-    0x0A66,0x0A6F; 0x0AE6,0x0AEF; 0x0B66,0x0B6F; 0x0BE7,0x0BEF;
-    0x0C66,0x0C6F; 0x0CE6,0x0CEF; 0x0D66,0x0D6F; 0x0E50,0x0E59;
-    0x0ED0,0x0ED9; 0x0F20,0x0F29 ]
-
-let extender =
-  [ 0x00B7,0x00B7; 0x02D0,0x02D1; 0x0387,0x0387; 0x0640,0x0640;
-    0x0E46,0x0E46; 0x0EC6,0x0EC6; 0x3005,0x3005; 0x3031,0x3035;
-    0x309D,0x309E; 0x30FC,0x30FE ]
-
-let blank =
-  [ 0x0009,0x000A; 0x000D,0x000D; 0x0020,0x0020 ]
-
-let letter = union base_char ideographic
-
-
-(* Letters to be used in identifiers, as specified
-   by ISO ....
-   Data provided by John M. Skaller *)
-let tr8876_ident_char = [
-  (* ASCII *)
-  (0x0041,0x005a);
-  (0x0061,0x007a);
-
-  (* Latin *)
-  (0x00c0,0x00d6);
-  (0x00d8,0x00f6);
-  (0x00f8,0x01f5);
-  (0x01fa,0x0217);
-  (0x0250,0x02a8);
-
-  (* Greek *)
-  (0x0384,0x0384);
-  (0x0388,0x038a);
-  (0x038c,0x038c);
-  (0x038e,0x03a1);
-  (0x03a3,0x03ce);
-  (0x03d0,0x03d6);
-  (0x03da,0x03da);
-  (0x03dc,0x03dc);
-  (0x03de,0x03de);
-  (0x03e0,0x03e0);
-  (0x03e2,0x03f3);
-
-  (* Cyrillic *)
-  (0x0401,0x040d);
-  (0x040f,0x044f);
-  (0x0451,0x045c);
-  (0x045e,0x0481);
-  (0x0490,0x04c4);
-  (0x04c7,0x04c4);
-  (0x04cb,0x04cc);
-  (0x04d0,0x04eb);
-  (0x04ee,0x04f5);
-  (0x04f8,0x04f9);
-
-  (* Armenian *)
-  (0x0531,0x0556);
-  (0x0561,0x0587);
-  (0x04d0,0x04eb);
-
-  (* Hebrew *)
-  (0x05d0,0x05ea);
-  (0x05f0,0x05f4);
-
-  (* Arabic *)
-  (0x0621,0x063a);
-  (0x0640,0x0652);
-  (0x0670,0x06b7);
-  (0x06ba,0x06be);
-  (0x06c0,0x06ce);
-  (0x06e5,0x06e7);
-
-  (* Devanagari *)
-  (0x0905,0x0939);
-  (0x0958,0x0962);
-
-  (* Bengali *)
-  (0x0985,0x098c);
-  (0x098f,0x0990);
-  (0x0993,0x09a8);
-  (0x09aa,0x09b0);
-  (0x09b2,0x09b2);
-  (0x09b6,0x09b9);
-  (0x09dc,0x09dd);
-  (0x09df,0x09e1);
-  (0x09f0,0x09f1);
-
-  (* Gurmukhi *)
-  (0x0a05,0x0a0a);
-  (0x0a0f,0x0a10);
-  (0x0a13,0x0a28);
-  (0x0a2a,0x0a30);
-  (0x0a32,0x0a33);
-  (0x0a35,0x0a36);
-  (0x0a38,0x0a39);
-  (0x0a59,0x0a5c);
-  (0x0a5e,0x0a5e);
-
-  (* Gunjarati *)
-  (0x0a85,0x0a8b);
-  (0x0a8d,0x0a8d);
-  (0x0a8f,0x0a91);
-  (0x0a93,0x0aa8);
-  (0x0aaa,0x0ab0);
-  (0x0ab2,0x0ab3);
-  (0x0ab5,0x0ab9);
-  (0x0ae0,0x0ae0);
-
-  (* Oriya *)
-  (0x0b05,0x0b0c);
-  (0x0b0f,0x0b10);
-  (0x0b13,0x0b28);
-  (0x0b2a,0x0b30);
-  (0x0b32,0x0b33);
-  (0x0b36,0x0b39);
-  (0x0b5c,0x0b5d);
-  (0x0b5f,0x0b61);
-
-  (* Tamil *)
-  (0x0b85,0x0b8a);
-  (0x0b8e,0x0b90);
-  (0x0b92,0x0b95);
-  (0x0b99,0x0b9a);
-  (0x0b9c,0x0b9c);
-  (0x0b9e,0x0b9f);
-  (0x0ba3,0x0ba4);
-  (0x0ba8,0x0baa);
-  (0x0bae,0x0bb5);
-  (0x0bb7,0x0bb9);
-
-  (* Telugu *)
-  (0x0c05,0x0c0c);
-  (0x0c0e,0x0c10);
-  (0x0c12,0x0c28);
-  (0x0c2a,0x0c33);
-  (0x0c35,0x0c39);
-  (0x0c60,0x0c61);
-
-  (* Kannada *)
-  (0x0c85,0x0c8c);
-  (0x0c8e,0x0c90);
-  (0x0c92,0x0ca8);
-  (0x0caa,0x0cb3);
-  (0x0cb5,0x0cb9);
-  (0x0ce0,0x0ce1);
-
-  (* Malayam *)
-  (0x0d05,0x0d0c);
-  (0x0d0e,0x0d10);
-  (0x0d12,0x0d28);
-  (0x0d2a,0x0d39);
-  (0x0d60,0x0d61);
-
-  (* Thai *)
-  (0x0e01,0x0e30);
-  (0x0e32,0x0e33);
-  (0x0e40,0x0e46);
-  (0x0e4f,0x0e5b);
-
-  (* Lao *)
-  (0x0e81,0x0e82);
-  (0x0e84,0x0e84);
-  (0x0e87,0x0e88);
-  (0x0e8a,0x0e8a);
-  (0x0e0d,0x0e0d);
-  (0x0e94,0x0e97);
-  (0x0e99,0x0e9f);
-  (0x0ea1,0x0ea3);
-  (0x0ea5,0x0ea5);
-  (0x0ea7,0x0ea7);
-  (0x0eaa,0x0eab);
-  (0x0ead,0x0eb0);
-  (0x0eb2,0x0eb3);
-  (0x0ebd,0x0ebd);
-  (0x0ec0,0x0ec4);
-  (0x0ec6,0x0ec6);
-
-  (* Georgian *)
-  (0x10a0,0x10c5);
-  (0x10d0,0x10f6);
-
-  (* Hangul Jamo *)
-  (0x1100,0x1159);
-  (0x1161,0x11a2);
-  (0x11a8,0x11f9);
-  (0x11d0,0x11f6);
-
-  (* Latin extensions *)
-  (0x1e00,0x1e9a);
-  (0x1ea0,0x1ef9);
-
-  (* Greek extended *)
-  (0x1f00,0x1f15);
-  (0x1f18,0x1f1d);
-  (0x1f20,0x1f45);
-  (0x1f48,0x1f4d);
-  (0x1f50,0x1f57);
-  (0x1f59,0x1f59);
-  (0x1f5b,0x1f5b);
-  (0x1f5d,0x1f5d);
-  (0x1f5f,0x1f7d);
-  (0x1f80,0x1fb4);
-  (0x1fb6,0x1fbc);
-  (0x1fc2,0x1fc4);
-  (0x1fc6,0x1fcc);
-  (0x1fd0,0x1fd3);
-  (0x1fd6,0x1fdb);
-  (0x1fe0,0x1fec);
-  (0x1ff2,0x1ff4);
-  (0x1ff6,0x1ffc);
-
-
-  (* Hiragana *)
-  (0x3041,0x3094);
-  (0x309b,0x309e);
-
-  (* Katakana *)
-  (0x30a1,0x30fe);
-
-  (* Bopmofo *)
-  (0x3105,0x312c);
-
-  (* CJK Unified Ideographs *)
-  (0x4e00,0x9fa5);
-
-  (* CJK Compatibility Ideographs *)
-  (0xf900,0xfa2d);
-
-  (* Arabic Presentation Forms *)
-  (0xfb1f,0xfb36);
-  (0xfb38,0xfb3c);
-  (0xfb3e,0xfb3e);
-  (0xfb40,0xfb41);
-  (0xfb42,0xfb44);
-  (0xfb46,0xfbb1);
-  (0xfbd3,0xfd35);
-
-  (* Arabic Presentation Forms-A *)
-  (0xfd50,0xfd85);
-  (0xfd92,0xfbc7);
-  (0xfdf0,0xfdfb);
-
-  (* Arabic Presentation Forms-B *)
-  (0xfe70,0xfe72);
-  (0xfe74,0xfe74);
-  (0xfe76,0xfefc);
-
-  (* Half width and Fullwidth Forms *)
-  (0xff21,0xff3a);
-  (0xff41,0xff5a);
-  (0xff66,0xffbe);
-  (0xffc2,0xffc7);
-  (0xffca,0xffcf);
-  (0xffd2,0xffd7);
-  (0xffd2,0xffd7);
-  (0xffda,0xffdc)
-]

src/syntax/cset.mli

@@ -1,30 +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.                       *)
-
-(** Representation of sets of unicode code points. *)
-
-type t = (int * int) list
-
-val min_code: int
-val max_code: int
-
-val empty: t
-val any: t
-val union: t -> t -> t
-val difference: t -> t -> t
-val intersection: t -> t -> t
-val is_empty: t -> bool
-val eof: t
-val singleton: int -> t
-val interval: int -> int -> t
-
-val letter: t
-val digit: t
-val extender: t
-val base_char: t
-val ideographic: t
-val combining_char: t
-val blank: t
-val tr8876_ident_char: t
-

src/syntax/dune

@@ -0,0 +1,17 @@
+(library
+ (name sedlex_ppx)
+ (public_name noslop-sedlex.ppx)
+ (kind ppx_rewriter)
+ (libraries ppxlib noslop-sedlex noslop-sedlex.utils)
+ (ppx_runtime_libraries noslop-sedlex)
+ (preprocess
+  (pps ppxlib.metaquot)))
+
+(rule
+ (targets unicode.ml)
+ (mode promote)
+ (deps
+  (:gen ../generator/gen_unicode.exe)
+  (glob_files ../generator/data/*.txt))
+ (action
+  (run %{gen} %{targets})))

src/syntax/iso.ml

@@ -0,0 +1,217 @@
+(* The package sedlex is released under the terms of an MIT-like license. *)
+(* See the attached LICENSE file.                                         *)
+
+open Sedlex_cset
+
+let tr8876_ident_char =
+  let l =
+    [
+      (* ASCII *)
+      (0x0041, 0x005a);
+      (0x0061, 0x007a);
+      (* Latin *)
+      (0x00c0, 0x00d6);
+      (0x00d8, 0x00f6);
+      (0x00f8, 0x01f5);
+      (0x01fa, 0x0217);
+      (0x0250, 0x02a8);
+      (* Greek *)
+      (0x0384, 0x0384);
+      (0x0388, 0x038a);
+      (0x038c, 0x038c);
+      (0x038e, 0x03a1);
+      (0x03a3, 0x03ce);
+      (0x03d0, 0x03d6);
+      (0x03da, 0x03da);
+      (0x03dc, 0x03dc);
+      (0x03de, 0x03de);
+      (0x03e0, 0x03e0);
+      (0x03e2, 0x03f3);
+      (* Cyrillic *)
+      (0x0401, 0x040d);
+      (0x040f, 0x044f);
+      (0x0451, 0x045c);
+      (0x045e, 0x0481);
+      (0x0490, 0x04c4);
+      (0x04c7, 0x04c4);
+      (0x04cb, 0x04cc);
+      (0x04d0, 0x04eb);
+      (0x04ee, 0x04f5);
+      (0x04f8, 0x04f9);
+      (* Armenian *)
+      (0x0531, 0x0556);
+      (0x0561, 0x0587);
+      (0x04d0, 0x04eb);
+      (* Hebrew *)
+      (0x05d0, 0x05ea);
+      (0x05f0, 0x05f4);
+      (* Arabic *)
+      (0x0621, 0x063a);
+      (0x0640, 0x0652);
+      (0x0670, 0x06b7);
+      (0x06ba, 0x06be);
+      (0x06c0, 0x06ce);
+      (0x06e5, 0x06e7);
+      (* Devanagari *)
+      (0x0905, 0x0939);
+      (0x0958, 0x0962);
+      (* Bengali *)
+      (0x0985, 0x098c);
+      (0x098f, 0x0990);
+      (0x0993, 0x09a8);
+      (0x09aa, 0x09b0);
+      (0x09b2, 0x09b2);
+      (0x09b6, 0x09b9);
+      (0x09dc, 0x09dd);
+      (0x09df, 0x09e1);
+      (0x09f0, 0x09f1);
+      (* Gurmukhi *)
+      (0x0a05, 0x0a0a);
+      (0x0a0f, 0x0a10);
+      (0x0a13, 0x0a28);
+      (0x0a2a, 0x0a30);
+      (0x0a32, 0x0a33);
+      (0x0a35, 0x0a36);
+      (0x0a38, 0x0a39);
+      (0x0a59, 0x0a5c);
+      (0x0a5e, 0x0a5e);
+      (* Gunjarati *)
+      (0x0a85, 0x0a8b);
+      (0x0a8d, 0x0a8d);
+      (0x0a8f, 0x0a91);
+      (0x0a93, 0x0aa8);
+      (0x0aaa, 0x0ab0);
+      (0x0ab2, 0x0ab3);
+      (0x0ab5, 0x0ab9);
+      (0x0ae0, 0x0ae0);
+      (* Oriya *)
+      (0x0b05, 0x0b0c);
+      (0x0b0f, 0x0b10);
+      (0x0b13, 0x0b28);
+      (0x0b2a, 0x0b30);
+      (0x0b32, 0x0b33);
+      (0x0b36, 0x0b39);
+      (0x0b5c, 0x0b5d);
+      (0x0b5f, 0x0b61);
+      (* Tamil *)
+      (0x0b85, 0x0b8a);
+      (0x0b8e, 0x0b90);
+      (0x0b92, 0x0b95);
+      (0x0b99, 0x0b9a);
+      (0x0b9c, 0x0b9c);
+      (0x0b9e, 0x0b9f);
+      (0x0ba3, 0x0ba4);
+      (0x0ba8, 0x0baa);
+      (0x0bae, 0x0bb5);
+      (0x0bb7, 0x0bb9);
+      (* Telugu *)
+      (0x0c05, 0x0c0c);
+      (0x0c0e, 0x0c10);
+      (0x0c12, 0x0c28);
+      (0x0c2a, 0x0c33);
+      (0x0c35, 0x0c39);
+      (0x0c60, 0x0c61);
+      (* Kannada *)
+      (0x0c85, 0x0c8c);
+      (0x0c8e, 0x0c90);
+      (0x0c92, 0x0ca8);
+      (0x0caa, 0x0cb3);
+      (0x0cb5, 0x0cb9);
+      (0x0ce0, 0x0ce1);
+      (* Malayam *)
+      (0x0d05, 0x0d0c);
+      (0x0d0e, 0x0d10);
+      (0x0d12, 0x0d28);
+      (0x0d2a, 0x0d39);
+      (0x0d60, 0x0d61);
+      (* Thai *)
+      (0x0e01, 0x0e30);
+      (0x0e32, 0x0e33);
+      (0x0e40, 0x0e46);
+      (0x0e4f, 0x0e5b);
+      (* Lao *)
+      (0x0e81, 0x0e82);
+      (0x0e84, 0x0e84);
+      (0x0e87, 0x0e88);
+      (0x0e8a, 0x0e8a);
+      (0x0e0d, 0x0e0d);
+      (0x0e94, 0x0e97);
+      (0x0e99, 0x0e9f);
+      (0x0ea1, 0x0ea3);
+      (0x0ea5, 0x0ea5);
+      (0x0ea7, 0x0ea7);
+      (0x0eaa, 0x0eab);
+      (0x0ead, 0x0eb0);
+      (0x0eb2, 0x0eb3);
+      (0x0ebd, 0x0ebd);
+      (0x0ec0, 0x0ec4);
+      (0x0ec6, 0x0ec6);
+      (* Georgian *)
+      (0x10a0, 0x10c5);
+      (0x10d0, 0x10f6);
+      (* Hangul Jamo *)
+      (0x1100, 0x1159);
+      (0x1161, 0x11a2);
+      (0x11a8, 0x11f9);
+      (0x11d0, 0x11f6);
+      (* Latin extensions *)
+      (0x1e00, 0x1e9a);
+      (0x1ea0, 0x1ef9);
+      (* Greek extended *)
+      (0x1f00, 0x1f15);
+      (0x1f18, 0x1f1d);
+      (0x1f20, 0x1f45);
+      (0x1f48, 0x1f4d);
+      (0x1f50, 0x1f57);
+      (0x1f59, 0x1f59);
+      (0x1f5b, 0x1f5b);
+      (0x1f5d, 0x1f5d);
+      (0x1f5f, 0x1f7d);
+      (0x1f80, 0x1fb4);
+      (0x1fb6, 0x1fbc);
+      (0x1fc2, 0x1fc4);
+      (0x1fc6, 0x1fcc);
+      (0x1fd0, 0x1fd3);
+      (0x1fd6, 0x1fdb);
+      (0x1fe0, 0x1fec);
+      (0x1ff2, 0x1ff4);
+      (0x1ff6, 0x1ffc);
+      (* Hiragana *)
+      (0x3041, 0x3094);
+      (0x309b, 0x309e);
+      (* Katakana *)
+      (0x30a1, 0x30fe);
+      (* Bopmofo *)
+      (0x3105, 0x312c);
+      (* CJK Unified Ideographs *)
+      (0x4e00, 0x9fa5);
+      (* CJK Compatibility Ideographs *)
+      (0xf900, 0xfa2d);
+      (* Arabic Presentation Forms *)
+      (0xfb1f, 0xfb36);
+      (0xfb38, 0xfb3c);
+      (0xfb3e, 0xfb3e);
+      (0xfb40, 0xfb41);
+      (0xfb42, 0xfb44);
+      (0xfb46, 0xfbb1);
+      (0xfbd3, 0xfd35);
+      (* Arabic Presentation Forms-A *)
+      (0xfd50, 0xfd85);
+      (0xfd92, 0xfbc7);
+      (0xfdf0, 0xfdfb);
+      (* Arabic Presentation Forms-B *)
+      (0xfe70, 0xfe72);
+      (0xfe74, 0xfe74);
+      (0xfe76, 0xfefc);
+      (* Half width and Fullwidth Forms *)
+      (0xff21, 0xff3a);
+      (0xff41, 0xff5a);
+      (0xff66, 0xffbe);
+      (0xffc2, 0xffc7);
+      (0xffca, 0xffcf);
+      (0xffd2, 0xffd7);
+      (0xffd2, 0xffd7);
+      (0xffda, 0xffdc);
+    ]
+  in
+  union_list (List.map (fun (a, b) -> interval a b) l)

src/syntax/iso.mli

@@ -0,0 +1,10 @@
+(* The package sedlex is released under the terms of an MIT-like license. *)
+(* See the attached LICENSE file.                                         *)
+
+open Sedlex_cset
+
+(** Letters to be used in identifiers, as specified by ISO .... *)
+
+(* Data provided by John M. Skaller *)
+
+val tr8876_ident_char : t

src/syntax/ppx_sedlex.ml

@@ -1,28 +1,39 @@
-(* 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 Longident
-open Parsetree
-open Asttypes
+open Ppxlib
+open Ast_builder.Default
 open Ast_helper
-open Ast_convenience
+
+(* let ocaml_version = Versions.ocaml_408 *)
+
+module Cset = Sedlex_cset
 
 (* Decision tree for partitions *)
 
+let default_loc = Location.none
+
 type decision_tree =
   | Lte of int * decision_tree * decision_tree
   | Table of int * int array
   | Return of int
 
+let rec simplify_decision_tree (x : decision_tree) =
+  match x with
+    | Table _ | Return _ -> x
+    | Lte (_, (Return a as l), Return b) when a = b -> l
+    | Lte (i, l, r) -> (
+        let l = simplify_decision_tree l in
+        let r = simplify_decision_tree r in
+        match (l, r) with
+          | Return a, Return b when a = b -> l
+          | _ -> Lte (i, l, r))
+
 let decision l =
   let l = List.map (fun (a, b, i) -> (a, b, Return i)) l in
   let rec merge2 = function
     | (a1, b1, d1) :: (a2, b2, d2) :: rest ->
-	let x =
-	  if b1 + 1 = a2 then d2
-	  else Lte (a2 - 1, Return (-1), d2)
-	in
+        let x = if b1 + 1 = a2 then d2 else Lte (a2 - 1, Return (-1), d2) in
         (a1, b2, Lte (b1, d1, x)) :: merge2 rest
     | rest -> rest
   in
@@ -37,117 +48,81 @@ let limit = 8192
 
 let decision_table l =
   let rec aux m accu = function
-    | ((a, b, i) as x)::rem when b < limit && i < 255->
+    | ((a, b, i) as x) :: rem when b < limit && i < 255 ->
         aux (min a m) (x :: accu) rem
-    | rem -> m, accu, rem
+    | rem -> (m, accu, rem)
   in
-  let (min, table, rest) = aux max_int [] l in
+  let min, table, rest = aux max_int [] l in
   match table with
     | [] -> decision l
     | [(min, max, i)] ->
-      Lte (min - 1, Return (-1), (Lte (max, Return i, decision rest)))
+        Lte (min - 1, Return (-1), Lte (max, Return i, decision rest))
     | (_, max, _) :: _ ->
-      let arr = Array.create (max - min + 1) 0 in
-      let set (a, b, i) = for j = a to b do arr.(j - min) <- i + 1 done in
+        let arr = Array.make (max - min + 1) 0 in
+        let set (a, b, i) =
+          for j = a to b do
+            arr.(j - min) <- i + 1
+          done
+        in
         List.iter set table;
         Lte (min - 1, Return (-1), Lte (max, Table (min, arr), decision rest))
 
 let rec simplify min max = function
-  | Lte (i,yes,no) ->
+  | Lte (i, yes, no) ->
       if i >= max then simplify min max yes
       else if i < min then simplify min max no
-      else Lte (i, simplify min i yes, simplify (i+1) max no)
+      else Lte (i, simplify min i yes, simplify (i + 1) max no)
   | x -> x
 
 let segments_of_partition p =
   let seg = ref [] in
   Array.iteri
-    (fun i c -> List.iter (fun (a, b) -> seg := (a, b, i) :: !seg) c)
+    (fun i c ->
+      List.iter
+        (fun (a, b) -> seg := (a, b, i) :: !seg)
+        (c : Sedlex_cset.t :> (int * int) list))
     p;
-  List.sort (fun (a1,_,_) (a2,_,_) -> compare a1 a2) !seg
+  List.sort (fun (a1, _, _) (a2, _, _) -> compare a1 a2) !seg
 
 let decision_table p =
-  simplify (-1) (Cset.max_code) (decision_table (segments_of_partition p))
-
+  simplify (-1) Cset.max_code (decision_table (segments_of_partition p))
 
 (* Helpers to build AST *)
 
+let appfun s l =
+  let loc = default_loc in
+  eapply ~loc (evar ~loc s) l
 
-let appfun s l = app (evar s) l
-let pint i = Pat.constant (Const_int i)
-let glb_value name def = Str.value Nonrecursive [Vb.mk (pvar name) def]
+let glb_value name def =
+  let loc = default_loc in
+  pstr_value ~loc Nonrecursive
+    [value_binding ~loc ~pat:(pvar ~loc name) ~expr:def]
 
 (* Named regexps *)
 
-module StringMap = Map.Make(struct
+module StringMap = Map.Make (struct
   type t = string
+
   let compare = compare
 end)
 
 let builtin_regexps =
-  List.fold_left (fun acc (n, c) -> StringMap.add n (Sedlex.chars c) acc)
+  List.fold_left
+    (fun acc (n, c) -> StringMap.add n (Sedlex.chars c) acc)
     StringMap.empty
-    [
-     "any", Cset.any;
-     "eof", Cset.eof;
-     "xml_letter", Cset.letter;
-     "xml_digit", Cset.digit;
-     "xml_extender", Cset.extender;
-     "xml_base_char", Cset.base_char;
-     "xml_ideographic", Cset.ideographic;
-     "xml_combining_char", Cset.combining_char;
-     "xml_blank", Cset.blank;
-     "tr8876_ident_char", Cset.tr8876_ident_char;
-
-     (* Unicode 6.3 categories *)
-     "cc", Unicode63.Categories.cc;
-     "cf", Unicode63.Categories.cf;
-     "cn", Unicode63.Categories.cn;
-     "co", Unicode63.Categories.co;
-     "cs", Unicode63.Categories.cs;
-     "ll", Unicode63.Categories.ll;
-     "lm", Unicode63.Categories.lm;
-     "lo", Unicode63.Categories.lo;
-     "lt", Unicode63.Categories.lt;
-     "lu", Unicode63.Categories.lu;
-     "mc", Unicode63.Categories.mc;
-     "me", Unicode63.Categories.me;
-     "mn", Unicode63.Categories.mn;
-     "nd", Unicode63.Categories.nd;
-     "nl", Unicode63.Categories.nl;
-     "no", Unicode63.Categories.no;
-     "pc", Unicode63.Categories.pc;
-     "pd", Unicode63.Categories.pd;
-     "pe", Unicode63.Categories.pe;
-     "pf", Unicode63.Categories.pf;
-     "pi", Unicode63.Categories.pi;
-     "po", Unicode63.Categories.po;
-     "ps", Unicode63.Categories.ps;
-     "sc", Unicode63.Categories.sc;
-     "sk", Unicode63.Categories.sk;
-     "sm", Unicode63.Categories.sm;
-     "so", Unicode63.Categories.so;
-     "zl", Unicode63.Categories.zl;
-     "zp", Unicode63.Categories.zp;
-     "zs", Unicode63.Categories.zs;
-
-     (* Unicode 6.3 properties *)
-     "alphabetic", Unicode63.Properties.alphabetic;
-     "ascii_hex_digit", Unicode63.Properties.ascii_hex_digit;
-     "hex_digit", Unicode63.Properties.hex_digit;
-     "id_continue", Unicode63.Properties.id_continue;
-     "id_start", Unicode63.Properties.id_start;
-     "lowercase", Unicode63.Properties.lowercase;
-     "math", Unicode63.Properties.math;
-     "other_alphabetic", Unicode63.Properties.other_alphabetic;
-     "other_lowercase", Unicode63.Properties.other_lowercase;
-     "other_math", Unicode63.Properties.other_math;
-     "other_uppercase", Unicode63.Properties.other_uppercase;
-     "uppercase", Unicode63.Properties.uppercase;
-     "white_space", Unicode63.Properties.white_space;
-     "xid_continue", Unicode63.Properties.xid_continue;
-     "xid_start", Unicode63.Properties.xid_start;
+    ([
+       ("any", Cset.any);
+       ("eof", Cset.eof);
+       ("xml_letter", Xml.letter);
+       ("xml_digit", Xml.digit);
+       ("xml_extender", Xml.extender);
+       ("xml_base_char", Xml.base_char);
+       ("xml_ideographic", Xml.ideographic);
+       ("xml_combining_char", Xml.combining_char);
+       ("xml_blank", Xml.blank);
+       ("tr8876_ident_char", Iso.tr8876_ident_char);
      ]
+    @ Unicode.Categories.list @ Unicode.Properties.list)
 
 (* Tables (indexed mapping: codepoint -> next state) *)
 
@@ -166,14 +141,18 @@ let table_name x =
 let table (name, v) =
   let n = Array.length v in
   let s = Bytes.create n in
-  for i = 0 to n - 1 do Bytes.set s i (Char.chr v.(i)) done;
-  glb_value name (str (Bytes.to_string s))
+  for i = 0 to n - 1 do
+    Bytes.set s i (Char.chr v.(i))
+  done;
+  glb_value name (estring ~loc:default_loc (Bytes.to_string s))
 
 (* Partition (function: codepoint -> next state) *)
 
 let partitions = Hashtbl.create 31
 let partition_counter = ref 0
-let get_partitions () = Hashtbl.fold (fun key x accu -> (x, key) :: accu) partitions []
+
+let get_partitions () =
+  Hashtbl.fold (fun key x accu -> (x, key) :: accu) partitions []
 
 let partition_name x =
   try Hashtbl.find partitions x
@@ -183,17 +162,28 @@ let partition_name x =
     Hashtbl.add partitions x s;
     s
 
+(* We duplicate the body for the EOF (-1) case rather than creating
+   an interior utility function. *)
 let partition (name, p) =
+  let loc = default_loc in
   let rec gen_tree = function
     | Lte (i, yes, no) ->
-        [%expr if c <= [%e int i] then [%e gen_tree yes] else [%e gen_tree no]]
-    | Return i -> int i
+        [%expr
+          if c <= [%e eint ~loc i] then [%e gen_tree yes] else [%e gen_tree no]]
+    | Return i -> eint ~loc:default_loc i
     | Table (offset, t) ->
-	      let c = if offset = 0 then [%expr c] else [%expr c - [%e int offset]] in
-        [%expr Char.code (String.get [%e evar (table_name t)] [%e c]) - 1]
+        let c =
+          if offset = 0 then [%expr c] else [%expr c - [%e eint ~loc offset]]
         in
-  let body = gen_tree (decision_table p) in
-  glb_value name (func [pvar "c", body])
+        [%expr
+          Char.code (String.unsafe_get [%e evar ~loc (table_name t)] [%e c]) - 1]
+  in
+  let body = gen_tree (simplify_decision_tree (decision_table p)) in
+  glb_value name
+    [%expr
+      fun c ->
+        let open! Stdlib in
+        [%e body]]
 
 (* Code generation for the automata *)
 
@@ -207,41 +197,79 @@ 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
-  if Array.length trans = 0
-  then match best_final final with
-  | Some i -> int i
-  | None -> assert false
-  else appfun (state_fun state) [evar lexbuf]
+  let { Sedlex.trans; finals } = auto.(state) in
+  if Array.length trans = 0 then (
+    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 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 = Array.mapi (fun i (_, j) -> Exp.case(pint i) (call_state lexbuf auto j)) trans in
+  let cases =
+    Array.mapi
+      (fun i (_, j) ->
+        case ~lhs:(pint ~loc i) ~guard:None ~rhs:(call_state lexbuf auto j))
+      trans
+  in
   let cases = Array.to_list cases in
   let body () =
-    Exp.match_
-      (appfun (partition_name partition) [[%expr Sedlexing.next [%e evar lexbuf]]])
-      (cases @ [Exp.case [%pat? _] [%expr Sedlexing.backtrack [%e evar lexbuf]]])
+    pexp_match ~loc
+      (appfun (partition_name partition)
+         [[%expr Sedlexing.__private__next_int [%e lexbuf]]])
+      (cases
+      @ [
+          case
+            ~lhs:[%pat? _]
+            ~guard:None
+            ~rhs:[%expr Sedlexing.backtrack [%e lexbuf]];
+        ])
   in
-  let ret body = [ Vb.mk (pvar (state_fun i)) (func [pvar lexbuf, body]) ] in
-  match best_final final with
+  let ret body =
+    let lhs = pvar ~loc:lexbuf.pexp_loc lexbuf_name in
+    [
+      value_binding ~loc
+        ~pat:(pvar ~loc (state_fun i))
+        ~expr:(Exp.fun_ ~loc Nolabel None lhs body);
+    ]
+  in
+  match best_final finals with
     | None -> ret (body ())
     | Some _ when Array.length trans = 0 -> []
-    | Some i -> ret [%expr Sedlexing.mark [%e evar lexbuf] [%e int i]; [%e body ()]]
+    | Some i ->
+        ret
+          [%expr
+            Sedlexing.mark [%e lexbuf] [%e eint ~loc i];
+            [%e body ()]]
 
-let gen_definition lexbuf l error =
-  let brs = Array.of_list l in
-  let auto = Sedlex.compile (Array.map fst brs) in
-  let cases = Array.to_list (Array.mapi (fun i (_, e) -> Exp.case (pint i) e) brs) in
-  let states = Array.mapi (gen_state lexbuf auto) auto in
+let gen_recflag auto =
+  (* The generated function is not recursive if the transitions end
+     in states with no further transitions. *)
+  try
+    Array.iter
+      (fun { Sedlex.trans; _ } ->
+        Array.iter
+          (fun (_, j) ->
+            if Array.length auto.(j).Sedlex.trans > 0 then raise Exit)
+          trans)
+      auto;
+    Nonrecursive
+  with Exit -> Recursive
+
+let gen_definition ((_, lexbuf) as lexbuf_with_name) auto l error =
+  let loc = default_loc in
+  let cases =
+    List.mapi (fun i (_, e) -> case ~lhs:(pint ~loc i) ~guard:None ~rhs:e) l
+  in
+  let states = Array.mapi (gen_state lexbuf_with_name auto) auto in
   let states = List.flatten (Array.to_list states) in
-  Exp.let_ Recursive states
-    (Exp.sequence
-       [%expr Sedlexing.start [%e evar lexbuf]]
-       (Exp.match_ (appfun (state_fun 0) [evar lexbuf])
-          (cases @ [Exp.case (Pat.any ()) error])
-       )
-    )
+  pexp_let ~loc (gen_recflag auto) states
+    (pexp_sequence ~loc
+       [%expr Sedlexing.start [%e lexbuf]]
+       (pexp_match ~loc
+          (appfun (state_fun 0) [lexbuf])
+          (cases @ [case ~lhs:(ppat_any ~loc) ~guard:None ~rhs:error])))
 
 (* Lexer specification parser *)
 
@@ -250,120 +278,311 @@ 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 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 fmt =
+  Printf.ksprintf
+    (fun s ->
+      raise (Location.Error (Location.Error.createf ~loc "Sedlex: %s" s)))
+    fmt
 
-let err loc s =
-  raise (Location.Error (Location.error ~loc ("Sedlex: " ^ s)))
+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 aux p =
+  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 match func (aux ~encoding p0) (aux ~encoding p1) with
+            | Some r -> r
+            | None ->
+                err loc
+                  "the %s operator can only applied to single-character length \
+                   regexps"
+                  name
+          end
+      | _ ->
+          err 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
-    | Ppat_construct ({txt = Lident "Star"}, Some p) ->
-        Sedlex.rep (aux p)
-    | Ppat_construct ({txt = Lident "Plus"}, Some p) ->
-        Sedlex.plus (aux p)
-    | Ppat_construct ({txt = Lident "Opt"}, Some p) ->
-        Sedlex.alt Sedlex.eps (aux p)
-    | Ppat_construct ({txt = Lident "Compl"}, Some p0) ->
-        begin match Sedlex.compl (aux p0) with
+          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 ~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"; _ },
+            Some
+              ( _,
+                {
+                  ppat_desc =
+                    Ppat_tuple
+                      [
+                        p0;
+                        {
+                          ppat_desc =
+                            Ppat_constant (i1 as i2) | Ppat_interval (i1, i2);
+                          _;
+                        };
+                      ];
+                  _;
+                } ) ) ->
+          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 ~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 ~encoding p)
+      | Ppat_construct ({ txt = Lident "Compl"; _ }, arg) ->
+          begin match arg with
+            | Some (_, p0) ->
+                begin match Sedlex.compl (aux ~encoding p0) with
                   | Some r -> r
                   | None ->
                       err p.ppat_loc
-            "the Compl operator can only applied to a single-character regexp"
+                        "the Compl operator can only applied to a \
+                         single-character length regexp"
                 end
-    | Ppat_construct ({txt = Lident "Chars"}, Some {ppat_desc=Ppat_constant (Const_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
-    | Ppat_interval (Const_char c1, Const_char c2) ->
-        Sedlex.chars (Cset.interval (Char.code c1) (Char.code c2))
-    | Ppat_interval (Const_int i1, Const_int i2) ->
-        Sedlex.chars (Cset.interval (codepoint i1) (codepoint i2))
-
-    | Ppat_constant (Const_string (s, _)) -> regexp_for_string s
-    | Ppat_constant (Const_char c) -> regexp_for_char c
-    | Ppat_constant (Const_int c) -> Sedlex.chars (Cset.singleton (codepoint c))
-    | Ppat_var {txt=x} ->
-        begin try StringMap.find x env
-        with Not_found ->
-          err p.ppat_loc (Printf.sprintf "unbound regexp %s" x)
+            | _ -> err p.ppat_loc "the Compl operator requires an argument"
           end
-    | _ ->
-      err p.ppat_loc "this pattern is not a valid regexp"
+      | Ppat_construct ({ txt = Lident "Sub"; _ }, arg) ->
+          char_pair_op ~encoding Sedlex.subtract "Sub" ~loc:p.ppat_loc
+            (Option.map (fun (_, arg) -> arg) arg)
+      | Ppat_construct ({ txt = Lident "Intersect"; _ }, arg) ->
+          char_pair_op ~encoding Sedlex.intersection "Intersect" ~loc:p.ppat_loc
+            (Option.map (fun (_, arg) -> arg) arg)
+      | Ppat_construct ({ txt = Lident "Chars"; _ }, arg) -> (
+          let const =
+            match arg with
+              | Some (_, { ppat_desc = Ppat_constant const; _ }) -> Some const
+              | _ -> None
           in
-  aux
+          match const with
+            | Some (Pconst_string (s, _, _)) ->
+                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
+                  (Cset.interval
+                     (codepoint (int_of_string i1))
+                     (codepoint (int_of_string i2)))
+            | _ -> err p.ppat_loc "this pattern is not a valid interval regexp"
+          end
+      | Ppat_constant const ->
+          begin match const with
+            | 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 "unbound regexp %s" x
+          end
+      | _ -> err p.ppat_loc "this pattern is not a valid regexp"
+  in
+  aux ~encoding:Ascii
 
-
-let mapper =
-  object(this)
-    inherit Ast_mapper_class.mapper as super
-
-    val env = builtin_regexps
-
-    method define_regexp name p =
-      {< env = StringMap.add name (regexp_of_pattern env p) env >}
-
-    method! expr e =
-      match e with
-      | [%expr [%sedlex [%e? {pexp_desc=Pexp_match ({pexp_desc=Pexp_ident{txt=Lident lexbuf}}, cases)}]]] ->
+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} -> super # expr e
-              | {pc_lhs = p} ->
-                err p.ppat_loc "the last branch must a catch-all error case"
+      | { 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, super # expr e
-                  | {pc_guard = Some e} ->
-                    err e.pexp_loc "'when' guards are not supported"
-                ) cases
+        | { 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
-            gen_definition lexbuf cases error
-      | [%expr let [%p? {ppat_desc=Ppat_var{txt=name}}] = [%sedlex.regexp? [%p? p]] in [%e? body]] ->
-          (this # define_regexp name p) # expr body
-      | _ -> super # expr e
+  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 []
+let should_set_cookies = ref false
+
+let mapper =
+  object (this)
+    inherit Ast_traverse.map as super
+    val env = builtin_regexps
+
+    method define_regexp name p =
+      {<env = StringMap.add name (regexp_of_pattern env p) env>}
+
+    method! expression e =
+      match e with
+        | [%expr [%sedlex [%e? { pexp_desc = Pexp_match _; _ } as match_expr]]]
+          ->
+            fst (handle_sedlex_match ~env ~map_rhs:this#expression match_expr)
+        | [%expr
+            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"
+        | _ -> super#expression e
 
     val toplevel = true
 
-    method! structure l =
-      if toplevel then
-        let l = {< toplevel = false >} # structure l in
-        let parts = List.map partition (get_partitions ()) in
-        let tables = List.map table (get_tables ()) in
-        tables @ parts @ l
-      else
+    method structure_with_regexps l =
       let mapper = ref this in
+      let regexps = ref [] in
+      let l =
         List.concat
           (List.map
              (function
-               | [%stri let [%p? {ppat_desc=Ppat_var{txt=name}}] = [%sedlex.regexp? [%p? p]]] ->
-                 mapper := !mapper # define_regexp name p;
+               | [%stri
+                   let [%p? { ppat_desc = Ppat_var { txt = name; _ }; _ }] =
+                     [%sedlex.regexp? [%p? p]]] as i ->
+                   regexps := i :: !regexps;
+                   mapper := !mapper#define_regexp name p;
                    []
-               | i ->
-                 [ !mapper # structure_item i ]
-             ) l)
+               | i -> [!mapper#structure_item i])
+             l)
+      in
+      (l, List.rev !regexps)
+
+    method! structure l =
+      if toplevel then (
+        let sub = {<toplevel = false>} in
+        let l, regexps' = sub#structure_with_regexps (!previous @ l) in
+        let parts = List.map partition (get_partitions ()) in
+        let tables = List.map table (get_tables ()) in
+        regexps := regexps';
+        should_set_cookies := true;
+        tables @ parts @ l)
+      else fst (this#structure_with_regexps l)
   end
 
+let pre_handler cookies =
+  previous :=
+    match Driver.Cookies.get cookies "sedlex.regexps" Ast_pattern.__ with
+      | Some { pexp_desc = Pexp_extension (_, PStr l); _ } -> l
+      | Some _ -> assert false
+      | None -> []
+
+let post_handler cookies =
+  if !should_set_cookies then (
+    let loc = default_loc in
+    Driver.Cookies.set cookies "sedlex.regexps"
+      (pexp_extension ~loc ({ loc; txt = "regexps" }, PStr !regexps)))
+
+let extensions =
+  [
+    Extension.declare "sedlex" Extension.Context.expression
+      Ast_pattern.(single_expr_payload __)
+      (fun ~loc:_ ~path:_ expr -> mapper#expression expr);
+  ]
 
 let () =
-  Ast_mapper.register "sedlex" (fun _ -> Ast_mapper_class.to_mapper mapper)
+  Driver.Cookies.add_handler pre_handler;
+  Driver.Cookies.add_post_handler post_handler;
+  Driver.register_transformation "sedlex" ~impl:mapper#structure

src/syntax/sedlex.ml

@@ -1,6 +1,7 @@
-(* 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
 
 (* NFA *)
 
@@ -15,6 +16,7 @@ type node = {
 type regexp = node -> node
 
 let cur_id = ref 0
+
 let new_node () =
   incr cur_id;
   { id = !cur_id; eps = []; trans = [] }
@@ -22,21 +24,21 @@ 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 =
   let n = new_node () in
-  n.trans <- [c,succ];
+  n.trans <- [(c, succ)];
   n
 
 let alt r1 r2 succ =
   let nr1 = r1 succ and nr2 = r2 succ in
-  match is_chars succ nr1, is_chars succ nr2 with
+  match (is_chars succ nr1, is_chars succ nr2) with
     | Some c1, Some c2 -> chars (Cset.union c1 c2) succ
     | _ ->
         let n = new_node () in
-    n.eps <- [r1 succ; r2 succ];
+        n.eps <- [nr1; nr2];
         n
 
 let rep r succ =
@@ -50,15 +52,24 @@ let plus r succ =
   n.eps <- [nr; succ];
   nr
 
-let eps succ = succ
+let eps succ = succ (* eps for epsilon *)
 
 let compl r =
   let n = new_node () in
   match is_chars n (r n) with
-  | Some c ->
-    Some (chars (Cset.difference Cset.any c))
-  | _ ->
-    None
+    | Some c -> Some (chars (Cset.difference Cset.any c))
+    | _ -> None
+
+let pair_op f r0 r1 =
+  (* Construct subtract or intersection *)
+  let n = new_node () in
+  let to_chars r = is_chars n (r n) in
+  match (to_chars r0, to_chars r1) with
+    | Some c0, Some c1 -> Some (chars (f c0 c1))
+    | _ -> None
+
+let subtract = pair_op Cset.difference
+let intersection = pair_op Cset.intersection
 
 let compile_re re =
   let final = new_node () in
@@ -67,36 +78,35 @@ let compile_re re =
 (* Determinization *)
 
 type state = node list
-      (* A state of the DFA corresponds to a set of nodes in the NFA. *)
+(* A state of the DFA corresponds to a set of nodes in the NFA. *)
 
 let rec add_node state node =
-  if List.memq node state then state else add_nodes (node::state) node.eps
-and add_nodes state nodes =
-  List.fold_left add_node state nodes
+  if List.memq node state then state else add_nodes (node :: state) node.eps
 
+and add_nodes state nodes = List.fold_left add_node state nodes
 
 let transition (state : state) =
   (* Merge transition with the same target *)
   let rec norm = function
-    | (c1, n1)::((c2, n2)::q as l) ->
-	if n1 == n2 then norm ((Cset.union c1 c2, n1)::q)
-	else (c1, n1)::(norm l)
-    | l -> l in
+    | (c1, n1) :: ((c2, n2) :: q as l) ->
+        if n1 == n2 then norm ((Cset.union c1 c2, n1) :: q)
+        else (c1, n1) :: norm l
+    | l -> l
+  in
   let t = List.concat (List.map (fun n -> n.trans) state) in
   let t = norm (List.sort (fun (_, n1) (_, n2) -> n1.id - n2.id) t) in
 
   (* Split char sets so as to make them disjoint *)
   let split (all, t) (c0, n0) =
     let t =
-      (Cset.difference c0 all, [n0]) ::
-      List.map (fun (c, ns) -> (Cset.intersection c c0, n0::ns)) t @
-      List.map (fun (c, ns) -> (Cset.difference c c0, ns)) t
+      (Cset.difference c0 all, [n0])
+      :: List.map (fun (c, ns) -> (Cset.intersection c c0, n0 :: ns)) t
+      @ List.map (fun (c, ns) -> (Cset.difference c c0, ns)) t
     in
-    Cset.union all c0,
-    List.filter (fun (c, _) -> not (Cset.is_empty c)) t
+    (Cset.union all c0, List.filter (fun (c, _) -> not (Cset.is_empty c)) t)
   in
 
-  let (_,t) = List.fold_left split (Cset.empty,[]) t in
+  let _, t = List.fold_left split (Cset.empty, []) t in
 
   (* Epsilon closure of targets *)
   let t = List.map (fun (c, ns) -> (c, add_nodes [] ns)) t in
@@ -106,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
@@ -120,11 +133,64 @@ 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
-  Array.iter (fun (i,_) -> init := add_node !init i) rs;
+  Array.iter (fun (i, _) -> init := add_node !init i) rs;
   let i = aux !init in
-  assert(i = 0);
+  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,19 +1,28 @@
-(* 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
 
-val chars: Cset.t -> regexp
-val seq: regexp -> regexp -> regexp
-val alt: regexp -> regexp -> regexp
-val rep: regexp -> regexp
-val plus: regexp -> regexp
-val eps: regexp
+val chars : Sedlex_cset.t -> regexp
+val seq : regexp -> regexp -> regexp
+val alt : regexp -> regexp -> regexp
+val rep : regexp -> regexp
+val plus : regexp -> regexp
+val eps : regexp
+val compl : regexp -> regexp option
 
-val compl: regexp -> regexp option
-   (* If the argument is a single [chars] regexp, returns a regexp
+(* If the argument is a single [chars] regexp, returns a regexp
    which matches the complement set.  Otherwise returns [None]. *)
+val subtract : regexp -> regexp -> regexp option
 
+(* If each argument is a single [chars] regexp, returns a regexp
+   which matches the set (arg1 - arg2).  Otherwise returns [None]. *)
+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 -> ((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

@@ -0,0 +1,4 @@
+(* Copyright 2005, 2013 by Alain Frisch and LexiFi.                       *)
+(* Copyright 2026 by xenia <xenia@awoo.systems>                           *)
+
+include Sedlex_utils.Cset

src/syntax/unicode.mli

@@ -0,0 +1,56 @@
+(* Version is automatically generated from unicode data at
+ * src/generator/data *)
+val version : string
+
+module Categories : sig
+  val cc : Sedlex_cset.t
+  val cf : Sedlex_cset.t
+  val cn : Sedlex_cset.t
+  val co : Sedlex_cset.t
+  val cs : Sedlex_cset.t
+  val ll : Sedlex_cset.t
+  val lm : Sedlex_cset.t
+  val lo : Sedlex_cset.t
+  val lt : Sedlex_cset.t
+  val lu : Sedlex_cset.t
+  val mc : Sedlex_cset.t
+  val me : Sedlex_cset.t
+  val mn : Sedlex_cset.t
+  val nd : Sedlex_cset.t
+  val nl : Sedlex_cset.t
+  val no : Sedlex_cset.t
+  val pc : Sedlex_cset.t
+  val pd : Sedlex_cset.t
+  val pe : Sedlex_cset.t
+  val pf : Sedlex_cset.t
+  val pi : Sedlex_cset.t
+  val po : Sedlex_cset.t
+  val ps : Sedlex_cset.t
+  val sc : Sedlex_cset.t
+  val sk : Sedlex_cset.t
+  val sm : Sedlex_cset.t
+  val so : Sedlex_cset.t
+  val zl : Sedlex_cset.t
+  val zp : Sedlex_cset.t
+  val zs : Sedlex_cset.t
+  val list : (string * Sedlex_cset.t) list
+end
+
+module Properties : sig
+  val alphabetic : Sedlex_cset.t
+  val ascii_hex_digit : Sedlex_cset.t
+  val hex_digit : Sedlex_cset.t
+  val id_continue : Sedlex_cset.t
+  val id_start : Sedlex_cset.t
+  val lowercase : Sedlex_cset.t
+  val math : Sedlex_cset.t
+  val other_alphabetic : Sedlex_cset.t
+  val other_lowercase : Sedlex_cset.t
+  val other_math : Sedlex_cset.t
+  val other_uppercase : Sedlex_cset.t
+  val uppercase : Sedlex_cset.t
+  val white_space : Sedlex_cset.t
+  val xid_continue : Sedlex_cset.t
+  val xid_start : Sedlex_cset.t
+  val list : (string * Sedlex_cset.t) list
+end

src/syntax/unicode63.mli

@@ -1,54 +0,0 @@
-module Categories : sig
-
-  val cc : Cset.t
-  val cf : Cset.t
-  val cn : Cset.t
-  val co : Cset.t
-  val cs : Cset.t
-  val ll : Cset.t
-  val lm : Cset.t
-  val lo : Cset.t
-  val lt : Cset.t
-  val lu : Cset.t
-  val mc : Cset.t
-  val me : Cset.t
-  val mn : Cset.t
-  val nd : Cset.t
-  val nl : Cset.t
-  val no : Cset.t
-  val pc : Cset.t
-  val pd : Cset.t
-  val pe : Cset.t
-  val pf : Cset.t
-  val pi : Cset.t
-  val po : Cset.t
-  val ps : Cset.t
-  val sc : Cset.t
-  val sk : Cset.t
-  val sm : Cset.t
-  val so : Cset.t
-  val zl : Cset.t
-  val zp : Cset.t
-  val zs : Cset.t
-
-end
-
-module Properties : sig
-
-  val alphabetic       : Cset.t
-  val ascii_hex_digit  : Cset.t
-  val hex_digit        : Cset.t
-  val id_continue      : Cset.t
-  val id_start         : Cset.t
-  val lowercase        : Cset.t
-  val math             : Cset.t
-  val other_alphabetic : Cset.t
-  val other_lowercase  : Cset.t
-  val other_math       : Cset.t
-  val other_uppercase  : Cset.t
-  val uppercase        : Cset.t
-  val white_space      : Cset.t
-  val xid_continue     : Cset.t
-  val xid_start        : Cset.t
-
-end

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

src/syntax/xml.ml

@@ -0,0 +1,365 @@
+(* The package sedlex is released under the terms of an MIT-like license. *)
+(* See the attached LICENSE file.                                         *)
+
+open Sedlex_cset
+
+(* Unicode classes from XML *)
+let base_char =
+  let l =
+    [
+      (0x0041, 0x005A);
+      (0x0061, 0x007A);
+      (0x00C0, 0x00D6);
+      (0x00D8, 0x00F6);
+      (0x00F8, 0x00FF);
+      (0x0100, 0x0131);
+      (0x0134, 0x013E);
+      (0x0141, 0x0148);
+      (0x014A, 0x017E);
+      (0x0180, 0x01C3);
+      (0x01CD, 0x01F0);
+      (0x01F4, 0x01F5);
+      (0x01FA, 0x0217);
+      (0x0250, 0x02A8);
+      (0x02BB, 0x02C1);
+      (0x0386, 0x0386);
+      (0x0388, 0x038A);
+      (0x038C, 0x038C);
+      (0x038E, 0x03A1);
+      (0x03A3, 0x03CE);
+      (0x03D0, 0x03D6);
+      (0x03DA, 0x03DA);
+      (0x03DC, 0x03DC);
+      (0x03DE, 0x03DE);
+      (0x03E0, 0x03E0);
+      (0x03E2, 0x03F3);
+      (0x0401, 0x040C);
+      (0x040E, 0x044F);
+      (0x0451, 0x045C);
+      (0x045E, 0x0481);
+      (0x0490, 0x04C4);
+      (0x04C7, 0x04C8);
+      (0x04CB, 0x04CC);
+      (0x04D0, 0x04EB);
+      (0x04EE, 0x04F5);
+      (0x04F8, 0x04F9);
+      (0x0531, 0x0556);
+      (0x0559, 0x0559);
+      (0x0561, 0x0586);
+      (0x05D0, 0x05EA);
+      (0x05F0, 0x05F2);
+      (0x0621, 0x063A);
+      (0x0641, 0x064A);
+      (0x0671, 0x06B7);
+      (0x06BA, 0x06BE);
+      (0x06C0, 0x06CE);
+      (0x06D0, 0x06D3);
+      (0x06D5, 0x06D5);
+      (0x06E5, 0x06E6);
+      (0x0905, 0x0939);
+      (0x093D, 0x093D);
+      (0x0958, 0x0961);
+      (0x0985, 0x098C);
+      (0x098F, 0x0990);
+      (0x0993, 0x09A8);
+      (0x09AA, 0x09B0);
+      (0x09B2, 0x09B2);
+      (0x09B6, 0x09B9);
+      (0x09DC, 0x09DD);
+      (0x09DF, 0x09E1);
+      (0x09F0, 0x09F1);
+      (0x0A05, 0x0A0A);
+      (0x0A0F, 0x0A10);
+      (0x0A13, 0x0A28);
+      (0x0A2A, 0x0A30);
+      (0x0A32, 0x0A33);
+      (0x0A35, 0x0A36);
+      (0x0A38, 0x0A39);
+      (0x0A59, 0x0A5C);
+      (0x0A5E, 0x0A5E);
+      (0x0A72, 0x0A74);
+      (0x0A85, 0x0A8B);
+      (0x0A8D, 0x0A8D);
+      (0x0A8F, 0x0A91);
+      (0x0A93, 0x0AA8);
+      (0x0AAA, 0x0AB0);
+      (0x0AB2, 0x0AB3);
+      (0x0AB5, 0x0AB9);
+      (0x0ABD, 0x0ABD);
+      (0x0AE0, 0x0AE0);
+      (0x0B05, 0x0B0C);
+      (0x0B0F, 0x0B10);
+      (0x0B13, 0x0B28);
+      (0x0B2A, 0x0B30);
+      (0x0B32, 0x0B33);
+      (0x0B36, 0x0B39);
+      (0x0B3D, 0x0B3D);
+      (0x0B5C, 0x0B5D);
+      (0x0B5F, 0x0B61);
+      (0x0B85, 0x0B8A);
+      (0x0B8E, 0x0B90);
+      (0x0B92, 0x0B95);
+      (0x0B99, 0x0B9A);
+      (0x0B9C, 0x0B9C);
+      (0x0B9E, 0x0B9F);
+      (0x0BA3, 0x0BA4);
+      (0x0BA8, 0x0BAA);
+      (0x0BAE, 0x0BB5);
+      (0x0BB7, 0x0BB9);
+      (0x0C05, 0x0C0C);
+      (0x0C0E, 0x0C10);
+      (0x0C12, 0x0C28);
+      (0x0C2A, 0x0C33);
+      (0x0C35, 0x0C39);
+      (0x0C60, 0x0C61);
+      (0x0C85, 0x0C8C);
+      (0x0C8E, 0x0C90);
+      (0x0C92, 0x0CA8);
+      (0x0CAA, 0x0CB3);
+      (0x0CB5, 0x0CB9);
+      (0x0CDE, 0x0CDE);
+      (0x0CE0, 0x0CE1);
+      (0x0D05, 0x0D0C);
+      (0x0D0E, 0x0D10);
+      (0x0D12, 0x0D28);
+      (0x0D2A, 0x0D39);
+      (0x0D60, 0x0D61);
+      (0x0E01, 0x0E2E);
+      (0x0E30, 0x0E30);
+      (0x0E32, 0x0E33);
+      (0x0E40, 0x0E45);
+      (0x0E81, 0x0E82);
+      (0x0E84, 0x0E84);
+      (0x0E87, 0x0E88);
+      (0x0E8A, 0x0E8A);
+      (0x0E8D, 0x0E8D);
+      (0x0E94, 0x0E97);
+      (0x0E99, 0x0E9F);
+      (0x0EA1, 0x0EA3);
+      (0x0EA5, 0x0EA5);
+      (0x0EA7, 0x0EA7);
+      (0x0EAA, 0x0EAB);
+      (0x0EAD, 0x0EAE);
+      (0x0EB0, 0x0EB0);
+      (0x0EB2, 0x0EB3);
+      (0x0EBD, 0x0EBD);
+      (0x0EC0, 0x0EC4);
+      (0x0F40, 0x0F47);
+      (0x0F49, 0x0F69);
+      (0x10A0, 0x10C5);
+      (0x10D0, 0x10F6);
+      (0x1100, 0x1100);
+      (0x1102, 0x1103);
+      (0x1105, 0x1107);
+      (0x1109, 0x1109);
+      (0x110B, 0x110C);
+      (0x110E, 0x1112);
+      (0x113C, 0x113C);
+      (0x113E, 0x113E);
+      (0x1140, 0x1140);
+      (0x114C, 0x114C);
+      (0x114E, 0x114E);
+      (0x1150, 0x1150);
+      (0x1154, 0x1155);
+      (0x1159, 0x1159);
+      (0x115F, 0x1161);
+      (0x1163, 0x1163);
+      (0x1165, 0x1165);
+      (0x1167, 0x1167);
+      (0x1169, 0x1169);
+      (0x116D, 0x116E);
+      (0x1172, 0x1173);
+      (0x1175, 0x1175);
+      (0x119E, 0x119E);
+      (0x11A8, 0x11A8);
+      (0x11AB, 0x11AB);
+      (0x11AE, 0x11AF);
+      (0x11B7, 0x11B8);
+      (0x11BA, 0x11BA);
+      (0x11BC, 0x11C2);
+      (0x11EB, 0x11EB);
+      (0x11F0, 0x11F0);
+      (0x11F9, 0x11F9);
+      (0x1E00, 0x1E9B);
+      (0x1EA0, 0x1EF9);
+      (0x1F00, 0x1F15);
+      (0x1F18, 0x1F1D);
+      (0x1F20, 0x1F45);
+      (0x1F48, 0x1F4D);
+      (0x1F50, 0x1F57);
+      (0x1F59, 0x1F59);
+      (0x1F5B, 0x1F5B);
+      (0x1F5D, 0x1F5D);
+      (0x1F5F, 0x1F7D);
+      (0x1F80, 0x1FB4);
+      (0x1FB6, 0x1FBC);
+      (0x1FBE, 0x1FBE);
+      (0x1FC2, 0x1FC4);
+      (0x1FC6, 0x1FCC);
+      (0x1FD0, 0x1FD3);
+      (0x1FD6, 0x1FDB);
+      (0x1FE0, 0x1FEC);
+      (0x1FF2, 0x1FF4);
+      (0x1FF6, 0x1FFC);
+      (0x2126, 0x2126);
+      (0x212A, 0x212B);
+      (0x212E, 0x212E);
+      (0x2180, 0x2182);
+      (0x3041, 0x3094);
+      (0x30A1, 0x30FA);
+      (0x3105, 0x312C);
+      (0xAC00, 0xD7A3);
+    ]
+  in
+  of_list l
+
+let ideographic =
+  let l = [(0x3007, 0x3007); (0x3021, 0x3029); (0x4E00, 0x9FA5)] in
+  of_list l
+
+let combining_char =
+  let l =
+    [
+      (0x0300, 0x0345);
+      (0x0360, 0x0361);
+      (0x0483, 0x0486);
+      (0x0591, 0x05A1);
+      (0x05A3, 0x05B9);
+      (0x05BB, 0x05BD);
+      (0x05BF, 0x05BF);
+      (0x05C1, 0x05C2);
+      (0x05C4, 0x05C4);
+      (0x064B, 0x0652);
+      (0x0670, 0x0670);
+      (0x06D6, 0x06DC);
+      (0x06DD, 0x06DF);
+      (0x06E0, 0x06E4);
+      (0x06E7, 0x06E8);
+      (0x06EA, 0x06ED);
+      (0x0901, 0x0903);
+      (0x093C, 0x093C);
+      (0x093E, 0x094C);
+      (0x094D, 0x094D);
+      (0x0951, 0x0954);
+      (0x0962, 0x0963);
+      (0x0981, 0x0983);
+      (0x09BC, 0x09BC);
+      (0x09BE, 0x09BE);
+      (0x09BF, 0x09BF);
+      (0x09C0, 0x09C4);
+      (0x09C7, 0x09C8);
+      (0x09CB, 0x09CD);
+      (0x09D7, 0x09D7);
+      (0x09E2, 0x09E3);
+      (0x0A02, 0x0A02);
+      (0x0A3C, 0x0A3C);
+      (0x0A3E, 0x0A3E);
+      (0x0A3F, 0x0A3F);
+      (0x0A40, 0x0A42);
+      (0x0A47, 0x0A48);
+      (0x0A4B, 0x0A4D);
+      (0x0A70, 0x0A71);
+      (0x0A81, 0x0A83);
+      (0x0ABC, 0x0ABC);
+      (0x0ABE, 0x0AC5);
+      (0x0AC7, 0x0AC9);
+      (0x0ACB, 0x0ACD);
+      (0x0B01, 0x0B03);
+      (0x0B3C, 0x0B3C);
+      (0x0B3E, 0x0B43);
+      (0x0B47, 0x0B48);
+      (0x0B4B, 0x0B4D);
+      (0x0B56, 0x0B57);
+      (0x0B82, 0x0B83);
+      (0x0BBE, 0x0BC2);
+      (0x0BC6, 0x0BC8);
+      (0x0BCA, 0x0BCD);
+      (0x0BD7, 0x0BD7);
+      (0x0C01, 0x0C03);
+      (0x0C3E, 0x0C44);
+      (0x0C46, 0x0C48);
+      (0x0C4A, 0x0C4D);
+      (0x0C55, 0x0C56);
+      (0x0C82, 0x0C83);
+      (0x0CBE, 0x0CC4);
+      (0x0CC6, 0x0CC8);
+      (0x0CCA, 0x0CCD);
+      (0x0CD5, 0x0CD6);
+      (0x0D02, 0x0D03);
+      (0x0D3E, 0x0D43);
+      (0x0D46, 0x0D48);
+      (0x0D4A, 0x0D4D);
+      (0x0D57, 0x0D57);
+      (0x0E31, 0x0E31);
+      (0x0E34, 0x0E3A);
+      (0x0E47, 0x0E4E);
+      (0x0EB1, 0x0EB1);
+      (0x0EB4, 0x0EB9);
+      (0x0EBB, 0x0EBC);
+      (0x0EC8, 0x0ECD);
+      (0x0F18, 0x0F19);
+      (0x0F35, 0x0F35);
+      (0x0F37, 0x0F37);
+      (0x0F39, 0x0F39);
+      (0x0F3E, 0x0F3E);
+      (0x0F3F, 0x0F3F);
+      (0x0F71, 0x0F84);
+      (0x0F86, 0x0F8B);
+      (0x0F90, 0x0F95);
+      (0x0F97, 0x0F97);
+      (0x0F99, 0x0FAD);
+      (0x0FB1, 0x0FB7);
+      (0x0FB9, 0x0FB9);
+      (0x20D0, 0x20DC);
+      (0x20E1, 0x20E1);
+      (0x302A, 0x302F);
+      (0x3099, 0x3099);
+      (0x309A, 0x309A);
+    ]
+  in
+  of_list l
+
+let digit =
+  let l =
+    [
+      (0x0030, 0x0039);
+      (0x0660, 0x0669);
+      (0x06F0, 0x06F9);
+      (0x0966, 0x096F);
+      (0x09E6, 0x09EF);
+      (0x0A66, 0x0A6F);
+      (0x0AE6, 0x0AEF);
+      (0x0B66, 0x0B6F);
+      (0x0BE7, 0x0BEF);
+      (0x0C66, 0x0C6F);
+      (0x0CE6, 0x0CEF);
+      (0x0D66, 0x0D6F);
+      (0x0E50, 0x0E59);
+      (0x0ED0, 0x0ED9);
+      (0x0F20, 0x0F29);
+    ]
+  in
+  of_list l
+
+let extender =
+  let l =
+    [
+      (0x00B7, 0x00B7);
+      (0x02D0, 0x02D1);
+      (0x0387, 0x0387);
+      (0x0640, 0x0640);
+      (0x0E46, 0x0E46);
+      (0x0EC6, 0x0EC6);
+      (0x3005, 0x3005);
+      (0x3031, 0x3035);
+      (0x309D, 0x309E);
+      (0x30FC, 0x30FE);
+    ]
+  in
+  of_list l
+
+let blank =
+  let l = [(0x0009, 0x000A); (0x000D, 0x000D); (0x0020, 0x0020)] in
+  of_list l
+
+let letter = union base_char ideographic

src/syntax/xml.mli

@@ -0,0 +1,14 @@
+(* The package sedlex is released under the terms of an MIT-like license. *)
+(* See the attached LICENSE file.                                         *)
+
+(** Unicode classes from XML *)
+
+open Sedlex_cset
+
+val letter : t
+val digit : t
+val extender : t
+val base_char : t
+val ideographic : t
+val combining_char : t
+val blank : t

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

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

test/nested.ml

@@ -0,0 +1,9 @@
+let%expect_test _ =
+  let lb = Sedlexing.Utf8.from_string "ab" in
+  let res =
+    match%sedlex lb with
+      | 'a' -> ( match%sedlex lb with 'b' -> "ok" | _ -> "error")
+      | _ -> "error"
+  in
+  print_endline res;
+  [%expect {| ok |}]

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