From 7d3851ec48129fd29f5fce4a8cef3fc7c96b312e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Sep 2008 19:43:36 -0500 Subject: [PATCH 1/5] add scaffold tool --- basis/tools/scaffold/scaffold.factor | 177 +++++++++++++++++++++++++++ 1 file changed, 177 insertions(+) create mode 100644 basis/tools/scaffold/scaffold.factor diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor new file mode 100644 index 0000000000..94204c3127 --- /dev/null +++ b/basis/tools/scaffold/scaffold.factor @@ -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 . ; + +: scaffolding ( path -- ) + "Creating scaffolding for " write . ; + +: 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 ; From 1e3e21537e8a434369d1602a4690cff756de919a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Sep 2008 20:08:39 -0500 Subject: [PATCH 2/5] keep track of a using list so stack effects with types aren't annoying to use --- basis/tools/scaffold/scaffold.factor | 36 ++++++++++++++++++---------- 1 file changed, 23 insertions(+), 13 deletions(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 94204c3127..45beda8a2e 100644 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -3,10 +3,12 @@ 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 ; +strings arrays prettyprint words vocabs sorting combinators.lib +sets cords ; IN: tools.scaffold SYMBOL: developer-name +SYMBOL: using ERROR: not-a-vocab-root string ; @@ -18,9 +20,7 @@ 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 ; @@ -106,13 +106,16 @@ ERROR: vocab-name-contains-dot path ; { "ch" "a character" } } at* ; +: add-using ( object -- ) + vocabulary>> using get conjoin ; + : ($values.) ( array -- ) [ " { " write dup array? [ first ] when dup lookup-type [ [ unparse write bl ] - [ dup string? [ unparse write ] [ pprint ] if ] bi* + [ dup string? [ unparse write ] [ [ pprint ] [ add-using ] bi ] if ] bi* ] [ drop unparse write ] if @@ -139,18 +142,23 @@ ERROR: vocab-name-contains-dot path ; : help-file-string ( str1 -- str2 ) [ - scaffold-copyright - [ - "USING: help.markup help.syntax ;" print - "IN: " write print nl - ] + [ "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 ; +: write-using ( -- ) + "USING:" write + using get keys + { "help.markup" "help.syntax" } cord-append natural-sort + [ bl write ] each + " ;" print ; + : set-scaffold-help-file ( path vocab -- ) - help-file-string swap utf8 set-file-contents ; + swap utf8 [ + scaffold-copyright help-file-string write-using write + ] with-output-stream ; : check-scaffold ( vocab-root str -- vocab-root str ) [ check-root ] [ check-vocab-name ] bi* ; @@ -163,9 +171,11 @@ ERROR: vocab-name-contains-dot 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 ; + H{ } clone using [ + prepare-scaffold + [ "-docs.factor" scaffold-path ] dip + swap [ set-scaffold-help-file ] [ 2drop ] if + ] with-variable ; : scaffold-vocab ( vocab-root str -- ) prepare-scaffold From 35e423b570a22e35b80754711a668d9983e60444 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Sep 2008 20:30:38 -0500 Subject: [PATCH 3/5] add more types, nicer printing of values --- basis/tools/scaffold/scaffold.factor | 66 ++++++++++++++++------------ 1 file changed, 37 insertions(+), 29 deletions(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 45beda8a2e..777dddf0eb 100644 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -3,8 +3,8 @@ 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 -sets cords ; +strings arrays prettyprint words vocabs sorting sets cords +sequences.lib combinators.lib ; IN: tools.scaffold SYMBOL: developer-name @@ -12,19 +12,19 @@ SYMBOL: using ERROR: not-a-vocab-root string ; -: root? ( str -- ? ) +: root? ( string -- ? ) vocab-roots get member? ; ERROR: vocab-name-contains-separator path ; ERROR: vocab-name-contains-dot path ; -: check-vocab-name ( str -- str ) +: check-vocab-name ( string -- string ) 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-root ( string -- string ) check-vocab-name dup "resource:" head? [ "resource:" prepend ] unless dup root? [ not-a-vocab-root ] unless ; @@ -41,7 +41,7 @@ ERROR: vocab-name-contains-dot path ; : scaffolding ( path -- ) "Creating scaffolding for " write . ; -: scaffold-path ( path suffix -- path ? ) +: scaffold-path ( path string -- path ? ) dupd [ file-name ] dip append append-path dup exists? [ dup not-scaffolding f ] [ dup scaffolding t ] if ; @@ -50,7 +50,7 @@ ERROR: vocab-name-contains-dot path ; developer-name get [ "Your name" ] unless* bl write "." print "! See http://factorcode.org/license.txt for BSD license." print ; -: main-file-string ( vocab -- str ) +: main-file-string ( vocab -- string ) [ scaffold-copyright "USING: ;" print @@ -64,7 +64,7 @@ ERROR: vocab-name-contains-dot path ; [ ".factor" scaffold-path ] dip swap [ set-scaffold-main-file ] [ 2drop ] if ; -: tests-file-string ( vocab -- str ) +: tests-file-string ( vocab -- string ) [ scaffold-copyright "USING: tools.test " write dup write " ;" print @@ -88,22 +88,24 @@ ERROR: vocab-name-contains-dot path ; : lookup-type ( string -- object/string ? ) H{ - { "obj" object } - { "obj1" object } - { "obj2" object } - { "obj3" object } - { "obj4" object } - { "quot" quotation } - { "quot1" quotation } - { "quot2" quotation } - { "quot3" quotation } + { "object" object } { "obj" object } + { "obj1" object } { "obj2" object } + { "obj3" object } { "obj4" object } + { "quot" quotation } { "quot1" quotation } + { "quot2" quotation } { "quot3" quotation } + { "string" string } { "string1" string } + { "string2" string } { "string3" string } { "str" string } - { "str1" string } - { "str2" string } - { "str3" string } + { "str1" string } { "str2" string } { "str3" string } + { "hash" hashtable } { "hashtable" hashtable } { "?" "a boolean" } { "ch" "a character" } + { "word" word } + { "array" array } + { "path" "a pathname string" } + { "vocab" "a vocabulary specifier" } + { "vocab-root" "a vocabulary root string" } } at* ; : add-using ( object -- ) @@ -117,17 +119,23 @@ ERROR: vocab-name-contains-dot path ; [ unparse write bl ] [ dup string? [ unparse write ] [ [ pprint ] [ add-using ] bi ] if ] bi* ] [ - drop unparse write + drop unparse write bl null pprint + null add-using ] if " }" write ] each ; : $values. ( word -- ) "declared-effect" word-prop [ - "{ $values" print [ in>> ] [ out>> ] bi - [ " " write ($values.) nl ] bi@ - "}" write nl + 2dup [ empty? ] bi@ and [ + 2drop + ] [ + "{ $values" print + [ " " write ($values.) ] + [ [ nl " " write ($values.) ] unless-empty ] bi* + " }" write nl + ] if ] when* ; : $description. ( word -- ) @@ -160,24 +168,24 @@ ERROR: vocab-name-contains-dot path ; scaffold-copyright help-file-string write-using write ] with-output-stream ; -: check-scaffold ( vocab-root str -- vocab-root str ) +: check-scaffold ( vocab-root string -- vocab-root string ) [ check-root ] [ check-vocab-name ] bi* ; -: vocab>scaffold-path ( vocab-root str -- path ) +: vocab>scaffold-path ( vocab-root string -- path ) path-separator first CHAR: . associate substitute append-path ; -: prepare-scaffold ( vocab-root str -- str path ) +: prepare-scaffold ( vocab-root string -- string path ) check-scaffold [ vocab>scaffold-path ] keep ; -: scaffold-help ( vocab-root str -- ) +: scaffold-help ( vocab-root string -- ) H{ } clone using [ prepare-scaffold [ "-docs.factor" scaffold-path ] dip swap [ set-scaffold-help-file ] [ 2drop ] if ] with-variable ; -: scaffold-vocab ( vocab-root str -- ) +: scaffold-vocab ( vocab-root string -- ) prepare-scaffold { [ drop scaffold-directory ] From b5389b8a8cecfd3fecc2665581c3d3f0dadc689a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Sep 2008 20:31:38 -0500 Subject: [PATCH 4/5] add authors file --- basis/tools/scaffold/authors.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 basis/tools/scaffold/authors.txt diff --git a/basis/tools/scaffold/authors.txt b/basis/tools/scaffold/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/tools/scaffold/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file From b0e16704e6ed1b4b8c526c5d959dd217fc20ad6d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Sep 2008 21:38:16 -0500 Subject: [PATCH 5/5] eliminate redundant redundancy --- basis/tools/scaffold/scaffold.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 777dddf0eb..1c1a48ff9d 100644 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -117,7 +117,7 @@ ERROR: vocab-name-contains-dot path ; dup array? [ first ] when dup lookup-type [ [ unparse write bl ] - [ dup string? [ unparse write ] [ [ pprint ] [ add-using ] bi ] if ] bi* + [ [ pprint ] [ dup string? [ drop ] [ add-using ] if ] bi ] bi* ] [ drop unparse write bl null pprint null add-using