Compare commits
No commits in common. "main" and "upstream/v2.6" have entirely different histories.
main
...
upstream/v
|
|
@ -1 +0,0 @@
|
|||
test/stress_test.ml text diff
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
name: CI
|
||||
|
||||
on:
|
||||
pull_request:
|
||||
push:
|
||||
branches:
|
||||
- master
|
||||
|
||||
jobs:
|
||||
build:
|
||||
runs-on: ${{ matrix.os }}
|
||||
strategy:
|
||||
matrix:
|
||||
os: [ubuntu-latest, macos-latest, windows-latest]
|
||||
steps:
|
||||
- name: Build and test module
|
||||
uses: savonet/build-and-test-ocaml-module@main
|
||||
|
|
@ -19,4 +19,3 @@ examples/complement
|
|||
examples/tokenizer
|
||||
examples/subtraction
|
||||
_opam
|
||||
.direnv
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
version=0.29.0
|
||||
version=0.19.0
|
||||
profile = conventional
|
||||
break-separators = after
|
||||
space-around-lists = false
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,87 @@
|
|||
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
|
||||
128
CHANGES.md
128
CHANGES.md
|
|
@ -1,128 +0,0 @@
|
|||
# 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
|
||||
26
LICENSE
26
LICENSE
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
28
README.md
28
README.md
|
|
@ -1,6 +1,6 @@
|
|||
# sedlex
|
||||
|
||||
[](https://github.com/ocaml-community/sedlex/actions/workflows/build.yml)
|
||||
[](https://travis-ci.com/ocaml-community/sedlex)
|
||||
|
||||
Unicode-friendly lexer generator for OCaml.
|
||||
|
||||
|
|
@ -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
|
||||
|
|
@ -258,6 +241,3 @@ The `examples/` subdirectory contains several samples of sedlex in use.
|
|||
- 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
|
||||
|
|
|
|||
26
dune-project
26
dune-project
|
|
@ -1,21 +1,17 @@
|
|||
(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 2.8)
|
||||
(version 2.6)
|
||||
(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
|
||||
|
|
@ -26,4 +22,4 @@ extension.")
|
|||
dune
|
||||
(ppxlib (>= 0.26.0))
|
||||
gen
|
||||
(ppx_expect :with-test)))
|
||||
uchar))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -1,58 +1,50 @@
|
|||
(* This test that unicode_old.ml is a strict sub-set of new unicode.ml. *)
|
||||
(* 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 = ("13.0.0", "14.0.0")
|
||||
let regressions = []
|
||||
let interval s e = Array.to_list (Array.init (e - s) (fun pos -> s + pos))
|
||||
|
||||
let test_versions = ("16.0.0", "17.0.0")
|
||||
exception Found
|
||||
|
||||
let regressions =
|
||||
[ (* Example *)
|
||||
(* ("lt", CSet.union (CSet.singleton 0x1c5) (CSet.singleton (0x0001))) *) ]
|
||||
let test_exception name x =
|
||||
try
|
||||
let l = List.assoc name regressions in
|
||||
List.iter (fun (s, e) -> if s <= x && x <= e then raise Found) l
|
||||
with Not_found -> ()
|
||||
|
||||
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
|
||||
let compare name old_l new_l =
|
||||
let code_points =
|
||||
List.fold_left (fun res (s, e) -> res @ interval s e) [] old_l
|
||||
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
|
||||
let test x =
|
||||
try
|
||||
test_exception name x;
|
||||
List.iter (fun (s, e) -> if s <= x && x <= e then raise Found) new_l;
|
||||
false
|
||||
with Found -> true
|
||||
in
|
||||
List.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)
|
||||
if not (test x) then
|
||||
Printf.printf "Code point 0x%x missing in %s!\n" x name)
|
||||
code_points
|
||||
|
||||
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))
|
||||
if name <> "cn" then compare name old_l (List.assoc name new_l)
|
||||
|
||||
let () =
|
||||
if (Unicode_old.version, Unicode.version) <> test_versions then
|
||||
if (Unicode_old.version, Sedlex_ppx.Unicode.version) <> test_versions then
|
||||
failwith
|
||||
(Printf.sprintf "Test written for versions: %s => %s\n%!"
|
||||
Unicode_old.version Unicode.version);
|
||||
Unicode_old.version Sedlex_ppx.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
|
||||
Sedlex_ppx.Unicode.version;
|
||||
List.iter
|
||||
(test Sedlex_ppx.Unicode.Categories.list)
|
||||
Unicode_old.Categories.list;
|
||||
List.iter
|
||||
(test Sedlex_ppx.Unicode.Properties.list)
|
||||
Unicode_old.Properties.list
|
||||
|
|
|
|||
13705
examples/unicode_old.ml
13705
examples/unicode_old.ml
File diff suppressed because it is too large
Load Diff
45
flake.lock
45
flake.lock
|
|
@ -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
23
flake.nix
|
|
@ -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
|
||||
'';
|
||||
};
|
||||
};
|
||||
}
|
||||
|
|
@ -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
52
package.nix
|
|
@ -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;
|
||||
})
|
||||
|
|
@ -1,23 +1,26 @@
|
|||
# This file is generated by dune, edit dune-project instead
|
||||
opam-version: "2.0"
|
||||
version: "3.7"
|
||||
version: "2.6"
|
||||
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" {>= "2.8"}
|
||||
"ppxlib" {>= "0.26.0"}
|
||||
"gen"
|
||||
"ppx_expect" {with-test}
|
||||
"uchar"
|
||||
"odoc" {with-doc}
|
||||
]
|
||||
build: [
|
||||
|
|
@ -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"
|
||||
|
|
@ -0,0 +1 @@
|
|||
doc: "https://ocaml-community.github.io/sedlex/index.html"
|
||||
|
|
@ -1,78 +0,0 @@
|
|||
(* 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)
|
||||
|
|
@ -1,25 +0,0 @@
|
|||
(* 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
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
(library
|
||||
(name sedlex_utils)
|
||||
(public_name noslop-sedlex.utils))
|
||||
|
|
@ -1 +1 @@
|
|||
https://www.unicode.org/Public/17.0.0
|
||||
https://www.unicode.org/Public/14.0.0
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
(rule
|
||||
(target DerivedCoreProperties.txt)
|
||||
(targets DerivedCoreProperties.txt)
|
||||
(deps base_url)
|
||||
(action
|
||||
(run
|
||||
|
|
@ -8,10 +8,10 @@
|
|||
-s
|
||||
%{read:base_url}/ucd/DerivedCoreProperties.txt
|
||||
-o
|
||||
%{target})))
|
||||
DerivedCoreProperties.txt)))
|
||||
|
||||
(rule
|
||||
(target DerivedGeneralCategory.txt)
|
||||
(targets DerivedGeneralCategory.txt)
|
||||
(deps base_url)
|
||||
(action
|
||||
(run
|
||||
|
|
@ -20,16 +20,10 @@
|
|||
-s
|
||||
%{read:base_url}/ucd/extracted/DerivedGeneralCategory.txt
|
||||
-o
|
||||
%{target})))
|
||||
DerivedGeneralCategory.txt)))
|
||||
|
||||
(rule
|
||||
(target PropList.txt)
|
||||
(targets 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})))
|
||||
(run curl -L -s %{read:base_url}/ucd/PropList.txt -o PropList.txt)))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,9 @@
|
|||
(executable
|
||||
(name gen_unicode)
|
||||
(libraries str noslop-sedlex.utils))
|
||||
(libraries str))
|
||||
|
||||
(rule
|
||||
(targets gen_unicode.ml)
|
||||
(deps gen_unicode.ml.inc)
|
||||
(action
|
||||
(run cp gen_unicode.ml.inc gen_unicode.ml)))
|
||||
|
|
|
|||
|
|
@ -1,209 +0,0 @@
|
|||
(* 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
|
||||
|
|
@ -0,0 +1,145 @@
|
|||
(* This file generates unicode data from
|
||||
* the files exported at https://www.unicode.org/Public/<unicode version>
|
||||
* and stored at src/generator/data. *)
|
||||
|
||||
let target = Sys.argv.(1)
|
||||
|
||||
let categories =
|
||||
Hashtbl.create 1024
|
||||
|
||||
let labels =
|
||||
Hashtbl.create 1024
|
||||
|
||||
(* Categories and Properties that we're keeping. *)
|
||||
let keepers =
|
||||
["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"; "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 prop_interval_rex =
|
||||
Str.regexp "^\\([0-9a-fA-F]+\\)\\.\\.\\([0-9a-fA-F]+\\)[ ]*;[ ]+\\([a-zA-Z_]+\\)[ ]+#[ ]+\\([a-zA-Z][a-zA-Z&]\\)"
|
||||
|
||||
let prop_single_rex =
|
||||
Str.regexp "^\\([0-9a-fA-F]+\\)[ ]*;[ ]+\\([a-zA-Z_]+\\)[ ]+#[ ]+\\([a-zA-Z][a-zA-Z&]\\)"
|
||||
|
||||
let derived_interval_rex =
|
||||
Str.regexp "^\\([0-9a-fA-F]+\\)\\.\\.\\([0-9a-fA-F]+\\)[ ]*;[ ]+\\([a-zA-Z_]+\\)"
|
||||
|
||||
let derived_single_rex =
|
||||
Str.regexp "^\\([0-9a-fA-F]+\\)[ ]*;[ ]+\\([a-zA-Z_]+\\)"
|
||||
|
||||
let add_entry hashtbl (b,e) name =
|
||||
let mk s =
|
||||
int_of_string (Printf.sprintf "0x%s" s)
|
||||
in
|
||||
let interval = (mk b, mk e) in
|
||||
let label = String.lowercase_ascii name in
|
||||
if List.mem label keepers then
|
||||
Hashtbl.add hashtbl label interval
|
||||
|
||||
let match_interval s =
|
||||
if (Str.string_match prop_interval_rex s 0) then
|
||||
let interval = Str.matched_group 1 s, Str.matched_group 2 s in
|
||||
add_entry labels interval (Str.matched_group 3 s);
|
||||
add_entry categories interval (Str.matched_group 4 s)
|
||||
|
||||
let match_single s =
|
||||
if (Str.string_match prop_single_rex s 0) then
|
||||
let interval = Str.matched_group 1 s, Str.matched_group 1 s in
|
||||
add_entry labels interval (Str.matched_group 2 s);
|
||||
add_entry categories interval (Str.matched_group 3 s)
|
||||
|
||||
let match_derived_interval s =
|
||||
if (Str.string_match derived_interval_rex s 0) then
|
||||
let interval = Str.matched_group 1 s, Str.matched_group 2 s in
|
||||
add_entry categories interval (Str.matched_group 3 s)
|
||||
|
||||
let match_derived_single s =
|
||||
if (Str.string_match derived_single_rex s 0) then
|
||||
let interval = Str.matched_group 1 s, Str.matched_group 1 s in
|
||||
add_entry categories interval (Str.matched_group 2 s)
|
||||
|
||||
let split list n =
|
||||
let rec aux acc rem =
|
||||
match acc, rem with
|
||||
| [], el::rem ->
|
||||
aux [[el]] rem
|
||||
| l::acc, el::rem when List.length l = n ->
|
||||
aux ([el]::(List.rev l)::acc) rem
|
||||
| l::acc, el::rem ->
|
||||
aux ((el::l)::acc) rem
|
||||
| _, [] -> List.rev acc
|
||||
in
|
||||
aux [] list
|
||||
|
||||
let print_elements ch hashtbl =
|
||||
let cats =
|
||||
List.sort_uniq compare
|
||||
(Hashtbl.fold (fun cat _ l -> cat::l) hashtbl [])
|
||||
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)
|
||||
(List.sort_uniq compare
|
||||
(Hashtbl.find_all hashtbl c))
|
||||
in
|
||||
let entries =
|
||||
List.map (String.concat "; ") (split entries 5)
|
||||
in
|
||||
let entries =
|
||||
String.concat ";\n " entries
|
||||
in
|
||||
Printf.fprintf ch " let %s =\n [%s]\n\n" c entries) 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"
|
||||
|
||||
let files = [
|
||||
("PropList.txt", [match_interval; match_single]);
|
||||
("DerivedCoreProperties.txt", [match_interval; match_single]);
|
||||
("DerivedGeneralCategory.txt", [match_derived_interval; match_derived_single])
|
||||
]
|
||||
|
||||
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 () =
|
||||
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, fns) ->
|
||||
let ch =
|
||||
open_in_bin
|
||||
(Filename.concat base_dir fname)
|
||||
in
|
||||
try
|
||||
while true do
|
||||
let ret = input_line ch in
|
||||
List.iter (fun fn -> fn ret) fns
|
||||
done
|
||||
with End_of_file -> close_in ch) files;
|
||||
let ch = open_out_bin target in
|
||||
Printf.fprintf ch "let version = %S\n\n" version;
|
||||
Printf.fprintf ch "module Categories = struct\n\n";
|
||||
print_elements ch categories;
|
||||
Printf.fprintf ch "end\n\n";
|
||||
Printf.fprintf ch "module Properties = struct\n\n";
|
||||
print_elements ch labels;
|
||||
Printf.fprintf ch "end\n";
|
||||
close_out ch
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -1,79 +1,44 @@
|
|||
(* 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 gen_of_channel chan =
|
||||
let f () = try Some (input_char chan) with End_of_file -> None in
|
||||
f
|
||||
|
||||
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 ( >>= ) o f = match o with Some x -> f x | None -> None
|
||||
|
||||
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
|
||||
(* For legacy purposes. *)
|
||||
let gen_of_stream stream =
|
||||
let f () = try Some (Stream.next stream) with Stream.Failure -> None in
|
||||
f
|
||||
|
||||
(* Absolute position from the beginning of the stream *)
|
||||
type apos = int
|
||||
|
||||
type lexbuf = {
|
||||
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 *)
|
||||
(* Number of meaningful char in buffer *)
|
||||
mutable offset : apos;
|
||||
(* Number of meaningful bytes in buffer *)
|
||||
mutable bytes_offset : apos;
|
||||
(* Position of the first uchar in buffer
|
||||
(* Position of the first char in buffer
|
||||
in the input stream *)
|
||||
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 *)
|
||||
(* pos is the index in the buffer *)
|
||||
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. *)
|
||||
(* bol is the index in the input stream but not buffer *)
|
||||
mutable curr_line : int;
|
||||
(* starting position, in uchar. *)
|
||||
(* start from 1, if it is 0, we would not track postion info for you *)
|
||||
mutable start_pos : int;
|
||||
(* starting position, in bytes. *)
|
||||
mutable start_bytes_pos : int;
|
||||
(* First uchar we need to keep visible *)
|
||||
(* First char 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;
|
||||
|
|
@ -82,82 +47,69 @@ type lexbuf = {
|
|||
|
||||
let chunk_size = 512
|
||||
|
||||
let empty_lexbuf bytes_per_char =
|
||||
let empty_lexbuf =
|
||||
{
|
||||
refill = (fun _ _ _ -> assert false);
|
||||
bytes_per_char;
|
||||
buf = [||];
|
||||
len = 0;
|
||||
offset = 0;
|
||||
bytes_offset = 0;
|
||||
pos = 0;
|
||||
bytes_pos = 0;
|
||||
curr_bol = 0;
|
||||
curr_bytes_bol = 0;
|
||||
curr_line = 1;
|
||||
curr_line = 0;
|
||||
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 dummy_uchar = Uchar.of_int 0
|
||||
let nl_uchar = Uchar.of_int 10
|
||||
|
||||
let create ?(bytes_per_char = fun _ -> 1) refill =
|
||||
let create f =
|
||||
{
|
||||
(empty_lexbuf bytes_per_char) with
|
||||
refill;
|
||||
buf = Array.make chunk_size dummy_uchar;
|
||||
empty_lexbuf with
|
||||
refill = f;
|
||||
buf = Array.make chunk_size (Uchar.of_int 0);
|
||||
curr_line = 1;
|
||||
}
|
||||
|
||||
let set_position ?bytes_position lexbuf position =
|
||||
let set_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
|
||||
lexbuf.curr_line <- position.Lexing.pos_lnum
|
||||
|
||||
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
|
||||
let fill_buf_from_gen f gen buf pos len =
|
||||
let rec aux i =
|
||||
if i >= len then len
|
||||
else (
|
||||
match gen () with
|
||||
| Some c ->
|
||||
buf.(pos + i) <- f c;
|
||||
aux (i + 1)
|
||||
| None -> i)
|
||||
in
|
||||
create ?bytes_per_char refill
|
||||
aux 0
|
||||
|
||||
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_gen s = create (fill_buf_from_gen (fun id -> id) s)
|
||||
let from_stream s = from_gen @@ gen_of_stream s
|
||||
|
||||
let from_uchar_array ?(bytes_per_char = fun _ -> 1) a =
|
||||
let from_int_array a =
|
||||
let len = Array.length a in
|
||||
{
|
||||
(empty_lexbuf bytes_per_char) with
|
||||
empty_lexbuf with
|
||||
buf = Array.init len (fun i -> Uchar.of_int a.(i));
|
||||
len;
|
||||
finished = true;
|
||||
}
|
||||
|
||||
let from_uchar_array a =
|
||||
let len = Array.length a in
|
||||
{
|
||||
empty_lexbuf with
|
||||
buf = Array.init len (fun i -> a.(i));
|
||||
len;
|
||||
finished = true;
|
||||
|
|
@ -166,91 +118,75 @@ let from_uchar_array ?(bytes_per_char = fun _ -> 1) a =
|
|||
let refill lexbuf =
|
||||
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.make newlen dummy_uchar in
|
||||
let newbuf = Array.make newlen (Uchar.of_int 0) 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.marked_bytes_pos <- lexbuf.marked_bytes_pos - s_bytes;
|
||||
lexbuf.start_pos <- 0;
|
||||
lexbuf.start_bytes_pos <- 0
|
||||
lexbuf.start_pos <- 0
|
||||
end;
|
||||
let n = lexbuf.refill lexbuf.buf lexbuf.pos chunk_size in
|
||||
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
|
||||
if lexbuf.curr_line != 0 then lexbuf.curr_line <- lexbuf.curr_line + 1;
|
||||
lexbuf.curr_bol <- lexbuf.pos + lexbuf.offset
|
||||
|
||||
let[@inline always] next_aux some none lexbuf =
|
||||
let next lexbuf =
|
||||
if (not lexbuf.finished) && lexbuf.pos = lexbuf.len then refill lexbuf;
|
||||
if lexbuf.finished && lexbuf.pos = lexbuf.len then none
|
||||
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
|
||||
if ret = Uchar.of_int 10 then new_line lexbuf;
|
||||
Some ret
|
||||
end
|
||||
|
||||
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 __private__next_int lexbuf : int =
|
||||
if (not lexbuf.finished) && lexbuf.pos = lexbuf.len then refill lexbuf;
|
||||
if lexbuf.finished && lexbuf.pos = lexbuf.len then -1
|
||||
else begin
|
||||
let ret = lexbuf.buf.(lexbuf.pos) in
|
||||
lexbuf.pos <- lexbuf.pos + 1;
|
||||
if ret = Uchar.of_int 10 then new_line lexbuf;
|
||||
Uchar.to_int ret
|
||||
end
|
||||
|
||||
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_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_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 bytes_loc lexbuf =
|
||||
( lexbuf.start_bytes_pos + lexbuf.bytes_offset,
|
||||
lexbuf.bytes_pos + lexbuf.bytes_offset )
|
||||
|
||||
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 + pos) len
|
||||
|
|
@ -260,46 +196,22 @@ let lexeme lexbuf =
|
|||
|
||||
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
|
||||
let start_p =
|
||||
{
|
||||
Lexing.pos_fname = lexbuf.filename;
|
||||
pos_lnum = lexbuf.start_line;
|
||||
pos_cnum = lexbuf.start_pos + lexbuf.offset;
|
||||
pos_bol = lexbuf.start_bol;
|
||||
}
|
||||
and curr_p =
|
||||
{
|
||||
Lexing.pos_fname = lexbuf.filename;
|
||||
pos_lnum = lexbuf.curr_line;
|
||||
pos_cnum = lexbuf.pos + lexbuf.offset;
|
||||
pos_bol = lexbuf.curr_bol;
|
||||
}
|
||||
in
|
||||
(start_p, curr_p)
|
||||
|
||||
let with_tokenizer lexer' lexbuf =
|
||||
|
|
@ -310,103 +222,20 @@ let with_tokenizer lexer' lexbuf =
|
|||
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_gen s =
|
||||
from_gen ~bytes_per_char:(fun _ -> 1) (Gen.map Uchar.of_char s)
|
||||
let from_gen s = create (fill_buf_from_gen Uchar.of_char s)
|
||||
let from_stream s = from_gen @@ gen_of_stream s
|
||||
|
||||
let from_string s =
|
||||
let len = String.length s in
|
||||
{
|
||||
(empty_lexbuf (fun _ -> 1)) with
|
||||
empty_lexbuf with
|
||||
buf = Array.init len (fun i -> Uchar.of_char s.[i]);
|
||||
len;
|
||||
finished = true;
|
||||
}
|
||||
|
||||
let from_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 from_channel ic = from_gen (gen_of_channel ic)
|
||||
|
||||
let to_latin1 c =
|
||||
if Uchar.is_char c then Uchar.to_char c
|
||||
|
|
@ -428,133 +257,157 @@ module Utf8 = struct
|
|||
module Helper = struct
|
||||
(* http://www.faqs.org/rfcs/rfc3629.html *)
|
||||
|
||||
let width = function
|
||||
| '\000' .. '\127' -> 1
|
||||
| '\192' .. '\223' -> 2
|
||||
| '\224' .. '\239' -> 3
|
||||
| '\240' .. '\247' -> 4
|
||||
| _ -> raise MalFormed
|
||||
let width = Array.make 256 (-1)
|
||||
|
||||
(* 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 () =
|
||||
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 next s i =
|
||||
let c1 = s.[i] in
|
||||
match width c1 with
|
||||
| 1 -> Char.code c1
|
||||
| 2 ->
|
||||
let n1 = Char.code c1 in
|
||||
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
|
||||
check_two n1 n2
|
||||
| 3 ->
|
||||
let n1 = Char.code c1 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 s.[i + 1] in
|
||||
let n3 = Char.code s.[i + 2] in
|
||||
check_three n1 n2 n3
|
||||
| 4 ->
|
||||
let n1 = Char.code c1 in
|
||||
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
|
||||
| '\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
|
||||
check_four n1 n2 n3 n4
|
||||
| _ -> assert false
|
||||
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 gen_from_char_gen s =
|
||||
let next_or_fail () =
|
||||
match Gen.next s with None -> raise MalFormed | Some x -> Char.code x
|
||||
let from_gen s =
|
||||
Gen.next s >>= function
|
||||
| '\000' .. '\127' as c -> Some (Uchar.of_char c)
|
||||
| '\192' .. '\223' as c ->
|
||||
let n1 = Char.code c in
|
||||
Gen.next s >>= fun c2 ->
|
||||
let n2 = Char.code c2 in
|
||||
if n2 lsr 6 != 0b10 then raise MalFormed;
|
||||
Some (Uchar.of_int (((n1 land 0x1f) lsl 6) lor (n2 land 0x3f)))
|
||||
| '\224' .. '\239' as c ->
|
||||
let n1 = Char.code c in
|
||||
Gen.next s >>= fun c2 ->
|
||||
let n2 = Char.code c2 in
|
||||
Gen.next s >>= fun c3 ->
|
||||
let n3 = Char.code c3 in
|
||||
if n2 lsr 6 != 0b10 || n3 lsr 6 != 0b10 then raise MalFormed;
|
||||
Some
|
||||
(Uchar.of_int
|
||||
(((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
|
||||
Gen.next s >>= fun c2 ->
|
||||
let n2 = Char.code c2 in
|
||||
Gen.next s >>= fun c3 ->
|
||||
let n3 = Char.code c3 in
|
||||
Gen.next s >>= fun c4 ->
|
||||
let n4 = Char.code c4 in
|
||||
if n2 lsr 6 != 0b10 || n3 lsr 6 != 0b10 || n4 lsr 6 != 0b10 then
|
||||
raise MalFormed;
|
||||
Some
|
||||
(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
|
||||
|
||||
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)
|
||||
in
|
||||
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
|
||||
aux 0 pos
|
||||
|
||||
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.make n 0 in
|
||||
blit_to_int s pos a 0 n;
|
||||
a
|
||||
|
||||
(**************************)
|
||||
|
||||
let to_buffer a apos len b =
|
||||
for i = apos to apos + len - 1 do
|
||||
Buffer.add_utf_8_uchar b a.(i)
|
||||
done
|
||||
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_uchar_array a apos len =
|
||||
let b = Buffer.create (len * 4) in
|
||||
let rec aux apos len =
|
||||
if len > 0 then (
|
||||
store b (Uchar.to_int a.(apos));
|
||||
aux (succ apos) (pred len))
|
||||
else Buffer.contents b
|
||||
in
|
||||
aux apos len
|
||||
|
||||
let gen_from_char_gen s () = from_gen s
|
||||
end
|
||||
|
||||
let from_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_channel ic = from_gen (Helper.gen_from_char_gen (gen_of_channel ic))
|
||||
|
||||
let from_gen s =
|
||||
from_gen ~bytes_per_char:Uchar.utf_8_byte_length
|
||||
(Helper.gen_from_char_gen s)
|
||||
create (fill_buf_from_gen (fun id -> id) (Helper.gen_from_char_gen s))
|
||||
|
||||
let from_string s =
|
||||
from_gen (Gen.init ~limit:(String.length s) (fun i -> String.get s i))
|
||||
let from_stream s = from_gen @@ gen_of_stream s
|
||||
let from_string s = from_int_array (Helper.to_int_array s 0 (String.length s))
|
||||
|
||||
let sub_lexeme lexbuf pos len =
|
||||
let buf = Buffer.create (len * 4) in
|
||||
Helper.to_buffer lexbuf.buf (lexbuf.start_pos + pos) len buf;
|
||||
Buffer.contents buf
|
||||
Helper.from_uchar_array lexbuf.buf (lexbuf.start_pos + pos) len
|
||||
|
||||
let lexeme lexbuf = sub_lexeme lexbuf 0 (lexbuf.pos - lexbuf.start_pos)
|
||||
end
|
||||
|
|
@ -565,94 +418,117 @@ module Utf16 = struct
|
|||
module Helper = struct
|
||||
(* http://www.ietf.org/rfc/rfc2781.txt *)
|
||||
|
||||
let number_of_pair bo c1 c2 =
|
||||
let number_of_char_pair bo c1 c2 =
|
||||
match bo with
|
||||
| Little_endian -> (c2 lsl 8) + c1
|
||||
| Big_endian -> (c1 lsl 8) + c2
|
||||
| Little_endian -> (Char.code c2 lsl 8) + Char.code c1
|
||||
| Big_endian -> (Char.code c1 lsl 8) + Char.code c2
|
||||
|
||||
let get_bo bo c1 c2 =
|
||||
match !bo with
|
||||
| Some o -> o
|
||||
| None ->
|
||||
let o =
|
||||
match (c1, c2) with
|
||||
| 0xff, 0xfe -> Little_endian
|
||||
| _ -> Big_endian
|
||||
in
|
||||
bo := Some o;
|
||||
o
|
||||
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_gen bo s =
|
||||
Gen.next s >>= fun c1 ->
|
||||
Gen.next s >>= fun c2 -> Some (number_of_char_pair bo c1 c2)
|
||||
|
||||
let from_gen bo s w1 =
|
||||
if w1 = 0xfffe then raise (InvalidCodepoint w1);
|
||||
if w1 < 0xd800 || 0xdfff < w1 then Some (Uchar.of_int w1)
|
||||
else if w1 <= 0xdbff then (
|
||||
next_in_gen bo s >>= fun w2 ->
|
||||
if w2 < 0xdc00 || w2 > 0xdfff then raise MalFormed;
|
||||
let upper10 = (w1 land 0x3ff) lsl 10 and lower10 = w2 land 0x3ff in
|
||||
Some (Uchar.of_int (0x10000 + upper10 + lower10)))
|
||||
else raise MalFormed
|
||||
|
||||
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
|
||||
Gen.next s >>= fun c1 ->
|
||||
Gen.next s >>= fun c2 ->
|
||||
let o =
|
||||
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
|
||||
from_gen o s (number_of_char_pair o c1 c2)
|
||||
|
||||
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
|
||||
let compute_len opt_bo str pos bytes =
|
||||
let s =
|
||||
gen_from_char_gen opt_bo
|
||||
(Gen.init ~limit:(bytes - pos) (fun i -> str.[i + pos]))
|
||||
in
|
||||
if bom then store (Uchar.of_int 0xfeff);
|
||||
let l = ref 0 in
|
||||
Gen.iter (fun _ -> incr l) s;
|
||||
!l
|
||||
|
||||
let blit_to_int opt_bo s spos a apos bytes =
|
||||
let s =
|
||||
gen_from_char_gen opt_bo
|
||||
(Gen.init ~limit:(bytes - spos) (fun i -> s.[i + spos]))
|
||||
in
|
||||
let p = ref apos in
|
||||
Gen.iter
|
||||
(fun x ->
|
||||
a.(!p) <- x;
|
||||
incr p)
|
||||
s
|
||||
|
||||
let to_uchar_array opt_bo s pos bytes =
|
||||
let len = compute_len opt_bo s pos bytes in
|
||||
let a = Array.make len (Uchar.of_int 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_uchar_array bo a apos len bom =
|
||||
let b = Buffer.create ((len * 4) + 2) in
|
||||
(* +2 for the BOM *)
|
||||
if bom then store bo b 0xfeff;
|
||||
(* first, store the BOM *)
|
||||
for i = apos to apos + len - 1 do
|
||||
store a.(i)
|
||||
done
|
||||
let rec aux apos len =
|
||||
if len > 0 then (
|
||||
store bo b (Uchar.to_int a.(apos));
|
||||
aux (succ apos) (pred len))
|
||||
else Buffer.contents b
|
||||
in
|
||||
aux apos len
|
||||
end
|
||||
|
||||
let from_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_gen s opt_bo = from_gen (Helper.gen_from_char_gen opt_bo s)
|
||||
let from_stream s = from_gen @@ gen_of_stream s
|
||||
let from_channel ic opt_bo = from_gen (gen_of_channel ic) opt_bo
|
||||
|
||||
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 from_string s opt_bo =
|
||||
let a = Helper.to_uchar_array opt_bo s 0 (String.length s) in
|
||||
from_uchar_array a
|
||||
|
||||
let sub_lexeme lb pos len bo 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
|
||||
Helper.from_uchar_array bo lb.buf (lb.start_pos + pos) len bom
|
||||
|
||||
let lexeme lb bo bom = sub_lexeme lb 0 (lb.pos - lb.start_pos) bo bom
|
||||
end
|
||||
|
|
|
|||
|
|
@ -1,164 +1,121 @@
|
|||
(* 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. *)
|
||||
val create :
|
||||
?bytes_per_char:(Uchar.t -> int) ->
|
||||
(Uchar.t 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
|
||||
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. *)
|
||||
val create : (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.
|
||||
*)
|
||||
val set_position :
|
||||
?bytes_position:Lexing.position -> lexbuf -> Lexing.position -> unit
|
||||
(** set the initial tracked input position for [lexbuf].
|
||||
If set to [Lexing.dummy_pos], Sedlexing will not track position
|
||||
information for you. *)
|
||||
val set_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. *)
|
||||
val from_gen : ?bytes_per_char:(Uchar.t -> int) -> Uchar.t Gen.t -> lexbuf
|
||||
(** Create a lexbuf from a stream of Unicode code points. *)
|
||||
val from_gen : 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 a stream of Unicode code points. *)
|
||||
val from_stream : Uchar.t Stream.t -> lexbuf
|
||||
[@@ocaml.deprecated "Use [Sedlexing.from_gen] instead."]
|
||||
|
||||
(** 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
|
||||
(** Create a lexbuf from an array of Unicode code points. *)
|
||||
val from_int_array : int array -> lexbuf
|
||||
|
||||
(** Create a lexbuf from an array of Unicode code points. *)
|
||||
val from_uchar_array : 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. *)
|
||||
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. *)
|
||||
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)].
|
||||
*)
|
||||
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. *)
|
||||
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 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. *)
|
||||
(** [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 +123,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.
|
||||
|
||||
This is a private API, it should not be used by code using this module's API
|
||||
and can be removed at any time. *)
|
||||
(** [__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. *)
|
||||
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 +182,35 @@ 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 stream (ie a stream
|
||||
of Unicode code points in the range [0..255]) *)
|
||||
val from_stream : char Stream.t -> lexbuf
|
||||
[@@ocaml.deprecated "Use [Sedlexing.Latin1.from_gen] instead."]
|
||||
|
||||
(** 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
|
||||
|
||||
|
|
@ -252,6 +218,10 @@ module Utf8 : sig
|
|||
(** Create a lexbuf from a UTF-8 encoded stream. *)
|
||||
val from_gen : char Gen.t -> lexbuf
|
||||
|
||||
(** Create a lexbuf from a UTF-8 encoded stream. *)
|
||||
val from_stream : char Stream.t -> lexbuf
|
||||
[@@ocaml.deprecated "Use [Sedlexing.Utf8.from_gen] instead."]
|
||||
|
||||
(** Create a lexbuf from a UTF-8 encoded input channel. *)
|
||||
val from_channel : in_channel -> lexbuf
|
||||
|
||||
|
|
@ -263,38 +233,38 @@ 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 a [stream]. *)
|
||||
val from_stream : char Stream.t -> byte_order option -> lexbuf
|
||||
[@@ocaml.deprecated "Use [Sedlexing.Utf16.from_gen] instead."]
|
||||
|
||||
(** Works as [Utf16.from_gen] with an [in_channel]. *)
|
||||
val from_channel : in_channel -> byte_order option -> lexbuf
|
||||
|
||||
(** 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
|
||||
|
|
|
|||
|
|
@ -1,17 +1,21 @@
|
|||
(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)
|
||||
(ppx_runtime_libraries sedlex)
|
||||
(preprocess
|
||||
(pps ppxlib.metaquot)))
|
||||
(pps ppxlib.metaquot))
|
||||
(flags
|
||||
(:standard -w -9)))
|
||||
|
||||
(rule
|
||||
(targets unicode.ml)
|
||||
(mode promote)
|
||||
(mode promote-until-clean)
|
||||
(deps
|
||||
(:gen ../generator/gen_unicode.exe)
|
||||
(glob_files ../generator/data/*.txt))
|
||||
../generator/data/DerivedCoreProperties.txt
|
||||
../generator/data/DerivedGeneralCategory.txt
|
||||
../generator/data/PropList.txt)
|
||||
(action
|
||||
(run %{gen} %{targets})))
|
||||
|
|
|
|||
|
|
@ -1,217 +0,0 @@
|
|||
(* 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)
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
(* 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
|
||||
|
|
@ -1,9 +1,9 @@
|
|||
(* 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
|
||||
open Ast_helper
|
||||
|
||||
(* let ocaml_version = Versions.ocaml_408 *)
|
||||
|
||||
|
|
@ -12,6 +12,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
|
||||
|
|
@ -77,10 +78,7 @@ let rec simplify min max = function
|
|||
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 : Sedlex_cset.t :> (int * int) list))
|
||||
(fun i c -> List.iter (fun (a, b) -> seg := (a, b, i) :: !seg) c)
|
||||
p;
|
||||
List.sort (fun (a1, _, _) (a2, _, _) -> compare a1 a2) !seg
|
||||
|
||||
|
|
@ -113,14 +111,14 @@ let builtin_regexps =
|
|||
([
|
||||
("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);
|
||||
("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.Categories.list @ Unicode.Properties.list)
|
||||
|
||||
|
|
@ -179,11 +177,7 @@ let partition (name, p) =
|
|||
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]]
|
||||
glb_value name [%expr fun c -> [%e body]]
|
||||
|
||||
(* Code generation for the automata *)
|
||||
|
||||
|
|
@ -197,14 +191,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]
|
||||
else appfun (state_fun state) [evar ~loc:default_loc lexbuf]
|
||||
|
||||
let gen_state (lexbuf_name, lexbuf) auto i { Sedlex.trans; finals } =
|
||||
let gen_state lexbuf auto i (trans, final) =
|
||||
let loc = default_loc in
|
||||
let partition = Array.map fst trans in
|
||||
let cases =
|
||||
|
|
@ -217,30 +211,31 @@ let gen_state (lexbuf_name, lexbuf) auto i { Sedlex.trans; finals } =
|
|||
let body () =
|
||||
pexp_match ~loc
|
||||
(appfun (partition_name partition)
|
||||
[[%expr Sedlexing.__private__next_int [%e lexbuf]]])
|
||||
[[%expr Sedlexing.__private__next_int [%e evar ~loc lexbuf]]])
|
||||
(cases
|
||||
@ [
|
||||
case
|
||||
~lhs:[%pat? _]
|
||||
~guard:None
|
||||
~rhs:[%expr Sedlexing.backtrack [%e lexbuf]];
|
||||
~rhs:[%expr Sedlexing.backtrack [%e evar ~loc lexbuf]];
|
||||
])
|
||||
in
|
||||
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);
|
||||
~expr:
|
||||
(pexp_function ~loc
|
||||
[case ~lhs:(pvar ~loc lexbuf) ~guard:None ~rhs:body]);
|
||||
]
|
||||
in
|
||||
match best_final finals with
|
||||
match best_final final with
|
||||
| None -> ret (body ())
|
||||
| Some _ when Array.length trans = 0 -> []
|
||||
| Some i ->
|
||||
ret
|
||||
[%expr
|
||||
Sedlexing.mark [%e lexbuf] [%e eint ~loc i];
|
||||
Sedlexing.mark [%e evar ~loc lexbuf] [%e eint ~loc i];
|
||||
[%e body ()]]
|
||||
|
||||
let gen_recflag auto =
|
||||
|
|
@ -248,27 +243,33 @@ 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 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 = Array.mapi (gen_state lexbuf auto) auto in
|
||||
let states = List.flatten (Array.to_list states) in
|
||||
pexp_let ~loc (gen_recflag auto) states
|
||||
(pexp_sequence ~loc
|
||||
[%expr Sedlexing.start [%e lexbuf]]
|
||||
[%expr Sedlexing.start [%e evar ~loc lexbuf]]
|
||||
(pexp_match ~loc
|
||||
(appfun (state_fun 0) [lexbuf])
|
||||
(appfun (state_fun 0) [evar ~loc lexbuf])
|
||||
(cases @ [case ~lhs:(ppat_any ~loc) ~guard:None ~rhs:error])))
|
||||
|
||||
(* Lexer specification parser *)
|
||||
|
|
@ -278,46 +279,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 +297,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 +333,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 +392,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 +424,43 @@ 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 lexbuf } } -> 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 } ->
|
||||
super#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, super#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 +473,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 +498,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 -> []
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,4 +1,598 @@
|
|||
(* 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
|
||||
(* 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);
|
||||
]
|
||||
|
|
|
|||
|
|
@ -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. *)
|
||||
|
||||
(** 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
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
val fold :
|
||||
f:('a -> int -> [> `Malformed of string | `Uchar of Uchar.t ] -> 'a) ->
|
||||
'a ->
|
||||
string ->
|
||||
'a
|
||||
|
|
@ -1,365 +0,0 @@
|
|||
(* 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
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
(* 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
|
||||
Binary file not shown.
1062
test/basic.ml
1062
test/basic.ml
File diff suppressed because it is too large
Load Diff
|
|
@ -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)))
|
||||
|
|
@ -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 -> () | _ -> ())
|
||||
|}]
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
(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)))
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
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 |}]
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
(library
|
||||
(name ppx_sedlex_test)
|
||||
(kind ppx_rewriter)
|
||||
(libraries ppxlib noslop-sedlex.ppx)
|
||||
(preprocess
|
||||
(pps ppxlib.metaquot)))
|
||||
|
|
@ -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]
|
||||
Binary file not shown.
33
test/utf8.ml
33
test/utf8.ml
|
|
@ -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À |}]
|
||||
Loading…
Reference in New Issue