diff --git a/basis/present/present-tests.factor b/basis/present/present-tests.factor index 96aa7b24f2..022ae9d6d9 100644 --- a/basis/present/present-tests.factor +++ b/basis/present/present-tests.factor @@ -5,4 +5,4 @@ USING: tools.test vocabs.hierarchy present math vocabs sequences kernel ; [ "Hi" ] [ "Hi" present ] unit-test [ "+" ] [ \ + present ] unit-test [ "kernel" ] [ "kernel" vocab present ] unit-test -[ ] [ all-vocabs-recursive no-roots no-prefixes [ present ] map drop ] unit-test \ No newline at end of file +[ ] [ all-vocabs-recursive filter-vocabs [ present ] map drop ] unit-test diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index e0a43927ba..c2265b2981 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -90,7 +90,7 @@ PRIVATE> all-words name-completions ; : vocabs-matching ( str -- seq ) - all-vocabs-recursive no-roots no-prefixes name-completions ; + all-vocabs-recursive filter-vocabs name-completions ; : chars-matching ( str -- seq ) name-map keys dup zip completions ; diff --git a/basis/vocabs/files/files.factor b/basis/vocabs/files/files.factor index 1c3e3731bd..4739fc80da 100644 --- a/basis/vocabs/files/files.factor +++ b/basis/vocabs/files/files.factor @@ -5,7 +5,7 @@ sequences vocabs.loader ; IN: vocabs.files : vocab-tests-file ( vocab -- path ) - dup "-tests.factor" vocab-dir+ vocab-append-path dup + dup "-tests.factor" append-vocab-dir vocab-append-path dup [ dup exists? [ drop f ] unless ] [ drop f ] if ; : vocab-tests-dir ( vocab -- paths ) diff --git a/basis/vocabs/hierarchy/hierarchy-docs.factor b/basis/vocabs/hierarchy/hierarchy-docs.factor index fee3fd30e0..09e3808e5a 100644 --- a/basis/vocabs/hierarchy/hierarchy-docs.factor +++ b/basis/vocabs/hierarchy/hierarchy-docs.factor @@ -1,13 +1,16 @@ -USING: help.markup help.syntax strings vocabs.loader ; +USING: help.markup help.syntax strings vocabs.loader +sequences ; IN: vocabs.hierarchy ARTICLE: "vocabs.hierarchy" "Vocabulary hierarchy tools" -"These tools operate on all vocabularies found in the current set of " { $link vocab-roots } ", loaded or not." +"These tools operate on all vocabularies found in the current set of " { $link vocab-roots } ", loaded or not. A prefix is the first part of a vocabulary name." $nl "Loading vocabulary hierarchies:" { $subsections load load-all + load-root + load-from-root } "Getting all vocabularies from disk:" { $subsections @@ -23,6 +26,7 @@ $nl { $subsections no-roots no-prefixes + filter-vocabs } "Getting " { $link "vocabs.metadata" } " for all vocabularies from disk:" { $subsections @@ -40,3 +44,14 @@ HELP: load HELP: load-all { $description "Load all vocabularies in the source tree." } ; +HELP: load-from-root +{ $values + { "root" "a vocaulary root" } { "prefix" string } +} +{ $description "Attempts to load all of the vocabularies with a certain prefix from a vocabulary root." } ; + +HELP: load-root +{ $values + { "root" "a vocabulary root" } +} +{ $description "Attempts to load all of the vocabularies in a vocabulary root." } ; diff --git a/basis/vocabs/hierarchy/hierarchy.factor b/basis/vocabs/hierarchy/hierarchy.factor index 609d485f0c..d3436d7dba 100644 --- a/basis/vocabs/hierarchy/hierarchy.factor +++ b/basis/vocabs/hierarchy/hierarchy.factor @@ -24,21 +24,30 @@ M: vocab-prefix vocab-name name>> ; : vocab-dir? ( root name -- ? ) over - [ ".factor" vocab-dir+ append-path exists? ] + [ ".factor" append-vocab-dir append-path exists? ] [ 2drop f ] if ; +ERROR: vocab-root-required root ; + +: ensure-vocab-root ( root -- root ) + dup vocab-roots get member? [ vocab-root-required ] unless ; + +: ensure-vocab-root/prefix ( root prefix -- root prefix ) + [ ensure-vocab-root ] [ forbid-absolute-path ] bi* ; + : (child-vocabs) ( root prefix -- vocabs ) + ensure-vocab-root/prefix [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ] [ nip [ '[ [ _ "." ] dip 3append ] map ] unless-empty ] [ drop '[ _ over vocab-dir? [ >vocab-link ] [ ] if ] map ] 2tri ; -: ((child-vocabs-recursive)) ( root name -- ) +: ((child-vocabs-recursive)) ( root prefix -- ) dupd vocab-name (child-vocabs) [ dup , ((child-vocabs-recursive)) ] with each ; -: (child-vocabs-recursive) ( root name -- seq ) +: (child-vocabs-recursive) ( root prefix -- seq ) [ ((child-vocabs-recursive)) ] { } make ; : no-rooted ( seq -- seq' ) [ find-vocab-root not ] filter ; @@ -73,6 +82,9 @@ PRIVATE> : no-roots ( assoc -- seq ) values concat ; +: filter-vocabs ( assoc -- seq ) + no-roots no-prefixes members ; + : child-vocabs ( prefix -- assoc ) [ [ vocab-roots get ] dip '[ dup _ (child-vocabs) ] { } map>assoc ] [ unrooted-child-vocabs [ vocab ] map f swap 2array ] @@ -90,27 +102,49 @@ MEMO: all-vocabs-recursive ( -- assoc ) "" child-vocabs-recursive ; : all-vocab-names ( -- seq ) - all-vocabs-recursive no-roots no-prefixes [ vocab-name ] map ; + all-vocabs-recursive filter-vocabs [ vocab-name ] map ; : child-vocab-names ( prefix -- seq ) - child-vocabs no-roots no-prefixes [ vocab-name ] map ; + child-vocabs filter-vocabs [ vocab-name ] map ; vocab-link ] [ drop f ] if ; + PRIVATE> -: (load) ( prefix -- failures ) - [ child-vocabs-recursive no-roots no-prefixes ] - [ dup find-vocab-root [ >vocab-link prefix ] [ drop ] if ] bi - filter-don't-load +: vocabs-in-root/prefix ( root prefix -- seq ) + [ (child-vocabs-recursive) ] + [ maybe-include-root/prefix [ prefix ] when* ] 2bi ; + +: vocabs-in-root ( root -- seq ) + "" vocabs-in-root/prefix ; + +: (load-from-root) ( root prefix -- failures ) + vocabs-in-root/prefix + [ don't-load? not ] filter no-prefixes require-all ; +: load-from-root ( root prefix -- ) + (load-from-root) load-failures. ; + +: load-root ( root -- ) + "" load-from-root ; + +: (load) ( prefix -- failures ) + [ vocab-roots get ] dip '[ _ (load-from-root) ] map concat ; + : load ( prefix -- ) - (load) load-failures. ; + (load) [ load-failures. ] each ; : load-all ( -- ) "" load ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 6df810359d..c0995205e4 100644 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -45,23 +45,28 @@ PRIVATE> : vocab-dir ( vocab -- dir ) vocab-name { { CHAR: . CHAR: / } } substitute ; -: vocab-dir+ ( vocab str/f -- path ) - [ vocab-name "." split ] dip +ERROR: absolute-path-forbidden path ; + +: forbid-absolute-path ( str -- str ) + dup absolute-path? [ absolute-path-forbidden ] when ; + +: append-vocab-dir ( vocab str/f -- path ) + [ vocab-name forbid-absolute-path "." split ] dip [ [ dup last ] dip append suffix ] when* "/" join ; : find-vocab-root ( vocab -- path/f ) vocab-name dup root-cache get at - [ ] [ ".factor" vocab-dir+ find-root-for ] ?if ; + [ ] [ ".factor" append-vocab-dir find-root-for ] ?if ; : vocab-append-path ( vocab path -- newpath ) swap find-vocab-root dup [ prepend-path ] [ 2drop f ] if ; : vocab-source-path ( vocab -- path/f ) - dup ".factor" vocab-dir+ vocab-append-path ; + dup ".factor" append-vocab-dir vocab-append-path ; : vocab-docs-path ( vocab -- path/f ) - dup "-docs.factor" vocab-dir+ vocab-append-path ; + dup "-docs.factor" append-vocab-dir vocab-append-path ; SYMBOL: load-help? diff --git a/core/vocabs/vocabs-tests.factor b/core/vocabs/vocabs-tests.factor index ec486e3a5a..18e6b37101 100644 --- a/core/vocabs/vocabs-tests.factor +++ b/core/vocabs/vocabs-tests.factor @@ -8,6 +8,3 @@ IN: vocabs.tests [ t ] [ "" "io.files" child-vocab? ] unit-test [ t ] [ "io" "io.files" child-vocab? ] unit-test [ f ] [ "io.files" "io" child-vocab? ] unit-test - -[ t ] [ "io.files" "io" parent-vocab? ] unit-test -[ f ] [ "io" "io.files" parent-vocab? ] unit-test diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index f023472c68..38881673e9 100644 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -111,12 +111,6 @@ ERROR: no-vocab name ; : child-vocabs ( vocab -- seq ) vocab-name vocabs [ child-vocab? ] with filter ; -: parent-vocab? ( suffix name -- ? ) - swap child-vocab? ; - -: parent-vocabs ( vocab -- seq ) - vocab-name vocabs [ parent-vocab? ] with filter ; - GENERIC: >vocab-link ( name -- vocab ) M: vocab-spec >vocab-link ; diff --git a/extra/readline-listener/readline-listener.factor b/extra/readline-listener/readline-listener.factor index 9f23b8ef36..d1c418fecb 100644 --- a/extra/readline-listener/readline-listener.factor +++ b/extra/readline-listener/readline-listener.factor @@ -23,7 +23,7 @@ M: readline-reader prompt. all-words [ name>> ] map ; : vocab-names ( -- strs ) - all-vocabs-recursive no-roots no-prefixes [ name>> ] map ; + all-vocabs-recursive filter-vocabs [ name>> ] map ; : prefixed-words ( prefix -- words ) '[ _ head? ] word-names swap filter ;