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