core/vocabs/parser/parser.factor

   1 ! Copyright (C) 2007, 2008 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 ;
   6 IN: vocabs.parser
   7
   8 ERROR: no-word-error name ;
   9
  10 : word-restarts ( name possibilities -- restarts )
  11     natural-sort
  12     [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc
  13     swap "Defer word in current vocabulary" swap 2array
  14     suffix ;
  15
  16 : <no-word-error> ( name possibilities -- error restarts )
  17     [ drop \ no-word-error boa ] [ word-restarts ] 2bi ;
  18
  19 SYMBOL: use
  20 SYMBOL: in
  21
  22 : (use+) ( vocab -- )
  23     vocab-words use get push ;
  24
  25 : use+ ( vocab -- )
  26     load-vocab (use+) ;
  27
  28 : add-use ( seq -- ) [ use+ ] each ;
  29
  30 : set-use ( seq -- )
  31     [ vocab-words ] V{ } map-as sift use set ;
  32
  33 : add-qualified ( vocab prefix -- )
  34     [ load-vocab vocab-words ] [ CHAR: : suffix ] bi*
  35     [ swap [ prepend ] dip ] curry assoc-map
  36     use get push ;
  37
  38 : partial-vocab ( words vocab -- assoc )
  39     load-vocab vocab-words
  40     [ dupd at [ no-word-error ] unless* ] curry { } map>assoc ;
  41
  42 : add-words-from ( words vocab -- )
  43     partial-vocab use get push ;
  44
  45 : partial-vocab-excluding ( words vocab -- assoc )
  46     load-vocab [ vocab-words keys swap diff ] keep partial-vocab ;
  47
  48 : add-words-excluding ( words vocab -- )
  49     partial-vocab-excluding use get push ;
  50
  51 : add-renamed-word ( word vocab new-name -- )
  52     [ load-vocab vocab-words dupd at [ ] [ no-word-error ] ?if ] dip
  53     associate use get push ;
  54
  55 : check-vocab-string ( name -- name )
  56     dup string? [ "Vocabulary name must be a string" throw ] unless ;
  57
  58 : set-in ( name -- )
  59     check-vocab-string dup in set create-vocab (use+) ;