modern: Add to extra/ some version of modern that has the modern.paths vocab.
For travisci.elevate-erg
Doug Coleman
parent
138d150da2
commit
256f0ed4a4
|
|
@ -0,0 +1,243 @@
|
||||||
|
! Copyright (C) 2017 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: modern modern.slices multiline tools.test ;
|
||||||
|
IN: modern.tests
|
||||||
|
|
||||||
|
{ f } [ "" upper-colon? ] unit-test
|
||||||
|
{ t } [ ":" upper-colon? ] unit-test
|
||||||
|
{ t } [ "::" upper-colon? ] unit-test
|
||||||
|
{ t } [ ":::" upper-colon? ] unit-test
|
||||||
|
{ t } [ "FOO:" upper-colon? ] unit-test
|
||||||
|
{ t } [ "FOO::" upper-colon? ] unit-test
|
||||||
|
{ t } [ "FOO:::" upper-colon? ] unit-test
|
||||||
|
|
||||||
|
! 'FOO:
|
||||||
|
{ f } [ "'" upper-colon? ] unit-test
|
||||||
|
{ t } [ "':" upper-colon? ] unit-test
|
||||||
|
{ t } [ "'::" upper-colon? ] unit-test
|
||||||
|
{ t } [ "':::" upper-colon? ] unit-test
|
||||||
|
{ t } [ "'FOO:" upper-colon? ] unit-test
|
||||||
|
{ t } [ "'FOO::" upper-colon? ] unit-test
|
||||||
|
{ t } [ "'FOO:::" upper-colon? ] unit-test
|
||||||
|
|
||||||
|
! \FOO: is not an upper-colon form, it is deactivated by the \
|
||||||
|
{ f } [ "\\" upper-colon? ] unit-test
|
||||||
|
{ f } [ "\\:" upper-colon? ] unit-test
|
||||||
|
{ f } [ "\\::" upper-colon? ] unit-test
|
||||||
|
{ f } [ "\\:::" upper-colon? ] unit-test
|
||||||
|
{ f } [ "\\FOO:" upper-colon? ] unit-test
|
||||||
|
{ f } [ "\\FOO::" upper-colon? ] unit-test
|
||||||
|
{ f } [ "\\FOO:::" upper-colon? ] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
! Comment
|
||||||
|
{
|
||||||
|
{ { "!" "" } }
|
||||||
|
} [ "!" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{
|
||||||
|
{ { "!" " lol" } }
|
||||||
|
} [ "! lol" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{
|
||||||
|
{ "lol!" }
|
||||||
|
} [ "lol!" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{
|
||||||
|
{ { "!" "lol" } }
|
||||||
|
} [ "!lol" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
! Colon
|
||||||
|
{
|
||||||
|
{ ":asdf:" }
|
||||||
|
} [ ":asdf:" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{
|
||||||
|
{ { "one:" { "1" } } }
|
||||||
|
} [ "one: 1" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{
|
||||||
|
{ { "two::" { "1" "2" } } }
|
||||||
|
} [ "two:: 1 2" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{
|
||||||
|
{ "1" ":>" "one" }
|
||||||
|
} [ "1 :> one" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{
|
||||||
|
{ { ":" { "foo" } ";" } }
|
||||||
|
} [ ": foo ;" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "FOO:" { "a" } }
|
||||||
|
{ "BAR:" { "b" } }
|
||||||
|
}
|
||||||
|
} [ "FOO: a BAR: b" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{
|
||||||
|
{ { "FOO:" { "a" } ";" } }
|
||||||
|
} [ "FOO: a ;" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{
|
||||||
|
{ { "FOO:" { "a" } "FOO;" } }
|
||||||
|
} [ "FOO: a FOO;" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
! Acute
|
||||||
|
{
|
||||||
|
{ { "<A" { } "A>" } }
|
||||||
|
} [ "<A A>" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{
|
||||||
|
{ { "<B:" { "hi" } ";B>" } }
|
||||||
|
} [ "<B: hi ;B>" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{ { "<foo>" } } [ "<foo>" string>literals >strings ] unit-test
|
||||||
|
{ { ">foo<" } } [ ">foo<" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{ { "foo>" } } [ "foo>" string>literals >strings ] unit-test
|
||||||
|
{ { ">foo" } } [ ">foo" string>literals >strings ] unit-test
|
||||||
|
{ { ">foo>" } } [ ">foo>" string>literals >strings ] unit-test
|
||||||
|
{ { ">>foo>" } } [ ">>foo>" string>literals >strings ] unit-test
|
||||||
|
{ { ">>foo>>" } } [ ">>foo>>" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{ { "foo<" } } [ "foo<" string>literals >strings ] unit-test
|
||||||
|
{ { "<foo" } } [ "<foo" string>literals >strings ] unit-test
|
||||||
|
{ { "<foo<" } } [ "<foo<" string>literals >strings ] unit-test
|
||||||
|
{ { "<<foo<" } } [ "<<foo<" string>literals >strings ] unit-test
|
||||||
|
{ { "<<foo<<" } } [ "<<foo<<" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
! Backslash \AVL{ foo\bar foo\bar{
|
||||||
|
{
|
||||||
|
{ { "SYNTAX:" { "\\AVL{" } } }
|
||||||
|
} [ "SYNTAX: \\AVL{" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
[ "\\" string>literals >strings ] must-fail ! \ alone should be legal eventually (?)
|
||||||
|
|
||||||
|
{ { "\\FOO" } } [ "\\FOO" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{
|
||||||
|
{ "foo\\bar" }
|
||||||
|
} [ "foo\\bar" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
[ "foo\\bar{" string>literals >strings ] must-fail
|
||||||
|
|
||||||
|
{
|
||||||
|
{ { "foo\\bar{" { "1" } "}" } }
|
||||||
|
} [ "foo\\bar{ 1 }" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{ { { "char:" { "\\{" } } } } [ "char: \\{" string>literals >strings ] unit-test
|
||||||
|
[ "char: {" string>literals >strings ] must-fail
|
||||||
|
[ "char: [" string>literals >strings ] must-fail
|
||||||
|
[ "char: {" string>literals >strings ] must-fail
|
||||||
|
[ "char: \"" string>literals >strings ] must-fail
|
||||||
|
! { { { "char:" { "\\\\" } } } } [ "char: \\\\" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
[ "char: \\" string>literals >strings ] must-fail ! char: \ should be legal eventually
|
||||||
|
|
||||||
|
{ { { "\\" { "(" } } } } [ "\\ (" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{ { "\\[[" } } [ "\\[[" string>literals >strings ] unit-test
|
||||||
|
{ { "\\[=[" } } [ "\\[=[" string>literals >strings ] unit-test
|
||||||
|
{ { "\\[==[" } } [ "\\[==[" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
{ t } [ "FOO:" strict-upper? ] unit-test
|
||||||
|
{ t } [ ":" strict-upper? ] unit-test
|
||||||
|
{ f } [ "<FOO" strict-upper? ] unit-test
|
||||||
|
{ f } [ "<FOO:" strict-upper? ] unit-test
|
||||||
|
{ f } [ "->" strict-upper? ] unit-test
|
||||||
|
{ f } [ "FOO>" strict-upper? ] unit-test
|
||||||
|
{ f } [ ";FOO>" strict-upper? ] unit-test
|
||||||
|
|
||||||
|
{ f } [ "FOO" section-open? ] unit-test
|
||||||
|
{ f } [ "FOO:" section-open? ] unit-test
|
||||||
|
{ f } [ ";FOO" section-close? ] unit-test
|
||||||
|
{ f } [ "FOO" section-close? ] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
! Strings
|
||||||
|
{
|
||||||
|
{ { "url\"" "google.com" "\"" } }
|
||||||
|
} [ [[ url"google.com" ]] string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{
|
||||||
|
{ { "\"" "google.com" "\"" } }
|
||||||
|
} [ [[ "google.com" ]] string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "(" { "a" "b" } ")" }
|
||||||
|
{ "[" { "a" "b" "+" } "]" }
|
||||||
|
{ "(" { "c" } ")" }
|
||||||
|
}
|
||||||
|
} [ "( a b ) [ a b + ] ( c )" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
![[
|
||||||
|
! Concatenated syntax
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "(" { "a" "b" } ")" }
|
||||||
|
{ "[" { "a" "b" "+" } "]" }
|
||||||
|
{ "(" { "c" } ")" }
|
||||||
|
}
|
||||||
|
}
|
||||||
|
} [ "( a b )[ a b + ]( c )" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "\"" "abc" "\"" }
|
||||||
|
{ "[" { "0" } "]" }
|
||||||
|
}
|
||||||
|
}
|
||||||
|
} [ "\"abc\"[ 0 ]" string>literals >strings ] unit-test
|
||||||
|
]]
|
||||||
|
|
||||||
|
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "<FOO" { { "BAR:" { "bar" } } } "FOO>" }
|
||||||
|
}
|
||||||
|
} [ "<FOO BAR: bar FOO>" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "<FOO:" { "foo" { "BAR:" { "bar" } } } ";FOO>" }
|
||||||
|
}
|
||||||
|
} [ "<FOO: foo BAR: bar ;FOO>" string>literals >strings ] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
![[
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{
|
||||||
|
"foo::"
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "<FOO" { } "FOO>" }
|
||||||
|
{ "[" { "0" } "]" }
|
||||||
|
{ "[" { "1" } "]" }
|
||||||
|
{ "[" { "2" } "]" }
|
||||||
|
{ "[" { "3" } "]" }
|
||||||
|
}
|
||||||
|
{ { "<BAR" { } "BAR>" } }
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
} [ "foo:: <FOO FOO>[ 0 ][ 1 ][ 2 ][ 3 ] <BAR BAR>" string>literals >strings ] unit-test
|
||||||
|
]]
|
||||||
|
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "foo::" { { "<FOO" { } "FOO>" } { "[" { "0" } "]" } } }
|
||||||
|
{ "[" { "1" } "]" }
|
||||||
|
{ "[" { "2" } "]" }
|
||||||
|
{ "[" { "3" } "]" }
|
||||||
|
{ "<BAR" { } "BAR>" }
|
||||||
|
}
|
||||||
|
} [ "foo:: <FOO FOO> [ 0 ] [ 1 ] [ 2 ] [ 3 ] <BAR BAR>" string>literals >strings ] unit-test
|
||||||
|
|
@ -0,0 +1,499 @@
|
||||||
|
! Copyright (C) 2016 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: arrays assocs combinators combinators.short-circuit
|
||||||
|
continuations fry io.encodings.utf8 io.files kernel locals make
|
||||||
|
math math.order modern.paths modern.slices sequences
|
||||||
|
sequences.extras sets splitting strings unicode vocabs.loader ;
|
||||||
|
IN: modern
|
||||||
|
|
||||||
|
ERROR: string-expected-got-eof n string ;
|
||||||
|
ERROR: long-opening-mismatch tag open n string ch ;
|
||||||
|
|
||||||
|
! (( )) [[ ]] {{ }}
|
||||||
|
MACRO:: read-double-matched ( open-ch -- quot: ( n string tag ch -- n' string seq ) )
|
||||||
|
open-ch dup matching-delimiter {
|
||||||
|
[ drop 2 swap <string> ]
|
||||||
|
[ drop 1string ]
|
||||||
|
[ nip 2 swap <string> ]
|
||||||
|
} 2cleave :> ( openstr2 openstr1 closestr2 )
|
||||||
|
[| n string tag! ch |
|
||||||
|
ch {
|
||||||
|
{ CHAR: = [
|
||||||
|
tag 1 cut-slice* drop tag! ! tag of (=( is ( here, fix it
|
||||||
|
n string openstr1 slice-til-separator-inclusive [ -1 modify-from ] dip :> ( n' string' opening ch )
|
||||||
|
ch open-ch = [ tag openstr2 n string ch long-opening-mismatch ] unless
|
||||||
|
opening matching-delimiter-string :> needle
|
||||||
|
|
||||||
|
n' string' needle slice-til-string :> ( n'' string'' payload closing )
|
||||||
|
n'' string
|
||||||
|
tag opening payload closing 4array
|
||||||
|
] }
|
||||||
|
{ open-ch [
|
||||||
|
tag 1 cut-slice* swap tag! 1 modify-to :> opening
|
||||||
|
n 1 + string closestr2 slice-til-string :> ( n' string' payload closing )
|
||||||
|
n' string
|
||||||
|
tag opening payload closing 4array
|
||||||
|
] }
|
||||||
|
[ [ tag openstr2 n string ] dip long-opening-mismatch ]
|
||||||
|
} case
|
||||||
|
] ;
|
||||||
|
|
||||||
|
: read-double-matched-paren ( n string tag ch -- n' string seq ) CHAR: ( read-double-matched ;
|
||||||
|
: read-double-matched-bracket ( n string tag ch -- n' string seq ) CHAR: [ read-double-matched ;
|
||||||
|
: read-double-matched-brace ( n string tag ch -- n' string seq ) CHAR: { read-double-matched ;
|
||||||
|
|
||||||
|
DEFER: lex-factor-top
|
||||||
|
DEFER: lex-factor
|
||||||
|
ERROR: lex-expected-but-got-eof n string expected ;
|
||||||
|
! For implementing [ { (
|
||||||
|
: lex-until ( n string tag-sequence -- n' string payload )
|
||||||
|
3dup '[
|
||||||
|
[
|
||||||
|
lex-factor-top dup f like [ , ] when* [
|
||||||
|
dup [
|
||||||
|
! } gets a chance, but then also full seq { } after recursion...
|
||||||
|
[ _ ] dip '[ _ sequence= ] any? not
|
||||||
|
] [
|
||||||
|
drop t ! loop again?
|
||||||
|
] if
|
||||||
|
] [
|
||||||
|
_ _ _ lex-expected-but-got-eof
|
||||||
|
] if*
|
||||||
|
] loop
|
||||||
|
] { } make ;
|
||||||
|
|
||||||
|
DEFER: section-close?
|
||||||
|
DEFER: upper-colon?
|
||||||
|
DEFER: lex-factor-nested
|
||||||
|
: lex-colon-until ( n string tag-sequence -- n' string payload )
|
||||||
|
'[
|
||||||
|
[
|
||||||
|
lex-factor-nested dup f like [ , ] when* [
|
||||||
|
dup [
|
||||||
|
! This is for ending COLON: forms like ``A: PRIVATE>``
|
||||||
|
dup section-close? [
|
||||||
|
drop f
|
||||||
|
] [
|
||||||
|
! } gets a chance, but then also full seq { } after recursion...
|
||||||
|
[ _ ] dip '[ _ sequence= ] any? not
|
||||||
|
] if
|
||||||
|
] [
|
||||||
|
drop t ! loop again?
|
||||||
|
] if
|
||||||
|
] [
|
||||||
|
f
|
||||||
|
] if*
|
||||||
|
] loop
|
||||||
|
] { } make ;
|
||||||
|
|
||||||
|
: split-double-dash ( seq -- seqs )
|
||||||
|
dup [ { [ "--" sequence= ] } 1&& ] split-when
|
||||||
|
dup length 1 > [ nip ] [ drop ] if ;
|
||||||
|
|
||||||
|
MACRO:: read-matched ( ch -- quot: ( n string tag -- n' string slice' ) )
|
||||||
|
ch dup matching-delimiter {
|
||||||
|
[ drop "=" swap prefix ]
|
||||||
|
[ nip 1string ]
|
||||||
|
} 2cleave :> ( openstreq closestr1 ) ! [= ]
|
||||||
|
[| n string tag |
|
||||||
|
n string tag
|
||||||
|
2over nth-check-eof {
|
||||||
|
{ [ dup openstreq member? ] [ ch read-double-matched ] } ! (=( or ((
|
||||||
|
{ [ dup blank? ] [
|
||||||
|
drop dup '[ _ matching-delimiter-string closestr1 2array members lex-until ] dip
|
||||||
|
swap unclip-last 3array ] } ! ( foo )
|
||||||
|
[ drop [ slice-til-whitespace drop ] dip span-slices ] ! (foo)
|
||||||
|
} cond
|
||||||
|
] ;
|
||||||
|
|
||||||
|
: read-bracket ( n string slice -- n' string slice' ) CHAR: [ read-matched ;
|
||||||
|
: read-brace ( n string slice -- n' string slice' ) CHAR: { read-matched ;
|
||||||
|
: read-paren ( n string slice -- n' string slice' ) CHAR: ( read-matched ;
|
||||||
|
: read-string-payload ( n string -- n' string )
|
||||||
|
over [
|
||||||
|
{ CHAR: \\ CHAR: \" } slice-til-separator-inclusive {
|
||||||
|
{ f [ drop ] }
|
||||||
|
{ CHAR: \" [ drop ] }
|
||||||
|
{ CHAR: \\ [ drop next-char-from drop read-string-payload ] }
|
||||||
|
} case
|
||||||
|
] [
|
||||||
|
string-expected-got-eof
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
:: read-string ( n string tag -- n' string seq )
|
||||||
|
n string read-string-payload drop :> n'
|
||||||
|
n' string
|
||||||
|
n' [ n string string-expected-got-eof ] unless
|
||||||
|
n n' 1 - string <slice>
|
||||||
|
n' 1 - n' string <slice>
|
||||||
|
tag -rot 3array ;
|
||||||
|
|
||||||
|
: take-comment ( n string slice -- n' string comment )
|
||||||
|
2over ?nth CHAR: [ = [
|
||||||
|
[ 1 + ] 2dip 2over ?nth read-double-matched-bracket
|
||||||
|
] [
|
||||||
|
[ slice-til-eol drop ] dip swap 2array
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: terminator? ( slice -- ? )
|
||||||
|
{
|
||||||
|
[ ";" sequence= ]
|
||||||
|
[ "]" sequence= ]
|
||||||
|
[ "}" sequence= ]
|
||||||
|
[ ")" sequence= ]
|
||||||
|
} 1|| ;
|
||||||
|
|
||||||
|
ERROR: expected-length-tokens n string length seq ;
|
||||||
|
: ensure-no-false ( n string seq -- n string seq )
|
||||||
|
dup [ length 0 > ] all? [ [ length ] keep expected-length-tokens ] unless ;
|
||||||
|
|
||||||
|
ERROR: token-expected n string obj ;
|
||||||
|
ERROR: unexpected-terminator n string slice ;
|
||||||
|
: read-lowercase-colon ( n string slice -- n' string lowercase-colon )
|
||||||
|
dup [ CHAR: : = ] count-tail
|
||||||
|
'[
|
||||||
|
_ [ lex-factor ] replicate ensure-no-false dup [ token-expected ] unless
|
||||||
|
dup terminator? [ unexpected-terminator ] when
|
||||||
|
] dip swap 2array ;
|
||||||
|
|
||||||
|
: (strict-upper?) ( string -- ? )
|
||||||
|
{
|
||||||
|
! All chars must...
|
||||||
|
[
|
||||||
|
[
|
||||||
|
{ [ CHAR: A CHAR: Z between? ] [ "':-\\#" member? ] } 1||
|
||||||
|
] all?
|
||||||
|
]
|
||||||
|
! At least one char must...
|
||||||
|
[ [ { [ CHAR: A CHAR: Z between? ] [ CHAR: ' = ] } 1|| ] any? ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
: strict-upper? ( string -- ? )
|
||||||
|
{ [ ":" sequence= ] [ (strict-upper?) ] } 1|| ;
|
||||||
|
|
||||||
|
! <A <A: but not <A>
|
||||||
|
: section-open? ( string -- ? )
|
||||||
|
{
|
||||||
|
[ "<" head? ]
|
||||||
|
[ length 2 >= ]
|
||||||
|
[ rest strict-upper? ]
|
||||||
|
[ ">" tail? not ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
: html-self-close? ( string -- ? )
|
||||||
|
{
|
||||||
|
[ "<" head? ]
|
||||||
|
[ length 2 >= ]
|
||||||
|
[ rest strict-upper? not ]
|
||||||
|
[ [ blank? ] any? not ]
|
||||||
|
[ "/>" tail? ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
: html-full-open? ( string -- ? )
|
||||||
|
{
|
||||||
|
[ "<" head? ]
|
||||||
|
[ length 2 >= ]
|
||||||
|
[ second CHAR: / = not ]
|
||||||
|
[ rest strict-upper? not ]
|
||||||
|
[ [ blank? ] any? not ]
|
||||||
|
[ ">" tail? ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
: html-half-open? ( string -- ? )
|
||||||
|
{
|
||||||
|
[ "<" head? ]
|
||||||
|
[ length 2 >= ]
|
||||||
|
[ second CHAR: / = not ]
|
||||||
|
[ rest strict-upper? not ]
|
||||||
|
[ [ blank? ] any? not ]
|
||||||
|
[ ">" tail? not ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
: html-close? ( string -- ? )
|
||||||
|
{
|
||||||
|
[ "</" head? ]
|
||||||
|
[ length 2 >= ]
|
||||||
|
[ rest strict-upper? not ]
|
||||||
|
[ [ blank? ] any? not ]
|
||||||
|
[ ">" tail? ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
: special-acute? ( string -- ? )
|
||||||
|
{
|
||||||
|
[ section-open? ]
|
||||||
|
[ html-self-close? ]
|
||||||
|
[ html-full-open? ]
|
||||||
|
[ html-half-open? ]
|
||||||
|
[ html-close? ]
|
||||||
|
} 1|| ;
|
||||||
|
|
||||||
|
: upper-colon? ( string -- ? )
|
||||||
|
dup { [ length 0 > ] [ [ CHAR: : = ] all? ] } 1&& [
|
||||||
|
drop t
|
||||||
|
] [
|
||||||
|
{
|
||||||
|
[ length 2 >= ]
|
||||||
|
[ "\\" head? not ] ! XXX: good?
|
||||||
|
[ ":" tail? ]
|
||||||
|
[ dup [ CHAR: : = ] find drop head strict-upper? ]
|
||||||
|
} 1&&
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: section-close? ( string -- ? )
|
||||||
|
{
|
||||||
|
[ length 2 >= ]
|
||||||
|
[ "\\" head? not ] ! XXX: good?
|
||||||
|
[ ">" tail? ]
|
||||||
|
[
|
||||||
|
{
|
||||||
|
[ but-last strict-upper? ]
|
||||||
|
[ { [ ";" head? ] [ rest but-last strict-upper? ] } 1&& ]
|
||||||
|
} 1||
|
||||||
|
]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
: read-til-semicolon ( n string slice -- n' string semi )
|
||||||
|
dup '[ but-last ";" append ";" 2array { "--" ")" } append lex-colon-until ] dip
|
||||||
|
swap
|
||||||
|
! What ended the FOO: .. ; form?
|
||||||
|
! Remove the ; from the payload if present
|
||||||
|
! XXX: probably can remove this, T: is dumb
|
||||||
|
! Also in stack effects ( T: int -- ) can be ended by -- and )
|
||||||
|
dup ?last {
|
||||||
|
{ [ dup ";" sequence= ] [ drop unclip-last 3array ] }
|
||||||
|
{ [ dup ";" tail? ] [ drop unclip-last 3array ] }
|
||||||
|
{ [ dup "--" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
|
||||||
|
{ [ dup "]" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
|
||||||
|
{ [ dup "}" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
|
||||||
|
{ [ dup ")" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] } ! (n*quot) breaks
|
||||||
|
{ [ dup section-close? ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
|
||||||
|
{ [ dup upper-colon? ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
|
||||||
|
[ drop 2array ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
ERROR: colon-word-must-be-all-uppercase-or-lowercase n string word ;
|
||||||
|
: read-colon ( n string slice -- n' string colon )
|
||||||
|
{
|
||||||
|
{ [ dup strict-upper? ] [ read-til-semicolon ] }
|
||||||
|
{ [ dup ":" tail? ] [ dup ":" head? [ read-lowercase-colon ] unless ] } ! :foo: vs foo:
|
||||||
|
[ ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: read-acute-html ( n string slice -- n' string acute )
|
||||||
|
{
|
||||||
|
! <FOO <FOO:
|
||||||
|
{ [ dup section-open? ] [
|
||||||
|
[
|
||||||
|
matching-section-delimiter 1array lex-until
|
||||||
|
] keep swap unclip-last 3array
|
||||||
|
] }
|
||||||
|
! <foo/>
|
||||||
|
{ [ dup html-self-close? ] [
|
||||||
|
! do nothing special
|
||||||
|
] }
|
||||||
|
! <foo>
|
||||||
|
{ [ dup html-full-open? ] [
|
||||||
|
dup [
|
||||||
|
rest-slice
|
||||||
|
dup ">" tail? [ but-last-slice ] when
|
||||||
|
"</" ">" surround 1array lex-until unclip-last
|
||||||
|
] dip -rot 3array
|
||||||
|
] }
|
||||||
|
! <foo
|
||||||
|
{ [ dup html-half-open? ] [
|
||||||
|
! n seq slice
|
||||||
|
[ { ">" "/>" } lex-until ] dip
|
||||||
|
! n seq slice2 slice
|
||||||
|
over ">" sequence= [
|
||||||
|
"</" ">" surround array '[ _ lex-until ] dip unclip-last
|
||||||
|
-rot roll unclip-last [ 3array ] 2dip 3array
|
||||||
|
] [
|
||||||
|
! self-contained
|
||||||
|
swap unclip-last 3array
|
||||||
|
] if
|
||||||
|
] }
|
||||||
|
! </foo>
|
||||||
|
{ [ dup html-close? ] [
|
||||||
|
! Do nothing
|
||||||
|
] }
|
||||||
|
[ [ slice-til-whitespace drop ] dip span-slices ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: read-acute ( n string slice -- n' string acute )
|
||||||
|
[ matching-section-delimiter 1array lex-until ] keep swap unclip-last 3array ;
|
||||||
|
|
||||||
|
! Words like append! and suffix! are allowed for now.
|
||||||
|
: read-exclamation ( n string slice -- n' string obj )
|
||||||
|
dup { [ "!" sequence= ] [ "#!" sequence= ] } 1||
|
||||||
|
[ take-comment ] [ merge-slice-til-whitespace ] if ;
|
||||||
|
|
||||||
|
ERROR: no-backslash-payload n string slice ;
|
||||||
|
: (read-backslash) ( n string slice -- n' string obj )
|
||||||
|
merge-slice-til-whitespace dup "\\" tail? [
|
||||||
|
! \ foo, M\ foo
|
||||||
|
dup [ CHAR: \\ = ] count-tail
|
||||||
|
'[
|
||||||
|
_ [ skip-blank-from slice-til-whitespace drop ] replicate
|
||||||
|
ensure-no-false
|
||||||
|
dup [ no-backslash-payload ] unless
|
||||||
|
] dip swap 2array
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
DEFER: lex-factor-top*
|
||||||
|
: read-backslash ( n string slice -- n' string obj )
|
||||||
|
! foo\ so far, could be foo\bar{
|
||||||
|
! remove the \ and continue til delimiter/eof
|
||||||
|
[ "\"!:[{(<>\s\r\n" slice-til-either ] dip swap [ span-slices ] dip
|
||||||
|
over "\\" head? [
|
||||||
|
drop
|
||||||
|
! \ foo
|
||||||
|
dup [ CHAR: \\ = ] all? [ (read-backslash) ] [ merge-slice-til-whitespace ] if
|
||||||
|
] [
|
||||||
|
! foo\ or foo\bar (?)
|
||||||
|
over "\\" tail? [ drop (read-backslash) ] [ lex-factor-top* ] if
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
! If the slice is 0 width, we stopped on whitespace.
|
||||||
|
! Advance the index and read again!
|
||||||
|
|
||||||
|
: read-token-or-whitespace-top ( n string slice -- n' string slice/f )
|
||||||
|
dup length 0 = [ [ 1 + ] 2dip drop lex-factor-top ] when ;
|
||||||
|
|
||||||
|
: read-token-or-whitespace-nested ( n string slice -- n' string slice/f )
|
||||||
|
dup length 0 = [ [ 1 + ] 2dip drop lex-factor-nested ] when ;
|
||||||
|
|
||||||
|
: lex-factor-fallthrough ( n/f string slice/f ch/f -- n'/f string literal )
|
||||||
|
{
|
||||||
|
{ CHAR: \ [ read-backslash ] }
|
||||||
|
{ CHAR: [ [ read-bracket ] }
|
||||||
|
{ CHAR: { [ read-brace ] }
|
||||||
|
{ CHAR: ( [ read-paren ] }
|
||||||
|
{ CHAR: ] [ ] }
|
||||||
|
{ CHAR: } [ ] }
|
||||||
|
{ CHAR: ) [ ] }
|
||||||
|
{ CHAR: " [ read-string ] }
|
||||||
|
{ CHAR: ! [ read-exclamation ] }
|
||||||
|
{ CHAR: > [
|
||||||
|
[ [ CHAR: > = not ] slice-until ] dip merge-slices
|
||||||
|
dup section-close? [
|
||||||
|
[ slice-til-whitespace drop ] dip ?span-slices
|
||||||
|
] unless
|
||||||
|
] }
|
||||||
|
{ f [ ] }
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
! Inside a FOO: or a <FOO FOO>
|
||||||
|
: lex-factor-nested* ( n/f string slice/f ch/f -- n'/f string literal )
|
||||||
|
{
|
||||||
|
! Nested ``A: a B: b`` so rewind and let the parser get it top-level
|
||||||
|
{ CHAR: : [
|
||||||
|
! A: B: then interrupt the current parser
|
||||||
|
! A: b: then keep going
|
||||||
|
merge-slice-til-whitespace
|
||||||
|
dup { [ upper-colon? ] [ ":" = ] } 1||
|
||||||
|
! dup upper-colon?
|
||||||
|
[ rewind-slice f ]
|
||||||
|
[ read-colon ] if
|
||||||
|
] }
|
||||||
|
{ CHAR: < [
|
||||||
|
! FOO: a b <BAR: ;BAR>
|
||||||
|
! FOO: a b <BAR BAR>
|
||||||
|
! FOO: a b <asdf>
|
||||||
|
! FOO: a b <asdf asdf>
|
||||||
|
|
||||||
|
! if we are in a FOO: and we hit a <BAR or <BAR:
|
||||||
|
! then end the FOO:
|
||||||
|
! Don't rewind for a <foo/> or <foo></foo>
|
||||||
|
[ slice-til-whitespace drop ] dip span-slices
|
||||||
|
dup section-open? [ rewind-slice f ] when
|
||||||
|
] }
|
||||||
|
{ CHAR: \s [ read-token-or-whitespace-nested ] }
|
||||||
|
{ CHAR: \r [ read-token-or-whitespace-nested ] }
|
||||||
|
{ CHAR: \n [ read-token-or-whitespace-nested ] }
|
||||||
|
[ lex-factor-fallthrough ]
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
: lex-factor-nested ( n/f string -- n'/f string literal )
|
||||||
|
! skip-whitespace
|
||||||
|
"\"\\!:[{(]})<>\s\r\n" slice-til-either
|
||||||
|
lex-factor-nested* ; inline
|
||||||
|
|
||||||
|
: lex-factor-top* ( n/f string slice/f ch/f -- n'/f string literal )
|
||||||
|
{
|
||||||
|
{ CHAR: : [ merge-slice-til-whitespace read-colon ] }
|
||||||
|
{ CHAR: < [
|
||||||
|
! FOO: a b <BAR: ;BAR>
|
||||||
|
! FOO: a b <BAR BAR>
|
||||||
|
! FOO: a b <asdf>
|
||||||
|
! FOO: a b <asdf asdf>
|
||||||
|
|
||||||
|
! if we are in a FOO: and we hit a <BAR or <BAR:
|
||||||
|
! then end the FOO:
|
||||||
|
[ slice-til-whitespace drop ] dip span-slices
|
||||||
|
! read-acute-html
|
||||||
|
dup section-open? [ read-acute ] when
|
||||||
|
] }
|
||||||
|
|
||||||
|
{ CHAR: \s [ read-token-or-whitespace-top ] }
|
||||||
|
{ CHAR: \r [ read-token-or-whitespace-top ] }
|
||||||
|
{ CHAR: \n [ read-token-or-whitespace-top ] }
|
||||||
|
[ lex-factor-fallthrough ]
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
: lex-factor-top ( n/f string -- n'/f string literal )
|
||||||
|
! skip-whitespace
|
||||||
|
"\"\\!:[{(]})<>\s\r\n" slice-til-either
|
||||||
|
lex-factor-top* ; inline
|
||||||
|
|
||||||
|
ERROR: compound-syntax-disallowed n seq obj ;
|
||||||
|
: check-for-compound-syntax ( n/f seq obj -- n/f seq obj )
|
||||||
|
dup length 1 > [ compound-syntax-disallowed ] when ;
|
||||||
|
|
||||||
|
: check-compound-loop ( n/f string -- n/f string ? )
|
||||||
|
[ ] [ peek-from ] [ previous-from ] 2tri
|
||||||
|
[ blank? ] bi@ or not ! no blanks between tokens
|
||||||
|
pick and ; ! and a valid index
|
||||||
|
|
||||||
|
: lex-factor ( n/f string/f -- n'/f string literal/f )
|
||||||
|
[
|
||||||
|
! Compound syntax loop
|
||||||
|
[
|
||||||
|
lex-factor-top f like [ , ] when*
|
||||||
|
! concatenated syntax ( a )[ a 1 + ]( b )
|
||||||
|
check-compound-loop
|
||||||
|
] loop
|
||||||
|
] { } make
|
||||||
|
check-for-compound-syntax
|
||||||
|
! concat ! "ALIAS: n*quot (n*quot)" string>literals ... breaks here
|
||||||
|
?first f like ;
|
||||||
|
|
||||||
|
: string>literals ( string -- sequence )
|
||||||
|
[ 0 ] dip [
|
||||||
|
[ lex-factor [ , ] when* over ] loop
|
||||||
|
] { } make 2nip ;
|
||||||
|
|
||||||
|
: vocab>literals ( vocab -- sequence )
|
||||||
|
".private" ?tail drop
|
||||||
|
vocab-source-path utf8 file-contents string>literals ;
|
||||||
|
|
||||||
|
: path>literals ( path -- sequence )
|
||||||
|
utf8 file-contents string>literals ;
|
||||||
|
|
||||||
|
: lex-paths ( vocabs -- assoc )
|
||||||
|
[ [ path>literals ] [ nip ] recover ] map-zip ;
|
||||||
|
|
||||||
|
: lex-vocabs ( vocabs -- assoc )
|
||||||
|
[ [ vocab>literals ] [ nip ] recover ] map-zip ;
|
||||||
|
|
||||||
|
: failed-lexing ( assoc -- assoc' ) [ nip array? ] assoc-reject ;
|
||||||
|
|
||||||
|
: lex-core ( -- assoc ) core-bootstrap-vocabs lex-vocabs ;
|
||||||
|
: lex-basis ( -- assoc ) basis-vocabs lex-vocabs ;
|
||||||
|
: lex-extra ( -- assoc ) extra-vocabs lex-vocabs ;
|
||||||
|
: lex-roots ( -- assoc ) lex-core lex-basis lex-extra 3append ;
|
||||||
|
|
||||||
|
: lex-docs ( -- assoc ) all-docs-paths lex-paths ;
|
||||||
|
: lex-tests ( -- assoc ) all-tests-paths lex-paths ;
|
||||||
|
|
||||||
|
: lex-all ( -- assoc )
|
||||||
|
lex-roots lex-docs lex-tests 3append ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Doug Coleman
|
||||||
|
|
@ -0,0 +1,108 @@
|
||||||
|
! Copyright (C) 2017 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors arrays assocs combinators.short-circuit
|
||||||
|
constructors continuations io io.encodings.utf8 io.files
|
||||||
|
io.streams.string kernel modern modern.paths modern.slices
|
||||||
|
prettyprint sequences sequences.extras splitting strings
|
||||||
|
vocabs.loader ;
|
||||||
|
IN: modern.out
|
||||||
|
|
||||||
|
: token? ( obj -- ? )
|
||||||
|
{ [ slice? ] [ seq>> string? ] } 1&& ;
|
||||||
|
|
||||||
|
TUPLE: renamed slice string ;
|
||||||
|
CONSTRUCTOR: <renamed> renamed ( slice string -- obj ) ;
|
||||||
|
|
||||||
|
: trim-before-newline ( seq -- seq' )
|
||||||
|
dup [ char: \s = not ] find
|
||||||
|
{ char: \r char: \n } member?
|
||||||
|
[ tail-slice ] [ drop ] if ;
|
||||||
|
|
||||||
|
: write-whitespace ( last obj -- )
|
||||||
|
swap
|
||||||
|
[ swap slice-between ] [ slice-before ] if*
|
||||||
|
trim-before-newline io::write ;
|
||||||
|
|
||||||
|
GENERIC: write-literal* ( last obj -- last' )
|
||||||
|
M: slice write-literal* [ write-whitespace ] [ write ] [ ] tri ;
|
||||||
|
M: array write-literal* [ write-literal* ] each ;
|
||||||
|
M: renamed write-literal* [ slice>> write-whitespace ] [ string>> write ] [ slice>> ] tri ; ! for refactoring
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
DEFER: map-literals
|
||||||
|
: (map-literals) ( obj quot: ( obj -- obj' ) -- seq )
|
||||||
|
over [ array? ] any? [
|
||||||
|
[ call drop ] [ map-literals ] 2bi
|
||||||
|
] [
|
||||||
|
over array? [ map-literals ] [ call ] if
|
||||||
|
] if ; inline recursive
|
||||||
|
|
||||||
|
: map-literals ( obj quot: ( obj -- obj' ) -- seq )
|
||||||
|
'[ _ (map-literals) ] map ; inline recursive
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
! Start with no slice as ``last``
|
||||||
|
: write-literal ( obj -- ) f swap write-literal* drop ;
|
||||||
|
|
||||||
|
: write-modern-string ( seq -- string )
|
||||||
|
[ write-literal ] with-string-writer ; inline
|
||||||
|
|
||||||
|
: write-modern-path ( seq path -- )
|
||||||
|
utf8 [ write-literal nl ] with-file-writer ; inline
|
||||||
|
|
||||||
|
: write-modern-vocab ( seq vocab -- )
|
||||||
|
vocab-source-path write-modern-path ; inline
|
||||||
|
|
||||||
|
: rewrite-path ( path quot: ( obj -- obj' ) -- )
|
||||||
|
! dup print
|
||||||
|
'[ [ path>literals _ map-literals ] [ ] bi write-modern-path ]
|
||||||
|
[ drop . ] recover ; inline recursive
|
||||||
|
|
||||||
|
: rewrite-string ( string quot: ( obj -- obj' ) -- )
|
||||||
|
! dup print
|
||||||
|
[ string>literals ] dip map-literals write-modern-string ; inline recursive
|
||||||
|
|
||||||
|
: rewrite-paths ( seq quot: ( obj -- obj' ) -- ) '[ _ rewrite-path ] each ; inline recursive
|
||||||
|
|
||||||
|
: rewrite-vocab ( vocab quot: ( obj -- obj' ) -- )
|
||||||
|
[ [ vocab>literals ] dip map-literals ] 2keep drop write-modern-vocab ; inline recursive
|
||||||
|
|
||||||
|
: rewrite-string-exact ( string -- string' )
|
||||||
|
string>literals write-modern-string ;
|
||||||
|
|
||||||
|
![[
|
||||||
|
: rewrite-path-exact ( path -- )
|
||||||
|
[ path>literals ] [ ] bi write-modern-path ;
|
||||||
|
|
||||||
|
: rewrite-vocab-exact ( name -- )
|
||||||
|
vocab-source-path rewrite-path-exact ;
|
||||||
|
|
||||||
|
: rewrite-paths ( paths -- )
|
||||||
|
[ rewrite-path-exact ] each ;
|
||||||
|
]]
|
||||||
|
|
||||||
|
: strings-core-to-file ( -- )
|
||||||
|
core-bootstrap-vocabs
|
||||||
|
[ ".private" ?tail drop vocab-source-path utf8 file-contents ] map-zip
|
||||||
|
[ "[========[" dup matching-delimiter-string surround ] assoc-map
|
||||||
|
[
|
||||||
|
first2 [ "VOCAB: " prepend ] dip " " glue
|
||||||
|
] map
|
||||||
|
[ " " prepend ] map "\n\n" join
|
||||||
|
"<VOCAB-ROOT: factorcode-core \"https://factorcode.org/git/factor.git\" \"core/\"\n"
|
||||||
|
"\n;VOCAB-ROOT>" surround "resource:core-strings.factor" utf8 set-file-contents ;
|
||||||
|
|
||||||
|
: parsed-core-to-file ( -- )
|
||||||
|
core-bootstrap-vocabs
|
||||||
|
[ vocab>literals ] map-zip
|
||||||
|
[
|
||||||
|
first2 [ "<VOCAB: " prepend ] dip
|
||||||
|
>strings
|
||||||
|
! [ 3 head ] [ 3 tail* ] bi [ >strings ] bi@ { "..." } glue
|
||||||
|
";VOCAB>" 3array
|
||||||
|
] map 1array
|
||||||
|
|
||||||
|
{ "<VOCAB-ROOT:" "factorcode-core" "https://factorcode.org/git/factor.git" "core/" }
|
||||||
|
{ ";VOCAB-ROOT>" } surround "resource:core-parsed.factor" utf8 [ ... ] with-file-writer ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Doug Coleman
|
||||||
|
|
@ -0,0 +1,107 @@
|
||||||
|
! Copyright (C) 2015 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors combinators.smart io.files kernel sequences
|
||||||
|
splitting vocabs.files vocabs.hierarchy vocabs.loader
|
||||||
|
vocabs.metadata sets ;
|
||||||
|
IN: modern.paths
|
||||||
|
|
||||||
|
ERROR: not-a-source-path path ;
|
||||||
|
|
||||||
|
: vocabs-from ( root -- vocabs )
|
||||||
|
"" disk-vocabs-in-root/prefix
|
||||||
|
no-prefixes [ name>> ] map ;
|
||||||
|
|
||||||
|
: core-vocabs ( -- seq ) "resource:core" vocabs-from ;
|
||||||
|
: less-core-test-vocabs ( seq -- seq' )
|
||||||
|
{
|
||||||
|
"vocabs.loader.test.a"
|
||||||
|
"vocabs.loader.test.b"
|
||||||
|
"vocabs.loader.test.c"
|
||||||
|
"vocabs.loader.test.d"
|
||||||
|
"vocabs.loader.test.e"
|
||||||
|
"vocabs.loader.test.f"
|
||||||
|
"vocabs.loader.test.g"
|
||||||
|
"vocabs.loader.test.h"
|
||||||
|
"vocabs.loader.test.i"
|
||||||
|
"vocabs.loader.test.j"
|
||||||
|
"vocabs.loader.test.k"
|
||||||
|
"vocabs.loader.test.l"
|
||||||
|
"vocabs.loader.test.m"
|
||||||
|
"vocabs.loader.test.n"
|
||||||
|
"vocabs.loader.test.o"
|
||||||
|
"vocabs.loader.test.p"
|
||||||
|
} diff ;
|
||||||
|
|
||||||
|
: core-bootstrap-vocabs ( -- seq )
|
||||||
|
core-vocabs less-core-test-vocabs ;
|
||||||
|
|
||||||
|
: basis-vocabs ( -- seq ) "resource:basis" vocabs-from ;
|
||||||
|
: extra-vocabs ( -- seq ) "resource:extra" vocabs-from ;
|
||||||
|
: all-vocabs ( -- seq )
|
||||||
|
[
|
||||||
|
core-vocabs
|
||||||
|
basis-vocabs
|
||||||
|
extra-vocabs
|
||||||
|
] { } append-outputs-as ;
|
||||||
|
|
||||||
|
: filter-exists ( seq -- seq' ) [ exists? ] filter ;
|
||||||
|
|
||||||
|
! These paths have syntax errors on purpose...
|
||||||
|
: reject-some-paths ( seq -- seq' )
|
||||||
|
{
|
||||||
|
"resource:core/vocabs/loader/test/a/a.factor"
|
||||||
|
"resource:core/vocabs/loader/test/b/b.factor"
|
||||||
|
"resource:core/vocabs/loader/test/c/c.factor"
|
||||||
|
! Here down have parse errors
|
||||||
|
"resource:core/vocabs/loader/test/d/d.factor"
|
||||||
|
"resource:core/vocabs/loader/test/e/e.factor"
|
||||||
|
"resource:core/vocabs/loader/test/f/f.factor"
|
||||||
|
"resource:core/vocabs/loader/test/g/g.factor"
|
||||||
|
"resource:core/vocabs/loader/test/h/h.factor"
|
||||||
|
"resource:core/vocabs/loader/test/i/i.factor"
|
||||||
|
"resource:core/vocabs/loader/test/j/j.factor"
|
||||||
|
"resource:core/vocabs/loader/test/k/k.factor"
|
||||||
|
"resource:core/vocabs/loader/test/l/l.factor"
|
||||||
|
"resource:core/vocabs/loader/test/m/m.factor"
|
||||||
|
"resource:core/vocabs/loader/test/n/n.factor"
|
||||||
|
"resource:core/vocabs/loader/test/o/o.factor"
|
||||||
|
"resource:core/vocabs/loader/test/p/p.factor"
|
||||||
|
} diff
|
||||||
|
! Don't parse .modern files yet
|
||||||
|
[ ".modern" tail? ] reject ;
|
||||||
|
|
||||||
|
: modern-source-paths ( names -- paths )
|
||||||
|
[ vocab-source-path ] map filter-exists reject-some-paths ;
|
||||||
|
: modern-docs-paths ( names -- paths )
|
||||||
|
[ vocab-docs-path ] map filter-exists reject-some-paths ;
|
||||||
|
: modern-tests-paths ( names -- paths )
|
||||||
|
[ vocab-tests ] map concat filter-exists reject-some-paths ;
|
||||||
|
|
||||||
|
: all-source-paths ( -- seq )
|
||||||
|
all-vocabs modern-source-paths ;
|
||||||
|
|
||||||
|
: core-docs-paths ( -- seq ) core-vocabs modern-docs-paths ;
|
||||||
|
: basis-docs-paths ( -- seq ) basis-vocabs modern-docs-paths ;
|
||||||
|
: extra-docs-paths ( -- seq ) extra-vocabs modern-docs-paths ;
|
||||||
|
|
||||||
|
: core-test-paths ( -- seq ) core-vocabs modern-tests-paths ;
|
||||||
|
: basis-test-paths ( -- seq ) basis-vocabs modern-tests-paths ;
|
||||||
|
: extra-test-paths ( -- seq ) extra-vocabs modern-tests-paths ;
|
||||||
|
|
||||||
|
|
||||||
|
: all-docs-paths ( -- seq ) all-vocabs modern-docs-paths ;
|
||||||
|
: all-tests-paths ( -- seq ) all-vocabs modern-tests-paths ;
|
||||||
|
|
||||||
|
: all-paths ( -- seq )
|
||||||
|
[
|
||||||
|
all-source-paths all-docs-paths all-tests-paths
|
||||||
|
] { } append-outputs-as ;
|
||||||
|
|
||||||
|
: core-source-paths ( -- seq )
|
||||||
|
core-vocabs modern-source-paths reject-some-paths ;
|
||||||
|
: basis-source-paths ( -- seq )
|
||||||
|
basis-vocabs
|
||||||
|
modern-source-paths reject-some-paths ;
|
||||||
|
: extra-source-paths ( -- seq )
|
||||||
|
extra-vocabs
|
||||||
|
modern-source-paths reject-some-paths ;
|
||||||
|
|
@ -0,0 +1,228 @@
|
||||||
|
! Copyright (C) 2016 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors assocs fry kernel locals math sequences
|
||||||
|
sequences.deep sequences.extras strings unicode ;
|
||||||
|
IN: modern.slices
|
||||||
|
|
||||||
|
: >strings ( seq -- str )
|
||||||
|
[ dup slice? [ >string ] when ] deep-map ;
|
||||||
|
|
||||||
|
: matching-delimiter ( ch -- ch' )
|
||||||
|
H{
|
||||||
|
{ CHAR: ( CHAR: ) }
|
||||||
|
{ CHAR: [ CHAR: ] }
|
||||||
|
{ CHAR: { CHAR: } }
|
||||||
|
{ CHAR: < CHAR: > }
|
||||||
|
{ CHAR: : CHAR: ; }
|
||||||
|
} ?at drop ;
|
||||||
|
|
||||||
|
: matching-delimiter-string ( string -- string' )
|
||||||
|
[ matching-delimiter ] map ;
|
||||||
|
|
||||||
|
: matching-section-delimiter ( string -- string' )
|
||||||
|
dup ":" tail? [
|
||||||
|
rest but-last ";" ">" surround
|
||||||
|
] [
|
||||||
|
rest ">" append
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
ERROR: unexpected-end n string ;
|
||||||
|
: nth-check-eof ( n string -- nth )
|
||||||
|
2dup ?nth [ 2nip ] [ unexpected-end ] if* ;
|
||||||
|
|
||||||
|
: peek-from ( n/f string -- ch )
|
||||||
|
over [ ?nth ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
: previous-from ( n/f string -- ch )
|
||||||
|
over [ [ 1 - ] dip ?nth ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
! Allow eof
|
||||||
|
: next-char-from ( n/f string -- n'/f string ch/f )
|
||||||
|
over [
|
||||||
|
2dup ?nth [ [ 1 + ] 2dip ] [ f ] if*
|
||||||
|
] [
|
||||||
|
[ 2drop f ] [ nip ] 2bi f
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: prev-char-from-slice-end ( slice -- ch/f )
|
||||||
|
[ to>> 2 - ] [ seq>> ] bi ?nth ;
|
||||||
|
|
||||||
|
: prev-char-from-slice ( slice -- ch/f )
|
||||||
|
[ from>> 1 - ] [ seq>> ] bi ?nth ;
|
||||||
|
|
||||||
|
: next-char-from-slice ( slice -- ch/f )
|
||||||
|
[ to>> ] [ seq>> ] bi ?nth ;
|
||||||
|
|
||||||
|
: char-before-slice ( slice -- ch/f )
|
||||||
|
[ from>> 1 - ] [ seq>> ] bi ?nth ;
|
||||||
|
|
||||||
|
: char-after-slice ( slice -- ch/f )
|
||||||
|
[ to>> ] [ seq>> ] bi ?nth ;
|
||||||
|
|
||||||
|
: find-from* ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt ? )
|
||||||
|
[ find-from ] 2keep drop
|
||||||
|
pick [ drop t ] [ length -rot nip f ] if ; inline
|
||||||
|
|
||||||
|
: skip-blank-from ( n string -- n' string )
|
||||||
|
over [
|
||||||
|
[ [ blank? not ] find-from* 2drop ] keep
|
||||||
|
] when ; inline
|
||||||
|
|
||||||
|
: skip-til-eol-from ( n string -- n' string )
|
||||||
|
[ [ "\r\n" member? ] find-from* 2drop ] keep ; inline
|
||||||
|
|
||||||
|
! Don't include the whitespace in the slice
|
||||||
|
:: slice-til-whitespace ( n string -- n' string slice/f ch/f )
|
||||||
|
n [
|
||||||
|
n string [ "\s\r\n" member? ] find-from :> ( n' ch )
|
||||||
|
n' string
|
||||||
|
n n' string ?<slice>
|
||||||
|
ch
|
||||||
|
] [
|
||||||
|
f string f f
|
||||||
|
] if ; inline
|
||||||
|
|
||||||
|
:: (slice-until) ( n string quot -- n' string slice/f ch/f )
|
||||||
|
n string quot find-from :> ( n' ch )
|
||||||
|
n' string
|
||||||
|
n n' string ?<slice>
|
||||||
|
ch ; inline
|
||||||
|
|
||||||
|
: slice-until ( n string quot -- n' string slice/f )
|
||||||
|
(slice-until) drop ; inline
|
||||||
|
|
||||||
|
:: slice-til-not-whitespace ( n string -- n' string slice/f ch/f )
|
||||||
|
n [
|
||||||
|
n string [ "\s\r\n" member? not ] find-from :> ( n' ch )
|
||||||
|
n' string
|
||||||
|
n n' string ?<slice>
|
||||||
|
ch
|
||||||
|
] [
|
||||||
|
n string f f
|
||||||
|
] if ; inline
|
||||||
|
|
||||||
|
: skip-whitespace ( n/f string -- n'/f string )
|
||||||
|
slice-til-not-whitespace 2drop ;
|
||||||
|
|
||||||
|
: empty-slice-end ( seq -- slice )
|
||||||
|
[ length dup ] [ ] bi <slice> ; inline
|
||||||
|
|
||||||
|
: empty-slice-from ( n seq -- slice )
|
||||||
|
dupd <slice> ; inline
|
||||||
|
|
||||||
|
:: slice-til-eol ( n string -- n' string slice/f ch/f )
|
||||||
|
n [
|
||||||
|
n string '[ "\r\n" member? ] find-from :> ( n' ch )
|
||||||
|
n' string
|
||||||
|
n n' string ?<slice>
|
||||||
|
ch
|
||||||
|
] [
|
||||||
|
n string string empty-slice-end f
|
||||||
|
] if ; inline
|
||||||
|
|
||||||
|
:: merge-slice-til-eol-slash'' ( n string -- n' string slice/f ch/f )
|
||||||
|
n [
|
||||||
|
n string '[ "\r\n\\" member? ] find-from :> ( n' ch )
|
||||||
|
n' string
|
||||||
|
n n' string ?<slice>
|
||||||
|
ch
|
||||||
|
] [
|
||||||
|
n string string empty-slice-end f
|
||||||
|
] if ; inline
|
||||||
|
|
||||||
|
: merge-slice-til-whitespace ( n string slice -- n' string slice' )
|
||||||
|
pick [
|
||||||
|
[ slice-til-whitespace drop ] dip merge-slices
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
: merge-slice-til-eol ( n string slice -- n' string slice' )
|
||||||
|
[ slice-til-eol drop ] dip merge-slices ;
|
||||||
|
|
||||||
|
: slice-between ( slice1 slice2 -- slice )
|
||||||
|
! ensure-same-underlying
|
||||||
|
slice-order-by-from
|
||||||
|
[ to>> ]
|
||||||
|
[ [ from>> 2dup < [ swap ] unless ] [ seq>> ] bi ] bi* <slice> ;
|
||||||
|
|
||||||
|
: slice-before ( slice -- slice' )
|
||||||
|
[ drop 0 ] [ from>> ] [ seq>> ] tri <slice> ;
|
||||||
|
|
||||||
|
: (?nth) ( n/f string/f -- obj/f )
|
||||||
|
over [ (?nth) ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
:: merge-slice-til-eol-slash' ( n string slice -- n' string slice/f ch/f )
|
||||||
|
n string merge-slice-til-eol-slash'' :> ( n' string' slice' ch' )
|
||||||
|
ch' CHAR: \\ = [
|
||||||
|
n' 1 + string' (?nth) "\r\n" member? [
|
||||||
|
n' 2 + string' slice slice' span-slices merge-slice-til-eol-slash'
|
||||||
|
] [
|
||||||
|
"omg" throw
|
||||||
|
] if
|
||||||
|
] [
|
||||||
|
n' string' slice slice' span-slices ch'
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
! Supports \ at eol (with no space after it)
|
||||||
|
: slice-til-eol-slash ( n string -- n' string slice/f ch/f )
|
||||||
|
2dup empty-slice-from merge-slice-til-eol-slash' ;
|
||||||
|
|
||||||
|
:: slice-til-separator-inclusive ( n string tokens -- n' string slice/f ch/f )
|
||||||
|
n string '[ tokens member? ] find-from [ dup [ 1 + ] when ] dip :> ( n' ch )
|
||||||
|
n' string
|
||||||
|
n n' string ?<slice>
|
||||||
|
ch ; inline
|
||||||
|
|
||||||
|
: slice-til-separator-exclusive ( n string tokens -- n' string slice/f ch/f )
|
||||||
|
slice-til-separator-inclusive dup [
|
||||||
|
[ [ 1 - ] change-to ] dip
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
! Takes at least one character if not whitespace
|
||||||
|
:: slice-til-either ( n string tokens -- n'/f string slice/f ch/f )
|
||||||
|
n [
|
||||||
|
n string '[ tokens member? ] find-from
|
||||||
|
dup "\s\r\n" member? [
|
||||||
|
:> ( n' ch )
|
||||||
|
n' string
|
||||||
|
n n' string ?<slice>
|
||||||
|
ch
|
||||||
|
] [
|
||||||
|
[ dup [ 1 + ] when ] dip :> ( n' ch )
|
||||||
|
n' string
|
||||||
|
n n' string ?<slice>
|
||||||
|
ch
|
||||||
|
] if
|
||||||
|
] [
|
||||||
|
f string f f
|
||||||
|
] if ; inline
|
||||||
|
|
||||||
|
ERROR: subseq-expected-but-got-eof n string expected ;
|
||||||
|
|
||||||
|
:: slice-til-string ( n string search -- n' string payload end-string )
|
||||||
|
search string n subseq-start-from :> n'
|
||||||
|
n' [ n string search subseq-expected-but-got-eof ] unless
|
||||||
|
n' search length + string
|
||||||
|
n n' string ?<slice>
|
||||||
|
n' dup search length + string ?<slice> ;
|
||||||
|
|
||||||
|
: modify-from ( slice n -- slice' )
|
||||||
|
'[ from>> _ + ] [ to>> ] [ seq>> ] tri <slice> ;
|
||||||
|
|
||||||
|
: modify-to ( slice n -- slice' )
|
||||||
|
[ [ from>> ] [ to>> ] [ seq>> ] tri ] dip
|
||||||
|
swap [ + ] dip <slice> ;
|
||||||
|
|
||||||
|
! { CHAR: \] [ read-closing ] }
|
||||||
|
! { CHAR: \} [ read-closing ] }
|
||||||
|
! { CHAR: \) [ read-closing ] }
|
||||||
|
: read-closing ( n string tok -- n string tok )
|
||||||
|
dup length 1 = [
|
||||||
|
-1 modify-to [ 1 - ] 2dip
|
||||||
|
] unless ;
|
||||||
|
|
||||||
|
: rewind-slice ( n string slice -- n' string )
|
||||||
|
pick [
|
||||||
|
length swap [ - ] dip
|
||||||
|
] [
|
||||||
|
[ nip ] dip [ [ length ] bi@ - ] 2keep drop
|
||||||
|
] if ; inline
|
||||||
Loading…
Reference in New Issue