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 cords
   7 classes sequences.lib combinators.lib alien math ;
   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 : root? ( string -- ? )
  20     vocab-roots get member?  ;
  21
  22 : check-vocab-name ( string -- string )
  23     dup dup [ CHAR: . = ] trim [ length ] bi@ =
  24     [ vocab-name-contains-dot ] unless
  25     ".." over subseq? [ vocab-name-contains-dot ] when
  26     dup [ path-separator? ] contains?
  27     [ vocab-name-contains-separator ] when ;
  28
  29 : check-root ( string -- string )
  30     check-vocab-name
  31     dup "resource:" head? [ "resource:" prepend ] unless
  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     dup exists? [ dup not-scaffolding f ] [ dup scaffolding t ] if ;
  49
  50 : scaffold-copyright ( -- )
  51     "! Copyright (C) " write now year>> number>string write
  52     developer-name get [ "Your name" ] unless* bl write "." print
  53     "! See http://factorcode.org/license.txt for BSD license." print ;
  54
  55 : main-file-string ( vocab -- string )
  56     [
  57         scaffold-copyright
  58         "USING: ;" print
  59         "IN: " write print
  60     ] with-string-writer ;
  61
  62 : set-scaffold-main-file ( path vocab -- )
  63     main-file-string swap utf8 set-file-contents ;
  64
  65 : scaffold-main ( path vocab -- )
  66     [ ".factor" scaffold-path ] dip
  67     swap [ set-scaffold-main-file ] [ 2drop ] if ;
  68
  69 : tests-file-string ( vocab -- string )
  70     [
  71         scaffold-copyright
  72         "USING: tools.test " write dup write " ;" print
  73         "IN: " write write ".tests" print
  74     ] with-string-writer ;
  75
  76 : set-scaffold-tests-file ( path vocab -- )
  77     tests-file-string swap utf8 set-file-contents ;
  78
  79 : scaffold-tests ( path vocab -- )
  80     [ "-tests.factor" scaffold-path ] dip
  81     swap [ set-scaffold-tests-file ] [ 2drop ] if ;
  82
  83 : scaffold-authors ( path -- )
  84     "authors.txt" append-path dup exists? [
  85         not-scaffolding
  86     ] [
  87         dup scaffolding
  88         developer-name get swap utf8 set-file-contents
  89     ] if ;
  90
  91 : lookup-type ( string -- object/string ? )
  92     H{
  93         { "object" object } { "obj" object }
  94         { "obj1" object } { "obj2" object }
  95         { "obj3" object } { "obj4" object }
  96         { "quot" quotation } { "quot1" quotation }
  97         { "quot2" quotation } { "quot3" quotation }
  98         { "quot'" quotation }
  99         { "string" string } { "string1" string }
 100         { "string2" string } { "string3" string }
 101         { "str" string }
 102         { "str1" string } { "str2" string } { "str3" string }
 103         { "hash" hashtable }
 104         { "hashtable" hashtable }
 105         { "?" "a boolean" }
 106         { "ch" "a character" }
 107         { "word" word }
 108         { "array" array }
 109         { "duration" duration }
 110         { "path" "a pathname string" }
 111         { "vocab" "a vocabulary specifier" }
 112         { "vocab-root" "a vocabulary root string" }
 113         { "c-ptr" c-ptr }
 114         { "seq" sequence } { "seq1" sequence } { "seq2" sequence }
 115         { "seq3" sequence } { "seq4" sequence }
 116         { "seq1'" sequence } { "seq2'" sequence }
 117         { "newseq" sequence }
 118         { "assoc" assoc } { "assoc1" assoc } { "assoc2" assoc }
 119         { "assoc3" assoc } { "newassoc" assoc }
 120         { "alist" "an array of key/value pairs" }
 121         { "keys" sequence } { "values" sequence }
 122         { "class" class }
 123     } at* ;
 124
 125 : add-using ( object -- )
 126     vocabulary>> using get [ conjoin ] [ drop ] if* ;
 127
 128 : ($values.) ( array -- )
 129     [
 130         " { " write
 131         dup array? [ first ] when
 132         dup lookup-type [
 133             [ unparse write bl ]
 134             [ [ pprint ] [ dup string? [ drop ] [ add-using ] if ] bi ] bi*
 135         ] [
 136             drop unparse write bl null pprint
 137             null add-using
 138         ] if
 139         " }" write
 140     ] each ;
 141
 142 : $values. ( word -- )
 143     "declared-effect" word-prop [
 144         [ in>> ] [ out>> ] bi
 145         2dup [ empty? ] bi@ and [
 146             2drop
 147         ] [
 148             "{ $values" print
 149             [ "    " write ($values.) ]
 150             [ [ nl "    " write ($values.) ] unless-empty ] bi*
 151             " }" write nl
 152         ] if
 153     ] when* ;
 154
 155 : $description. ( word -- )
 156     drop
 157     "{ $description \"\" } ;" print ;
 158
 159 : help-header. ( word -- )
 160     "HELP: " write name>> print ;
 161
 162 : (help.) ( word -- )
 163     [ help-header. ] [ $values. ] [ $description. ] tri ;
 164
 165 : interesting-words ( vocab -- array )
 166     words
 167     [ [ "help" word-prop ] [ predicate? ] bi or not ] filter
 168     natural-sort ;
 169
 170 : interesting-words. ( vocab -- )
 171     interesting-words [ (help.) nl ] each ;
 172
 173 : help-file-string ( str1 -- str2 )
 174     [
 175         [ "IN: " write print nl ]
 176         [ interesting-words. ]
 177         [ "ARTICLE: " write unparse dup write bl print ";" print nl ]
 178         [ "ABOUT: " write unparse print ] quad
 179     ] with-string-writer ;
 180
 181 : write-using ( -- )
 182     "USING:" write
 183     using get keys
 184     { "help.markup" "help.syntax" } cord-append natural-sort
 185     [ bl write ] each
 186     " ;" print ;
 187
 188 : set-scaffold-help-file ( path vocab -- )
 189     swap utf8 <file-writer> [
 190         scaffold-copyright help-file-string write-using write
 191     ] with-output-stream ;
 192
 193 : check-scaffold ( vocab-root string -- vocab-root string )
 194     [ check-root ] [ check-vocab-name ] bi* ;
 195
 196 : vocab>scaffold-path ( vocab-root string -- path )
 197     path-separator first CHAR: . associate substitute
 198     append-path ;
 199
 200 : prepare-scaffold ( vocab-root string -- string path )
 201     check-scaffold [ vocab>scaffold-path ] keep ;
 202
 203 : with-scaffold ( quot -- )
 204     [ H{ } clone using ] dip with-variable ; inline
 205
 206 : check-vocab ( vocab -- vocab )
 207     dup find-vocab-root [ no-vocab ] unless ;
 208 PRIVATE>
 209
 210 : link-vocab ( vocab -- )
 211     check-vocab
 212     "Edit documentation: " write
 213     [ find-vocab-root ] keep
 214     [ append-path ] keep "-docs.factor" append append-path
 215     <pathname> . ;
 216
 217 : help. ( word -- )
 218     [ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
 219
 220 : scaffold-help ( vocab-root string -- )
 221     [
 222         check-vocab
 223         prepare-scaffold
 224         [ "-docs.factor" scaffold-path ] dip
 225         swap [ set-scaffold-help-file ] [ 2drop ] if
 226     ] with-scaffold ;
 227
 228 : scaffold-undocumented ( string -- )
 229     [ interesting-words. ] [ link-vocab ] bi ;
 230
 231 : scaffold-vocab ( vocab-root string -- )
 232     prepare-scaffold
 233     {
 234         [ drop scaffold-directory ]
 235         [ scaffold-main ]
 236         [ scaffold-tests ]
 237         [ drop scaffold-authors ]
 238         [ nip require ]
 239     } 2cleave ;
 240
 241 SYMBOL: examples-flag
 242
 243 : example ( -- )
 244     {
 245         "{ $example \"\" \"USING: prettyprint ;\""
 246         "           \"\""
 247         "           \"\""
 248         "}"
 249     } [ examples-flag get [ "    " write ] when print ] each ;
 250
 251 : examples ( n -- )
 252     t \ examples-flag [
 253         "{ $examples " print
 254         [ example ] times
 255         "}" print
 256     ] with-variable ;