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

Fix a couple of bugs in xmode and add a unit test

db4
Slava Pestov 2009-01-30 19:34:31 -06:00
parent e36376b432
commit f8092480a6
7 changed files with 49 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
basis/xmode/catalog/catalog.factor
View File

@ -52,9 +52,15 @@ SYMBOL: rule-sets
dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if* dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if*
dup -roll at* [ nip ] [ drop no-such-rule-set ] if ; dup -roll at* [ nip ] [ drop no-such-rule-set ] if ;
DEFER: finalize-rule-set
: resolve-delegate ( rule -- ) : resolve-delegate ( rule -- )
dup delegate>> dup string? dup delegate>> dup string? [
[ get-rule-set nip swap (>>delegate) ] [ 2drop ] if ; 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 -- ) : each-rule ( rule-set quot -- )
[ rules>> values concat ] dip each ; inline [ rules>> values concat ] dip each ; inline
@ -74,26 +80,22 @@ SYMBOL: rule-sets
: resolve-imports ( ruleset -- ) : resolve-imports ( ruleset -- )
dup imports>> [ dup imports>> [
get-rule-set swap rule-sets [ get-rule-set swap rule-sets [
dup resolve-delegates [ nip resolve-delegates ]
2dup import-keywords [ import-keywords ]
import-rules [ import-rules ]
2tri
] with-variable ] with-variable
] with each ; ] with each ;
ERROR: mutually-recursive-rulesets ruleset ; ERROR: mutually-recursive-rulesets ruleset ;
: finalize-rule-set ( ruleset -- ) : finalize-rule-set ( ruleset -- )
dup finalized?>> { dup finalized?>> [ drop ] [
{ f [ t >>finalized?
{ [ resolve-imports ]
[ 1 >>finalized? drop ] [ resolve-delegates ]
[ resolve-imports ] bi
[ resolve-delegates ] ] if ;
[ t >>finalized? drop ]
} cleave
] }
{ t [ drop ] }
{ 1 [ mutually-recursive-rulesets ] }
} case ;
: finalize-mode ( rulesets -- ) : finalize-mode ( rulesets -- )
rule-sets [ rule-sets [

9
basis/xmode/code2html/code2html-tests.factor
View File

@ -1,7 +1,7 @@
IN: xmode.code2html.tests IN: xmode.code2html.tests
USING: xmode.code2html xmode.catalog USING: xmode.code2html xmode.catalog
tools.test multiline splitting memoize tools.test multiline splitting memoize
kernel ; kernel io.streams.string xml.writer ;
[ ] [ \ (load-mode) reset-memoized ] unit-test [ ] [ \ (load-mode) reset-memoized ] unit-test
@ -9,4 +9,11 @@ kernel ;
<" <style type="text/css" media="screen" > <" <style type="text/css" media="screen" >
* {margin:0; padding:0; border:0;} "> * {margin:0; padding:0; border:0;} ">
string-lines "html" htmlize-lines drop string-lines "html" htmlize-lines drop
] unit-test
[ ] [
"test.c"
<" int x = "hi";
/* a comment */ "> <string-reader> htmlize-stream
write-xml
] unit-test ] unit-test

6
basis/xmode/code2html/code2html.factor
View File

@ -8,14 +8,14 @@ IN: xmode.code2html
[ str>> ] [ id>> ] bi [ [ str>> ] [ id>> ] bi [
name>> swap name>> swap
[XML <span class=<->><-></span> XML] [XML <span class=<->><-></span> XML]
] [ ] if* ] when*
] map ; ] map ;
: htmlize-line ( line-context line rules -- line-context' xml ) : htmlize-line ( line-context line rules -- line-context' xml )
tokenize-line htmlize-tokens ; tokenize-line htmlize-tokens ;
: htmlize-lines ( lines mode -- xml ) : 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 ) : default-stylesheet ( -- xml )
"resource:basis/xmode/code2html/stylesheet.css" "resource:basis/xmode/code2html/stylesheet.css"
@ -24,7 +24,7 @@ IN: xmode.code2html
:: htmlize-stream ( path stream -- xml ) :: htmlize-stream ( path stream -- xml )
stream lines stream lines
[ "" ] [ first find-mode path swap htmlize-lines ] [ "" ] [ path over first find-mode htmlize-lines ]
if-empty :> input if-empty :> input
default-stylesheet :> stylesheet default-stylesheet :> stylesheet
<XML <html> <XML <html>

16
basis/xmode/loader/loader.factor
View File

