basis/unicode/syntax/syntax.factor

   1 USING: unicode.data kernel math sequences parser lexer
   2 bit-arrays namespaces make sequences.private arrays quotations
   3 assocs classes.predicate math.order eval ;
   4 IN: unicode.syntax
   5
   6 ! Character classes (categories)
   7
   8 : category# ( char -- category )
   9     ! There are a few characters that should be Cn
  10     ! that this gives Cf or Mn
  11     ! Cf = 26; Mn = 5; Cn = 29
  12     ! Use a compressed array instead?
  13     dup category-map ?nth [ ] [
  14         dup HEX: E0001 HEX: E007F between?
  15         [ drop 26 ] [
  16             HEX: E0100 HEX: E01EF between?  5 29 ?
  17         ] if
  18     ] ?if ;
  19
  20 : category ( char -- category )
  21     category# categories nth ;
  22
  23 : >category-array ( categories -- bitarray )
  24     categories [ swap member? ] with map >bit-array ;
  25
  26 : as-string ( strings -- bit-array )
  27     concat "\"" tuck 3append eval ;
  28
  29 : [category] ( categories -- quot )
  30     [
  31         [ [ categories member? not ] filter as-string ] keep
  32         [ categories member? ] filter >category-array
  33         [ dup category# ] % , [ nth-unsafe [ drop t ] ] %
  34         \ member? 2array >quotation ,
  35         \ if ,
  36     ] [ ] make ;
  37
  38 : define-category ( word categories -- )
  39     [category] integer swap define-predicate-class ;
  40
  41 : CATEGORY:
  42     CREATE ";" parse-tokens define-category ; parsing
  43
  44 : seq-minus ( seq1 seq2 -- diff )
  45     [ member? not ] curry filter ;
  46
  47 : CATEGORY-NOT:
  48     CREATE ";" parse-tokens
  49     categories swap seq-minus define-category ; parsing