! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien arrays assocs byte-arrays calendar
-classes combinators combinators.short-circuit fry hashtables
-help.markup interpolate io io.directories io.encodings.utf8
-io.files io.pathnames io.streams.string kernel math math.parser
-namespaces prettyprint quotations sequences sets sorting
-splitting strings system timers unicode.categories urls vocabs
-vocabs.loader vocabs.metadata words words.symbol ;
+classes classes.error combinators combinators.short-circuit
+continuations eval hashtables help.markup interpolate io
+io.directories io.encodings.utf8 io.files io.pathnames
+io.streams.string kernel math math.parser namespaces prettyprint
+quotations sequences sets sorting splitting strings system
+timers unicode urls vocabs vocabs.loader vocabs.metadata words
+words.symbol ;
IN: tools.scaffold
SYMBOL: developer-name
ERROR: not-a-vocab-root string ;
+ERROR: vocab-must-not-exist string ;
+
<PRIVATE
: vocab-root? ( string -- ? )
- trim-tail-separators
- vocab-roots get member? ;
-
-: contains-dot? ( string -- ? ) ".." swap subseq? ;
-
-: contains-separator? ( string -- ? ) [ path-separator? ] any? ;
+ trim-tail-separators vocab-roots get member? ;
: ensure-vocab-exists ( string -- string )
- dup loaded-vocab-names member? [ no-vocab ] unless ;
+ dup lookup-vocab [ no-vocab ] unless ;
-: check-root ( string -- string )
+: check-vocab-root ( string -- string )
dup vocab-root? [ not-a-vocab-root ] unless ;
-: check-vocab-root/vocab ( vocab-root string -- vocab-root string )
- [ check-root ] [ check-vocab-name ] bi* ;
+: check-vocab-root/name ( vocab-root string -- vocab-root string )
+ [ check-vocab-root ] [ check-vocab-name ] bi* ;
: replace-vocab-separators ( vocab -- path )
- path-separator first CHAR: . associate substitute ; inline
+ path-separator first CHAR: . associate substitute ;
: vocab-root/vocab>path ( vocab-root vocab -- path )
- check-vocab-root/vocab
+ check-vocab-root/name
[ ] [ replace-vocab-separators ] bi* append-path ;
: vocab>path ( vocab -- path )
- check-vocab
- [ find-vocab-root ] keep vocab-root/vocab>path ;
+ check-vocab [ find-vocab-root ] keep vocab-root/vocab>path ;
: vocab-root/vocab/file>path ( vocab-root vocab file -- path )
[ vocab-root/vocab>path ] dip append-path ;
: scaffold-directory ( vocab-root vocab -- )
vocab-root/vocab>path
- dup exists? [ directory-exists ] [ make-directories ] if ;
+ dup file-exists? [ directory-exists ] [ make-directories ] if ;
: not-scaffolding ( path -- path )
"Not creating scaffolding for " write dup <pathname> . ;
"Creating scaffolding for " write dup <pathname> . ;
: scaffolding? ( path -- path ? )
- dup exists? [ not-scaffolding f ] [ scaffolding t ] if ;
+ dup file-exists? [ not-scaffolding f ] [ scaffolding t ] if ;
: scaffold-copyright ( -- )
"! Copyright (C) " write now year>> number>string write
{ "vocab-root" "a vocabulary root string" }
{ "c-ptr" c-ptr }
{ "sequence" sequence }
+ { "slice" slice }
+ { "from" integer }
+ { "to" integer }
+ { "i" integer }
+ { "n" integer }
{ "seq" sequence }
{ "exemplar" object }
{ "assoc" assoc }
{ "alist" "an array of key/value pairs" }
- { "keys" sequence } { "values" sequence }
- { "class" class } { "tuple" tuple }
+ { "keys" sequence }
+ { "values" sequence }
+ { "class" class }
+ { "tuple" tuple }
{ "url" url }
} at* [ swap [ \ $maybe swap 2array ] when ] dip ;
M: string add-using drop ;
-M: object add-using ( object -- )
+M: object add-using
vocabulary>> using get [ adjoin ] [ drop ] if* ;
-: 4bl ( -- )
- " " write ; inline
-
: ($values.) ( array -- )
[
- 4bl
+ " " write
[ bl ] [
"{ " write
dup array? [ first ] when
[ unparse write bl ]
[ [ pprint ] [ add-using ] bi ] bi*
] [
- drop unparse write bl null pprint
- null add-using
+ drop unparse write bl object pprint
+ object add-using
] if
" }" write
] interleave
] if
] when* ;
+: error-description. ( word -- )
+ [ $values. ] [
+ "{ $description \"Throws " write
+ name>> dup a/an write " \" { $link " write
+ write " } \" error.\" }" print
+ ] bi "{ $error-description \"\" } ;" print ;
+
+: class-description. ( word -- )
+ drop "{ $class-description \"\" } ;" print ;
+
: symbol-description. ( word -- )
- drop
- "{ $var-description \"\" } ;" print ;
+ drop "{ $var-description \"\" } ;" print ;
: $description. ( word -- )
- drop
- "{ $description \"\" } ;" print ;
+ drop "{ $description \"\" } ;" print ;
: docs-body. ( word/symbol -- )
- dup symbol? [
- symbol-description.
- ] [
- [ $values. ] [ $description. ] bi
- ] if ;
+ {
+ { [ dup error-class? ] [ error-description. ] }
+ { [ dup class? ] [ class-description. ] }
+ { [ dup symbol? ] [ symbol-description. ] }
+ [ [ $values. ] [ $description. ] bi ]
+ } cond ;
: docs-header. ( word -- )
"HELP: " write name>> print ;
[ HS{ } clone using ] dip with-variable ; inline
: link-vocab ( vocab -- )
+ ".private" ?tail drop
check-vocab
"Edit documentation: " write
"-docs.factor" vocab/suffix>path <pathname> . ;
: scaffold-platforms ( vocab platforms -- )
[ "platforms.txt" ] dip scaffold-metadata ;
-: scaffold-vocab ( vocab-root string -- )
+: delete-from-root-cache ( string -- )
+ root-cache get delete-at ;
+
+: scaffold-vocab-in ( vocab-root string -- )
+ dup delete-from-root-cache
{
[ scaffold-directory ]
[ scaffold-main ]
[ nip scaffold-authors ]
} 2cleave ;
-: scaffold-core ( string -- ) "resource:core" swap scaffold-vocab ;
+: scaffold-core ( string -- )
+ "resource:core" swap scaffold-vocab-in ;
-: scaffold-basis ( string -- ) "resource:basis" swap scaffold-vocab ;
+: scaffold-basis ( string -- )
+ "resource:basis" swap scaffold-vocab-in ;
-: scaffold-extra ( string -- ) "resource:extra" swap scaffold-vocab ;
+: scaffold-extra ( string -- )
+ "resource:extra" swap scaffold-vocab-in ;
-: scaffold-work ( string -- ) "resource:work" swap scaffold-vocab ;
+: scaffold-work ( string -- )
+ "resource:work" swap scaffold-vocab-in ;
+
+: scaffold-vocab ( string -- )
+ "Choose a vocabulary root:" vocab-roots get
+ '[ [ "Use " prepend ] keep ] { } map>assoc throw-restarts
+ swap scaffold-vocab-in ;
<PRIVATE
SYMBOL: nested-examples
: example-using ( using -- )
- " " join "example-using" [
+ join-words "example-using" [
nested-examples get 4 0 ? CHAR: \s <string> "example-indent" [
- """${example-indent}"Example:"
-${example-indent}{ $example "USING: ${example-using} ;"
-${example-indent} ""
-${example-indent} ""
+ "${example-indent}\"Example:\"
+${example-indent}{ $example \"USING: ${example-using} ;\"
+${example-indent} \"\"
+${example-indent} \"\"
${example-indent}}
-"""
+"
interpolate
] with-variable
] with-variable ;
: scaffold-examples ( word -- )
2 swap scaffold-n-examples ;
-: touch. ( path -- )
+: scaffold-file ( path -- )
[ touch-file ]
[ "Click to edit: " write <pathname> . ] bi ;
: scaffold-rc ( path -- )
- [ home ] dip append-path touch. ;
+ home prepend-path scaffold-file ;
: scaffold-factor-boot-rc ( -- )
".factor-boot-rc" scaffold-rc ;
: scaffold-factor-roots ( -- )
".factor-roots" scaffold-rc ;
+: make-unit-test ( answer code -- str )
+ [ split-lines [ " " prepend ] map "\n" join ] bi@
+ [ "{\n" "\n}" surround ] [ "[\n" "\n] unit-test\n" surround ] bi*
+ " " glue ;
+
+: scaffold-unit-test ( -- str/f )
+ read-contents dup "" = [
+ drop f
+ ] [
+ [ eval( -- x ) unparse ] keep make-unit-test
+ ] if ;
+
+: scaffold-unit-tests ( -- str )
+ [ scaffold-unit-test dup ] [ ] produce nip "\n\n" join ;
+
HOOK: scaffold-emacs os ( -- )
-M: unix scaffold-emacs ( -- ) ".emacs" scaffold-rc ;
+M: unix scaffold-emacs ".emacs" scaffold-rc ;
projects / factor.git / blobdiff