124 lines
3.2 KiB
Factor
124 lines
3.2 KiB
Factor
USING: accessors assocs globs io.pathnames kernel memoize
|
|
namespaces regexp sequences sorting splitting strings
|
|
unicode xml xml.data xml.syntax xml.traversal xmode.loader
|
|
xmode.rules xmode.utilities ;
|
|
IN: xmode.catalog
|
|
|
|
TUPLE: mode file file-name-glob first-line-glob ;
|
|
|
|
TAGS: parse-mode-tag ( modes tag -- )
|
|
|
|
TAG: MODE parse-mode-tag
|
|
dup "NAME" attr [
|
|
mode new {
|
|
{ "FILE" f file<< }
|
|
{ "FILE_NAME_GLOB" f file-name-glob<< }
|
|
{ "FIRST_LINE_GLOB" f first-line-glob<< }
|
|
} init-from-tag
|
|
[ [ >case-fold <glob> ] [ f ] if* ] change-file-name-glob
|
|
[ [ >case-fold <glob> ] [ f ] if* ] change-first-line-glob
|
|
] dip
|
|
rot set-at ;
|
|
|
|
: parse-modes-tag ( tag -- modes )
|
|
H{ } clone [
|
|
swap children-tags [ parse-mode-tag ] with each
|
|
] keep ;
|
|
|
|
MEMO: modes ( -- modes )
|
|
"vocab:xmode/modes/catalog"
|
|
file>xml parse-modes-tag ;
|
|
|
|
MEMO: mode-names ( -- modes )
|
|
modes keys natural-sort ;
|
|
|
|
: reset-catalog ( -- )
|
|
\ modes reset-memoized ;
|
|
|
|
MEMO: (load-mode) ( name -- rule-sets )
|
|
modes at [
|
|
file>>
|
|
"vocab:xmode/modes/" prepend parse-mode
|
|
] [
|
|
"text" (load-mode)
|
|
] if* ;
|
|
|
|
SYMBOL: rule-sets
|
|
|
|
: no-such-rule-set ( name -- * )
|
|
"No such rule set: " prepend throw ;
|
|
|
|
: get-rule-set ( name -- rule-sets rules )
|
|
dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if*
|
|
[ at* [ nip ] [ drop no-such-rule-set ] if ] keep swap ;
|
|
|
|
DEFER: finalize-rule-set
|
|
|
|
: resolve-delegate ( rule -- )
|
|
dup delegate>> dup string? [
|
|
get-rule-set
|
|
dup rule-set? [ "not a rule set" throw ] unless
|
|
swap rule-sets [ dup finalize-rule-set ] with-variable
|
|
>>delegate drop
|
|
] [ 2drop ] if ;
|
|
|
|
: each-rule ( rule-set quot -- )
|
|
[ rules>> values concat ] dip each ; inline
|
|
|
|
: resolve-delegates ( ruleset -- )
|
|
[ resolve-delegate ] each-rule ;
|
|
|
|
: ?update ( keyword-map/f keyword-map -- keyword-map )
|
|
over [ assoc-union! ] [ nip clone ] if ;
|
|
|
|
: import-keywords ( parent child -- )
|
|
over [ [ keywords>> ] bi@ ?update ] dip keywords<< ;
|
|
|
|
: import-rules ( parent child -- )
|
|
swap [ add-rule ] curry each-rule ;
|
|
|
|
: resolve-imports ( ruleset -- )
|
|
dup imports>> [
|
|
get-rule-set swap rule-sets [
|
|
[ nip resolve-delegates ]
|
|
[ import-keywords ]
|
|
[ import-rules ]
|
|
2tri
|
|
] with-variable
|
|
] with each ;
|
|
|
|
: finalize-rule-set ( ruleset -- )
|
|
dup finalized?>> [ drop ] [
|
|
t >>finalized?
|
|
[ resolve-imports ]
|
|
[ resolve-delegates ]
|
|
bi
|
|
] if ;
|
|
|
|
: finalize-mode ( rulesets -- )
|
|
dup rule-sets [
|
|
[ nip finalize-rule-set ] assoc-each
|
|
] with-variable ;
|
|
|
|
: load-mode ( name -- rule-sets )
|
|
(load-mode) dup finalize-mode ;
|
|
|
|
: reset-modes ( -- )
|
|
\ (load-mode) reset-memoized ;
|
|
|
|
: ?matches ( string glob/f -- ? )
|
|
[ >case-fold ] dip dup [ matches? ] [ 2drop f ] if ;
|
|
|
|
: suitable-mode? ( file-name first-line mode -- ? )
|
|
[ nip ] 2keep first-line-glob>> ?matches
|
|
[ 2drop t ] [ file-name-glob>> ?matches ] if ;
|
|
|
|
: ?find-mode ( file-name first-line -- mode/f )
|
|
[ file-name ] dip
|
|
modes
|
|
[ nip [ 2dup ] dip suitable-mode? ] assoc-find
|
|
2drop [ 2drop ] dip ;
|
|
|
|
: find-mode ( file-name first-line -- mode )
|
|
?find-mode "text" or ; inline
|