Fix a couple of bugs in xmode and add a unit test
Slava Pestov
parent
e36376b432
commit
f8092480a6
|
|
@ -52,9 +52,15 @@ SYMBOL: rule-sets
|
|||
dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if*
|
||||
dup -roll at* [ nip ] [ drop no-such-rule-set ] if ;
|
||||
|
||||
DEFER: finalize-rule-set
|
||||
|
||||
: resolve-delegate ( rule -- )
|
||||
dup delegate>> dup string?
|
||||
[ get-rule-set nip swap (>>delegate) ] [ 2drop ] if ;
|
||||
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
|
||||
|
|
@ -74,26 +80,22 @@ SYMBOL: rule-sets
|
|||
: resolve-imports ( ruleset -- )
|
||||
dup imports>> [
|
||||
get-rule-set swap rule-sets [
|
||||
dup resolve-delegates
|
||||
2dup import-keywords
|
||||
import-rules
|
||||
[ nip resolve-delegates ]
|
||||
[ import-keywords ]
|
||||
[ import-rules ]
|
||||
2tri
|
||||
] with-variable
|
||||
] with each ;
|
||||
|
||||
ERROR: mutually-recursive-rulesets ruleset ;
|
||||
|
||||
: finalize-rule-set ( ruleset -- )
|
||||
dup finalized?>> {
|
||||
{ f [
|
||||
{
|
||||
[ 1 >>finalized? drop ]
|
||||
[ resolve-imports ]
|
||||
[ resolve-delegates ]
|
||||
[ t >>finalized? drop ]
|
||||
} cleave
|
||||
] }
|
||||
{ t [ drop ] }
|
||||
{ 1 [ mutually-recursive-rulesets ] }
|
||||
} case ;
|
||||
dup finalized?>> [ drop ] [
|
||||
t >>finalized?
|
||||
[ resolve-imports ]
|
||||
[ resolve-delegates ]
|
||||
bi
|
||||
] if ;
|
||||
|
||||
: finalize-mode ( rulesets -- )
|
||||
rule-sets [
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: xmode.code2html.tests
|
||||
USING: xmode.code2html xmode.catalog
|
||||
tools.test multiline splitting memoize
|
||||
kernel ;
|
||||
kernel io.streams.string xml.writer ;
|
||||
|
||||
[ ] [ \ (load-mode) reset-memoized ] unit-test
|
||||
|
||||
|
|
@ -9,4 +9,11 @@ kernel ;
|
|||
<" <style type="text/css" media="screen" >
|
||||
* {margin:0; padding:0; border:0;} ">
|
||||
string-lines "html" htmlize-lines drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"test.c"
|
||||
<" int x = "hi";
|
||||
/* a comment */ "> <string-reader> htmlize-stream
|
||||
write-xml
|
||||
] unit-test
|
||||
|
|
@ -8,14 +8,14 @@ IN: xmode.code2html
|
|||
[ str>> ] [ id>> ] bi [
|
||||
name>> swap
|
||||
[XML <span class=<->><-></span> XML]
|
||||
] [ ] if*
|
||||
] when*
|
||||
] map ;
|
||||
|
||||
: htmlize-line ( line-context line rules -- line-context' xml )
|
||||
tokenize-line htmlize-tokens ;
|
||||
|
||||
: htmlize-lines ( lines mode -- xml )
|
||||
[ f ] 2dip load-mode [ htmlize-line ] curry map nip ;
|
||||
[ f ] 2dip load-mode [ htmlize-line "\n" suffix ] curry map nip ;
|
||||
|
||||
: default-stylesheet ( -- xml )
|
||||
"resource:basis/xmode/code2html/stylesheet.css"
|
||||
|
|
@ -24,7 +24,7 @@ IN: xmode.code2html
|
|||
|
||||
:: htmlize-stream ( path stream -- xml )
|
||||
stream lines
|
||||
[ "" ] [ first find-mode path swap htmlize-lines ]
|
||||
[ "" ] [ path over first find-mode htmlize-lines ]
|
||||
if-empty :> input
|
||||
default-stylesheet :> stylesheet
|
||||
<XML <html>
|
||||
|
|
|
|||
|
|
@ -43,17 +43,17 @@ RULE: MARK_PREVIOUS mark-previous-rule
|
|||
shared-tag-attrs match-type-attr literal-start ;
|
||||
|
||||
TAG: KEYWORDS ( rule-set tag -- key value )
|
||||
ignore-case? get <keyword-map>
|
||||
rule-set get ignore-case?>> <keyword-map>
|
||||
swap child-tags [ over parse-keyword-tag ] each
|
||||
swap (>>keywords) ;
|
||||
|
||||
TAGS>
|
||||
|
||||
: ?<regexp> ( string/f -- regexp/f )
|
||||
dup [ ignore-case? get <regexp> ] when ;
|
||||
dup [ rule-set get ignore-case?>> <regexp> ] when ;
|
||||
|
||||
: (parse-rules-tag) ( tag -- rule-set )
|
||||
<rule-set>
|
||||
<rule-set> dup rule-set set
|
||||
{
|
||||
{ "SET" string>rule-set-name (>>name) }
|
||||
{ "IGNORE_CASE" string>boolean (>>ignore-case?) }
|
||||
|
|
@ -65,11 +65,11 @@ TAGS>
|
|||
} init-from-tag ;
|
||||
|
||||
: parse-rules-tag ( tag -- rule-set )
|
||||
dup (parse-rules-tag) [
|
||||
dup ignore-case?>> ignore-case? [
|
||||
swap child-tags [ parse-rule-tag ] with each
|
||||
] with-variable
|
||||
] keep ;
|
||||
[
|
||||
[ (parse-rules-tag) ] [ child-tags ] bi
|
||||
[ parse-rule-tag ] with each
|
||||
rule-set get
|
||||
] with-scope ;
|
||||
|
||||
: merge-rule-set-props ( props rule-set -- )
|
||||
[ assoc-union ] change-props drop ;
|
||||
|
|
|
|||
|
|
@ -1,13 +1,11 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors xmode.tokens xmode.rules xmode.keyword-map
|
||||
xml.data xml.utilities xml assocs kernel combinators sequences
|
||||
math.parser namespaces make parser lexer xmode.utilities
|
||||
parser-combinators.regexp io.files ;
|
||||
parser-combinators.regexp io.files splitting arrays ;
|
||||
IN: xmode.loader.syntax
|
||||
|
||||
SYMBOL: ignore-case?
|
||||
|
||||
! Rule tag parsing utilities
|
||||
: (parse-rule-tag) ( rule-set tag specs class -- )
|
||||
new swap init-from-tag swap add-rule ; inline
|
||||
|
|
@ -44,16 +42,19 @@ SYMBOL: ignore-case?
|
|||
|
||||
: parse-literal-matcher ( tag -- matcher )
|
||||
dup children>string
|
||||
ignore-case? get <string-matcher>
|
||||
rule-set get ignore-case?>> <string-matcher>
|
||||
swap position-attrs <matcher> ;
|
||||
|
||||
: parse-regexp-matcher ( tag -- matcher )
|
||||
dup children>string ignore-case? get <regexp>
|
||||
dup children>string rule-set get ignore-case?>> <regexp>
|
||||
swap position-attrs <matcher> ;
|
||||
|
||||
: shared-tag-attrs ( -- )
|
||||
{ "TYPE" string>token (>>body-token) } , ; inline
|
||||
|
||||
: parse-delegate ( string -- pair )
|
||||
"::" split1 [ rule-set get swap ] unless* 2array ;
|
||||
|
||||
: delegate-attr ( -- )
|
||||
{ "DELEGATE" f (>>delegate) } , ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: accessors kernel ;
|
||||
USING: accessors kernel xmode.rules ;
|
||||
IN: xmode.marker.context
|
||||
|
||||
! Based on org.gjt.sp.jedit.syntax.TokenMarker.LineContext
|
||||
|
|
@ -10,7 +10,7 @@ end
|
|||
;
|
||||
|
||||
: <line-context> ( ruleset parent -- line-context )
|
||||
over [ "no context" throw ] unless
|
||||
over rule-set? [ "not a rule-set" throw ] unless
|
||||
line-context new
|
||||
swap >>parent
|
||||
swap >>in-rule-set ;
|
||||
|
|
|
|||
|
|
@ -157,7 +157,7 @@ M: seq-rule handle-rule-start
|
|||
mark-token
|
||||
add-remaining-token
|
||||
tuck body-token>> next-token,
|
||||
delegate>> [ push-context ] when* ;
|
||||
get-delegate [ push-context ] when* ;
|
||||
|
||||
UNION: abstract-span-rule span-rule eol-span-rule ;
|
||||
|
||||
|
|
@ -168,7 +168,7 @@ M: abstract-span-rule handle-rule-start
|
|||
tuck rule-match-token* next-token,
|
||||
! ... end subst ...
|
||||
dup context get (>>in-rule)
|
||||
delegate>> push-context ;
|
||||
get-delegate push-context ;
|
||||
|
||||
M: span-rule handle-rule-end
|
||||
2drop ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue