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 CONSTANT: default-vocab-roots {
  13     "resource:core"
  14     "resource:basis"
  15     "resource:extra"
  16     "resource:work"
  17 }
  18
  19 [
  20     default-vocab-roots V{ } like vocab-roots set-global
  21
  22     [ drop ] add-vocab-root-hook set-global
  23 ] "vocabs.loader" add-startup-hook
  24
  25 : add-vocab-root ( root -- )
  26     trim-tail-separators dup vocab-roots get ?adjoin
  27     [ add-vocab-root-hook get-global call( root -- ) ] [ drop ] if ;
  28
  29 SYMBOL: root-cache
  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 file-exists? ] with find nip ;
  38
  39 M: string vocab-path
  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 dup ".private" tail? [ drop f ] [
  54         root-cache get 2dup at [ 2nip ] [
  55             over ".factor" append-vocab-dir find-root-for
  56             [ [ -rot set-at ] [ 2drop ] if* ] keep
  57         ] if*
  58     ] if ;
  59
  60 : vocab-exists? ( name -- ? )
  61     dup lookup-vocab [ ] [ find-vocab-root ] ?if ;
  62
  63 : vocab-append-path ( vocab path -- newpath )
  64     swap find-vocab-root [ prepend-path ] [ drop f ] if* ;
  65
  66 : vocab-source-path ( vocab -- path/f )
  67     vocab-name ".private" ?tail drop
  68     dup ".factor" append-vocab-dir vocab-append-path ;
  69
  70 : vocab-docs-path ( vocab -- path/f )
  71     vocab-name ".private" ?tail drop
  72     dup "-docs.factor" append-vocab-dir vocab-append-path ;
  73
  74 SYMBOL: load-help?
  75
  76 ! Defined by vocabs.metadata
  77 SYMBOL: check-vocab-hook
  78 check-vocab-hook [ [ drop ] ] initialize
  79
  80 <PRIVATE
  81
  82 SYMBOL: require-when-vocabs
  83 require-when-vocabs [ HS{ } clone ] initialize
  84
  85 SYMBOL: require-when-table
  86 require-when-table [ V{ } clone ] initialize
  87
  88 : load-conditional-requires ( vocab -- )
  89     vocab-name require-when-vocabs get in? [
  90         require-when-table get [
  91             [ [ lookup-vocab dup [ source-loaded?>> +done+ = ] when ] all? ] dip
  92             [ require ] curry when
  93         ] assoc-each
  94     ] when ;
  95
  96 : load-source ( vocab -- )
  97     dup check-vocab-hook get call( vocab -- )
  98     [
  99         +parsing+ >>source-loaded?
 100         dup vocab-source-path [ parse-file ] [ [ ] ] if*
 101         [ +parsing+ >>source-loaded? ] dip
 102         [ % ] [ call( -- ) ] if-bootstrapping
 103         +done+ >>source-loaded?
 104         load-conditional-requires
 105     ] [ ] [ f >>source-loaded? ] cleanup ;
 106
 107 : load-docs ( vocab -- )
 108     load-help? get [
 109         [
 110             +parsing+ >>docs-loaded?
 111             dup vocab-docs-path [ ?run-file ] when*
 112             +done+ >>docs-loaded?
 113         ] [ ] [ f >>docs-loaded? ] cleanup
 114     ] when drop ;
 115
 116 PRIVATE>
 117
 118 : require-when ( if then -- )
 119     over [ lookup-vocab ] all? [
 120         require drop
 121     ] [
 122         [ drop require-when-vocabs get adjoin-all ]
 123         [ 2array require-when-table get push ] 2bi
 124     ] if ;
 125
 126 : reload ( name -- )
 127     dup lookup-vocab
 128     [ [ load-source ] [ load-docs ] bi ]
 129     [ require ]
 130     ?if ;
 131
 132 : run ( vocab -- )
 133     dup load-vocab vocab-main [
 134         execute( -- )
 135     ] [
 136         "The " write vocab-name write
 137         " vocabulary does not define an entry point." print
 138         "To define one, refer to \\ MAIN: help" print
 139     ] ?if ;
 140
 141 SYMBOL: errorlist
 142
 143 <PRIVATE
 144
 145 : add-to-errorlist ( error vocab -- )
 146     vocab-name errorlist get [ set-at ] [ 2drop ] if* ;
 147
 148 GENERIC: (require) ( name -- )
 149
 150 M: vocab (require)
 151     [
 152         dup source-loaded?>> +parsing+ eq? [ drop ] [
 153             dup source-loaded?>> [ dup load-source ] unless
 154             dup docs-loaded?>> [ dup load-docs ] unless
 155             drop
 156         ] if
 157     ] [ [ swap add-to-errorlist ] keep rethrow ] recover ;
 158
 159 M: vocab-link (require)
 160     vocab-name (require) ;
 161
 162 M: string (require)
 163     dup check-vocab-hook get call( vocab -- )
 164     create-vocab (require) ;
 165
 166 PRIVATE>
 167
 168 : require-all ( vocabs -- )
 169     V{ } clone errorlist [ [ require ] each ] with-variable ;
 170
 171 [
 172     dup vocab-name errorlist get at*
 173     [ rethrow ]
 174     [
 175         drop dup find-vocab-root
 176         [ (require) ]
 177         [ dup lookup-vocab [ drop ] [ no-vocab ] if ]
 178         if
 179     ] if
 180 ] require-hook set-global
 181
 182 M: vocab-spec where vocab-source-path dup [ 1 2array ] when ;
 183
 184 ! put here to avoid circularity between vocabs.loader and source-files.errors
 185 { "source-files.errors" "debugger" } "source-files.errors.debugger" require-when