digraphs and hooks

diff --git a/extra/digraphs/digraphs.factor b/extra/digraphs/digraphs.factor
index 87dc766a294d1fa27efdd50520a358d21d19fe45..5c6fa9b2a10b3eab34aaeaa4bbc7f62e33d2d1ca 100644 (file)
--- a/extra/digraphs/digraphs.factor
+++ b/extra/digraphs/digraphs.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs kernel new-slots sequences vectors ;
 IN: digraphs
 
@@ -43,3 +45,6 @@ DEFER: (topological-sort)
 : topological-sort ( digraph -- seq )
     dup clone V{ } clone spin
     [ drop (topological-sort) ] assoc-each drop reverse ;
+
+: topological-sorted-values ( digraph -- seq )
+    dup topological-sort swap [ at value>> ] curry map ;

diff --git a/extra/hooks/hooks-tests.factor b/extra/hooks/hooks-tests.factor
new file mode 100644 (file)
index 0000000..683109f
--- /dev/null
+++ b/extra/hooks/hooks-tests.factor
@@ -0,0 +1,14 @@
+USING: hooks kernel tools.test ;
+IN: hooks.tests
+
+SYMBOL: test-hook
+test-hook reset-hook
+: add-test-hook test-hook add-hook ;
+[ ] [ test-hook call-hook ] unit-test
+[ "op called" ] [ "op" [ "op called" ] add-test-hook test-hook call-hook ] unit-test
+[ "first called" "second called" ] [
+    test-hook reset-hook
+    "second op" [ "second called" ] add-test-hook
+    "first op" [ "first called" ] add-test-hook
+    test-hook call-hook
+] unit-test

diff --git a/extra/hooks/hooks.factor b/extra/hooks/hooks.factor
new file mode 100644 (file)
index 0000000..65e310f
--- /dev/null
+++ b/extra/hooks/hooks.factor
@@ -0,0 +1,28 @@
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs digraphs kernel namespaces sequences ;
+IN: hooks
+
+: hooks ( -- hooks )
+    \ hooks global [ drop H{ } clone ] cache ;
+
+: hook-graph ( hook -- graph )
+    hooks [ drop <digraph> ] cache ;
+
+: reset-hook ( hook -- )
+    <digraph> swap hooks set-at ;
+
+: add-hook ( key quot hook -- )
+    #! hook should be a symbol. Note that symbols with the same name but
+    #! different vocab are not equal
+    hook-graph add-vertex ; 
+
+: before ( key1 key2 hook -- )
+    hook-graph add-edge ;
+
+: after ( key1 key2 hook -- )
+    swapd before ;
+
+: call-hook ( hook -- )
+    hook-graph topological-sorted-values [ call ] each ;
+