Add extract-keys word

core/assocs/assocs-tests.factor

@@ -104,3 +104,17 @@ unit-test
         2drop
     ] { } make
 ] unit-test
+
+[
+    H{
+        { "bangers" "mash" }
+        { "fries" "onion rings" }
+    }
+] [
+    { "bangers" "fries" } H{
+        { "fish" "chips" }
+        { "bangers" "mash" }
+        { "fries" "onion rings" }
+        { "nachos" "cheese" }
+    } extract-keys
+] unit-test

core/assocs/assocs.factor

@@ -150,6 +150,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
 : map>assoc ( seq quot exemplar -- assoc )
     >r [ 2array ] compose { } map-as r> assoc-like ; inline
 
+: extract-keys ( seq assoc -- subassoc )
+    [ [ dupd at ] curry ] keep map>assoc ;
+
 M: assoc >alist [ 2array ] { } assoc>map ;
 
 : value-at ( value assoc -- key/f )

core/generic/standard/engines/predicate/predicate.factor

@@ -22,8 +22,7 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
     } cond ;
 
 : sort-methods ( assoc -- assoc' )
-    [ keys sort-classes ]
-    [ [ dupd at ] curry ] bi { } map>assoc ;
+    >alist [ keys sort-classes ] keep extract-keys ;
 
 M: predicate-dispatch-engine engine>quot
     methods>> clone

core/inference/class/class.factor

@@ -152,16 +152,16 @@ M: pair apply-constraint
 M: pair constraint-satisfied?
     first constraint-satisfied? ;
 
-: extract-keys ( seq assoc -- newassoc )
-    [ dupd at ] curry H{ } map>assoc [ nip ] assoc-filter f assoc-like ;
+: valid-keys ( seq assoc -- newassoc )
+    extract-keys [ nip ] assoc-filter f assoc-like ;
 
 : annotate-node ( node -- )
     #! Annotate the node with the currently-inferred set of
     #! value classes.
     dup node-values {
-        [ value-intervals get extract-keys >>intervals ]
-        [ value-classes   get extract-keys >>classes   ]
-        [ value-literals  get extract-keys >>literals  ]
+        [ value-intervals get valid-keys >>intervals ]
+        [ value-classes   get valid-keys >>classes   ]
+        [ value-literals  get valid-keys >>literals  ]
         [ 2drop ]
     } cleave ;
 
@@ -330,7 +330,7 @@ M: #return infer-classes-around
             [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
             classes= not [
                 fixed-point? off
-                [ in-d>> value-classes get extract-keys ] keep
+                [ in-d>> value-classes get valid-keys ] keep
                 set-node-classes
             ] [ drop ] if
         ] [ call-next-method ] if