From 1e1561fc2535737533fc44d98eeb97b636a69752 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 16 Jan 2008 01:04:42 -0500 Subject: [PATCH] XMode loads now --- extra/xmode/loader/loader.factor | 103 +----------------------- extra/xmode/loader/syntax/syntax.factor | 101 +++++++++++++++++++++++ extra/xmode/tokens/tokens.factor | 16 ++-- extra/xmode/utilities/utilities.factor | 2 +- 4 files changed, 113 insertions(+), 109 deletions(-) create mode 100644 extra/xmode/loader/syntax/syntax.factor diff --git a/extra/xmode/loader/loader.factor b/extra/xmode/loader/loader.factor index e631a920be..096b83e22e 100755 --- a/extra/xmode/loader/loader.factor +++ b/extra/xmode/loader/loader.factor @@ -1,59 +1,11 @@ -USING: xmode.tokens xmode.rules xmode.keyword-map xml.data -xml.utilities xml assocs kernel combinators sequences -math.parser namespaces parser xmode.utilities regexp io.files ; +USING: xmode.loader.syntax xmode.tokens xmode.rules +xmode.keyword-map xml.data xml.utilities xml assocs kernel +combinators sequences math.parser namespaces parser +xmode.utilities regexp io.files ; IN: xmode.loader ! Based on org.gjt.sp.jedit.XModeHandler -SYMBOL: ignore-case? - -! Attribute utilities -: string>boolean ( string -- ? ) "TRUE" = ; - -: string>match-type ( string -- obj ) - { - { "RULE" [ f ] } - { "CONTEXT" [ t ] } - [ string>token ] - } case ; - -: string>rule-set-name "MAIN" or ; - -! PROP, PROPS -: parse-prop-tag ( tag -- key value ) - "NAME" over at "VALUE" rot at ; - -: parse-props-tag ( tag -- assoc ) - child-tags - [ parse-prop-tag ] H{ } map>assoc ; - -: position-attrs ( tag -- at-line-start? at-whitespace-end? at-word-start? ) - ! XXX Wrong logic! - { "AT_LINE_START" "AT_WHITESPACE_END" "AT_WORD_START" } - swap [ at string>boolean ] curry map first3 ; - -: parse-literal-matcher ( tag -- matcher ) - dup children>string - ignore-case? get - swap position-attrs ; - -: parse-regexp-matcher ( tag -- matcher ) - dup children>string ignore-case? get - swap position-attrs ; - -! SPAN's children - - ! RULES and its children number swap set-rule-set-terminate-char ; -: (parse-rule-tag) ( rule-set tag specs class -- ) - construct-rule swap init-from-tag swap add-rule ; inline - -: RULE: - scan scan-word - parse-definition { } make - swap [ (parse-rule-tag) ] 2curry (TAG:) ; parsing - -: shared-tag-attrs - { "TYPE" string>token set-rule-body-token } , ; inline - -: delegate-attr - { "DELEGATE" f set-rule-delegate } , ; - -: regexp-attr - { "HASH_CHAR" f set-rule-chars } , ; - -: match-type-attr - { "MATCH_TYPE" string>match-type set-rule-match-token } , ; - -: span-attrs - { "NO_LINE_BREAK" string>boolean set-rule-no-line-break? } , - { "NO_WORD_BREAK" string>boolean set-rule-no-word-break? } , - { "NO_ESCAPE" string>boolean set-rule-no-escape? } , ; - -: literal-start - [ parse-literal-matcher swap set-rule-start ] , ; - -: regexp-start - [ parse-regexp-matcher swap set-rule-start ] , ; - -: literal-end - [ parse-literal-matcher swap set-rule-end ] , ; - RULE: SEQ seq-rule shared-tag-attrs delegate-attr literal-start ; RULE: SEQ_REGEXP seq-rule shared-tag-attrs delegate-attr regexp-attr regexp-start ; -: parse-begin/end-tags - [ - ! XXX: handle position attrs on span tag itself - child-tags [ parse-begin/end-tag ] with each - ] , ; - -: init-span-tag [ drop init-span ] , ; - -: init-eol-span-tag [ drop init-eol-span ] , ; - RULE: SPAN span-rule shared-tag-attrs delegate-attr match-type-attr span-attrs parse-begin/end-tags init-span-tag ; @@ -134,9 +42,6 @@ RULE: MARK_FOLLOWING mark-following-rule RULE: MARK_PREVIOUS mark-previous-rule shared-tag-attrs match-type-attr literal-start ; -: parse-keyword-tag ( tag keyword-map -- ) - >r dup name-tag string>token swap children>string r> set-at ; - TAG: KEYWORDS ( rule-set tag -- key value ) ignore-case? get swap child-tags [ over parse-keyword-tag ] each diff --git a/extra/xmode/loader/syntax/syntax.factor b/extra/xmode/loader/syntax/syntax.factor new file mode 100644 index 0000000000..c754db61c8 --- /dev/null +++ b/extra/xmode/loader/syntax/syntax.factor @@ -0,0 +1,101 @@ +USING: xmode.tokens xmode.rules xmode.keyword-map xml.data +xml.utilities xml assocs kernel combinators sequences +math.parser namespaces parser xmode.utilities regexp io.files ; +IN: xmode.loader.syntax + +SYMBOL: ignore-case? + +! Rule tag parsing utilities +: (parse-rule-tag) ( rule-set tag specs class -- ) + construct-rule swap init-from-tag swap add-rule ; inline + +: RULE: + scan scan-word + parse-definition { } make + swap [ (parse-rule-tag) ] 2curry (TAG:) ; parsing + +! Attribute utilities +: string>boolean ( string -- ? ) "TRUE" = ; + +: string>match-type ( string -- obj ) + { + { "RULE" [ f ] } + { "CONTEXT" [ t ] } + [ string>token ] + } case ; + +: string>rule-set-name "MAIN" or ; + +! PROP, PROPS +: parse-prop-tag ( tag -- key value ) + "NAME" over at "VALUE" rot at ; + +: parse-props-tag ( tag -- assoc ) + child-tags + [ parse-prop-tag ] H{ } map>assoc ; + +: position-attrs ( tag -- at-line-start? at-whitespace-end? at-word-start? ) + ! XXX Wrong logic! + { "AT_LINE_START" "AT_WHITESPACE_END" "AT_WORD_START" } + swap [ at string>boolean ] curry map first3 ; + +: parse-literal-matcher ( tag -- matcher ) + dup children>string + ignore-case? get + swap position-attrs ; + +: parse-regexp-matcher ( tag -- matcher ) + dup children>string ignore-case? get + swap position-attrs ; + +: shared-tag-attrs + { "TYPE" string>token set-rule-body-token } , ; inline + +: delegate-attr + { "DELEGATE" f set-rule-delegate } , ; + +: regexp-attr + { "HASH_CHAR" f set-rule-chars } , ; + +: match-type-attr + { "MATCH_TYPE" string>match-type set-rule-match-token } , ; + +: span-attrs + { "NO_LINE_BREAK" string>boolean set-rule-no-line-break? } , + { "NO_WORD_BREAK" string>boolean set-rule-no-word-break? } , + { "NO_ESCAPE" string>boolean set-rule-no-escape? } , ; + +: literal-start + [ parse-literal-matcher swap set-rule-start ] , ; + +: regexp-start + [ parse-regexp-matcher swap set-rule-start ] , ; + +: literal-end + [ parse-literal-matcher swap set-rule-end ] , ; + +! SPAN's children + + +: parse-begin/end-tags + [ + ! XXX: handle position attrs on span tag itself + child-tags [ parse-begin/end-tag ] with each + ] , ; + +: init-span-tag [ drop init-span ] , ; + +: init-eol-span-tag [ drop init-eol-span ] , ; + +: parse-keyword-tag ( tag keyword-map -- ) + >r dup name-tag string>token swap children>string r> set-at ; diff --git a/extra/xmode/tokens/tokens.factor b/extra/xmode/tokens/tokens.factor index 14a48582ec..e1fa2dd04f 100644 --- a/extra/xmode/tokens/tokens.factor +++ b/extra/xmode/tokens/tokens.factor @@ -1,20 +1,18 @@ -USING: parser words sequences namespaces kernel assocs ; +USING: parser words sequences namespaces kernel assocs +compiler.units ; IN: xmode.tokens ! Based on org.gjt.sp.jedit.syntax.Token SYMBOL: tokens -: string>token ( string -- id ) tokens get at ; - -: TOKENS: - ";" parse-tokens [ +[ + { "COMMENT1" "COMMENT2" "COMMENT3" "COMMENT4" "DIGIT" "FUNCTION" "INVALID" "KEYWORD1" "KEYWORD2" "KEYWORD3" "KEYWORD4" "LABEL" "LITERAL1" "LITERAL2" "LITERAL3" "LITERAL4" "MARKUP" "OPERATOR" "END" "NULL" } [ create-in dup define-symbol dup word-name swap - ] H{ } map>assoc tokens set-global ; parsing + ] H{ } map>assoc tokens set-global +] with-compilation-unit -TOKENS: COMMENT1 COMMENT2 COMMENT3 COMMENT4 DIGIT FUNCTION -INVALID KEYWORD1 KEYWORD2 KEYWORD3 KEYWORD4 LABEL LITERAL1 -LITERAL2 LITERAL3 LITERAL4 MARKUP OPERATOR END NULL ; +: string>token ( string -- id ) tokens get at ; TUPLE: token str id ; diff --git a/extra/xmode/utilities/utilities.factor b/extra/xmode/utilities/utilities.factor index d4096b17e0..f7c8606420 100644 --- a/extra/xmode/utilities/utilities.factor +++ b/extra/xmode/utilities/utilities.factor @@ -55,4 +55,4 @@ SYMBOL: tag-handler-word : TAGS> tag-handler-word get tag-handlers get >alist [ >r dup name-tag r> case ] curry - define-compound ; parsing + define ; parsing