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: namespaces make sequences io io.files io.pathnames kernel
   4 assocs words vocabs definitions parser continuations hashtables
   5 sorting source-files arrays combinators strings system
   6 math.parser splitting init accessors sets ;
   7 IN: vocabs.loader
   8
   9 SYMBOL: vocab-roots
  10
  11 SYMBOL: add-vocab-root-hook
  12
  13 [
  14     V{
  15         "resource:core"
  16         "resource:basis"
  17         "resource:extra"
  18         "resource:work"
  19     } clone vocab-roots set-global
  20
  21     [ drop ] add-vocab-root-hook set-global
  22 ] "vocabs.loader" add-startup-hook
  23
  24 : add-vocab-root ( root -- )
  25     trim-tail-separators
  26     [ vocab-roots get adjoin ]
  27     [ add-vocab-root-hook get-global call( root -- ) ] bi ;
  28
  29 SYMBOL: root-cache
  30
  31 root-cache [ H{ } clone ] initialize
  32
  33 ERROR: not-found-in-roots path ;
  34
  35 <PRIVATE
  36
  37 : find-root-for ( path -- path/f )
  38     vocab-roots get [ prepend-path exists? ] with find nip ;
  39
  40 M: string vocab-path ( string -- path/f )
  41     dup find-root-for [ prepend-path ] [ not-found-in-roots ] if* ;
  42
  43 PRIVATE>
  44
  45 : vocab-dir ( vocab -- dir )
  46     vocab-name { { CHAR: . CHAR: / } } substitute ;
  47
  48 ERROR: absolute-path-forbidden path ;
  49
  50 : forbid-absolute-path ( str -- str )
  51     dup absolute-path? [ absolute-path-forbidden ] when ;
  52
  53 : append-vocab-dir ( vocab str/f -- path )
  54     [ vocab-name forbid-absolute-path "." split ] dip
  55     [ [ dup last ] dip append suffix ] when*
  56     "/" join ;
  57
  58 : find-vocab-root ( vocab -- path/f )
  59     vocab-name dup root-cache get at
  60     [ ] [ ".factor" append-vocab-dir find-root-for ] ?if ;
  61
  62 : vocab-append-path ( vocab path -- newpath )
  63     swap find-vocab-root dup [ prepend-path ] [ 2drop f ] if ;
  64
  65 : vocab-source-path ( vocab -- path/f )
  66     dup ".factor" append-vocab-dir vocab-append-path ;
  67
  68 : vocab-docs-path ( vocab -- path/f )
  69     dup "-docs.factor" append-vocab-dir vocab-append-path ;
  70
  71 SYMBOL: load-help?
  72
  73 ! Defined by vocabs.metadata
  74 SYMBOL: check-vocab-hook
  75
  76 check-vocab-hook [ [ drop ] ] initialize
  77
  78 DEFER: require
  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             [ vocab-docs-path [ ?run-file ] when* ] keep
 112             +done+ >>docs-loaded?
 113         ] [ ] [ f >>docs-loaded? ] cleanup
 114     ] when drop ;
 115
 116 PRIVATE>
 117
 118 : require ( vocab -- )
 119     load-vocab drop ;
 120
 121 : require-when ( if then -- )
 122     over [ lookup-vocab ] all? [
 123         require drop
 124     ] [
 125         [ drop [ require-when-vocabs get adjoin ] each ]
 126         [ 2array require-when-table get push ] 2bi
 127     ] if ;
 128
 129 : reload ( name -- )
 130     dup lookup-vocab
 131     [ [ load-source ] [ load-docs ] bi ]
 132     [ require ]
 133     ?if ;
 134
 135 : run ( vocab -- )
 136     dup load-vocab vocab-main [
 137         execute( -- )
 138     ] [
 139         "The " write vocab-name write
 140         " vocabulary does not define an entry point." print
 141         "To define one, refer to \\ MAIN: help" print
 142     ] ?if ;
 143
 144 SYMBOL: blacklist
 145
 146 <PRIVATE
 147
 148 : add-to-blacklist ( error vocab -- )
 149     vocab-name blacklist get dup [ set-at ] [ 3drop ] if ;
 150
 151 GENERIC: (load-vocab) ( name -- vocab )
 152
 153 M: vocab (load-vocab)
 154     [
 155         dup source-loaded?>> +parsing+ eq? [
 156             dup source-loaded?>> [ dup load-source ] unless
 157             dup docs-loaded?>> [ dup load-docs ] unless
 158         ] unless
 159     ] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
 160
 161 M: vocab-link (load-vocab)
 162     vocab-name (load-vocab) ;
 163
 164 M: string (load-vocab) create-vocab (load-vocab) ;
 165
 166 PRIVATE>
 167
 168 [
 169     dup vocab-name blacklist get at* [ rethrow ] [
 170         drop dup find-vocab-root
 171         [ (load-vocab) ] [ dup lookup-vocab [ ] [ no-vocab ] ?if ] if
 172     ] if
 173 ] load-vocab-hook set-global
 174
 175 M: vocab-spec where vocab-source-path dup [ 1 2array ] when ;