tools.scaffold: don't use sequences.extras.

[factor.git] / basis / tools / scaffold / scaffold.factor

diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor
index 026eb98ff06b0003b4e1adeaa0df3b0bb9ba6b4e..0b9e1e8085cb117048371bedac91c5a30b086b73 100644 (file)
--- a/basis/tools/scaffold/scaffold.factor
+++ b/basis/tools/scaffold/scaffold.factor
@@ -1,12 +1,13 @@
 ! 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 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
@@ -14,7 +15,7 @@ SYMBOL: using
 
 ERROR: not-a-vocab-root string ;
 
-ERROR: vocab-must-not-exist name root ;
+ERROR: vocab-must-not-exist string ;
 
 <PRIVATE
 
@@ -22,22 +23,19 @@ ERROR: vocab-must-not-exist name root ;
     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-exists ( string -- string )
-    dup vocab-exists? [ dup find-vocab-root vocab-must-not-exist ] when ;
+: 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 )
@@ -60,7 +58,7 @@ ERROR: vocab-must-not-exist name root ;
 
 : 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> . ;
@@ -69,7 +67,7 @@ ERROR: vocab-must-not-exist name root ;
     "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
@@ -128,6 +126,11 @@ ERROR: vocab-must-not-exist name root ;
         { "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 }
@@ -145,7 +148,7 @@ M: array add-using [ add-using ] each ;
 
 M: string add-using drop ;
 
-M: object add-using ( object -- )
+M: object add-using
     vocabulary>> using get [ adjoin ] [ drop ] if* ;
 
 : ($values.) ( array -- )
@@ -158,8 +161,8 @@ M: object add-using ( object -- )
                 [ 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
@@ -183,6 +186,13 @@ M: object add-using ( object -- )
         ] 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 ;
 
@@ -194,6 +204,7 @@ M: object add-using ( object -- )
 
 : docs-body. ( word/symbol -- )
     {
+        { [ dup error-class? ] [ error-description. ] }
         { [ dup class? ] [ class-description. ] }
         { [ dup symbol? ] [ symbol-description. ] }
         [ [ $values. ] [ $description. ] bi ]
@@ -245,6 +256,7 @@ M: object add-using ( object -- )
     [ HS{ } clone using ] dip with-variable ; inline
 
 : link-vocab ( vocab -- )
+    ".private" ?tail drop
     check-vocab
     "Edit documentation: " write
     "-docs.factor" vocab/suffix>path <pathname> . ;
@@ -279,21 +291,34 @@ PRIVATE>
 : scaffold-platforms ( vocab platforms -- )
     [ "platforms.txt" ] dip scaffold-metadata ;
 
-: scaffold-vocab ( vocab-root string -- )
-    check-vocab-exists {
+: 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 require ]
         [ 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
 
@@ -321,7 +346,7 @@ 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} ;\"
@@ -348,12 +373,12 @@ ${example-indent}}
 : 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 ;
@@ -367,6 +392,21 @@ ${example-indent}}
 : 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 ;