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 hashtables kernel math namespaces parser.notes
   6 sequences sets sorting splitting vectors vocabs words ;
   7 IN: vocabs.parser
   8
   9 ERROR: no-word-error name ;
  10
  11 : word-restarts ( possibilities -- restarts )
  12     natural-sort
  13     [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc ;
  14
  15 : word-restarts-with-defer ( name possibilities -- restarts )
  16     word-restarts
  17     swap "Defer word in current vocabulary" swap 2array
  18     suffix ;
  19
  20 : <no-word-error> ( name possibilities -- error restarts )
  21     [ drop \ no-word-error boa ] [ word-restarts-with-defer ] 2bi ;
  22
  23 TUPLE: manifest
  24 current-vocab
  25 { search-vocab-names hashtable }
  26 { search-vocabs vector }
  27 { qualified-vocabs vector }
  28 { auto-used vector } ;
  29
  30 : <manifest> ( -- manifest )
  31     manifest new
  32         H{ } clone >>search-vocab-names
  33         V{ } clone >>search-vocabs
  34         V{ } clone >>qualified-vocabs
  35         V{ } clone >>auto-used ;
  36
  37 M: manifest clone
  38     call-next-method
  39         [ clone ] change-search-vocab-names
  40         [ clone ] change-search-vocabs
  41         [ clone ] change-qualified-vocabs
  42         [ clone ] change-auto-used ;
  43
  44 TUPLE: extra-words words ;
  45
  46 M: extra-words equal?
  47     over extra-words? [ [ words>> ] bi@ eq? ] [ 2drop f ] if ;
  48
  49 C: <extra-words> extra-words
  50
  51 ERROR: no-word-in-vocab word vocab ;
  52
  53 <PRIVATE
  54
  55 : (add-qualified) ( qualified -- )
  56     manifest get qualified-vocabs>> push ;
  57
  58 : (from) ( vocab words -- vocab words words' vocab )
  59     2dup swap load-vocab ;
  60
  61 : extract-words ( seq vocab -- assoc )
  62     [ words>> extract-keys dup ] [ name>> ] bi
  63     [ swap [ 2drop ] [ no-word-in-vocab ] if ] curry assoc-each ;
  64
  65 : excluding-words ( seq vocab -- assoc )
  66     [ nip words>> ] [ extract-words ] 2bi assoc-diff ;
  67
  68 : qualified-words ( prefix vocab -- assoc )
  69     words>> swap [ swap [ swap ":" glue ] dip ] curry assoc-map ;
  70
  71 : (lookup) ( name assoc -- word/f )
  72     at* [ dup forward-reference? [ drop f ] when ] when ;
  73
  74 : (use-words) ( assoc -- extra-words seq )
  75     <extra-words> manifest get qualified-vocabs>> ;
  76
  77 PRIVATE>
  78
  79 : set-current-vocab ( name -- )
  80     create-vocab
  81     [ manifest get current-vocab<< ] [ (add-qualified) ] 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 : begin-private ( -- )
  99     current-vocab name>> ".private" ?tail
 100     [ drop ] [ ".private" append set-current-vocab ] if ;
 101
 102 : end-private ( -- )
 103     current-vocab name>> ".private" ?tail
 104     [ set-current-vocab ] [ drop ] if ;
 105
 106 : using-vocab? ( vocab -- ? )
 107     vocab-name manifest get search-vocab-names>> key? ;
 108
 109 : use-vocab ( vocab -- )
 110     dup using-vocab?
 111     [ vocab-name "Already using ``" "'' vocabulary" surround note. ] [
 112         manifest get
 113         [ [ load-vocab ] dip search-vocabs>> push ]
 114         [ [ vocab-name ] dip search-vocab-names>> conjoin ]
 115         2bi
 116     ] if ;
 117
 118 : auto-use-vocab ( vocab -- )
 119     [ use-vocab ] [ manifest get auto-used>> push ] bi ;
 120
 121 : auto-used? ( -- ? ) manifest get auto-used>> length 0 > ;
 122
 123 : unuse-vocab ( vocab -- )
 124     dup using-vocab? [
 125         manifest get
 126         [ [ load-vocab ] dip search-vocabs>> remove-eq! drop ]
 127         [ [ vocab-name ] dip search-vocab-names>> delete-at ]
 128         2bi
 129     ] [ drop ] if ;
 130
 131 TUPLE: qualified vocab prefix words ;
 132
 133 : <qualified> ( vocab prefix -- qualified )
 134     (from) qualified-words qualified boa ;
 135
 136 : add-qualified ( vocab prefix -- )
 137     <qualified> (add-qualified) ;
 138
 139 TUPLE: from vocab names words ;
 140
 141 : <from> ( vocab words -- from )
 142     (from) extract-words from boa ;
 143
 144 : add-words-from ( vocab words -- )
 145     <from> (add-qualified) ;
 146
 147 TUPLE: exclude vocab names words ;
 148
 149 : <exclude> ( vocab words -- from )
 150     (from) excluding-words exclude boa ;
 151
 152 : add-words-excluding ( vocab words -- )
 153     <exclude> (add-qualified) ;
 154
 155 TUPLE: rename word vocab words ;
 156
 157 : <rename> ( word vocab new-name -- rename )
 158     [ 2dup load-vocab words>> dupd at [ ] [ swap no-word-in-vocab ] ?if ] dip
 159     associate rename boa ;
 160
 161 : add-renamed-word ( word vocab new-name -- )
 162     <rename> (add-qualified) ;
 163
 164 : use-words ( assoc -- ) (use-words) push ;
 165
 166 : unuse-words ( assoc -- ) (use-words) remove! drop ;
 167
 168 TUPLE: ambiguous-use-error words ;
 169
 170 : <ambiguous-use-error> ( words -- error restarts )
 171     [ \ ambiguous-use-error boa ] [ word-restarts ] bi ;
 172
 173 <PRIVATE
 174
 175 : (vocab-search) ( name assocs -- words n )
 176     [ words>> (lookup) ] with map
 177     sift dup length ;
 178
 179 : vocab-search ( name manifest -- word/f )
 180     search-vocabs>>
 181     (vocab-search) {
 182         { 0 [ drop f ] }
 183         { 1 [ first ] }
 184         [
 185             drop <ambiguous-use-error> throw-restarts
 186             dup [ vocabulary>> ] [ name>> 1array ] bi add-words-from
 187         ]
 188     } case ;
 189
 190 : qualified-search ( name manifest -- word/f )
 191     qualified-vocabs>>
 192     (vocab-search) 0 = [ drop f ] [ last ] if ;
 193
 194 PRIVATE>
 195
 196 : search-manifest ( name manifest -- word/f )
 197     2dup qualified-search dup [ 2nip ] [ drop vocab-search ] if ;
 198
 199 : search ( name -- word/f )
 200     manifest get search-manifest ;
 201
 202 <PRIVATE
 203
 204 GENERIC: update ( search-path-elt -- valid? )
 205
 206 : trim-forgotten ( qualified-vocab -- valid? )
 207     [ [ nip "forgotten" word-prop not ] assoc-filter ] change-words
 208     words>> assoc-empty? not ;
 209
 210 M: from update trim-forgotten ;
 211 M: rename update trim-forgotten ;
 212 M: extra-words update trim-forgotten ;
 213 M: exclude update trim-forgotten ;
 214
 215 M: qualified update
 216     dup vocab>> lookup-vocab [
 217         dup [ prefix>> ] [ vocab>> load-vocab ] bi qualified-words
 218         >>words
 219     ] [ drop f ] if ;
 220
 221 M: vocab update dup name>> lookup-vocab eq? ;
 222
 223 : update-manifest ( manifest -- )
 224     [ dup [ name>> lookup-vocab ] when ] change-current-vocab
 225     [ [ drop lookup-vocab ] assoc-filter ] change-search-vocab-names
 226     dup search-vocab-names>> keys [ lookup-vocab ] V{ } map-as >>search-vocabs
 227     qualified-vocabs>> [ update ] filter! drop ;
 228
 229 M: manifest definitions-changed ( assoc manifest -- )
 230     nip update-manifest ;
 231
 232 PRIVATE>
 233
 234 : with-manifest ( quot -- )
 235     <manifest> manifest [
 236         [ call ] [
 237             [ manifest get add-definition-observer call ]
 238             [ manifest get remove-definition-observer ]
 239             [ ]
 240             cleanup
 241         ] if-bootstrapping
 242     ] with-variable ; inline