core/vocabs/loader/loader.factor

   1 ! Copyright (C) 2007, 2010 Eduardo Cavazos, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs continuations definitions init
   4 io io.files io.pathnames kernel make namespaces parser
   5 sequences sets splitting strings vocabs words ;
   6 IN: vocabs.loader
   7
   8 SYMBOL: vocab-roots
   9
  10 SYMBOL: add-vocab-root-hook
  11
  12 [
  13     V{
  14         "resource:core"
  15         "resource:basis"
  16         "resource:extra"
  17         "resource:work"
  18     } clone vocab-roots set-global
  19
  20     [ drop ] add-vocab-root-hook set-global
  21 ] "vocabs.loader" add-startup-hook
  22
  23 : add-vocab-root ( root -- )
  24     trim-tail-separators dup vocab-roots get ?adjoin
  25     [ add-vocab-root-hook get-global call( root -- ) ] [ drop ] if ;
  26
  27 SYMBOL: root-cache
  28 root-cache [ H{ } clone ] initialize
  29
  30 ERROR: not-found-in-roots path ;
  31
  32 <PRIVATE
  33
  34 : find-root-for ( path -- path/f )
  35     vocab-roots get [ prepend-path exists? ] with find nip ;
  36
  37 M: string vocab-path ( string -- path/f )
  38     dup find-root-for [ prepend-path ] [ not-found-in-roots ] if* ;
  39
  40 PRIVATE>
  41
  42 : vocab-dir ( vocab -- dir )
  43     vocab-name H{ { CHAR: . CHAR: / } } substitute ;
  44
  45 : append-vocab-dir ( vocab str/f -- path )
  46     [ vocab-name "." split ] dip
  47     [ [ dup last ] dip append suffix ] when*
  48     "/" join ;
  49
  50 : find-vocab-root ( vocab -- path/f )
  51     vocab-name root-cache get [
  52         dup ".private" tail? [ drop f ] [
  53             ".factor" append-vocab-dir find-root-for
  54         ] if
  55     ] cache ;
  56
  57 : vocab-exists? ( name -- ? )
  58     dup lookup-vocab [ ] [ find-vocab-root ] ?if ;
  59
  60 : vocab-append-path ( vocab path -- newpath )
  61     swap find-vocab-root [ prepend-path ] [ drop f ] if* ;
  62
  63 : vocab-source-path ( vocab -- path/f )
  64     dup ".factor" append-vocab-dir vocab-append-path ;
  65
  66 : vocab-docs-path ( vocab -- path/f )
  67     dup "-docs.factor" append-vocab-dir vocab-append-path ;
  68
  69 SYMBOL: load-help?
  70
  71 ! Defined by vocabs.metadata
  72 SYMBOL: check-vocab-hook
  73 check-vocab-hook [ [ drop ] ] initialize
  74
  75 <PRIVATE
  76
  77 SYMBOL: require-when-vocabs
  78 require-when-vocabs [ HS{ } clone ] initialize
  79
  80 SYMBOL: require-when-table
  81 require-when-table [ V{ } clone ] initialize
  82
  83 : load-conditional-requires ( vocab -- )
  84     vocab-name require-when-vocabs get in? [
  85         require-when-table get [
  86             [ [ lookup-vocab dup [ source-loaded?>> +done+ = ] when ] all? ] dip
  87             [ require ] curry when
  88         ] assoc-each
  89     ] when ;
  90
  91 : load-source ( vocab -- )
  92     dup check-vocab-hook get call( vocab -- )
  93     [
  94         +parsing+ >>source-loaded?
  95         dup vocab-source-path [ parse-file ] [ [ ] ] if*
  96         [ +parsing+ >>source-loaded? ] dip
  97         [ % ] [ call( -- ) ] if-bootstrapping
  98         +done+ >>source-loaded?
  99         load-conditional-requires
 100     ] [ ] [ f >>source-loaded? ] cleanup ;
 101
 102 : load-docs ( vocab -- )
 103     load-help? get [
 104         [
 105             +parsing+ >>docs-loaded?
 106             dup vocab-docs-path [ ?run-file ] when*
 107             +done+ >>docs-loaded?
 108         ] [ ] [ f >>docs-loaded? ] cleanup
 109     ] when drop ;
 110
 111 PRIVATE>
 112
 113 : require-when ( if then -- )
 114     over [ lookup-vocab ] all? [
 115         require drop
 116     ] [
 117         [ drop require-when-vocabs get adjoin-all ]
 118         [ 2array require-when-table get push ] 2bi
 119     ] if ;
 120
 121 : reload ( name -- )
 122     dup lookup-vocab
 123     [ [ load-source ] [ load-docs ] bi ]
 124     [ require ]
 125     ?if ;
 126
 127 : run ( vocab -- )
 128     dup load-vocab vocab-main [
 129         execute( -- )
 130     ] [
 131         "The " write vocab-name write
 132         " vocabulary does not define an entry point." print
 133         "To define one, refer to \\ MAIN: help" print
 134     ] ?if ;
 135
 136 SYMBOL: blacklist
 137
 138 : require-all ( vocabs -- )
 139     V{ } clone blacklist [ [ require ] each ] with-variable ;
 140
 141 <PRIVATE
 142
 143 : add-to-blacklist ( error vocab -- )
 144     vocab-name blacklist get [ set-at ] [ 2drop ] if* ;
 145
 146 GENERIC: (require) ( name -- )
 147
 148 M: vocab (require)
 149     [
 150         dup source-loaded?>> +parsing+ eq? [ drop ] [
 151             dup source-loaded?>> [ dup load-source ] unless
 152             dup docs-loaded?>> [ dup load-docs ] unless
 153             drop
 154         ] if
 155     ] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
 156
 157 M: vocab-link (require)
 158     vocab-name (require) ;
 159
 160 M: string (require) create-vocab (require) ;
 161
 162 PRIVATE>
 163
 164 [
 165     dup vocab-name blacklist get at*
 166     [ rethrow ]
 167     [
 168         drop dup find-vocab-root
 169         [ (require) ]
 170         [ dup lookup-vocab [ drop ] [ no-vocab ] if ]
 171         if
 172     ] if
 173 ] require-hook set-global
 174
 175 M: vocab-spec where vocab-source-path dup [ 1 2array ] when ;
 176
 177 ! put here to avoid circularity between vocabs.loader and source-files.errors
 178 { "source-files.errors" "debugger" } "source-files.errors.debugger" require-when