add scaffold tool
Doug Coleman
parent
8ebb7f9be7
commit
7d3851ec48
|
|
@ -0,0 +1,177 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs io.files hashtables kernel namespaces sequences
|
||||
vocabs.loader io combinators io.encodings.utf8 calendar accessors
|
||||
math.parser io.streams.string ui.tools.operations quotations
|
||||
strings arrays prettyprint words vocabs sorting combinators.lib ;
|
||||
IN: tools.scaffold
|
||||
|
||||
SYMBOL: developer-name
|
||||
|
||||
ERROR: not-a-vocab-root string ;
|
||||
|
||||
: root? ( str -- ? )
|
||||
vocab-roots get member? ;
|
||||
|
||||
ERROR: vocab-name-contains-separator path ;
|
||||
ERROR: vocab-name-contains-dot path ;
|
||||
: check-vocab-name ( str -- str )
|
||||
dup dup [ CHAR: . = ] trim [ length ] bi@ =
|
||||
[ vocab-name-contains-dot ] unless
|
||||
|
||||
".." over subseq? [ vocab-name-contains-dot ] when
|
||||
|
||||
dup [ path-separator? ] contains?
|
||||
[ vocab-name-contains-separator ] when ;
|
||||
|
||||
: check-root ( str -- str )
|
||||
check-vocab-name
|
||||
dup "resource:" head? [ "resource:" prepend ] unless
|
||||
dup root? [ not-a-vocab-root ] unless ;
|
||||
|
||||
: directory-exists ( path -- )
|
||||
"Not creating a directory, it already exists: " write print ;
|
||||
|
||||
: scaffold-directory ( path -- )
|
||||
dup exists? [ directory-exists ] [ make-directories ] if ;
|
||||
|
||||
: not-scaffolding ( path -- )
|
||||
"Not creating scaffolding for " write <pathname> . ;
|
||||
|
||||
: scaffolding ( path -- )
|
||||
"Creating scaffolding for " write <pathname> . ;
|
||||
|
||||
: scaffold-path ( path suffix -- path ? )
|
||||
dupd [ file-name ] dip append append-path
|
||||
dup exists? [ dup not-scaffolding f ] [ dup scaffolding t ] if ;
|
||||
|
||||
: scaffold-copyright ( -- )
|
||||
"! Copyright (C) " write now year>> number>string write
|
||||
developer-name get [ "Your name" ] unless* bl write "." print
|
||||
"! See http://factorcode.org/license.txt for BSD license." print ;
|
||||
|
||||
: main-file-string ( vocab -- str )
|
||||
[
|
||||
scaffold-copyright
|
||||
"USING: ;" print
|
||||
"IN: " write print
|
||||
] with-string-writer ;
|
||||
|
||||
: set-scaffold-main-file ( path vocab -- )
|
||||
main-file-string swap utf8 set-file-contents ;
|
||||
|
||||
: scaffold-main ( path vocab -- )
|
||||
[ ".factor" scaffold-path ] dip
|
||||
swap [ set-scaffold-main-file ] [ 2drop ] if ;
|
||||
|
||||
: tests-file-string ( vocab -- str )
|
||||
[
|
||||
scaffold-copyright
|
||||
"USING: tools.test " write dup write " ;" print
|
||||
"IN: " write write ".tests" print
|
||||
] with-string-writer ;
|
||||
|
||||
: set-scaffold-tests-file ( path vocab -- )
|
||||
tests-file-string swap utf8 set-file-contents ;
|
||||
|
||||
: scaffold-tests ( path vocab -- )
|
||||
[ "-tests.factor" scaffold-path ] dip
|
||||
swap [ set-scaffold-tests-file ] [ 2drop ] if ;
|
||||
|
||||
: scaffold-authors ( path -- )
|
||||
"authors.txt" append-path dup exists? [
|
||||
not-scaffolding
|
||||
] [
|
||||
dup scaffolding
|
||||
developer-name get swap utf8 set-file-contents
|
||||
] if ;
|
||||
|
||||
: lookup-type ( string -- object/string ? )
|
||||
H{
|
||||
{ "obj" object }
|
||||
{ "obj1" object }
|
||||
{ "obj2" object }
|
||||
{ "obj3" object }
|
||||
{ "obj4" object }
|
||||
{ "quot" quotation }
|
||||
{ "quot1" quotation }
|
||||
{ "quot2" quotation }
|
||||
{ "quot3" quotation }
|
||||
{ "str" string }
|
||||
{ "str1" string }
|
||||
{ "str2" string }
|
||||
{ "str3" string }
|
||||
{ "hashtable" hashtable }
|
||||
{ "?" "a boolean" }
|
||||
{ "ch" "a character" }
|
||||
} at* ;
|
||||
|
||||
: ($values.) ( array -- )
|
||||
[
|
||||
" { " write
|
||||
dup array? [ first ] when
|
||||
dup lookup-type [
|
||||
[ unparse write bl ]
|
||||
[ dup string? [ unparse write ] [ pprint ] if ] bi*
|
||||
] [
|
||||
drop unparse write
|
||||
] if
|
||||
" }" write
|
||||
] each ;
|
||||
|
||||
: $values. ( word -- )
|
||||
"declared-effect" word-prop [
|
||||
"{ $values" print
|
||||
[ in>> ] [ out>> ] bi
|
||||
[ " " write ($values.) nl ] bi@
|
||||
"}" write nl
|
||||
] when* ;
|
||||
|
||||
: $description. ( word -- )
|
||||
drop
|
||||
"{ $description } ;" print ;
|
||||
|
||||
: help-header. ( word -- )
|
||||
"HELP: " write name>> print ;
|
||||
|
||||
: help. ( word -- )
|
||||
[ help-header. ] [ $values. ] [ $description. ] tri ;
|
||||
|
||||
: help-file-string ( str1 -- str2 )
|
||||
[
|
||||
scaffold-copyright
|
||||
[
|
||||
"USING: help.markup help.syntax ;" print
|
||||
"IN: " write print nl
|
||||
]
|
||||
[ words natural-sort [ help. nl ] each ]
|
||||
[ "ARTICLE: " write unparse dup write bl print ";" print nl ]
|
||||
[ "ABOUT: " write unparse print ] quad
|
||||
] with-string-writer ;
|
||||
|
||||
: set-scaffold-help-file ( path vocab -- )
|
||||
help-file-string swap utf8 set-file-contents ;
|
||||
|
||||
: check-scaffold ( vocab-root str -- vocab-root str )
|
||||
[ check-root ] [ check-vocab-name ] bi* ;
|
||||
|
||||
: vocab>scaffold-path ( vocab-root str -- path )
|
||||
path-separator first CHAR: . associate substitute
|
||||
append-path ;
|
||||
|
||||
: prepare-scaffold ( vocab-root str -- str path )
|
||||
check-scaffold [ vocab>scaffold-path ] keep ;
|
||||
|
||||
: scaffold-help ( vocab-root str -- )
|
||||
prepare-scaffold
|
||||
[ "-docs.factor" scaffold-path ] dip
|
||||
swap [ set-scaffold-help-file ] [ 2drop ] if ;
|
||||
|
||||
: scaffold-vocab ( vocab-root str -- )
|
||||
prepare-scaffold
|
||||
{
|
||||
[ drop scaffold-directory ]
|
||||
[ scaffold-main ]
|
||||
[ scaffold-tests ]
|
||||
[ drop scaffold-authors ]
|
||||
} 2cleave ;
|
||||
Loading…
Reference in New Issue