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 ;
   7 IN: vocabs.parser
   8
   9 ERROR: no-word-error name ;
  10
  11 TUPLE: manifest
  12 current-vocab
  13 { search-vocabs vector }
  14 { qualified-vocabs vector }
  15 { extra-words vector } ;
  16
  17 : <manifest> ( -- manifest )
  18     manifest new
  19         V{ } clone >>search-vocabs
  20         V{ } clone >>qualified-vocabs
  21         V{ } clone >>extra-words ;
  22
  23 M: manifest clone
  24     call-next-method
  25         [ clone ] change-search-vocabs
  26         [ clone ] change-qualified-vocabs
  27         [ clone ] change-extra-words ;
  28
  29 <PRIVATE
  30
  31 : clear-manifest ( -- )
  32     manifest get
  33     [ search-vocabs>> delete-all ]
  34     [ qualified-vocabs>> delete-all ]
  35     [ extra-words>> delete-all ]
  36     tri ;
  37
  38 : (use-vocab) ( vocab -- vocab seq )
  39     load-vocab manifest get search-vocabs>> ;
  40
  41 : (add-qualified) ( qualified -- )
  42     manifest get qualified-vocabs>> push ;
  43
  44 : (from) ( vocab words -- vocab words words' assoc )
  45     2dup swap load-vocab words>> ;
  46
  47 : (use-words) ( assoc -- assoc seq )
  48     manifest get extra-words>> ;
  49
  50 : extract-words ( seq assoc -- assoc' )
  51     extract-keys dup [ [ drop ] [ no-word-error ] if ] assoc-each ;
  52
  53 : (lookup) ( name assoc -- word/f )
  54     at dup forward-reference? [ drop f ] when ;
  55
  56 PRIVATE>
  57
  58 : set-current-vocab ( name -- )
  59     create-vocab manifest get
  60     [ (>>current-vocab) ]
  61     [ [ words>> ] dip extra-words>> push ]
  62     2bi ;
  63
  64 TUPLE: no-current-vocab ;
  65
  66 : no-current-vocab ( -- vocab )
  67     \ no-current-vocab boa
  68     { { "Define words in scratchpad vocabulary" "scratchpad" } }
  69     throw-restarts dup set-current-vocab ;
  70
  71 : current-vocab ( -- vocab )
  72     manifest get current-vocab>> [ no-current-vocab ] unless* ;
  73
  74 : begin-private ( -- )
  75     manifest get current-vocab>> vocab-name ".private" ?tail
  76     [ drop ] [ ".private" append set-current-vocab ] if ;
  77
  78 : end-private ( -- )
  79     manifest get current-vocab>> vocab-name ".private" ?tail
  80     [ set-current-vocab ] [ drop ] if ;
  81
  82 : use-vocab ( vocab -- ) (use-vocab) push ;
  83
  84 : unuse-vocab ( vocab -- ) (use-vocab) delq ;
  85
  86 : only-use-vocabs ( vocabs -- )
  87     clear-manifest
  88     [ vocab ] V{ } map-as sift
  89     manifest get search-vocabs>> push-all ;
  90
  91 TUPLE: qualified vocab prefix words ;
  92
  93 : <qualified> ( vocab prefix -- qualified )
  94     2dup
  95     [ load-vocab words>> ] [ CHAR: : suffix ] bi*
  96     [ swap [ prepend ] dip ] curry assoc-map
  97     qualified boa ;
  98
  99 : add-qualified ( vocab prefix -- )
 100     <qualified> (add-qualified) ;
 101
 102 TUPLE: from vocab names words ;
 103
 104 : <from> ( vocab words -- from )
 105     (from) extract-words from boa ;
 106
 107 : add-words-from ( vocab words -- )
 108     <from> (add-qualified) ;
 109
 110 TUPLE: exclude vocab names words ;
 111
 112 : <exclude> ( vocab words -- from )
 113     (from) [ nip ] [ extract-words ] 2bi assoc-diff exclude boa ;
 114
 115 : add-words-excluding ( vocab words -- )
 116     <exclude> (add-qualified) ;
 117
 118 TUPLE: rename word vocab words ;
 119
 120 : <rename> ( word vocab new-name -- rename )
 121     [ 2dup load-vocab words>> dupd at [ ] [ no-word-error ] ?if ] dip
 122     associate rename boa ;
 123
 124 : add-renamed-word ( word vocab new-name -- )
 125     <rename> (add-qualified) ;
 126
 127 : use-words ( words -- ) (use-words) push ;
 128
 129 : unuse-words ( words -- ) (use-words) delq ;
 130
 131 ERROR: ambiguous-use-error words ;
 132
 133 <PRIVATE
 134
 135 : (vocab-search) ( name assocs -- words n )
 136     [ words>> (lookup) ] with map
 137     sift dup length ;
 138
 139 : vocab-search ( name manifest -- word/f )
 140     search-vocabs>>
 141     (vocab-search) {
 142         { 0 [ drop f ] }
 143         { 1 [ first ] }
 144         [ drop ambiguous-use-error ]
 145     } case ;
 146
 147 : qualified-search ( name manifest -- word/f )
 148     qualified-vocabs>>
 149     (vocab-search) 0 = [ drop f ] [ peek ] if ;
 150
 151 : word-search ( name manifest -- word/f )
 152     extra-words>> [ (lookup) ] with map-find-last drop ;
 153
 154 PRIVATE>
 155
 156 : search-manifest ( name manifest -- word/f )
 157     2dup word-search dup [ 2nip ] [
 158         drop 2dup qualified-search dup [ 2nip ] [
 159             drop vocab-search
 160         ] if
 161     ] if ;
 162
 163 : search ( name -- word/f )
 164     manifest get search-manifest ;
 165
 166 : word-restarts ( name possibilities -- restarts )
 167     natural-sort
 168     [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc
 169     swap "Defer word in current vocabulary" swap 2array
 170     suffix ;
 171
 172 : <no-word-error> ( name possibilities -- error restarts )
 173     [ drop \ no-word-error boa ] [ word-restarts ] 2bi ;