core/vocabs/parser/parser.factor

   1 ! Copyright (C) 2007, 2009 Daniel Ehrenberg, Bruno Deferrari,
   2 ! Slava Pestov.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: assocs hashtables kernel namespaces sequences
   5 sets strings vocabs sorting accessors arrays compiler.units
   6 combinators vectors splitting continuations math
   7 parser.notes ;
   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 hashtable }
  27 { search-vocabs vector }
  28 { qualified-vocabs vector }
  29 { extra-words vector }
  30 { auto-used vector } ;
  31
  32 : <manifest> ( -- manifest )
  33     manifest new
  34         H{ } clone >>search-vocab-names
  35         V{ } clone >>search-vocabs
  36         V{ } clone >>qualified-vocabs
  37         V{ } clone >>extra-words
  38         V{ } clone >>auto-used ;
  39
  40 M: manifest clone
  41     call-next-method
  42         [ clone ] change-search-vocab-names
  43         [ clone ] change-search-vocabs
  44         [ clone ] change-qualified-vocabs
  45         [ clone ] change-extra-words
  46         [ clone ] change-auto-used ;
  47
  48 TUPLE: extra-words words ;
  49
  50 M: extra-words equal?
  51     over extra-words? [ [ words>> ] bi@ eq? ] [ 2drop f ] if ;
  52
  53 C: <extra-words> extra-words
  54
  55 : clear-manifest ( -- )
  56     manifest get
  57     [ search-vocab-names>> clear-assoc ]
  58     [ search-vocabs>> delete-all ]
  59     [ qualified-vocabs>> delete-all ]
  60     tri ;
  61
  62 ERROR: no-word-in-vocab word vocab ;
  63
  64 <PRIVATE
  65
  66 : (add-qualified) ( qualified -- )
  67     manifest get qualified-vocabs>> push ;
  68
  69 : (from) ( vocab words -- vocab words words' vocab )
  70     2dup swap load-vocab ;
  71
  72 : extract-words ( seq vocab -- assoc' )
  73     [ words>> extract-keys dup ] [ name>> ] bi
  74     [ swap [ 2drop ] [ no-word-in-vocab ] if ] curry assoc-each ;
  75
  76 : (lookup) ( name assoc -- word/f )
  77     at dup forward-reference? [ drop f ] when ;
  78
  79 : (use-words) ( assoc -- extra-words seq )
  80     <extra-words> manifest get qualified-vocabs>> ;
  81
  82 PRIVATE>
  83
  84 : set-current-vocab ( name -- )
  85     create-vocab
  86     [ manifest get (>>current-vocab) ]
  87     [ words>> <extra-words> (add-qualified) ] bi ;
  88
  89 : with-current-vocab ( name quot -- )
  90     manifest get clone manifest [
  91         [ set-current-vocab ] dip call
  92     ] with-variable ; inline
  93
  94 TUPLE: no-current-vocab ;
  95
  96 : no-current-vocab ( -- vocab )
  97     \ no-current-vocab boa
  98     { { "Define words in scratchpad vocabulary" "scratchpad" } }
  99     throw-restarts dup set-current-vocab ;
 100
 101 : current-vocab ( -- vocab )
 102     manifest get current-vocab>> [ no-current-vocab ] unless* ;
 103
 104 : begin-private ( -- )
 105     manifest get current-vocab>> vocab-name ".private" ?tail
 106     [ drop ] [ ".private" append set-current-vocab ] if ;
 107
 108 : end-private ( -- )
 109     manifest get current-vocab>> vocab-name ".private" ?tail
 110     [ set-current-vocab ] [ drop ] if ;
 111
 112 : using-vocab? ( vocab -- ? )
 113     vocab-name manifest get search-vocab-names>> key? ;
 114
 115 : use-vocab ( vocab -- )
 116     dup using-vocab?
 117     [ vocab-name "Already using ``" "'' vocabulary" surround note. ] [
 118         manifest get
 119         [ [ load-vocab ] dip search-vocabs>> push ]
 120         [ [ vocab-name ] dip search-vocab-names>> conjoin ]
 121         2bi
 122     ] if ;
 123
 124 : auto-use-vocab ( vocab -- )
 125     [ use-vocab ] [ manifest get auto-used>> push ] bi ;
 126
 127 : auto-used? ( -- ? ) manifest get auto-used>> length 0 > ;
 128
 129 : unuse-vocab ( vocab -- )
 130     dup using-vocab? [
 131         manifest get
 132         [ [ load-vocab ] dip search-vocabs>> delq ]
 133         [ [ vocab-name ] dip search-vocab-names>> delete-at ]
 134         2bi
 135     ] [ drop ] if ;
 136
 137 TUPLE: qualified vocab prefix words ;
 138
 139 : <qualified> ( vocab prefix -- qualified )
 140     2dup
 141     [ load-vocab words>> ] [ CHAR: : suffix ] bi*
 142     [ swap [ prepend ] dip ] curry assoc-map
 143     qualified boa ;
 144
 145 : add-qualified ( vocab prefix -- )
 146     <qualified> (add-qualified) ;
 147
 148 TUPLE: from vocab names words ;
 149
 150 : <from> ( vocab words -- from )
 151     (from) extract-words from boa ;
 152
 153 : add-words-from ( vocab words -- )
 154     <from> (add-qualified) ;
 155
 156 TUPLE: exclude vocab names words ;
 157
 158 : <exclude> ( vocab words -- from )
 159     (from) [ nip words>> ] [ extract-words ] 2bi assoc-diff exclude boa ;
 160
 161 : add-words-excluding ( vocab words -- )
 162     <exclude> (add-qualified) ;
 163
 164 TUPLE: rename word vocab words ;
 165
 166 : <rename> ( word vocab new-name -- rename )
 167     [ 2dup load-vocab words>> dupd at [ ] [ swap no-word-in-vocab ] ?if ] dip
 168     associate rename boa ;
 169
 170 : add-renamed-word ( word vocab new-name -- )
 171     <rename> (add-qualified) ;
 172
 173 : use-words ( assoc -- ) (use-words) push ;
 174
 175 : unuse-words ( assoc -- ) (use-words) delete ;
 176
 177 TUPLE: ambiguous-use-error words ;
 178
 179 : <ambiguous-use-error> ( words -- error restarts )
 180     [ \ ambiguous-use-error boa ] [ word-restarts ] bi ;
 181
 182 <PRIVATE
 183
 184 : (vocab-search) ( name assocs -- words n )
 185     [ words>> (lookup) ] with map
 186     sift dup length ;
 187
 188 : vocab-search ( name manifest -- word/f )
 189     search-vocabs>>
 190     (vocab-search) {
 191         { 0 [ drop f ] }
 192         { 1 [ first ] }
 193         [
 194             drop <ambiguous-use-error> throw-restarts
 195             dup [ vocabulary>> ] [ name>> 1array ] bi add-words-from
 196         ]
 197     } case ;
 198
 199 : qualified-search ( name manifest -- word/f )
 200     qualified-vocabs>>
 201     (vocab-search) 0 = [ drop f ] [ last ] if ;
 202
 203 PRIVATE>
 204
 205 : search-manifest ( name manifest -- word/f )
 206     2dup qualified-search dup [ 2nip ] [ drop vocab-search ] if ;
 207
 208 : search ( name -- word/f )
 209     manifest get search-manifest ;