basis/xmode/catalog/catalog.factor

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