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 : with-words ( assoc quot -- )
 179     [ use-words ] prepose over '[ _ unuse-words ] finally ; inline
 180
 181 TUPLE: ambiguous-use-error name words ;
 182
 183 : <ambiguous-use-error> ( name words -- error restarts )
 184     [ ambiguous-use-error boa ] [ word-restarts ] bi ;
 185
 186 <PRIVATE
 187
 188 : (lookup-word) ( words name vocab -- words )
 189     words>> (lookup) [ suffix! ] when* ; inline
 190
 191 : (vocab-search) ( name assocs -- words )
 192     [ V{ } clone ] 2dip [ (lookup-word) ] with each ;
 193
 194 : (vocab-search-qualified) ( words name assocs -- words )
 195     [ ":" split1 swap ] dip pick [
 196         [ name>> = ] with find nip [ (lookup-word) ] with when*
 197     ] [
 198         3drop
 199     ] if ;
 200
 201 : (vocab-search-full) ( name assocs -- words )
 202     [ (vocab-search) ] [ (vocab-search-qualified) ] 2bi ;
 203
 204 : vocab-search ( name manifest -- word/f )
 205     dupd search-vocabs>> (vocab-search-full) dup length {
 206         { 0 [ 2drop f ] }
 207         { 1 [ first nip ] }
 208         [
 209             drop <ambiguous-use-error> throw-restarts
 210             dup [ vocabulary>> ] [ name>> 1array ] bi add-words-from
 211         ]
 212     } case ;
 213
 214 : qualified-search ( name manifest -- word/f )
 215     qualified-vocabs>> (vocab-search) ?last ;
 216
 217 PRIVATE>
 218
 219 : search-manifest ( name manifest -- word/f )
 220     2dup qualified-search [ 2nip ] [ vocab-search ] if* ;
 221
 222 : search ( name -- word/f )
 223     manifest get search-manifest ;
 224
 225 <PRIVATE
 226
 227 GENERIC: update ( search-path-elt -- valid? )
 228
 229 : trim-forgotten ( qualified-vocab -- valid? )
 230     [ [ nip "forgotten" word-prop ] assoc-reject ] change-words
 231     words>> assoc-empty? not ;
 232
 233 M: from update trim-forgotten ;
 234 M: rename update trim-forgotten ;
 235 M: extra-words update trim-forgotten ;
 236 M: exclude update trim-forgotten ;
 237
 238 M: qualified update
 239     dup vocab>> lookup-vocab [
 240         dup [ prefix>> ] [ vocab>> load-vocab ] bi qualified-words
 241         >>words
 242     ] [ drop f ] if ;
 243
 244 M: vocab update dup name>> lookup-vocab eq? ;
 245
 246 : update-current-vocab ( manifest -- manifest )
 247     [ dup [ name>> lookup-vocab ] when ] change-current-vocab ; inline
 248
 249 : compute-search-vocabs ( manifest -- search-vocab-names search-vocabs )
 250     search-vocab-names>> members dup length <vector> [
 251         [ push ] curry [ when* ] curry
 252         [ lookup-vocab dup ] prepose filter fast-set
 253     ] keep ; inline
 254
 255 : update-search-vocabs ( manifest -- manifest )
 256     dup compute-search-vocabs
 257     [ >>search-vocab-names ] [ >>search-vocabs ] bi* ; inline
 258
 259 : update-qualified-vocabs ( manifest -- manifest )
 260     dup qualified-vocabs>> [ update ] filter! drop ; inline
 261
 262 : update-manifest ( manifest -- manifest )
 263     update-current-vocab
 264     update-search-vocabs
 265     update-qualified-vocabs ; inline
 266
 267 M: manifest definitions-changed
 268     nip update-manifest drop ;
 269
 270 PRIVATE>
 271
 272 : with-manifest ( quot -- )
 273     <manifest> manifest [
 274         [ call ] [
 275             [ manifest get add-definition-observer call ]
 276             [ manifest get remove-definition-observer ]
 277             finally
 278         ] if-bootstrapping
 279     ] with-variable ; inline