basis/tools/scaffold/scaffold.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: assocs io.files io.pathnames io.directories
   4 io.encodings.utf8 hashtables kernel namespaces sequences
   5 vocabs.loader io combinators calendar accessors math.parser
   6 io.streams.string ui.tools.operations quotations strings arrays
   7 prettyprint words vocabs sorting sets classes math alien urls
   8 splitting ascii ;
   9 IN: tools.scaffold
  10
  11 SYMBOL: developer-name
  12 SYMBOL: using
  13
  14 ERROR: not-a-vocab-root string ;
  15 ERROR: vocab-name-contains-separator path ;
  16 ERROR: vocab-name-contains-dot path ;
  17 ERROR: no-vocab vocab ;
  18
  19 <PRIVATE
  20
  21 : root? ( string -- ? ) vocab-roots get member? ;
  22
  23 : contains-dot? ( string -- ? ) ".." swap subseq? ;
  24
  25 : contains-separator? ( string -- ? ) [ path-separator? ] contains? ;
  26
  27 : check-vocab-name ( string -- string )
  28     dup contains-dot? [ vocab-name-contains-dot ] when
  29     dup contains-separator? [ vocab-name-contains-separator ] when ;
  30
  31 : check-root ( string -- string )
  32     dup root? [ not-a-vocab-root ] unless ;
  33
  34 : directory-exists ( path -- )
  35     "Not creating a directory, it already exists: " write print ;
  36
  37 : scaffold-directory ( path -- )
  38     dup exists? [ directory-exists ] [ make-directories ] if ;
  39
  40 : not-scaffolding ( path -- )
  41     "Not creating scaffolding for " write <pathname> . ;
  42
  43 : scaffolding ( path -- )
  44     "Creating scaffolding for " write <pathname> . ;
  45
  46 : (scaffold-path) ( path string -- path )
  47     dupd [ file-name ] dip append append-path ;
  48
  49 : scaffold-path ( path string -- path ? )
  50     (scaffold-path)
  51     dup exists? [ dup not-scaffolding f ] [ dup scaffolding t ] if ;
  52
  53 : scaffold-copyright ( -- )
  54     "! Copyright (C) " write now year>> number>string write
  55     developer-name get [ "Your name" ] unless* bl write "." print
  56     "! See http://factorcode.org/license.txt for BSD license." print ;
  57
  58 : main-file-string ( vocab -- string )
  59     [
  60         scaffold-copyright
  61         "USING: ;" print
  62         "IN: " write print
  63     ] with-string-writer ;
  64
  65 : set-scaffold-main-file ( path vocab -- )
  66     main-file-string swap utf8 set-file-contents ;
  67
  68 : scaffold-main ( path vocab -- )
  69     [ ".factor" scaffold-path ] dip
  70     swap [ set-scaffold-main-file ] [ 2drop ] if ;
  71
  72 : tests-file-string ( vocab -- string )
  73     [
  74         scaffold-copyright
  75         "USING: tools.test " write dup write " ;" print
  76         "IN: " write write ".tests" print
  77     ] with-string-writer ;
  78
  79 : set-scaffold-tests-file ( path vocab -- )
  80     tests-file-string swap utf8 set-file-contents ;
  81
  82 : scaffold-tests ( path vocab -- )
  83     [ "-tests.factor" scaffold-path ] dip
  84     swap [ set-scaffold-tests-file ] [ 2drop ] if ;
  85
  86 : scaffold-authors ( path -- )
  87     "authors.txt" append-path dup exists? [
  88         not-scaffolding
  89     ] [
  90         dup scaffolding
  91         developer-name get swap utf8 set-file-contents
  92     ] if ;
  93
  94 : lookup-type ( string -- object/string ? )
  95     "new" ?head drop [ [ CHAR: ' = ] [ digit? ] bi or ] trim-right
  96     H{
  97         { "object" object } { "obj" object }
  98         { "quot" quotation }
  99         { "string" string }
 100         { "str" string }
 101         { "hash" hashtable }
 102         { "hashtable" hashtable }
 103         { "?" "a boolean" }
 104         { "ch" "a character" }
 105         { "word" word }
 106         { "array" array }
 107         { "duration" duration }
 108         { "path" "a pathname string" }
 109         { "vocab" "a vocabulary specifier" }
 110         { "vocab-root" "a vocabulary root string" }
 111         { "c-ptr" c-ptr }
 112         { "seq" sequence }
 113         { "assoc" assoc }
 114         { "alist" "an array of key/value pairs" }
 115         { "keys" sequence } { "values" sequence }
 116         { "class" class } { "tuple" tuple }
 117         { "url" url }
 118     } at* ;
 119
 120 : add-using ( object -- )
 121     vocabulary>> using get [ conjoin ] [ drop ] if* ;
 122
 123 : ($values.) ( array -- )
 124     [
 125         " { " write
 126         dup array? [ first ] when
 127         dup lookup-type [
 128             [ unparse write bl ]
 129             [ [ pprint ] [ dup string? [ drop ] [ add-using ] if ] bi ] bi*
 130         ] [
 131             drop unparse write bl null pprint
 132             null add-using
 133         ] if
 134         " }" write
 135     ] each ;
 136
 137 : $values. ( word -- )
 138     "declared-effect" word-prop [
 139         [ in>> ] [ out>> ] bi
 140         2dup [ empty? ] bi@ and [
 141             2drop
 142         ] [
 143             "{ $values" print
 144             [ "    " write ($values.) ]
 145             [ [ nl "    " write ($values.) ] unless-empty ] bi*
 146             nl "}" print
 147         ] if
 148     ] when* ;
 149
 150 : $description. ( word -- )
 151     drop
 152     "{ $description \"\" } ;" print ;
 153
 154 : help-header. ( word -- )
 155     "HELP: " write name>> print ;
 156
 157 : (help.) ( word -- )
 158     [ help-header. ] [ $values. ] [ $description. ] tri ;
 159
 160 : interesting-words ( vocab -- array )
 161     words
 162     [ [ "help" word-prop ] [ predicate? ] bi or not ] filter
 163     natural-sort ;
 164
 165 : interesting-words. ( vocab -- )
 166     interesting-words [ (help.) nl ] each ;
 167
 168 : help-file-string ( vocab -- str2 )
 169     [
 170         {
 171             [ "IN: " write print nl ]
 172             [ interesting-words. ]
 173             [
 174                 [ "ARTICLE: " write unparse dup write bl print ]
 175                 [ "{ $vocab-link " write pprint " }" print ] bi
 176                 ";" print nl
 177             ]
 178             [ "ABOUT: " write unparse print ]
 179         } cleave
 180     ] with-string-writer ;
 181
 182 : write-using ( vocab -- )
 183     "USING:" write
 184     using get keys
 185     { "help.markup" "help.syntax" } append natural-sort remove
 186     [ bl write ] each
 187     " ;" print ;
 188
 189 : set-scaffold-help-file ( path vocab -- )
 190     swap utf8 <file-writer> [
 191         scaffold-copyright
 192         [ help-file-string ] [ write-using ] bi
 193         write
 194     ] with-output-stream ;
 195
 196 : check-scaffold ( vocab-root string -- vocab-root string )
 197     [ check-root ] [ check-vocab-name ] bi* ;
 198
 199 : vocab>scaffold-path ( vocab-root string -- path )
 200     path-separator first CHAR: . associate substitute
 201     append-path ;
 202
 203 : prepare-scaffold ( vocab-root string -- string path )
 204     check-scaffold [ vocab>scaffold-path ] keep ;
 205
 206 : with-scaffold ( quot -- )
 207     [ H{ } clone using ] dip with-variable ; inline
 208
 209 : check-vocab ( vocab -- vocab )
 210     dup find-vocab-root [ no-vocab ] unless ;
 211
 212 PRIVATE>
 213
 214 : link-vocab ( vocab -- )
 215     check-vocab
 216     "Edit documentation: " write
 217     [ find-vocab-root ]
 218     [ vocab>scaffold-path ] bi
 219     "-docs.factor" (scaffold-path) <pathname> . ;
 220
 221 : help. ( word -- )
 222     [ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
 223
 224 : scaffold-help ( string -- )
 225     [
 226         [ find-vocab-root ] [ check-vocab ] bi
 227         prepare-scaffold
 228         [ "-docs.factor" scaffold-path ] dip
 229         swap [ set-scaffold-help-file ] [ 2drop ] if
 230     ] with-scaffold ;
 231
 232 : scaffold-undocumented ( string -- )
 233     [ interesting-words. ] [ link-vocab ] bi ;
 234
 235 : scaffold-vocab ( vocab-root string -- )
 236     prepare-scaffold
 237     {
 238         [ drop scaffold-directory ]
 239         [ scaffold-main ]
 240         [ scaffold-tests ]
 241         [ drop scaffold-authors ]
 242         [ nip require ]
 243     } 2cleave ;
 244
 245 SYMBOL: examples-flag
 246
 247 : example ( -- )
 248     {
 249         "{ $example \"\" \"USING: prettyprint ;\""
 250         "           \"\""
 251         "           \"\""
 252         "}"
 253     } [ examples-flag get [ "    " write ] when print ] each ;
 254
 255 : examples ( n -- )
 256     t \ examples-flag [
 257         "{ $examples " print
 258         [ example ] times
 259         "}" print
 260     ] with-variable ;
 261
 262 : scaffold-rc ( path -- )
 263     [ touch-file ] [ "Click to edit: " write <pathname> . ] bi ;
 264
 265 : scaffold-factor-boot-rc ( -- )
 266     home ".factor-boot-rc" append-path scaffold-rc ;
 267
 268 : scaffold-factor-rc ( -- )
 269     home ".factor-rc" append-path scaffold-rc ;