core/vocabs/parser/parser.factor

   1 ! Copyright (C) 2007, 2010 Daniel Ehrenberg, Bruno Deferrari,
   2 ! Slava Pestov.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: accessors arrays assocs combinators compiler.units
   5 continuations hash-sets hashtables kernel math namespaces
   6 parser.notes sequences sets sorting splitting vectors vocabs
   7 words ;
   8 IN: vocabs.parser
   9
  10 ERROR: no-word-error name ;
  11
  12 : word-restarts ( possibilities -- restarts )
  13     natural-sort [
  14         [ vocabulary>> "Use the " " vocabulary" surround ] keep
  15     ] { } map>assoc ;
  16
  17 : word-restarts-with-defer ( name possibilities -- restarts )
  18     word-restarts
  19     "Defer word in current vocabulary" rot 2array
  20     suffix ;
  21
  22 : <no-word-error> ( name possibilities -- error restarts )
  23     [ drop \ no-word-error boa ] [ word-restarts-with-defer ] 2bi ;
  24
  25 TUPLE: manifest
  26 current-vocab
  27 { search-vocab-names hash-set }
  28 { search-vocabs vector }
  29 { qualified-vocabs vector }
  30 { auto-used vector } ;
  31
  32 : <manifest> ( -- manifest )
  33     manifest new
  34         HS{ } clone >>search-vocab-names
  35         V{ } clone >>search-vocabs
  36         V{ } clone >>qualified-vocabs
  37         V{ } clone >>auto-used ;
  38
  39 M: manifest clone
  40     call-next-method
  41         [ clone ] change-search-vocab-names
  42         [ clone ] change-search-vocabs
  43         [ clone ] change-qualified-vocabs
  44         [ clone ] change-auto-used ;
  45
  46 TUPLE: extra-words words ;
  47
  48 M: extra-words equal?
  49     over extra-words? [ [ words>> ] bi@ eq? ] [ 2drop f ] if ;
  50
  51 C: <extra-words> extra-words
  52
  53 ERROR: no-word-in-vocab word vocab ;
  54
  55 <PRIVATE
  56
  57 : (from) ( vocab words -- vocab words words' vocab )
  58     2dup swap load-vocab ;
  59
  60 : extract-words ( seq vocab -- assoc )
  61     [ words>> extract-keys dup ] [ name>> ] bi
  62     [ swap [ 2drop ] [ no-word-in-vocab ] if ] curry assoc-each ;
  63
  64 : excluding-words ( seq vocab -- assoc )
  65     [ nip words>> ] [ extract-words ] 2bi assoc-diff ;
  66
  67 : qualified-words ( prefix vocab -- assoc )
  68     words>> swap [ swap [ swap ":" glue ] dip ] curry assoc-map ;
  69
  70 : (lookup) ( name assoc -- word/f )
  71     at* [ dup forward-reference? [ drop f ] when ] when ;
  72
  73 PRIVATE>
  74
  75 : qualified-vocabs ( -- qualified-vocabs )
  76     manifest get qualified-vocabs>> ;
  77
  78 : set-current-vocab ( name -- )
  79     create-vocab
  80     [ manifest get current-vocab<< ]
  81     [ qualified-vocabs push ] bi ;
  82
  83 : with-current-vocab ( name quot -- )
  84     manifest get clone manifest [
  85         [ set-current-vocab ] dip call
  86     ] with-variable ; inline
  87
  88 TUPLE: no-current-vocab-error ;
  89
  90 : no-current-vocab ( -- vocab )
  91     no-current-vocab-error boa
  92     { { "Define words in scratchpad vocabulary" "scratchpad" } }
  93     throw-restarts dup set-current-vocab ;
  94
  95 : current-vocab ( -- vocab )
  96     manifest get current-vocab>> [ no-current-vocab ] unless* ;
  97
  98 ERROR: unbalanced-private-declaration vocab ;
  99
 100 : begin-private ( -- )
 101     current-vocab name>> ".private" ?tail
 102     [ unbalanced-private-declaration ]
 103     [ ".private" append set-current-vocab ] if ;
 104
 105 : end-private ( -- )
 106     current-vocab name>> ".private" ?tail
 107     [ set-current-vocab ]
 108     [ unbalanced-private-declaration ] if ;
 109
 110 : using-vocab? ( vocab -- ? )
 111     vocab-name manifest get search-vocab-names>> in? ;
 112
 113 : use-vocab ( vocab -- )
 114     dup using-vocab? [
 115         vocab-name "Already using ``" "'' vocabulary" surround note.
 116     ] [
 117         manifest get
 118         [ [ ?load-vocab ] dip search-vocabs>> push ]
 119         [ [ vocab-name ] dip search-vocab-names>> adjoin ]
 120         2bi
 121     ] if ;
 122
 123 : auto-use-vocab ( vocab -- )
 124     [ use-vocab ] [ manifest get auto-used>> push ] bi ;
 125
 126 : auto-used? ( -- ? )
 127     manifest get auto-used>> length 0 > ;
 128
 129 : unuse-vocab ( vocab -- )
 130     dup using-vocab? [
 131         manifest get
 132         [ [ load-vocab ] dip search-vocabs>> remove-eq! drop ]
 133         [ [ vocab-name ] dip search-vocab-names>> delete ]
 134         2bi
 135     ] [ drop ] if ;
 136
 137 TUPLE: qualified vocab prefix words ;
 138
 139 : <qualified> ( vocab prefix -- qualified )
 140     (from) qualified-words qualified boa ;
 141
 142 : add-qualified ( vocab prefix -- )
 143     <qualified> qualified-vocabs push ;
 144
 145 TUPLE: from vocab names words ;
 146
 147 : <from> ( vocab words -- from )
 148     (from) extract-words from boa ;
 149
 150 : add-words-from ( vocab words -- )
 151     <from> qualified-vocabs push ;
 152
 153 TUPLE: exclude vocab names words ;
 154
 155 : <exclude> ( vocab words -- from )
 156     (from) excluding-words exclude boa ;
 157
 158 : add-words-excluding ( vocab words -- )
 159     <exclude> qualified-vocabs push ;
 160
 161 TUPLE: rename word vocab words ;
 162
 163 : <rename> ( word vocab new-name -- rename )
 164     [
 165         2dup load-vocab words>> dupd at
 166         [ ] [ swap no-word-in-vocab ] ?if
 167     ] dip associate rename boa ;
 168
 169 : add-renamed-word ( word vocab new-name -- )
 170     <rename> qualified-vocabs push ;
 171
 172 : use-words ( assoc -- )
 173     <extra-words> qualified-vocabs push ;
 174
 175 : unuse-words ( assoc -- )
 176     <extra-words> qualified-vocabs remove! drop ;
 177
 178 TUPLE: ambiguous-use-error name words ;
 179
 180 : <ambiguous-use-error> ( name words -- error restarts )
 181     [ ambiguous-use-error boa ] [ word-restarts ] bi ;
 182
 183 <PRIVATE
 184
 185 : (vocab-search) ( name assocs -- words )
 186     [ words>> (lookup) ] with map sift ;
 187
 188 : (vocab-search-qualified) ( name assocs -- words )
 189     [ ":" split1 swap ] dip [ name>> = ] with filter (vocab-search) ;
 190
 191 : (vocab-search-full) ( name assocs -- words )
 192     [ (vocab-search-qualified) ] [ (vocab-search) ] 2bi append ;
 193
 194 : vocab-search ( name manifest -- word/f )
 195     dupd search-vocabs>> sift (vocab-search-full) dup length {
 196         { 0 [ 2drop f ] }
 197         { 1 [ first nip ] }
 198         [
 199             drop <ambiguous-use-error> throw-restarts
 200             dup [ vocabulary>> ] [ name>> 1array ] bi add-words-from
 201         ]
 202     } case ;
 203
 204 : qualified-search ( name manifest -- word/f )
 205     qualified-vocabs>> (vocab-search) ?last ;
 206
 207 PRIVATE>
 208
 209 : search-manifest ( name manifest -- word/f )
 210     2dup qualified-search [ 2nip ] [ vocab-search ] if* ;
 211
 212 : search ( name -- word/f )
 213     manifest get search-manifest ;
 214
 215 <PRIVATE
 216
 217 GENERIC: update ( search-path-elt -- valid? )
 218
 219 : trim-forgotten ( qualified-vocab -- valid? )
 220     [ [ nip "forgotten" word-prop ] assoc-reject ] change-words
 221     words>> assoc-empty? not ;
 222
 223 M: from update trim-forgotten ;
 224 M: rename update trim-forgotten ;
 225 M: extra-words update trim-forgotten ;
 226 M: exclude update trim-forgotten ;
 227
 228 M: qualified update
 229     dup vocab>> lookup-vocab [
 230         dup [ prefix>> ] [ vocab>> load-vocab ] bi qualified-words
 231         >>words
 232     ] [ drop f ] if ;
 233
 234 M: vocab update dup name>> lookup-vocab eq? ;
 235
 236 : update-current-vocab ( manifest -- manifest )
 237     [ dup [ name>> lookup-vocab ] when ] change-current-vocab ; inline
 238
 239 : compute-search-vocabs ( manifest -- search-vocab-names search-vocabs )
 240     search-vocab-names>> members dup length <vector> [
 241         [ push ] curry [ when* ] curry
 242         [ lookup-vocab dup ] prepose filter fast-set
 243     ] keep ; inline
 244
 245 : update-search-vocabs ( manifest -- manifest )
 246     dup compute-search-vocabs
 247     [ >>search-vocab-names ] [ >>search-vocabs ] bi* ; inline
 248
 249 : update-qualified-vocabs ( manifest -- manifest )
 250     dup qualified-vocabs>> [ update ] filter! drop ; inline
 251
 252 : update-manifest ( manifest -- manifest )
 253     update-current-vocab
 254     update-search-vocabs
 255     update-qualified-vocabs ; inline
 256
 257 M: manifest definitions-changed
 258     nip update-manifest drop ;
 259
 260 PRIVATE>
 261
 262 : with-manifest ( quot -- )
 263     <manifest> manifest [
 264         [ call ] [
 265             [ manifest get add-definition-observer call ]
 266             [ manifest get remove-definition-observer ]
 267             [ ]
 268             cleanup
 269         ] if-bootstrapping
 270     ] with-variable ; inline