steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

partial update of xmode for new accessors

db4
Doug Coleman 2008-08-30 20:32:26 -05:00
parent 916d0b4271
commit 4a887d355f
6 changed files with 77 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
extra/xmode/catalog/catalog.factor
View File

@ -1,6 +1,6 @@
USING: xmode.loader xmode.utilities xmode.rules namespaces USING: xmode.loader xmode.utilities xmode.rules namespaces
strings splitting assocs sequences kernel io.files xml memoize strings splitting assocs sequences kernel io.files xml memoize
words globs combinators io.encodings.utf8 sorting ; words globs combinators io.encodings.utf8 sorting accessors ;
IN: xmode.catalog IN: xmode.catalog
TUPLE: mode file file-name-glob first-line-glob ; TUPLE: mode file file-name-glob first-line-glob ;
@ -10,9 +10,9 @@ TUPLE: mode file file-name-glob first-line-glob ;
TAG: MODE TAG: MODE
"NAME" over at >r "NAME" over at >r
mode new { mode new {
{ "FILE" f set-mode-file } { "FILE" f (>>file) }
{ "FILE_NAME_GLOB" f set-mode-file-name-glob } { "FILE_NAME_GLOB" f (>>file-name-glob) }
{ "FIRST_LINE_GLOB" f set-mode-first-line-glob } { "FIRST_LINE_GLOB" f (>>first-line-glob) }
} init-from-tag r> } init-from-tag r>
rot set-at ; rot set-at ;
@ -35,7 +35,7 @@ MEMO: mode-names ( -- modes )
MEMO: (load-mode) ( name -- rule-sets ) MEMO: (load-mode) ( name -- rule-sets )
modes at [ modes at [
mode-file file>>
"resource:extra/xmode/modes/" prepend "resource:extra/xmode/modes/" prepend
utf8 <file-reader> parse-mode utf8 <file-reader> parse-mode
] [ ] [
@ -72,7 +72,7 @@ SYMBOL: rule-sets
swap [ add-rule ] curry each-rule ; swap [ add-rule ] curry each-rule ;
: resolve-imports ( ruleset -- ) : resolve-imports ( ruleset -- )
dup rule-set-imports [ dup imports>> [
get-rule-set swap rule-sets [ get-rule-set swap rule-sets [
dup resolve-delegates dup resolve-delegates
2dup import-keywords 2dup import-keywords
@ -80,16 +80,17 @@ SYMBOL: rule-sets
] with-variable ] with-variable
] with each ; ] with each ;
ERROR: mutually-recursive-rulesets ruleset ;
: finalize-rule-set ( ruleset -- ) : finalize-rule-set ( ruleset -- )
dup rule-set-finalized? { dup finalized?>> {
{ f [ { f [
1 over set-rule-set-finalized? 1 >>finalized?
dup resolve-imports [ resolve-imports ]
dup resolve-delegates [ resolve-delegates ] bi
t swap set-rule-set-finalized? t >>finalized? drop
] } ] }
{ t [ drop ] } { t [ drop ] }
{ 1 [ "Mutually recursive rule sets" throw ] } { 1 [ mutually-recursive-rulesets ] }
} case ; } case ;
: finalize-mode ( rulesets -- ) : finalize-mode ( rulesets -- )
@ -107,8 +108,8 @@ SYMBOL: rule-sets
dup [ glob-matches? ] [ 2drop f ] if ; dup [ glob-matches? ] [ 2drop f ] if ;
: suitable-mode? ( file-name first-line mode -- ? ) : suitable-mode? ( file-name first-line mode -- ? )
tuck mode-first-line-glob ?glob-matches tuck first-line-glob>> ?glob-matches
[ 2drop t ] [ mode-file-name-glob ?glob-matches ] if ; [ 2drop t ] [ file-name-glob>> ?glob-matches ] if ;
: find-mode ( file-name first-line -- mode ) : find-mode ( file-name first-line -- mode )
modes modes

20
extra/xmode/loader/loader.factor
View File

@ -1,7 +1,7 @@
USING: xmode.loader.syntax xmode.tokens xmode.rules USING: xmode.loader.syntax xmode.tokens xmode.rules
xmode.keyword-map xml.data xml.utilities xml assocs kernel xmode.keyword-map xml.data xml.utilities xml assocs kernel
combinators sequences math.parser namespaces parser combinators sequences math.parser namespaces parser
xmode.utilities regexp io.files ; xmode.utilities regexp io.files accessors ;
IN: xmode.loader IN: xmode.loader
! Based on org.gjt.sp.jedit.XModeHandler ! Based on org.gjt.sp.jedit.XModeHandler
@ -10,13 +10,13 @@ IN: xmode.loader
<TAGS: parse-rule-tag ( rule-set tag -- ) <TAGS: parse-rule-tag ( rule-set tag -- )
TAG: PROPS TAG: PROPS
parse-props-tag swap set-rule-set-props ; parse-props-tag >>props drop ;
TAG: IMPORT TAG: IMPORT
"DELEGATE" swap at swap import-rule-set ; "DELEGATE" swap at swap import-rule-set ;
TAG: TERMINATE TAG: TERMINATE
"AT_CHAR" swap at string>number swap set-rule-set-terminate-char ; "AT_CHAR" swap at string>number >>terminate-char drop ;
RULE: SEQ seq-rule RULE: SEQ seq-rule
shared-tag-attrs delegate-attr literal-start ; shared-tag-attrs delegate-attr literal-start ;
@ -55,18 +55,18 @@ TAGS>
: (parse-rules-tag) ( tag -- rule-set ) : (parse-rules-tag) ( tag -- rule-set )
<rule-set> <rule-set>
{ {
{ "SET" string>rule-set-name set-rule-set-name } { "SET" string>rule-set-name (>>name) }
{ "IGNORE_CASE" string>boolean set-rule-set-ignore-case? } { "IGNORE_CASE" string>boolean (>>ignore-case?) }
{ "HIGHLIGHT_DIGITS" string>boolean set-rule-set-highlight-digits? } { "HIGHLIGHT_DIGITS" string>boolean (>>highlight-digits?) }
{ "DIGIT_RE" ?<regexp> set-rule-set-digit-re } { "DIGIT_RE" ?<regexp> (>>digit-re) }
{ "ESCAPE" f add-escape-rule } { "ESCAPE" f add-escape-rule }
{ "DEFAULT" string>token set-rule-set-default } { "DEFAULT" string>token (>>default) }
{ "NO_WORD_SEP" f set-rule-set-no-word-sep } { "NO_WORD_SEP" f (>>no-word-sep) }
} init-from-tag ; } init-from-tag ;
: parse-rules-tag ( tag -- rule-set ) : parse-rules-tag ( tag -- rule-set )
dup (parse-rules-tag) [ dup (parse-rules-tag) [
dup rule-set-ignore-case? ignore-case? [ dup ignore-case?>> ignore-case? [
swap child-tags [ parse-rule-tag ] with each swap child-tags [ parse-rule-tag ] with each
] with-variable ] with-variable
] keep ; ] keep ;

69
extra/xmode/marker/marker.factor
View File

@ -3,7 +3,7 @@ USING: kernel namespaces xmode.rules xmode.tokens
xmode.marker.state xmode.marker.context xmode.utilities xmode.marker.state xmode.marker.context xmode.utilities
xmode.catalog sequences math assocs combinators combinators.lib xmode.catalog sequences math assocs combinators combinators.lib
strings regexp splitting parser-combinators ascii unicode.case strings regexp splitting parser-combinators ascii unicode.case
combinators.short-circuit ; combinators.short-circuit accessors ;
! Based on org.gjt.sp.jedit.syntax.TokenMarker ! Based on org.gjt.sp.jedit.syntax.TokenMarker
@ -12,11 +12,11 @@ combinators.short-circuit ;
: keyword-number? ( keyword -- ? ) : keyword-number? ( keyword -- ? )
{ {
[ current-rule-set rule-set-highlight-digits? ] [ current-rule-set highlight-digits?>> ]
[ dup [ digit? ] contains? ] [ dup [ digit? ] contains? ]
[ [
dup [ digit? ] all? [ dup [ digit? ] all? [
current-rule-set rule-set-digit-re current-rule-set digit-re>>
dup [ dupd matches? ] [ drop f ] if dup [ dupd matches? ] [ drop f ] if
] unless* ] unless*
] ]
@ -26,10 +26,10 @@ combinators.short-circuit ;
keyword-number? DIGIT and ; keyword-number? DIGIT and ;
: mark-keyword ( keyword -- id ) : mark-keyword ( keyword -- id )
current-rule-set rule-set-keywords at ; current-rule-set keywords>> at ;
: add-remaining-token ( -- ) : add-remaining-token ( -- )
current-rule-set rule-set-default prev-token, ; current-rule-set default>> prev-token, ;
: mark-token ( -- ) : mark-token ( -- )
current-keyword current-keyword
@ -48,9 +48,9 @@ M: rule match-position drop position get ;
: can-match-here? ( matcher rule -- ? ) : can-match-here? ( matcher rule -- ? )
match-position { match-position {
[ over ] [ over ]
[ over matcher-at-line-start? over zero? implies ] [ over at-line-start?>> over zero? implies ]
[ over matcher-at-whitespace-end? over whitespace-end get = implies ] [ over at-whitespace-end?>> over whitespace-end get = implies ]
[ over matcher-at-word-start? over last-offset get = implies ] [ over at-word-start?>> over last-offset get = implies ]
} 0&& 2nip ; } 0&& 2nip ;
: rest-of-line ( -- str ) : rest-of-line ( -- str )
@ -73,18 +73,18 @@ M: regexp text-matches?
: rule-start-matches? ( rule -- match-count/f ) : rule-start-matches? ( rule -- match-count/f )
dup rule-start tuck swap can-match-here? [ dup rule-start tuck swap can-match-here? [
rest-of-line swap matcher-text text-matches? rest-of-line swap text>> text-matches?
] [ ] [
drop f drop f
] if ; ] if ;
: rule-end-matches? ( rule -- match-count/f ) : rule-end-matches? ( rule -- match-count/f )
dup mark-following-rule? [ dup mark-following-rule? [
dup rule-start swap can-match-here? 0 and dup start>> swap can-match-here? 0 and
] [ ] [
dup rule-end tuck swap can-match-here? [ dup end>> tuck swap can-match-here? [
rest-of-line rest-of-line
swap matcher-text context get line-context-end or swap text>> context get end>> or
text-matches? text-matches?
] [ ] [
drop f drop f
@ -94,10 +94,10 @@ M: regexp text-matches?
DEFER: get-rules DEFER: get-rules
: get-always-rules ( vector/f ruleset -- vector/f ) : get-always-rules ( vector/f ruleset -- vector/f )
f swap rule-set-rules at ?push-all ; f swap rules>> at ?push-all ;
: get-char-rules ( vector/f char ruleset -- vector/f ) : get-char-rules ( vector/f char ruleset -- vector/f )
>r ch>upper r> rule-set-rules at ?push-all ; >r ch>upper r> rules>> at ?push-all ;
: get-rules ( char ruleset -- seq ) : get-rules ( char ruleset -- seq )
f -rot [ get-char-rules ] keep get-always-rules ; f -rot [ get-char-rules ] keep get-always-rules ;
@ -108,9 +108,9 @@ GENERIC: handle-rule-end ( match-count rule -- )
: find-escape-rule ( -- rule ) : find-escape-rule ( -- rule )
context get dup context get dup
line-context-in-rule-set rule-set-escape-rule [ ] [ in-rule-set>> escape-rule>> [ ] [
line-context-parent line-context-in-rule-set parent>> in-rule-set>>
dup [ rule-set-escape-rule ] when dup [ escape-rule>> ] when
] ?if ; ] ?if ;
: check-escape-rule ( rule -- ? ) : check-escape-rule ( rule -- ? )
@ -138,9 +138,9 @@ GENERIC: handle-rule-end ( match-count rule -- )
] when* ; ] when* ;
: rule-match-token* ( rule -- id ) : rule-match-token* ( rule -- id )
dup rule-match-token { dup match-token>> {
{ f [ dup rule-body-token ] } { f [ dup rule-body-token ] }
{ t [ current-rule-set rule-set-default ] } { t [ current-rule-set default>> ] }
[ ] [ ]
} case nip ; } case nip ;
@ -156,8 +156,8 @@ M: seq-rule handle-rule-start
?end-rule ?end-rule
mark-token mark-token
add-remaining-token add-remaining-token
tuck rule-body-token next-token, tuck body-token>> next-token,
rule-delegate [ push-context ] when* ; delegate>> [ push-context ] when* ;
UNION: abstract-span-rule span-rule eol-span-rule ; UNION: abstract-span-rule span-rule eol-span-rule ;
@ -167,8 +167,8 @@ M: abstract-span-rule handle-rule-start
add-remaining-token add-remaining-token
tuck rule-match-token* next-token, tuck rule-match-token* next-token,
! ... end subst ... ! ... end subst ...
dup context get set-line-context-in-rule dup context get (>>in-rule)
rule-delegate push-context ; delegate>> push-context ;
M: span-rule handle-rule-end M: span-rule handle-rule-end
2drop ; 2drop ;
@ -197,15 +197,16 @@ M: mark-previous-rule handle-rule-start
] when ; ] when ;
: check-end-delegate ( -- ? ) : check-end-delegate ( -- ? )
context get line-context-parent [ context get parent>> [
line-context-in-rule [ in-rule>> [
dup rule-end-matches? dup [ dup rule-end-matches? dup [
[ [
swap handle-rule-end swap handle-rule-end
?end-rule ?end-rule
mark-token mark-token
add-remaining-token add-remaining-token
] keep context get line-context-parent line-context-in-rule rule-match-token* next-token, ] keep context get parent>> in-rule>>
rule-match-token* next-token,
pop-context pop-context
seen-whitespace-end? on t seen-whitespace-end? on t
] [ drop check-escape-rule ] if ] [ drop check-escape-rule ] if
@ -213,8 +214,8 @@ M: mark-previous-rule handle-rule-start
] [ f ] if* ; ] [ f ] if* ;
: handle-no-word-break ( -- ) : handle-no-word-break ( -- )
context get line-context-parent [ context get parent>> [
line-context-in-rule [ in-rule>> [
dup rule-no-word-break? [ dup rule-no-word-break? [
rule-match-token* prev-token, rule-match-token* prev-token,
pop-context pop-context
@ -231,11 +232,11 @@ M: mark-previous-rule handle-rule-start
: (check-word-break) ( -- ) : (check-word-break) ( -- )
check-rule check-rule
1 current-rule-set rule-set-default next-token, ; 1 current-rule-set default>> next-token, ;
: rule-set-empty? ( ruleset -- ? ) : rule-set-empty? ( ruleset -- ? )
dup rule-set-rules assoc-empty? [ rules>> ] [ keywords>> ] bi
swap rule-set-keywords assoc-empty? and ; [ assoc-empty? ] bi@ and ;
: check-word-break ( -- ? ) : check-word-break ( -- ? )
current-char dup blank? [ current-char dup blank? [
@ -285,9 +286,9 @@ M: mark-previous-rule handle-rule-start
check-rule ; check-rule ;
: unwind-no-line-break ( -- ) : unwind-no-line-break ( -- )
context get line-context-parent [ context get parent>> [
line-context-in-rule [ in-rule>> [
rule-no-line-break? [ no-line-break?>> [
pop-context pop-context
unwind-no-line-break unwind-no-line-break
] when ] when

11
extra/xmode/marker/state/state.factor
View File

@ -1,4 +1,4 @@
USING: xmode.marker.context xmode.rules symbols USING: xmode.marker.context xmode.rules symbols accessors
xmode.tokens namespaces kernel sequences assocs math ; xmode.tokens namespaces kernel sequences assocs math ;
IN: xmode.marker.state IN: xmode.marker.state
@ -9,10 +9,10 @@ SYMBOLS: line last-offset position context
escaped? process-escape? delegate-end-escaped? ; escaped? process-escape? delegate-end-escaped? ;
: current-rule ( -- rule ) : current-rule ( -- rule )
context get line-context-in-rule ; context get in-rule>> ;
: current-rule-set ( -- rule ) : current-rule-set ( -- rule )
context get line-context-in-rule-set ; context get in-rule-set>> ;
: current-keywords ( -- keyword-map ) : current-keywords ( -- keyword-map )
current-rule-set rule-set-keywords ; current-rule-set rule-set-keywords ;
@ -32,9 +32,8 @@ SYMBOLS: line last-offset position context
context [ <line-context> ] change ; context [ <line-context> ] change ;
: pop-context ( -- ) : pop-context ( -- )
context get line-context-parent context get parent>>
dup context set f >>in-rule context set ;
f swap set-line-context-in-rule ;
: init-token-marker ( main prev-context line -- ) : init-token-marker ( main prev-context line -- )
line set line set

18
extra/xmode/rules/rules.factor
View File

@ -30,10 +30,10 @@ finalized?
V{ } clone >>imports ; V{ } clone >>imports ;
MEMO: standard-rule-set ( id -- ruleset ) MEMO: standard-rule-set ( id -- ruleset )
<rule-set> [ set-rule-set-default ] keep ; <rule-set> swap >>default ;
: import-rule-set ( import ruleset -- ) : import-rule-set ( import ruleset -- )
rule-set-imports push ; imports>> push ;
: inverted-index ( hashes key index -- ) : inverted-index ( hashes key index -- )
[ swapd push-at ] 2curry each ; [ swapd push-at ] 2curry each ;
@ -44,8 +44,9 @@ MEMO: standard-rule-set ( id -- ruleset )
] when* ; ] when* ;
: rule-set-no-word-sep* ( ruleset -- str ) : rule-set-no-word-sep* ( ruleset -- str )
dup rule-set-no-word-sep [ no-word-sep>> ]
swap rule-set-keywords dup [ keyword-map-no-word-sep* ] when [ keywords>> ] bi
dup [ keyword-map-no-word-sep* ] when
"_" 3append ; "_" 3append ;
! Match restrictions ! Match restrictions
@ -101,18 +102,17 @@ M: string-matcher text-hash-char string-matcher-string first ;
M: regexp text-hash-char drop f ; M: regexp text-hash-char drop f ;
: rule-chars* ( rule -- string ) : rule-chars* ( rule -- string )
dup rule-chars [ chars>> ] [ start>> ] bi text>>
swap rule-start matcher-text
text-hash-char [ suffix ] when* ; text-hash-char [ suffix ] when* ;
: add-rule ( rule ruleset -- ) : add-rule ( rule ruleset -- )
>r dup rule-chars* >upper swap >r dup rule-chars* >upper swap
r> rule-set-rules inverted-index ; r> rules>> inverted-index ;
: add-escape-rule ( string ruleset -- ) : add-escape-rule ( string ruleset -- )
over [ over [
>r <escape-rule> r> [ <escape-rule> ] dip
2dup set-rule-set-escape-rule 2dup (>>escape-rule)
add-rule add-rule
] [ ] [
2drop 2drop

6
extra/xmode/utilities/utilities-tests.factor
View File

@ -14,7 +14,7 @@ TUPLE: company employees type ;
: <company> V{ } clone f company boa ; : <company> V{ } clone f company boa ;
: add-employee company-employees push ; : add-employee employees>> push ;
<TAGS: parse-employee-tag <TAGS: parse-employee-tag
@ -22,7 +22,7 @@ TUPLE: employee name description ;
TAG: employee TAG: employee
employee new employee new
{ { "name" f set-employee-name } { f set-employee-description } } { { "name" f (>>name) } { f (>>description) } }
init-from-tag swap add-employee ; init-from-tag swap add-employee ;
TAGS> TAGS>
@ -32,7 +32,7 @@ TAGS>
: parse-company-tag : parse-company-tag
[ [
<company> <company>
{ { "type" >upper set-company-type } } { { "type" >upper (>>type) } }
init-from-tag dup init-from-tag dup
] keep ] keep
children>> [ tag? ] filter children>> [ tag? ] filter