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

modern: Trying to get a using list graph.

modern-harvey3
Doug Coleman 2019-11-02 14:59:55 -05:00
parent b049b0919c
commit c279cf6a70
5 changed files with 66 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
extra/modern/manifest/manifest.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2019 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators
combinators.short-circuit kernel modern sequences
splitting.monotonic strings words ;
combinators.short-circuit kernel modern modern.compiler
sequences splitting.monotonic strings words ;
IN: modern.manifest
MIXIN: token
@ -228,27 +228,3 @@ GENERIC: upper-colon>definitions ( form -- seq )
{ [ dup ?first upper-colon? ] [ upper-colon>definitions ] }
[ ]
} cond ;
DEFER: map-literals
: map-literal ( obj quot: ( obj -- obj' ) -- obj )
over { [ array? ] [ ?first section-open? ] } 1&& [
[ first3 swap ] dip map-literals swap 3array
] [
call
] if ; inline recursive
: map-literals ( seq quot: ( obj -- obj' ) -- seq' )
'[ _ map-literal ] map ; inline recursive
DEFER: map-literals!
: map-literal! ( obj quot: ( obj -- obj' ) -- obj )
over { [ array? ] [ ?first section-open? ] } 1&& [
[ call drop ] [
map-literals!
] 2bi
] [
call
] if ; inline recursive
: map-literals! ( seq quot: ( obj -- obj' ) -- seq )
'[ _ map-literal! ] map! ; inline recursive

17
extra/modern/modern.factor
View File

@ -66,8 +66,7 @@ DEFER: lex-factor
] loop
] { } make ;
DEFER: section-close?
DEFER: upper-colon?
DEFER: section-close-form?
DEFER: lex-factor-nested
: lex-colon-until ( string n tag-sequence -- string n' payload )
'[
@ -77,7 +76,7 @@ DEFER: lex-factor-nested
[
dup [
! This is for ending COLON: forms like ``A: PRIVATE>``
dup section-close? [
dup section-close-form? [
drop f
] [
! } gets a chance, but then also full seq { } after recursion...
@ -249,7 +248,7 @@ MACRO:: read-matched ( ch -- quot: ( string n tag -- string n' slice' ) )
[ html-close? ]
} 1|| ;
: upper-colon? ( string -- ? )
: upper-colon-form? ( string -- ? )
dup { [ length 0 > ] [ [ char: \: = ] all? ] } 1&& [
drop t
] [
@ -261,7 +260,7 @@ MACRO:: read-matched ( ch -- quot: ( string n tag -- string n' slice' ) )
} 1&&
] if ;
: section-close? ( string -- ? )
: section-close-form? ( string -- ? )
{
[ length 2 >= ]
[ "\\" head? not ] ! XXX: good?
@ -290,8 +289,8 @@ MACRO:: read-matched ( ch -- quot: ( string n tag -- string n' slice' ) )
{ [ dup "]" sequence= ] [ drop unclip-last -rot 2array <upper-colon> [ rewind-slice ] dip ] }
{ [ dup "}" sequence= ] [ drop unclip-last -rot 2array <upper-colon> [ rewind-slice ] dip ] }
{ [ dup ")" sequence= ] [ drop unclip-last -rot 2array <upper-colon> [ rewind-slice ] dip ] } ! (n*quot) breaks
{ [ dup section-close? ] [ drop unclip-last -rot 2array <upper-colon> [ rewind-slice ] dip ] }
{ [ dup upper-colon? ] [ drop unclip-last -rot 2array <upper-colon> [ rewind-slice ] dip ] }
{ [ dup section-close-form? ] [ drop unclip-last -rot 2array <upper-colon> [ rewind-slice ] dip ] }
{ [ dup upper-colon-form? ] [ drop unclip-last -rot 2array <upper-colon> [ rewind-slice ] dip ] }
[ drop 2array <upper-colon> ]
} cond ;
@ -415,7 +414,7 @@ DEFER: lex-factor-top*
{ char: \! [ read-exclamation ] }
{ char: > [
[ [ char: > = not ] slice-until-exclude drop ] dip merge-slices
dup section-close? [
dup section-close-form? [
[ slice-til-whitespace drop ] dip ?span-slices
] unless
] }
@ -432,7 +431,7 @@ DEFER: lex-factor-top*
! A: B: then interrupt the current parser
! A: b: then keep going
merge-slice-til-whitespace
dup { [ upper-colon? ] [ ":" = ] } 1||
dup { [ upper-colon-form? ] [ ":" = ] } 1||
! dup upper-colon?
[ rewind-slice f ]
[ read-colon ] if

27
extra/modern/out/out.factor
View File

@ -30,6 +30,7 @@ M: renamed write-literal*
[ slice>> ] tri ; ! for refactoring
: write-literal ( obj -- ) f swap write-literal* drop ;
![[
DEFER: map-literals
: (map-literals) ( obj quot: ( obj -- obj' ) -- seq )
over array? [
@ -41,6 +42,32 @@ DEFER: map-literals
: map-literals ( obj quot: ( obj -- obj' ) -- seq )
'[ _ (map-literals) ] map ; inline recursive
]]
DEFER: map-literals
: map-literal ( obj quot: ( ..a obj -- ..a obj' ) -- obj )
over section? [
[ second ] dip map-literals
] [
call
] if ; inline recursive
: map-literals ( seq quot: ( ..a obj -- ..a obj' ) -- seq' )
'[ _ map-literal ] map ; inline recursive
DEFER: map-literals!
: map-literal! ( obj quot: ( obj -- obj' ) -- obj )
over { [ array? ] [ ?first section-open? ] } 1&& [
[ call drop ] [
map-literals!
] 2bi
] [
call
] if ; inline recursive
: map-literals! ( seq quot: ( obj -- obj' ) -- seq )
'[ _ map-literal! ] map! ; inline recursive
: write-modern-string ( seq -- string )
[ write-literal ] with-string-writer ; inline

1
extra/modern/tools/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

28
extra/modern/tools/tools.factor Normal file
View File

@ -0,0 +1,28 @@
! Copyright (C) 2019 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs combinators.short-circuit kernel modern
modern.compiler modern.out modern.slices sequences
sequences.extras ;
IN: modern.tools
: vocabs>using-tool ( vocabs -- assoc )
[ vocab>literals ] map-zip
[
[
{ [ upper-colon? ] [ first "USING:" sequence= ] } 1&&
] filter
[ second >strings ] map
] assoc-map ;
! Needs filter-literals
: vocabs>using-tool2 ( vocabs -- assoc )
[ vocab>literals ] map-zip
[
[
dup { [ upper-colon? ] [ first "USING:" sequence= ] } 1&& [
second >strings
] [
drop f
] if
] map-literals harvest concat harvest
] assoc-map ;