From 9a467aa31af098d554c9c7a157d33f12abc76bed Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Sat, 12 Apr 2008 13:27:46 -0300
Subject: [PATCH] Add QUALIFIED-WITH: FROM: EXCLUDE: and RENAME: to the
 qualified vocab.

---
 extra/qualified/qualified-docs.factor  | 26 +++++++++++++++
 extra/qualified/qualified-tests.factor | 18 ++++++++++-
 extra/qualified/qualified.factor       | 44 ++++++++++++++++++++++----
 3 files changed, 80 insertions(+), 8 deletions(-)

diff --git a/extra/qualified/qualified-docs.factor b/extra/qualified/qualified-docs.factor
index 36a503bec4..d336d31114 100755
--- a/extra/qualified/qualified-docs.factor
+++ b/extra/qualified/qualified-docs.factor
@@ -6,3 +6,29 @@ HELP: QUALIFIED:
 { $description "Similar to " { $link POSTPONE: USE: } " but loads vocabulary with prefix." }
 { $examples { $code
     "QUALIFIED: math\n1 2 math:+ ! ==> 3" } } ;
+
+HELP: QUALIFIED-WITH:
+{ $syntax "QUALIFIED-WITH: vocab prefix" }
+{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses the specified prefix." }
+{ $examples { $code
+    "QUALIFIED-WITH: math m\n1 2 m:+ ! ==> 3" } } ;
+
+HELP: FROM:
+{ $syntax "FROM: vocab => words ... ;" }
+{ $description "Imports the specified words from vocab." }
+{ $examples { $code
+    "FROM: math.parser => bin> hex> ; ! imports only bin> and hex>" } } ;
+
+HELP: EXCLUDE:
+{ $syntax "EXCLUDE: vocab => words ... ;" }
+{ $description "Imports everything from vocab excluding the specified words" }
+{ $examples { $code
+    "EXCLUDE: math.parser => bin> hex> ; ! imports everythin but bin> and hex>" } } ;
+
+HELP: RENAME:
+{ $syntax "RENAME: word vocab => newname " }
+{ $description "Imports word from vocab, but renamed to newname." }
+{ $examples { $code
+    "RENAME: + math => -"
+    "2 3 - ! => 5" } } ;
+
diff --git a/extra/qualified/qualified-tests.factor b/extra/qualified/qualified-tests.factor
index d1bd569a39..8f67ddf730 100644
--- a/extra/qualified/qualified-tests.factor
+++ b/extra/qualified/qualified-tests.factor
@@ -3,6 +3,22 @@ IN: foo
 : x 1 ;
 IN: bar
 : x 2 ;
+IN: baz
+: x 3 ;
+
 QUALIFIED: foo
 QUALIFIED: bar
-[ 1 2 2 ] [ foo:x bar:x x ] unit-test
+[ 1 2 3 ] [ foo:x bar:x x ] unit-test
+
+QUALIFIED-WITH: bar p
+[ 2 ] [ p:x ] unit-test
+
+RENAME: x baz => y
+[ 3 ] [ y ] unit-test
+
+FROM: baz => x ;
+[ 3 ] [ x ] unit-test
+
+EXCLUDE: bar => x ;
+[ 3 ] [ x ] unit-test
+
diff --git a/extra/qualified/qualified.factor b/extra/qualified/qualified.factor
index 69e4c09b6e..c6f8dd8c89 100644
--- a/extra/qualified/qualified.factor
+++ b/extra/qualified/qualified.factor
@@ -1,13 +1,43 @@
-USING: kernel sequences assocs parser vocabs namespaces
-vocabs.loader ;
+USING: kernel sequences assocs hashtables parser vocabs words namespaces
+vocabs.loader debugger ;
 IN: qualified
 
-: define-qualified ( vocab-name -- )
-    dup require
-    dup vocab-words swap CHAR: : suffix
+: define-qualified ( vocab-name prefix-name -- )
+    [ load-vocab vocab-words ] [ CHAR: : suffix ] bi*
     [ -rot >r append r> ] curry assoc-map
     use get push ;
 
-
 : QUALIFIED:
-    scan define-qualified ; parsing
+    #! Syntax: QUALIFIED: vocab
+    scan dup define-qualified ; parsing
+
+: QUALIFIED-WITH:
+    #! Syntax: QUALIFIED-WITH: vocab prefix
+    scan scan define-qualified ; parsing
+
+: expect=> scan "=>" assert= ;
+
+: partial-vocab ( words name -- assoc )
+    dupd [
+        lookup [ "No such word: " swap append throw ] unless*
+    ] curry map zip ;
+
+: partial-vocab-ignoring ( words name -- assoc )
+    [ vocab-words keys seq-diff ] keep partial-vocab ;
+
+: EXCLUDE:
+    #! Syntax: EXCLUDE: vocab => words ... ;
+    scan expect=>
+    ";" parse-tokens swap partial-vocab-ignoring use get push ; parsing
+
+: FROM:
+    #! Syntax: FROM: vocab => words... ;
+    scan expect=>
+    ";" parse-tokens swap partial-vocab use get push ; parsing
+
+: RENAME:
+    #! Syntax: RENAME: word vocab => newname
+    scan scan lookup [ "No such word" throw ] unless*
+    expect=>
+    scan associate use get push ; parsing
+