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