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