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