! 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 ;
+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 ;
FROM: sets => members ;
IN: tools.scaffold
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." ;
<PRIVATE
] 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 }
{ "seq" sequence }
+ { "exemplar" object }
{ "assoc" assoc }
{ "alist" "an array of key/value pairs" }
{ "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 ;
+
+M: object add-using ( object -- )
+ vocabulary>> using get [ adjoin ] [ drop ] if* ;
: 4bl ( -- )
" " write ; inline
+: ($values.) ( array -- )
+ [
+ 4bl
+ [ bl ] [
+ "{ " write
+ dup array? [ first ] when
+ dup lookup-type [
+ [ unparse write bl ]
+ [ [ pprint ] [ add-using ] bi ] bi*
+ ] [
+ drop unparse write bl null pprint
+ null 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* ;
: interesting-words ( vocab -- array )
words
- [ { [ "help" word-prop ] [ predicate? ] } 1|| not ] filter
+ [ { [ "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 -- )
check-vocab
: help. ( word -- )
[ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
-: scaffold-help ( vocab -- )
+: scaffold-docs ( vocab -- )
ensure-vocab-exists
[
dup "-docs.factor" vocab/suffix>path scaffolding? [
2drop
] if ;
-SYMBOL: examples-flag
+SYMBOL: nested-examples
+
+: example-using ( using -- )
+ " " join "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 ;
+: scaffold-examples ( word -- )
+ 2 swap scaffold-n-examples ;
+
: touch. ( path -- )
[ touch-file ]
[ "Click to edit: " write <pathname> . ] bi ;
[ home ] dip append-path touch. ;
: 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 ;
HOOK: scaffold-emacs os ( -- )
projects / factor.git / blobdiff