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
  25     [ vocab-roots get adjoin ]
  26     [ add-vocab-root-hook get-global call( root -- ) ] bi ;
  27
  28 SYMBOL: root-cache
  29
  30 root-cache [ H{ } clone ] initialize
  31
  32 ERROR: not-found-in-roots path ;
  33
  34 <PRIVATE
  35
  36 : find-root-for ( path -- path/f )
  37     vocab-roots get [ prepend-path exists? ] with find nip ;
  38
  39 M: string vocab-path ( string -- path/f )
  40     dup find-root-for [ prepend-path ] [ not-found-in-roots ] if* ;
  41
  42 PRIVATE>
  43
  44 : vocab-dir ( vocab -- dir )
  45     vocab-name H{ { CHAR: . CHAR: / } } substitute ;
  46
  47 : append-vocab-dir ( vocab str/f -- path )
  48     [ vocab-name "." split ] dip
  49     [ [ dup last ] dip append suffix ] when*
  50     "/" join ;
  51
  52 : find-vocab-root ( vocab -- path/f )
  53     vocab-name root-cache get
  54     [ ".factor" append-vocab-dir find-root-for ] cache ;
  55
  56 : vocab-append-path ( vocab path -- newpath )
  57     swap find-vocab-root dup [ prepend-path ] [ 2drop f ] if ;
  58
  59 : vocab-source-path ( vocab -- path/f )
  60     dup ".factor" append-vocab-dir vocab-append-path ;
  61
  62 : vocab-docs-path ( vocab -- path/f )
  63     dup "-docs.factor" append-vocab-dir vocab-append-path ;
  64
  65 SYMBOL: load-help?
  66
  67 ! Defined by vocabs.metadata
  68 SYMBOL: check-vocab-hook
  69
  70 check-vocab-hook [ [ drop ] ] initialize
  71
  72 <PRIVATE
  73
  74 SYMBOL: require-when-vocabs
  75 require-when-vocabs [ HS{ } clone ] initialize
  76
  77 SYMBOL: require-when-table
  78 require-when-table [ V{ } clone ] initialize
  79
  80 : load-conditional-requires ( vocab -- )
  81     vocab-name require-when-vocabs get in? [
  82         require-when-table get [
  83             [ [ lookup-vocab dup [ source-loaded?>> +done+ = ] when ] all? ] dip
  84             [ require ] curry when
  85         ] assoc-each
  86     ] when ;
  87
  88 : load-source ( vocab -- )
  89     dup check-vocab-hook get call( vocab -- )
  90     [
  91         +parsing+ >>source-loaded?
  92         dup vocab-source-path [ parse-file ] [ [ ] ] if*
  93         [ +parsing+ >>source-loaded? ] dip
  94         [ % ] [ call( -- ) ] if-bootstrapping
  95         +done+ >>source-loaded?
  96         load-conditional-requires
  97     ] [ ] [ f >>source-loaded? ] cleanup ;
  98
  99 : load-docs ( vocab -- )
 100     load-help? get [
 101         [
 102             +parsing+ >>docs-loaded?
 103             [ vocab-docs-path [ ?run-file ] when* ] keep
 104             +done+ >>docs-loaded?
 105         ] [ ] [ f >>docs-loaded? ] cleanup
 106     ] when drop ;
 107
 108 PRIVATE>
 109
 110 : require-when ( if then -- )
 111     over [ lookup-vocab ] all? [
 112         require drop
 113     ] [
 114         [ drop [ require-when-vocabs get adjoin ] each ]
 115         [ 2array require-when-table get push ] 2bi
 116     ] if ;
 117
 118 : reload ( name -- )
 119     dup lookup-vocab
 120     [ [ load-source ] [ load-docs ] bi ]
 121     [ require ]
 122     ?if ;
 123
 124 : run ( vocab -- )
 125     dup load-vocab vocab-main [
 126         execute( -- )
 127     ] [
 128         "The " write vocab-name write
 129         " vocabulary does not define an entry point." print
 130         "To define one, refer to \\ MAIN: help" print
 131     ] ?if ;
 132
 133 SYMBOL: blacklist
 134
 135 <PRIVATE
 136
 137 : add-to-blacklist ( error vocab -- )
 138     vocab-name blacklist get dup [ set-at ] [ 3drop ] if ;
 139
 140 GENERIC: (require) ( name -- )
 141
 142 M: vocab (require)
 143     [
 144         dup source-loaded?>> +parsing+ eq? [ drop ] [
 145             dup source-loaded?>> [ dup load-source ] unless
 146             dup docs-loaded?>> [ dup load-docs ] unless
 147             drop
 148         ] if
 149     ] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
 150
 151 M: vocab-link (require)
 152     vocab-name (require) ;
 153
 154 M: string (require) create-vocab (require) ;
 155
 156 PRIVATE>
 157
 158 [
 159     dup vocab-name blacklist get at*
 160     [ rethrow ]
 161     [
 162         drop dup find-vocab-root
 163         [ (require) ]
 164         [ dup lookup-vocab [ drop ] [ no-vocab ] if ]
 165         if
 166     ] if
 167 ] require-hook set-global
 168
 169 M: vocab-spec where vocab-source-path dup [ 1 2array ] when ;
 170
 171 ! put here to avoid circularity between vocabs.loader and source-files.errors
 172 { "source-files.errors" "debugger" } "source-files.errors.debugger" require-when