basis/xmode/catalog/catalog.factor

   1 USING: accessors assocs globs io.pathnames kernel memoize
   2 namespaces regexp sequences sorting splitting strings
   3 unicode.case xml xml.data xml.syntax xml.traversal xmode.loader
   4 xmode.rules xmode.utilities ;
   5 IN: xmode.catalog
   6
   7 TUPLE: mode file file-name-glob first-line-glob ;
   8
   9 TAGS: parse-mode-tag ( modes tag -- )
  10
  11 TAG: MODE parse-mode-tag
  12     dup "NAME" attr [
  13         mode new {
  14             { "FILE" f file<< }
  15             { "FILE_NAME_GLOB" f file-name-glob<< }
  16             { "FIRST_LINE_GLOB" f first-line-glob<< }
  17         } init-from-tag
  18         [ [ >case-fold <glob> ] [ f ] if* ] change-file-name-glob
  19         [ [ >case-fold <glob> ] [ f ] if* ] change-first-line-glob
  20     ] dip
  21     rot set-at ;
  22
  23 : parse-modes-tag ( tag -- modes )
  24     H{ } clone [
  25         swap children-tags [ parse-mode-tag ] with each
  26     ] keep ;
  27
  28 MEMO: modes ( -- modes )
  29     "vocab:xmode/modes/catalog"
  30     file>xml parse-modes-tag ;
  31
  32 MEMO: mode-names ( -- modes )
  33     modes keys natural-sort ;
  34
  35 : reset-catalog ( -- )
  36     \ modes reset-memoized ;
  37
  38 MEMO: (load-mode) ( name -- rule-sets )
  39     modes at [
  40         file>>
  41         "vocab:xmode/modes/" prepend parse-mode
  42     ] [
  43         "text" (load-mode)
  44     ] if* ;
  45
  46 SYMBOL: rule-sets
  47
  48 : no-such-rule-set ( name -- * )
  49     "No such rule set: " prepend throw ;
  50
  51 : get-rule-set ( name -- rule-sets rules )
  52     dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if*
  53     [ at* [ nip ] [ drop no-such-rule-set ] if ] keep swap ;
  54
  55 DEFER: finalize-rule-set
  56
  57 : resolve-delegate ( rule -- )
  58     dup delegate>> dup string? [
  59         get-rule-set
  60         dup rule-set? [ "not a rule set" throw ] unless
  61         swap rule-sets [ dup finalize-rule-set ] with-variable
  62         >>delegate drop
  63     ] [ 2drop ] if ;
  64
  65 : each-rule ( rule-set quot -- )
  66     [ rules>> values concat ] dip each ; inline
  67
  68 : resolve-delegates ( ruleset -- )
  69     [ resolve-delegate ] each-rule ;
  70
  71 : ?update ( keyword-map/f keyword-map -- keyword-map )
  72     over [ assoc-union! ] [ nip clone ] if ;
  73
  74 : import-keywords ( parent child -- )
  75     over [ [ keywords>> ] bi@ ?update ] dip keywords<< ;
  76
  77 : import-rules ( parent child -- )
  78     swap [ add-rule ] curry each-rule ;
  79
  80 : resolve-imports ( ruleset -- )
  81     dup imports>> [
  82         get-rule-set swap rule-sets [
  83             [ nip resolve-delegates ]
  84             [ import-keywords ]
  85             [ import-rules ]
  86             2tri
  87         ] with-variable
  88     ] with each ;
  89
  90 ERROR: mutually-recursive-rulesets ruleset ;
  91
  92 : finalize-rule-set ( ruleset -- )
  93     dup finalized?>> [ drop ] [
  94         t >>finalized?
  95         [ resolve-imports ]
  96         [ resolve-delegates ]
  97         bi
  98     ] if ;
  99
 100 : finalize-mode ( rulesets -- )
 101     dup rule-sets [
 102         [ nip finalize-rule-set ] assoc-each
 103     ] with-variable ;
 104
 105 : load-mode ( name -- rule-sets )
 106     (load-mode) dup finalize-mode ;
 107
 108 : reset-modes ( -- )
 109     \ (load-mode) reset-memoized ;
 110
 111 : ?matches ( string glob/f -- ? )
 112     [ >case-fold ] dip dup [ matches? ] [ 2drop f ] if ;
 113
 114 : suitable-mode? ( file-name first-line mode -- ? )
 115     [ nip ] 2keep first-line-glob>> ?matches
 116     [ 2drop t ] [ file-name-glob>> ?matches ] if ;
 117
 118 : ?find-mode ( file-name first-line -- mode/f )
 119     [ file-name ] dip
 120     modes
 121     [ nip [ 2dup ] dip suitable-mode? ] assoc-find
 122     2drop [ 2drop ] dip ;
 123
 124 : find-mode ( file-name first-line -- mode )
 125     ?find-mode "text" or ; inline