! 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 alarms
-words.symbol system summary ;
+USING: accessors alien arrays assocs byte-arrays calendar
+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
SYMBOL: using
ERROR: not-a-vocab-root string ;
-ERROR: vocab-name-contains-separator path ;
-ERROR: vocab-name-contains-dot path ;
-ERROR: bad-developer-name name ;
-M: bad-developer-name summary
- drop "Developer name must be a string." ;
+ERROR: vocab-must-not-exist string ;
<PRIVATE
-: vocab-root? ( string -- ? ) vocab-roots get member? ;
-
-: contains-dot? ( string -- ? ) ".." swap subseq? ;
-
-: contains-separator? ( string -- ? ) [ path-separator? ] any? ;
+: vocab-root? ( string -- ? )
+ trim-tail-separators vocab-roots get member? ;
: ensure-vocab-exists ( string -- string )
- dup vocabs member? [ no-vocab ] unless ;
+ dup lookup-vocab [ no-vocab ] unless ;
-: check-vocab-name ( string -- string )
- [ ]
- [ contains-dot? [ vocab-name-contains-dot ] when ]
- [ contains-separator? [ vocab-name-contains-separator ] when ] tri ;
-
-: 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
] with-string-writer ;
: set-scaffold-main-file ( vocab path -- )
- [ main-file-string ] dip utf8 set-file-contents ;
+ [ main-file-string 1array ] dip utf8 set-file-lines ;
: scaffold-main ( vocab-root vocab -- )
[ ".factor" vocab-root/vocab/suffix>path ] keep swap scaffolding? [
: scaffold-metadata ( vocab file contents -- )
[ ensure-vocab-exists ] 2dip
[
- [ vocab/file>path ] dip swap scaffolding? [
- utf8 set-file-contents
+ [ vocab/file>path ] dip 1array swap scaffolding? [
+ utf8 set-file-lines
] [
2drop
] if
] 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 }
- { "alarm" alarm }
+ { "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 -- )
- vocabulary>> using get [ conjoin ] [ drop ] if* ;
+GENERIC: add-using ( object -- )
-: ($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 ;
+M: array add-using [ add-using ] each ;
+
+M: string add-using drop ;
-: 4bl ( -- )
- " " write ; inline
+M: object add-using
+ vocabulary>> using get [ adjoin ] [ drop ] if* ;
+
+: ($values.) ( array -- )
+ [
+ " " 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 ;
: $values. ( word -- )
"declared-effect" word-prop [
[ in>> ] [ out>> ] bi
- 2dup [ empty? ] bi@ and [
+ 2dup [ empty? ] both? [
2drop
] [
+ [ members ] dip over diff
"{ $values" print
- [ 4bl ($values.) ]
- [ [ nl 4bl ($values.) ] unless-empty ] bi*
+ [ drop ($values.) ]
+ [ ?print-nl ]
+ [ 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 -- )
: write-using ( vocab -- )
"USING:" write
- using get keys
+ using get members
{ "help.markup" "help.syntax" } append natural-sort remove
[ bl write ] each
" ;" print ;
] with-output-stream ;
: with-scaffold ( quot -- )
- [ H{ } clone using ] dip with-variable ; inline
+ [ HS{ } clone using ] dip with-variable ; inline
: link-vocab ( vocab -- )
+ ".private" ?tail drop
check-vocab
"Edit documentation: " write
"-docs.factor" vocab/suffix>path <pathname> . ;
: help. ( word -- )
[ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
-: scaffold-help ( vocab -- )
+: scaffold-docs ( vocab -- )
ensure-vocab-exists
[
dup "-docs.factor" vocab/suffix>path scaffolding? [
: scaffold-summary ( vocab summary -- )
[ "summary.txt" ] dip scaffold-metadata ;
-: scaffold-vocab ( vocab-root string -- )
+: scaffold-platforms ( vocab platforms -- )
+ [ "platforms.txt" ] dip scaffold-metadata ;
+
+: 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 ;
-: example ( -- )
- {
- "{ $example \"\" \"USING: prettyprint ;\""
- " \"\""
- " \"\""
- "}"
- } [ examples-flag get [ 4bl ] when print ] each ;
-
-: examples ( n -- )
- t \ examples-flag [
- "{ $examples " print
- [ example ] times
+: n-examples-using ( n using -- )
+ '[ _ example-using ] 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 ( -- )
- os windows? "factor-boot-rc" ".factor-boot-rc" ? scaffold-rc ;
+ ".factor-boot-rc" scaffold-rc ;
: scaffold-factor-rc ( -- )
- os windows? "factor-rc" ".factor-rc" ? scaffold-rc ;
+ ".factor-rc" scaffold-rc ;
+
+: scaffold-mason-rc ( -- )
+ ".factor-mason-rc" scaffold-rc ;
+
+: scaffold-factor-roots ( -- )
+ ".factor-roots" scaffold-rc ;
+
+: make-unit-test ( answer code -- str )
+ split-lines [ " " prepend ] map "\n" join
+ "[\n" "\n] unit-test\n" surround
+ " " glue ;
+
+: run-string ( string -- datastack )
+ parse-string V{ } clone swap with-datastack ; inline
+
+: scaffold-unit-test ( -- str/f )
+ read-contents dup "" = [
+ drop f
+ ] [
+ [ run-string 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