noslop
/
noslop-sedlex
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Compare commits

base: noslop:main
Branches Tags
noslop:main
noslop:upstream/v3.7
noslop:upstream/v3.6
noslop:upstream/v3.5
noslop:upstream/v3.4
noslop:upstream/v3.3
noslop:upstream/v3.2
noslop:upstream/v3.1
noslop:upstream/v3.0
noslop:upstream/v2.6
noslop:upstream/v2.5
noslop:upstream/v2.4
noslop:upstream/v2.3
noslop:upstream/v2.2
noslop:upstream/v2.1
noslop:upstream/v2.0
noslop:upstream/v1.99.4
noslop:upstream/v1.99.3
noslop:upstream/sedlex-1.99.2
..
compare: noslop:upstream/v3.4
Branches Tags
noslop:main
noslop:upstream/v3.7
noslop:upstream/v3.6
noslop:upstream/v3.5
noslop:upstream/v3.4
noslop:upstream/v3.3
noslop:upstream/v3.2
noslop:upstream/v3.1
noslop:upstream/v3.0
noslop:upstream/v2.6
noslop:upstream/v2.5
noslop:upstream/v2.4
noslop:upstream/v2.3
noslop:upstream/v2.2
noslop:upstream/v2.1
noslop:upstream/v2.0
noslop:upstream/v1.99.4
noslop:upstream/v1.99.3
noslop:upstream/sedlex-1.99.2

No commits in common. "main" and "upstream/v3.4" have entirely different histories.
main ... upstream/v

48 changed files with 2258 additions and 2692 deletions
Show Stats Expand all files Collapse all files

1
.envrc
View File

@ -1 +0,0 @@
use flake

1
.gitattributes vendored
View File

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

3
.github/CODEOWNERS vendored Normal file
View File

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

69
.github/workflows/build.yml vendored Normal file
View File

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

20
.github/workflows/changelog.yml vendored Normal file
View File

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

28
.github/workflows/doc.yml vendored Normal file
View File

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

1
.gitignore vendored
View File

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

2
.ocamlformat
View File

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

19
.travis.yml Normal file
View File

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

12
CHANGES.md
View File

@ -1,15 +1,3 @@
# 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)

26
LICENSE
View File

@ -1,6 +1,22 @@
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
The MIT License (MIT)
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>
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.

27
Makefile Normal file
View File

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

23
README.md
View File

