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 ;
   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         { "string" string } { "string1" string }
  99         { "string2" string } { "string3" string }
 100         { "str" string }
 101         { "str1" string } { "str2" string } { "str3" string }
 102         { "hash" hashtable }
 103         { "hashtable" hashtable }
 104         { "?" "a boolean" }
 105         { "ch" "a character" }
 106         { "word" word }
 107         { "array" array }
 108         { "path" "a pathname string" }
 109         { "vocab" "a vocabulary specifier" }
 110         { "vocab-root" "a vocabulary root string" }
 111     } at* ;
 112
 113 : add-using ( object -- )
 114     vocabulary>> using get [ conjoin ] [ drop ] if* ;
 115
 116 : ($values.) ( array -- )
 117     [
 118         " { " write
 119         dup array? [ first ] when
 120         dup lookup-type [
 121             [ unparse write bl ]
 122             [ [ pprint ] [ dup string? [ drop ] [ add-using ] if ] bi ] bi*
 123         ] [
 124             drop unparse write bl null pprint
 125             null add-using
 126         ] if
 127         " }" write
 128     ] each ;
 129
 130 : $values. ( word -- )
 131     "declared-effect" word-prop [
 132         [ in>> ] [ out>> ] bi
 133         2dup [ empty? ] bi@ and [
 134             2drop
 135         ] [
 136             "{ $values" print
 137             [ "    " write ($values.) ]
 138             [ [ nl "    " write ($values.) ] unless-empty ] bi*
 139             " }" write nl
 140         ] if
 141     ] when* ;
 142
 143 : $description. ( word -- )
 144     drop
 145     "{ $description \"\" } ;" print ;
 146
 147 : help-header. ( word -- )
 148     "HELP: " write name>> print ;
 149
 150 : (help.) ( word -- )
 151     [ help-header. ] [ $values. ] [ $description. ] tri ;
 152
 153 : interesting-words ( vocab -- array )
 154     words
 155     [ [ "help" word-prop ] [ predicate? ] bi or not ] filter
 156     natural-sort ;
 157
 158 : interesting-words. ( vocab -- )
 159     interesting-words [ (help.) nl ] each ;
 160
 161 : help-file-string ( str1 -- str2 )
 162     [
 163         {
 164             [ "IN: " write print nl ]
 165             [ interesting-words. ]
 166             [ "ARTICLE: " write unparse dup write bl print ";" print nl ]
 167             [ "ABOUT: " write unparse print ]
 168         } cleave
 169     ] with-string-writer ;
 170
 171 : write-using ( -- )
 172     "USING:" write
 173     using get keys
 174     { "help.markup" "help.syntax" } append natural-sort
 175     [ bl write ] each
 176     " ;" print ;
 177
 178 : set-scaffold-help-file ( path vocab -- )
 179     swap utf8 <file-writer> [
 180         scaffold-copyright help-file-string write-using write
 181     ] with-output-stream ;
 182
 183 : check-scaffold ( vocab-root string -- vocab-root string )
 184     [ check-root ] [ check-vocab-name ] bi* ;
 185
 186 : vocab>scaffold-path ( vocab-root string -- path )
 187     path-separator first CHAR: . associate substitute
 188     append-path ;
 189
 190 : prepare-scaffold ( vocab-root string -- string path )
 191     check-scaffold [ vocab>scaffold-path ] keep ;
 192
 193 : with-scaffold ( quot -- )
 194     [ H{ } clone using ] dip with-variable ; inline
 195
 196 : check-vocab ( vocab -- vocab )
 197     dup find-vocab-root [ no-vocab ] unless ;
 198 PRIVATE>
 199
 200 : link-vocab ( vocab -- )
 201     check-vocab
 202     "Edit documentation: " write
 203     [ find-vocab-root ] keep
 204     [ append-path ] keep "-docs.factor" append append-path
 205     <pathname> . ;
 206
 207 : help. ( word -- )
 208     [ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
 209
 210 : scaffold-help ( vocab-root string -- )
 211     [
 212         check-vocab
 213         prepare-scaffold
 214         [ "-docs.factor" scaffold-path ] dip
 215         swap [ set-scaffold-help-file ] [ 2drop ] if
 216     ] with-scaffold ;
 217
 218 : scaffold-undocumented ( string -- )
 219     [ interesting-words. ] [ link-vocab ] bi ;
 220
 221 : scaffold-vocab ( vocab-root string -- )
 222     prepare-scaffold
 223     {
 224         [ drop scaffold-directory ]
 225         [ scaffold-main ]
 226         [ scaffold-tests ]
 227         [ drop scaffold-authors ]
 228         [ nip require ]
 229     } 2cleave ;