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 xml.traversal xml.syntax ;
7 TUPLE: mode file file-name-glob first-line-glob ;
9 TAGS: parse-mode-tag ( modes tag -- )
11 TAG: MODE parse-mode-tag
15 { "FILE_NAME_GLOB" f (>>file-name-glob) }
16 { "FIRST_LINE_GLOB" f (>>first-line-glob) }
21 : parse-modes-tag ( tag -- modes )
23 swap children-tags [ parse-mode-tag ] with each
26 MEMO: modes ( -- modes )
27 "resource:basis/xmode/modes/catalog"
28 file>xml parse-modes-tag ;
30 MEMO: mode-names ( -- modes )
31 modes keys natural-sort ;
33 : reset-catalog ( -- )
34 \ modes reset-memoized ;
36 MEMO: (load-mode) ( name -- rule-sets )
39 "resource:basis/xmode/modes/" prepend
40 utf8 <file-reader> parse-mode
47 : no-such-rule-set ( name -- * )
48 "No such rule set: " prepend throw ;
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 ;
54 DEFER: finalize-rule-set
56 : resolve-delegate ( rule -- )
57 dup delegate>> dup string? [
59 dup rule-set? [ "not a rule set" throw ] unless
60 swap rule-sets [ dup finalize-rule-set ] with-variable
64 : each-rule ( rule-set quot -- )
65 [ rules>> values concat ] dip each ; inline
67 : resolve-delegates ( ruleset -- )
68 [ resolve-delegate ] each-rule ;
70 : ?update ( keyword-map/f keyword-map -- keyword-map )
71 over [ dupd update ] [ nip clone ] if ;
73 : import-keywords ( parent child -- )
74 over [ [ keywords>> ] bi@ ?update ] dip (>>keywords) ;
76 : import-rules ( parent child -- )
77 swap [ add-rule ] curry each-rule ;
79 : resolve-imports ( ruleset -- )
81 get-rule-set swap rule-sets [
82 [ nip resolve-delegates ]
89 ERROR: mutually-recursive-rulesets ruleset ;
91 : finalize-rule-set ( ruleset -- )
92 dup finalized?>> [ drop ] [
99 : finalize-mode ( rulesets -- )
101 [ nip finalize-rule-set ] assoc-each
104 : load-mode ( name -- rule-sets )
105 (load-mode) dup finalize-mode ;
108 \ (load-mode) reset-memoized ;
110 : ?glob-matches ( string glob/f -- ? )
111 dup [ glob-matches? ] [ 2drop f ] if ;
113 : suitable-mode? ( file-name first-line mode -- ? )
114 tuck first-line-glob>> ?glob-matches
115 [ 2drop t ] [ file-name-glob>> ?glob-matches ] if ;
117 : find-mode ( file-name first-line -- mode )
119 [ nip [ 2dup ] dip suitable-mode? ] assoc-find
120 2drop [ 2drop ] dip [ "text" ] unless* ;