USING: accessors arrays assocs grouping kernel locals math namespaces
sequences fry quotations math.order math.ranges vectors
unicode.categories regexp.transition-tables words sets hashtables
-combinators.short-circuit unicode.case unicode.case.private regexp.ast
+combinators.short-circuit unicode.data regexp.ast
regexp.classes memoize ;
IN: regexp.nfa
-! This uses unicode.case.private for ch>upper and ch>lower
+! This uses unicode.data for ch>upper and ch>lower
! but case-insensitive matching should be done by case-folding everything
! before processing starts
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit unicode.categories kernel math
combinators splitting sequences math.parser io.files io assocs
-arrays namespaces make math.ranges unicode.normalize.private values
-io.encodings.ascii unicode.syntax unicode.data compiler.units fry
+arrays namespaces make math.ranges unicode.normalize
+unicode.normalize.private values io.encodings.ascii
+unicode.syntax unicode.data compiler.units fry
alien.syntax sets accessors interval-maps memoize locals words ;
IN: unicode.breaks
VALUE: word-break-table
-"vocab:unicode/data/WordBreakProperty.txt" load-script
+"vocab:unicode/data/WordBreakProperty.txt" load-key-value
to: word-break-table
C-ENUM: wOther wCR wLF wNewline wExtend wFormat wKatakana wALetter wMidLetter
! Copyright (C) 2008, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: unicode.case unicode.case.private tools.test namespaces strings unicode.normalize ;
+USING: unicode.case tools.test namespaces strings unicode.normalize
+unicode.case.private ;
IN: unicode.case.tests
\ >upper must-infer
QUALIFIED: ascii
IN: unicode.case
-<PRIVATE
-: ch>lower ( ch -- lower ) simple-lower at-default ; inline
-: ch>upper ( ch -- upper ) simple-upper at-default ; inline
-: ch>title ( ch -- title ) simple-title at-default ; inline
-PRIVATE>
-
SYMBOL: locale ! Just casing locale, or overall?
<PRIVATE
:: map-case ( string string-quot char-quot -- case )
string length <sbuf> :> out
string [
- dup special-casing at
+ dup special-case
[ string-quot call out push-all ]
[ char-quot call out push ] ?if
] each out "" like ; inline
{ $subsection non-starter? }
{ $subsection name>char }
{ $subsection char>name }
-{ $subsection property? } ;
+{ $subsection property? }
+{ $subsection load-key-value } ;
HELP: canonical-entry
{ $values { "char" "a code point" } { "seq" string } }
HELP: property?
{ $values { "char" "a code point" } { "property" string } { "?" "a boolean" } }
{ $description "Tests whether the code point is listed under the given property in PropList.txt in the Unicode Character Database." } ;
+
+HELP: load-key-value
+{ $values { "filename" string } { "table" "an interval map" } }
+{ $description "This loads a file that looks like Script.txt in the Unicode Character Database and converts it into an efficient interval map, where the keys are characters and the values are strings for the properties." } ;
strings.parser io.encodings.utf8 memoize ;
IN: unicode.data
+<PRIVATE
+
VALUE: simple-lower
VALUE: simple-upper
VALUE: simple-title
VALUE: special-casing
VALUE: properties
-: canonical-entry ( char -- seq ) canonical-map at ;
-: combine-chars ( a b -- char/f ) combine-map hash2 ;
-: compatibility-entry ( char -- seq ) compatibility-map at ;
-: combining-class ( char -- n ) class-map at ;
-: non-starter? ( char -- ? ) combining-class { 0 f } member? not ;
-: name>char ( name -- char ) name-map at ;
-: char>name ( char -- name ) name-map value-at ;
-: property? ( char property -- ? ) properties at interval-key? ;
+PRIVATE>
+
+: canonical-entry ( char -- seq ) canonical-map at ; inline
+: combine-chars ( a b -- char/f ) combine-map hash2 ; inline
+: compatibility-entry ( char -- seq ) compatibility-map at ; inline
+: combining-class ( char -- n ) class-map at ; inline
+: non-starter? ( char -- ? ) combining-class { 0 f } member? not ; inline
+: name>char ( name -- char ) name-map at ; inline
+: char>name ( char -- name ) name-map value-at ; inline
+: property? ( char property -- ? ) properties at interval-key? ; inline
+: ch>lower ( ch -- lower ) simple-lower at-default ; inline
+: ch>upper ( ch -- upper ) simple-upper at-default ; inline
+: ch>title ( ch -- title ) simple-title at-default ; inline
+: special-case ( ch -- casing-tuple ) special-casing at ; inline
! For non-existent characters, use Cn
CONSTANT: categories
"Zs" "Zl" "Zp"
"Cc" "Cf" "Cs" "Co" }
+<PRIVATE
+
MEMO: categories-map ( -- hashtable )
categories <enum> [ swap ] H{ } assoc-map-as ;
CONSTANT: num-chars HEX: 2FA1E
+PRIVATE>
+
: category# ( char -- category )
! There are a few characters that should be Cn
! that this gives Cf or Mn
: category ( char -- category )
category# categories nth ;
+<PRIVATE
+
! Loading data from UnicodeData.txt
: split-; ( line -- array )
: multihex ( hexstring -- string )
" " split [ hex> ] map sift ;
+PRIVATE>
+
TUPLE: code-point lower title upper ;
C: <code-point> code-point
+<PRIVATE
+
: set-code-point ( seq -- )
4 head [ multihex ] map first4
<code-point> swap first set ;
[ name>char [ "Invalid character" throw ] unless* ]
name>char-hook set-global
+
+SYMBOL: interned
+
+: parse-key-value ( filename -- assoc )
+ ! assoc is code point/range => name
+ ascii file-lines filter-comments [ split-; ] map ;
+
+: range, ( value key -- )
+ swap interned get
+ [ = ] with find nip 2array , ;
+
+: expand-ranges ( assoc -- interval-map )
+ [
+ [
+ swap CHAR: . over member? [
+ ".." split1 [ hex> ] bi@ 2array
+ ] [ hex> ] if range,
+ ] assoc-each
+ ] { } make <interval-map> ;
+
+: process-key-value ( ranges -- table )
+ dup values prune interned
+ [ expand-ranges ] with-variable ;
+
+PRIVATE>
+
+: load-key-value ( filename -- table )
+ parse-key-value process-key-value ;
<PRIVATE
-SYMBOL: interned
-
-: parse-script ( filename -- assoc )
- ! assoc is code point/range => name
- ascii file-lines filter-comments [ split-; ] map ;
-
-: range, ( value key -- )
- swap interned get
- [ = ] with find nip 2array , ;
-
-: expand-ranges ( assoc -- interval-map )
- [
- [
- swap CHAR: . over member? [
- ".." split1 [ hex> ] bi@ 2array
- ] [ hex> ] if range,
- ] assoc-each
- ] { } make <interval-map> ;
-
-: process-script ( ranges -- table )
- dup values prune interned
- [ expand-ranges ] with-variable ;
-
-: load-script ( filename -- table )
- parse-script process-script ;
-
VALUE: script-table
-"vocab:unicode/script/Scripts.txt" load-script
+"vocab:unicode/script/Scripts.txt" load-key-value
to: script-table
PRIVATE>
projects / factor.git / commitdiff