core/vocabs/parser/parser.factor

   1 ! Copyright (C) 2007, 2010 Daniel Ehrenberg, Bruno Deferrari,
   2 ! Slava Pestov.
   3 ! See https://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         [
 135             [ vocab-name ] dip qualified-vocabs>> [
 136                 dup extra-words? [ 2drop f ] [
 137                     dup vocab? [ vocab>> ] unless vocab-name =
 138                 ] if
 139             ] with reject! drop
 140         ] 2tri
 141     ] [ drop ] if ;
 142
 143 TUPLE: qualified vocab prefix words ;
 144
 145 : <qualified> ( vocab prefix -- qualified )
 146     (from) qualified-words qualified boa ;
 147
 148 : add-qualified ( vocab prefix -- )
 149     <qualified> qualified-vocabs push ;
 150
 151 TUPLE: from vocab names words ;
 152
 153 : <from> ( vocab words -- from )
 154     (from) extract-words from boa ;
 155
 156 : add-words-from ( vocab words -- )
 157     <from> qualified-vocabs push ;
 158
 159 TUPLE: exclude vocab names words ;
 160
 161 : <exclude> ( vocab words -- from )
 162     (from) excluding-words exclude boa ;
 163
 164 : add-words-excluding ( vocab words -- )
 165     <exclude> qualified-vocabs push ;
 166
 167 TUPLE: rename word vocab words ;
 168
 169 : <rename> ( word vocab new-name -- rename )
 170     [
 171         2dup load-vocab words>> dupd at
 172         [ ] [ swap no-word-in-vocab ] ?if
 173     ] dip associate rename boa ;
 174
 175 : add-renamed-word ( word vocab new-name -- )
 176     <rename> qualified-vocabs push ;
 177
 178 : use-words ( words -- )
 179     <extra-words> qualified-vocabs push ;
 180
 181 : unuse-words ( words -- )
 182     <extra-words> qualified-vocabs remove! drop ;
 183
 184 DEFER: with-words
 185
 186 <PRIVATE
 187
 188 : ?restart-with-words ( words error -- * )
 189     dup condition? [
 190         [ error>> ]
 191         [ restarts>> rethrow-restarts ]
 192         [ continuation>> '[ _ _ continue-with ] with-words ] tri
 193     ] [ nip rethrow ] if ;
 194
 195 PRIVATE>
 196
 197 : with-words ( words quot -- )
 198     [ over '[ _ use-words @ _ unuse-words ] ]
 199     [ drop dup '[ _ unuse-words _ swap ?restart-with-words ] ]
 200     2bi recover ; inline
 201
 202 TUPLE: ambiguous-use-error name words ;
 203
 204 : <ambiguous-use-error> ( name words -- error restarts )
 205     [ ambiguous-use-error boa ] [ word-restarts ] bi ;
 206
 207 <PRIVATE
 208
 209 : (lookup-word) ( words name vocab -- words )
 210     words>> (lookup) [ suffix! ] when* ; inline
 211
 212 : (vocab-search) ( name assocs -- words )
 213     [ V{ } clone ] 2dip [ (lookup-word) ] with each ;
 214
 215 : (vocab-search-qualified) ( words name assocs -- words )
 216     [ ":" split1 swap ] dip pick [
 217         [ name>> = ] with find nip [ (lookup-word) ] with when*
 218     ] [
 219         3drop
 220     ] if ;
 221
 222 : (vocab-search-full) ( name assocs -- words )
 223     [ (vocab-search) ] [ (vocab-search-qualified) ] 2bi ;
 224
 225 : vocab-search ( name manifest -- word/f )
 226     dupd search-vocabs>> (vocab-search-full) dup length {
 227         { 0 [ 2drop f ] }
 228         { 1 [ first nip ] }
 229         [
 230             drop <ambiguous-use-error> throw-restarts
 231             dup [ vocabulary>> ] [ name>> 1array ] bi add-words-from
 232         ]
 233     } case ;
 234
 235 : qualified-search ( name manifest -- word/f )
 236     qualified-vocabs>> (vocab-search) ?last ;
 237
 238 PRIVATE>
 239
 240 : search-manifest ( name manifest -- word/f )
 241     2dup qualified-search [ 2nip ] [ vocab-search ] if* ;
 242
 243 : search ( name -- word/f )
 244     manifest get search-manifest ;
 245
 246 <PRIVATE
 247
 248 GENERIC: update ( search-path-elt -- valid? )
 249
 250 : trim-forgotten ( qualified-vocab -- valid? )
 251     [ [ nip "forgotten" word-prop ] assoc-reject ] change-words
 252     words>> assoc-empty? not ;
 253
 254 M: from update trim-forgotten ;
 255 M: rename update trim-forgotten ;
 256 M: extra-words update trim-forgotten ;
 257 M: exclude update trim-forgotten ;
 258
 259 M: qualified update
 260     dup vocab>> lookup-vocab [
 261         dup [ prefix>> ] [ vocab>> load-vocab ] bi qualified-words
 262         >>words
 263     ] [ drop f ] if ;
 264
 265 M: vocab update dup name>> lookup-vocab eq? ;
 266
 267 : update-current-vocab ( manifest -- manifest )
 268     [ dup [ name>> lookup-vocab ] when ] change-current-vocab ; inline
 269
 270 : compute-search-vocabs ( manifest -- search-vocab-names search-vocabs )
 271     search-vocab-names>> members dup length <vector> [
 272         [ push ] curry [ when* ] curry
 273         [ lookup-vocab dup ] prepose filter fast-set
 274     ] keep ; inline
 275
 276 : update-search-vocabs ( manifest -- manifest )
 277     dup compute-search-vocabs
 278     [ >>search-vocab-names ] [ >>search-vocabs ] bi* ; inline
 279
 280 : update-qualified-vocabs ( manifest -- manifest )
 281     dup qualified-vocabs>> [ update ] filter! drop ; inline
 282
 283 : update-manifest ( manifest -- manifest )
 284     update-current-vocab
 285     update-search-vocabs
 286     update-qualified-vocabs ; inline
 287
 288 M: manifest definitions-changed
 289     nip update-manifest drop ;
 290
 291 PRIVATE>
 292
 293 SYMBOL: print-use-hook
 294
 295 print-use-hook [ [ ] ] initialize
 296
 297 : (with-manifest) ( quot manifest -- )
 298     manifest [
 299         [ call ] [
 300             [ manifest get add-definition-observer call ]
 301             [ manifest get remove-definition-observer ]
 302             finally
 303         ] if-bootstrapping
 304     ] with-variable ; inline
 305
 306 : with-manifest ( quot -- )
 307     <manifest> (with-manifest) ; inline
 308
 309 : with-current-manifest ( quot -- )
 310     manifest get (with-manifest) ; inline