! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs io.files io.pathnames io.directories
-io.encodings.utf8 hashtables kernel namespaces sequences
-vocabs.loader vocabs.metadata io combinators calendar accessors
-math.parser io.streams.string ui.tools.operations quotations
-strings arrays prettyprint words vocabs sorting sets classes
-math alien urls splitting ascii combinators.short-circuit timers
-words.symbol system summary ;
-FROM: sets => members ;
+
+USING: accessors alien arrays assocs byte-arrays calendar
+classes classes.error combinators combinators.short-circuit
+continuations 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
SYMBOL: using
ERROR: not-a-vocab-root string ;
-ERROR: vocab-name-contains-separator path ;
-ERROR: vocab-name-contains-dot path ;
+
+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 vocabs member? [ no-vocab ] unless ;
-
-: check-vocab-name ( string -- string )
- [ ]
- [ contains-dot? [ vocab-name-contains-dot ] when ]
- [ contains-separator? [ vocab-name-contains-separator ] when ] tri ;
+ 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
] if* ;
: lookup-type ( string -- object/string ? )
+ "/f" ?tail swap
"new" ?head drop [ { [ CHAR: ' = ] [ digit? ] } 1|| ] trim-tail
H{
- { "object" object } { "obj" object }
+ { "object" object }
+ { "obj" object }
{ "quot" quotation }
{ "string" string }
{ "str" string }
{ "ch" "a character" }
{ "word" word }
{ "array" array }
- { "timers" timer }
+ { "byte-array" byte-array }
+ { "timer" timer }
{ "duration" duration }
{ "path" "a pathname string" }
{ "vocab" "a vocabulary specifier" }
{ "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* ;
+ } at* [ swap [ \ $maybe swap 2array ] when ] dip ;
-: add-using ( object -- )
+GENERIC: add-using ( object -- )
+
+M: array add-using [ add-using ] each ;
+
+M: string add-using drop ;
+
+M: object add-using
vocabulary>> using get [ adjoin ] [ drop ] if* ;
: ($values.) ( array -- )
- [ bl ] [
- "{ " write
- dup array? [ first ] when
- dup lookup-type [
- [ unparse write bl ]
- [ [ pprint ] [ dup string? [ drop ] [ add-using ] if ] bi ] bi*
- ] [
- drop unparse write bl null pprint
- null add-using
- ] if
- " }" write
- ] interleave ;
-
-: 4bl ( -- )
- " " write ; inline
+ [
+ " " write
+ [ bl ] [
+ "{ " write
+ dup array? [ first ] when
+ dup lookup-type [
+ [ unparse write bl ]
+ [ [ pprint ] [ add-using ] bi ] bi*
+ ] [
+ drop unparse write bl object pprint
+ object add-using
+ ] if
+ " }" write
+ ] interleave
+ ] unless-empty ;
: ?print-nl ( seq1 seq2 -- )
[ empty? ] either? [ nl ] unless ;
] [
[ members ] dip over diff
"{ $values" print
- [ drop 4bl ($values.) ]
+ [ drop ($values.) ]
[ ?print-nl ]
- [ nip 4bl ($values.) ] 2tri
+ [ nip ($values.) ] 2tri
nl "}" print
] 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 ;
[ docs-header. ] [ docs-body. ] bi ;
: interesting-words ( vocab -- array )
- words
- [ { [ "help" word-prop ] [ predicate? ] } 1|| not ] filter
+ vocab-words
+ [ { [ "help" word-prop ] [ predicate? ] } 1|| ] reject
natural-sort ;
: interesting-words. ( vocab -- )
[ 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-in ;
-: scaffold-basis ( string -- ) "resource:basis" swap scaffold-vocab ;
+: scaffold-extra ( string -- )
+ "resource:extra" swap scaffold-vocab-in ;
-: scaffold-extra ( string -- ) "resource:extra" swap scaffold-vocab ;
+: scaffold-work ( string -- )
+ "resource:work" swap scaffold-vocab-in ;
-: scaffold-work ( string -- ) "resource:work" swap scaffold-vocab ;
+: scaffold-vocab ( string -- )
+ "Choose a vocabulary root:" vocab-roots get
+ '[ [ "Use " prepend ] keep ] { } map>assoc throw-restarts
+ swap scaffold-vocab-in ;
<PRIVATE
2drop
] if ;
-SYMBOL: examples-flag
+SYMBOL: nested-examples
+
+: example-using ( 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}}
+"
+ interpolate
+ ] with-variable
+ ] with-variable ;
+
+: n-examples-using ( n using -- )
+ '[ _ example-using ] times ;
-: example ( -- )
- {
- "{ $example \"\" \"USING: prettyprint ;\""
- " \"\""
- " \"\""
- "}"
- } [ examples-flag get [ 4bl ] when print ] each ;
-
-: examples ( n -- )
- t \ examples-flag [
- "{ $examples " print
- [ example ] times
+: scaffold-n-examples ( n word -- )
+ vocabulary>> "prettyprint" 2array
+ [ t nested-examples ] 2dip
+ '[
+ "{ $examples" print
+ _ _ n-examples-using
"}" print
] with-variable ;
-: touch. ( path -- )
+: scaffold-examples ( word -- )
+ 2 swap scaffold-n-examples ;
+
+: 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 ;
HOOK: scaffold-emacs os ( -- )
-M: unix scaffold-emacs ( -- ) ".emacs" scaffold-rc ;
+M: unix scaffold-emacs ".emacs" scaffold-rc ;