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 xml.data ;
   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     dup "NAME" attr [
  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
  17     ] dip
  18     rot set-at ;
  19
  20 TAGS>
  21
  22 : parse-modes-tag ( tag -- modes )
  23     H{ } clone [
  24         swap child-tags [ parse-mode-tag ] with each
  25     ] keep ;
  26
  27 MEMO: modes ( -- modes )
  28     "vocab:xmode/modes/catalog"
  29     file>xml parse-modes-tag ;
  30
  31 MEMO: mode-names ( -- modes )
  32     modes keys natural-sort ;
  33
  34 : reset-catalog ( -- )
  35     \ modes reset-memoized ;
  36
  37 MEMO: (load-mode) ( name -- rule-sets )
  38     modes at [
  39         file>>
  40         "vocab:xmode/modes/" prepend 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 DEFER: finalize-rule-set
  55
  56 : resolve-delegate ( rule -- )
  57     dup delegate>> dup string? [
  58         get-rule-set
  59         dup rule-set? [ "not a rule set" throw ] unless
  60         swap rule-sets [ dup finalize-rule-set ] with-variable
  61         >>delegate drop
  62     ] [ 2drop ] if ;
  63
  64 : each-rule ( rule-set quot -- )
  65     [ rules>> values concat ] dip each ; inline
  66
  67 : resolve-delegates ( ruleset -- )
  68     [ resolve-delegate ] each-rule ;
  69
  70 : ?update ( keyword-map/f keyword-map -- keyword-map )
  71     over [ dupd update ] [ nip clone ] if ;
  72
  73 : import-keywords ( parent child -- )
  74     over [ [ keywords>> ] bi@ ?update ] dip (>>keywords) ;
  75
  76 : import-rules ( parent child -- )
  77     swap [ add-rule ] curry each-rule ;
  78
  79 : resolve-imports ( ruleset -- )
  80     dup imports>> [
  81         get-rule-set swap rule-sets [
  82             [ nip resolve-delegates ]
  83             [ import-keywords ]
  84             [ import-rules ]
  85             2tri
  86         ] with-variable
  87     ] with each ;
  88
  89 ERROR: mutually-recursive-rulesets ruleset ;
  90
  91 : finalize-rule-set ( ruleset -- )
  92     dup finalized?>> [ drop ] [
  93         t >>finalized?
  94         [ resolve-imports ]
  95         [ resolve-delegates ]
  96         bi
  97     ] if ;
  98
  99 : finalize-mode ( rulesets -- )
 100     rule-sets [
 101         dup [ nip finalize-rule-set ] assoc-each
 102     ] with-variable ;
 103
 104 : load-mode ( name -- rule-sets )
 105     (load-mode) dup finalize-mode ;
 106
 107 : reset-modes ( -- )
 108     \ (load-mode) reset-memoized ;
 109
 110 : ?glob-matches ( string glob/f -- ? )
 111     dup [ glob-matches? ] [ 2drop f ] if ;
 112
 113 : suitable-mode? ( file-name first-line mode -- ? )
 114     tuck first-line-glob>> ?glob-matches
 115     [ 2drop t ] [ file-name-glob>> ?glob-matches ] if ;
 116
 117 : find-mode ( file-name first-line -- mode )
 118     modes
 119     [ nip [ 2dup ] dip suitable-mode? ] assoc-find
 120     2drop [ 2drop ] dip [ "text" ] unless* ;