@ -79,25 +79,12 @@ where:
Unlike ocamllex, lexers work on stream of Unicode codepoints, not
bytes.
Like ocamllex, sedlex uses **longest match** with **first rule priority**:
- The lexer always tries to match the longest possible prefix of the
input. It does so by continuing to read characters as long as some
rule can still match a longer string, while remembering the last
position at which a rule did match.
- When two or more rules match the same longest prefix (a tie), the
rule that appears first in the `match%sedlex` definition wins. For
example, given the rules `| "if" -> ...` and `| Plus ('a'..'z') -> ...`,
the input `"if"` is matched by the first rule because it is listed
first, even though the second rule also accepts `"if"`.
The actions can call functions from the Sedlexing module to extract
(parts of) the matched lexeme, in the desired encoding.
Regular expressions are syntactically OCaml patterns:
- `"...."` (string constant): recognize the specified string.
- `"...."` (string constant): recognize the specified string
- `'....'` (character constant) : recognize the specified character
- `i` (integer constant) : recognize the specified codepoint
- `'...' .. '...'`: character range
@ -116,9 +103,6 @@ Regular expressions are syntactically OCaml patterns:
and recognize the set of items in `R1` but not in `R2` ("subtract")
- `Intersect (R1,R2)` : assume that `R` is a single-character length regexp (see
below) and recognize the set of items which are in both `R1` and `R2`
- `Utf8 R` : string literals inside R are assumed to be utf-8 encoded.
- `Latin1 R` : string literals inside R are assumed to be latin1 encoded.
- `Ascii R` : string literals inside R are assumed to be ascii encoded.
- `lid` (lowercase identifier) : reference a named regexp (see below)
A single-character length regexp is a regexp which does not contain (after
@ -128,9 +112,8 @@ with a length different from one.
Note:
- 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.
- The OCaml source is assumed to be encoded in Latin1 (for string
and character literals).
It is possible to define named regular expressions with the following

23
dune-project
View File

@ -1,21 +1,18 @@
(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")
(lang dune 3.0)
(version 3.4)
(name sedlex)
(source (github ocaml-community/sedlex))
(license MIT)
(authors "Alain Frisch <alain.frisch@lexifi.com>"
"https://github.com/ocaml-community/sedlex/graphs/contributors")
(maintainers "Alain Frisch <alain.frisch@lexifi.com>")
(homepage "https://github.com/ocaml-community/sedlex")
(generate_opam_files true)
(executables_implicit_empty_intf true)
(package
(name noslop-sedlex)
(name 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

5
examples/dune
View File

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

2
examples/regressions.ml
View File

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

1910
examples/unicode_old.ml
View File

File diff suppressed because it is too large Load Diff

45
flake.lock
View File

@ -1,45 +0,0 @@
{
"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
}

23
flake.nix
View File

@ -1,23 +0,0 @@
{
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
'';
};
};
}

22
licenses/LICENSE.sedlex
View File

@ -1,22 +0,0 @@
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.

52
package.nix
View File

@ -1,52 +0,0 @@
{
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;
})

21
noslop-sedlex.opam → sedlex.opam
View File

@ -1,20 +1,23 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
version: "3.7"
version: "3.4"
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"
maintainer: ["Alain Frisch <alain.frisch@lexifi.com>"]
authors: [
"Alain Frisch <alain.frisch@lexifi.com>"
"https://github.com/ocaml-community/sedlex/graphs/contributors"
]
license: "MIT"
homepage: "https://github.com/ocaml-community/sedlex"
bug-reports: "https://github.com/ocaml-community/sedlex/issues"
depends: [
"ocaml" {>= "4.08"}
"dune" {>= "3.20"}
"dune" {>= "3.0"}
"ppxlib" {>= "0.26.0"}
"gen"
"ppx_expect" {with-test}
@ -34,5 +37,5 @@ build: [
"@doc" {with-doc}
]
]
dev-repo: "https://git.lain.faith/noslop/noslop-sedlex.git"
x-maintenance-intent: ["(latest)"]
dev-repo: "git+https://github.com/ocaml-community/sedlex.git"
doc: "https://ocaml-community.github.io/sedlex/index.html"

1
sedlex.opam.template Normal file
View File

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

3
src/common/cset.ml
View File

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

9
src/common/cset.mli
View File

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

2
src/common/dune
View File

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

2
src/generator/data/base_url
View File

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

2
src/generator/dune
View File

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

5
src/lib/dune
View File

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

82
src/lib/sedlexing.ml
View File

@ -1,5 +1,6 @@
(* 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
@ -435,49 +436,6 @@ module Utf8 = struct
| '\240' .. '\247' -> 4
| _ -> raise MalFormed
(* https://www.unicode.org/versions/corrigendum1.html *)
let check_two n1 n2 =
if n1 < 0xc2 || 0xdf < n1 then raise MalFormed;
if n2 < 0x80 || 0xbf < n2 then raise MalFormed;
if n2 lsr 6 != 0b10 then raise MalFormed;
((n1 land 0x1f) lsl 6) lor (n2 land 0x3f)
let check_three n1 n2 n3 =
if n1 = 0xe0 then (
if n2 < 0xa0 || 0xbf < n2 then raise MalFormed;
if n3 < 0x80 || 0xbf < n3 then raise MalFormed)
else (
if n1 < 0xe1 || 0xef < n1 then raise MalFormed;
if n2 < 0x80 || 0xbf < n2 then raise MalFormed;
if n3 < 0x80 || 0xbf < n3 then raise MalFormed);
if n2 lsr 6 != 0b10 || n3 lsr 6 != 0b10 then raise MalFormed;
let p =
((n1 land 0x0f) lsl 12) lor ((n2 land 0x3f) lsl 6) lor (n3 land 0x3f)
in
if p >= 0xd800 && p <= 0xdfff then raise MalFormed;
p
let check_four n1 n2 n3 n4 =
if n1 = 0xf0 then (
if n2 < 0x90 || 0xbf < n2 then raise MalFormed;
if n3 < 0x80 || 0xbf < n3 then raise MalFormed;
if n4 < 0x80 || 0xbf < n4 then raise MalFormed)
else if n1 = 0xf4 then (
if n2 < 0x80 || 0x8f < n2 then raise MalFormed;
if n3 < 0x80 || 0xbf < n3 then raise MalFormed;
if n4 < 0x80 || 0xbf < n4 then raise MalFormed)
else (
if n1 < 0xf1 || 0xf3 < n1 then raise MalFormed;
if n2 < 0x80 || 0xbf < n2 then raise MalFormed;
if n3 < 0x80 || 0xbf < n3 then raise MalFormed;
if n4 < 0x80 || 0xbf < n4 then raise MalFormed);
if n2 lsr 6 != 0b10 || n3 lsr 6 != 0b10 || n4 lsr 6 != 0b10 then
raise MalFormed;
((n1 land 0x07) lsl 18)
lor ((n2 land 0x3f) lsl 12)
lor ((n3 land 0x3f) lsl 6)
lor (n4 land 0x3f)
let next s i =
let c1 = s.[i] in
match width c1 with
@ -485,18 +443,31 @@ module Utf8 = struct
| 2 ->
let n1 = Char.code c1 in
let n2 = Char.code s.[i + 1] in
check_two n1 n2
if n2 lsr 6 != 0b10 then raise MalFormed;
((n1 land 0x1f) lsl 6) lor (n2 land 0x3f)
| 3 ->
let n1 = Char.code c1 in
let n2 = Char.code s.[i + 1] in
let n3 = Char.code s.[i + 2] in
check_three n1 n2 n3
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;
p
| 4 ->
let n1 = Char.code c1 in
let n2 = Char.code s.[i + 1] in
let n3 = Char.code s.[i + 2] in
let n4 = Char.code s.[i + 3] in
check_four n1 n2 n3 n4
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)
| _ -> assert false
let gen_from_char_gen s =
@ -510,18 +481,29 @@ module Utf8 = struct
| 2 ->
let n1 = Char.code c1 in
let n2 = next_or_fail () in
Uchar.of_int (check_two n1 n2)
if n2 lsr 6 != 0b10 then raise MalFormed;
Uchar.of_int (((n1 land 0x1f) lsl 6) lor (n2 land 0x3f))
| 3 ->
let n1 = Char.code c1 in
let n2 = next_or_fail () in
let n3 = next_or_fail () in
Uchar.of_int (check_three n1 n2 n3)
if n2 lsr 6 != 0b10 || n3 lsr 6 != 0b10 then raise MalFormed;
Uchar.of_int
(((n1 land 0x0f) lsl 12)
lor ((n2 land 0x3f) lsl 6)
lor (n3 land 0x3f))
| 4 ->
let n1 = Char.code c1 in
let n2 = next_or_fail () in
let n3 = next_or_fail () in
let n4 = next_or_fail () in
Uchar.of_int (check_four n1 n2 n3 n4)
if n2 lsr 6 != 0b10 || n3 lsr 6 != 0b10 || n4 lsr 6 != 0b10 then
raise MalFormed;
Uchar.of_int
(((n1 land 0x07) lsl 18)
lor ((n2 land 0x3f) lsl 12)
lor ((n3 land 0x3f) lsl 6)
lor (n4 land 0x3f))
| _ -> raise MalFormed
(**************************)

299
src/lib/sedlexing.mli
View File

@ -1,164 +1,171 @@
(* 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: {!Uchar.t} 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. *)
(** 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
(** Raised by some functions to signal that some code point is not compatible
with a specified encoding. *)
(** Raised by some functions to signal that some code point is not
compatible with a specified encoding. *)
exception InvalidCodepoint of int
(** Raised by functions in the [Utf8] and [Utf16] modules to report strings
which do not comply to the encoding. *)
(** Raised by functions in the [Utf8] and [Utf16] modules to report
strings which do not comply to the encoding. *)
exception MalFormed
(** {6 Creating generic lexbufs} *)
(** 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. *)
(** 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
(** 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.
*)
(** 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
(** [set_filename lexbuf file] sets the filename to [file] in [lexbuf]. It also
sets the {!Lexing.pos_fname} field in returned {!Lexing.position} records.
*)
(** [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. *)
optional. If unspecified, byte positions are the same as code point positions. *)
val from_gen : ?bytes_per_char:(Uchar.t -> int) -> Uchar.t Gen.t -> lexbuf
(** Create a lexbuf from an array of Unicode code points. [bytes_per_char] is
optional. If unspecified, byte positions are the same as code point
positions. *)
optional. If unspecified, byte positions are the same as code point positions. *)
val from_int_array : ?bytes_per_char:(Uchar.t -> int) -> int array -> lexbuf
(** Create a lexbuf from an array of Unicode code points. [bytes_per_char] is
optional. If unspecified, byte positions are the same as code point
positions. *)
optional. If unspecified, byte positions are the same as code point positions. *)
val from_uchar_array :
?bytes_per_char:(Uchar.t -> int) -> Uchar.t array -> lexbuf
(** {6 Interface for lexers semantic actions} *)
(** The following functions can be called from the semantic actions of 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. *)
(** [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
(** [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. *)
(** [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
(** [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_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
(** [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. *)
(** [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
(** [Sedlexing.loc lexbuf] returns the pair
[(Sedlexing.lexeme_start lexbuf,Sedlexing.lexeme_end lexbuf)]. *)
[(Sedlexing.lexeme_start lexbuf,Sedlexing.lexeme_end
lexbuf)]. *)
val loc : lexbuf -> int * int
(** [Sedlexing.bytes_loc lexbuf] returns the pair
[(Sedlexing.lexeme_bytes_start lexbuf,Sedlexing.lexeme_bytes_end lexbuf)].
*)
[(Sedlexing.lexeme_bytes_start lexbuf,Sedlexing.lexeme_bytes_end
lexbuf)]. *)
val bytes_loc : lexbuf -> int * int
(** [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. *)
[(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. *)
[(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]. *)
(** [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. *)
(** [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. *)
(** [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]. *)
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. *)
(** [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. *)
(** [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. *)
(** [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. *)
(** [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. *)
(** [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
@ -166,52 +173,56 @@ val lexeme_char : lexbuf -> int -> Uchar.t
val sub_lexeme : lexbuf -> int -> int -> Uchar.t array
(** [Sedlexing.rollback lexbuf] puts [lexbuf] back in its configuration before
the last lexeme was matched. It is then possible to use another 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.
*)
(** [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
(** [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. *)
(** [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
(** [__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.
(** [__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.
This is a private API, it should not be used by code using this module's API
and can be removed at any time. *)
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. *)
(** [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). *)
(** [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. *)
(** [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 ->
@ -221,30 +232,30 @@ val with_tokenizer :
(** {6 Support for common encodings} *)
module Latin1 : sig
(** Create a lexbuf from a Latin1 encoded stream (ie a stream of Unicode code
points in the range [0..255]) *)
(** 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
(** 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
(** 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. *)
(** 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
(** 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. *)
(** 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
(** 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
@ -263,24 +274,19 @@ module Utf8 : sig
(** As [Sedlexing.sub_lexeme] with a result encoded in UTF-8. *)
val sub_lexeme : lexbuf -> int -> int -> string
module Helper : sig
val width : char -> int
val check_two : int -> int -> int
val check_three : int -> int -> int -> int
val check_four : int -> int -> int -> int -> int
end
end
module Utf16 : sig
type byte_order = Little_endian | Big_endian
(** [Utf16.from_gen s opt_bo] creates a lexbuf from an UTF-16 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
(** Works as [Utf16.from_gen] with an [in_channel]. *)
@ -289,12 +295,13 @@ module Utf16 : sig
(** Works as [Utf16.from_gen] with a [string]. *)
val from_string : string -> byte_order option -> lexbuf
(** [utf16_lexeme lb bo bom] as [Sedlexing.lexeme] with a result 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
(** [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

10
src/syntax/dune
View File

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

3
src/syntax/iso.mli
View File

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

291
src/syntax/ppx_sedlex.ml
View File

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

63
src/syntax/sedlex.ml
View File

@ -1,5 +1,6 @@
(* 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
@ -24,7 +25,7 @@ let new_node () =
let seq r1 r2 succ = r1 (r2 succ)
let is_chars final = function
| { eps = []; trans = [(c, f)]; _ } when f == final -> Some c
| { eps = []; trans = [(c, f)] } when f == final -> Some c
| _ -> None
let chars c succ =
@ -116,9 +117,6 @@ 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
@ -133,7 +131,7 @@ let compile rs =
let trans = transition state in
let trans = Array.map (fun (p, t) -> (p, aux t)) trans in
let finals = Array.map (fun (_, f) -> List.memq f state) rs in
Hashtbl.add states_def i { trans; finals };
Hashtbl.add states_def i (trans, finals);
i
in
let init = ref [] in
@ -141,56 +139,3 @@ let compile rs =
let i = aux !init in
assert (i = 0);
Array.init !counter (Hashtbl.find states_def)
let cset_to_label cset =
let escape_dot c =
match c with
| '"' -> "\\\""
| '\\' -> "\\\\"
| '<' -> "\\<"
| '>' -> "\\>"
| _ -> String.make 1 c
in
let format_interval (lo, hi) =
if lo = -1 && hi = -1 then "EOF"
else if lo = hi then
if lo >= 32 && lo <= 126 then "'" ^ escape_dot (Char.chr lo) ^ "'"
else Printf.sprintf "U+%04X" lo
else if lo >= 32 && lo <= 126 && hi >= 32 && hi <= 126 then
"'" ^ escape_dot (Char.chr lo) ^ "'-'" ^ escape_dot (Char.chr hi) ^ "'"
else Printf.sprintf "U+%04X-U+%04X" lo hi
in
String.concat ", "
(List.map format_interval (cset : Cset.t :> (int * int) list))
let dfa_to_dot dfa =
let buf = Buffer.create 1024 in
let bprintf = Printf.bprintf in
bprintf buf "digraph {\n";
bprintf buf " rankdir=LR;\n";
bprintf buf " node [shape=circle];\n\n";
bprintf buf " _start [shape=point];\n";
bprintf buf " _start -> state0;\n\n";
Array.iteri
(fun i { trans; finals } ->
let accepted =
let acc = ref [] in
for r = Array.length finals - 1 downto 0 do
if finals.(r) then acc := r :: !acc
done;
!acc
in
(match accepted with
| [] -> bprintf buf " state%d [label=\"%d\"];\n" i i
| rules ->
bprintf buf
" state%d [label=\"%d\\n[rule %s]\", shape=doublecircle];\n" i i
(String.concat "," (List.map string_of_int rules)));
Array.iter
(fun (cset, target) ->
let label = cset_to_label cset in
bprintf buf " state%d -> state%d [label=\"%s\"];\n" i target label)
trans)
dfa;
bprintf buf "}\n";
Buffer.contents buf

9
src/syntax/sedlex.mli
View File

@ -1,5 +1,6 @@
(* 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
@ -21,8 +22,4 @@ 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]. *)
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
val compile : regexp array -> ((Sedlex_cset.t * int) array * bool array) array

3
src/syntax/sedlex_cset.ml
View File

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

1567
src/syntax/unicode.ml
View File

File diff suppressed because it is too large Load Diff

49
src/syntax/utf8.ml
View File

@ -1,49 +0,0 @@
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

5
src/syntax/utf8.mli
View File

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

BIN
test/UTF-8-test.txt
View File

Binary file not shown.

8
test/codegen/dune
View File

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

120
test/codegen/test_gen.ml
View File

@ -1,120 +0,0 @@
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 -> () | _ -> ())
|}]

7
test/dune
View File

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

6
test/ppx_test/dune
View File

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

36
test/ppx_test/ppx_sedlex_test.ml
View File

@ -1,36 +0,0 @@
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]

BIN
test/stress_test.ml
View File

Binary file not shown.

33
test/utf8.ml
View File

@ -1,33 +0,0 @@
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À |}]