@ -43,17 +43,17 @@ RULE: MARK_PREVIOUS mark-previous-rule
shared-tag-attrs match-type-attr literal-start ; shared-tag-attrs match-type-attr literal-start ;
TAG: KEYWORDS ( rule-set tag -- key value ) 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 child-tags [ over parse-keyword-tag ] each
swap (>>keywords) ; swap (>>keywords) ;
TAGS> TAGS>
: ?<regexp> ( string/f -- regexp/f ) : ?<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 ) : (parse-rules-tag) ( tag -- rule-set )
<rule-set> <rule-set> dup rule-set set
{ {
{ "SET" string>rule-set-name (>>name) } { "SET" string>rule-set-name (>>name) }
{ "IGNORE_CASE" string>boolean (>>ignore-case?) } { "IGNORE_CASE" string>boolean (>>ignore-case?) }
@ -65,11 +65,11 @@ TAGS>
} init-from-tag ; } init-from-tag ;
: parse-rules-tag ( tag -- rule-set ) : parse-rules-tag ( tag -- rule-set )
dup (parse-rules-tag) [ [
dup ignore-case?>> ignore-case? [ [ (parse-rules-tag) ] [ child-tags ] bi
swap child-tags [ parse-rule-tag ] with each [ parse-rule-tag ] with each
] with-variable rule-set get
] keep ; ] with-scope ;
: merge-rule-set-props ( props rule-set -- ) : merge-rule-set-props ( props rule-set -- )
[ assoc-union ] change-props drop ; [ assoc-union ] change-props drop ;

13
basis/xmode/loader/syntax/syntax.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors xmode.tokens xmode.rules xmode.keyword-map USING: accessors xmode.tokens xmode.rules xmode.keyword-map
xml.data xml.utilities xml assocs kernel combinators sequences xml.data xml.utilities xml assocs kernel combinators sequences
math.parser namespaces make parser lexer xmode.utilities math.parser namespaces make parser lexer xmode.utilities
parser-combinators.regexp io.files ; parser-combinators.regexp io.files splitting arrays ;
IN: xmode.loader.syntax IN: xmode.loader.syntax
SYMBOL: ignore-case?
! Rule tag parsing utilities ! Rule tag parsing utilities
: (parse-rule-tag) ( rule-set tag specs class -- ) : (parse-rule-tag) ( rule-set tag specs class -- )
new swap init-from-tag swap add-rule ; inline new swap init-from-tag swap add-rule ; inline
@ -44,16 +42,19 @@ SYMBOL: ignore-case?
: parse-literal-matcher ( tag -- matcher ) : parse-literal-matcher ( tag -- matcher )
dup children>string dup children>string
ignore-case? get <string-matcher> rule-set get ignore-case?>> <string-matcher>
swap position-attrs <matcher> ; swap position-attrs <matcher> ;
: parse-regexp-matcher ( tag -- 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> ; swap position-attrs <matcher> ;
: shared-tag-attrs ( -- ) : shared-tag-attrs ( -- )
{ "TYPE" string>token (>>body-token) } , ; inline { "TYPE" string>token (>>body-token) } , ; inline
: parse-delegate ( string -- pair )
"::" split1 [ rule-set get swap ] unless* 2array ;
: delegate-attr ( -- ) : delegate-attr ( -- )
{ "DELEGATE" f (>>delegate) } , ; { "DELEGATE" f (>>delegate) } , ;

4
basis/xmode/marker/context/context.factor
View File

@ -1,4 +1,4 @@
USING: accessors kernel ; USING: accessors kernel xmode.rules ;
IN: xmode.marker.context IN: xmode.marker.context
! Based on org.gjt.sp.jedit.syntax.TokenMarker.LineContext ! Based on org.gjt.sp.jedit.syntax.TokenMarker.LineContext
@ -10,7 +10,7 @@ end
; ;
: <line-context> ( ruleset parent -- line-context ) : <line-context> ( ruleset parent -- line-context )
over [ "no context" throw ] unless over rule-set? [ "not a rule-set" throw ] unless
line-context new line-context new
swap >>parent swap >>parent
swap >>in-rule-set ; swap >>in-rule-set ;

4
basis/xmode/marker/marker.factor
View File

@ -157,7 +157,7 @@ M: seq-rule handle-rule-start
mark-token mark-token
add-remaining-token add-remaining-token
tuck body-token>> next-token, tuck body-token>> next-token,
delegate>> [ push-context ] when* ; get-delegate [ push-context ] when* ;
UNION: abstract-span-rule span-rule eol-span-rule ; 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, tuck rule-match-token* next-token,
! ... end subst ... ! ... end subst ...
dup context get (>>in-rule) dup context get (>>in-rule)
delegate>> push-context ; get-delegate push-context ;
M: span-rule handle-rule-end M: span-rule handle-rule-end
2drop ; 2drop ;