Clean up logging and fix error logging

extra/logging/logging-tests.factor

@@ -0,0 +1,24 @@
+IN: logging.tests
+USING: tools.test logging math ;
+
+: input-logging-test ( a b -- c ) + ;
+
+\ input-logging-test NOTICE add-input-logging
+
+: output-logging-test ( a b -- c ) + ;
+
+\ output-logging-test DEBUG add-output-logging
+
+: error-logging-test ( a b -- c ) / ;
+
+\ error-logging-test ERROR add-error-logging
+
+"logging-test" [
+    [ 4 ] [ 1 3 input-logging-test ] unit-test
+    
+    [ 4 ] [ 1 3 output-logging-test ] unit-test
+    
+    [ 4/3 ] [ 4 3 error-logging-test ] unit-test
+    
+    [ f ] [ 1 0 error-logging-test ] unit-test
+] with-logging

extra/logging/logging.factor

@@ -4,33 +4,26 @@ USING: logging.server sequences namespaces concurrency.messaging
 words kernel arrays shuffle tools.annotations
 prettyprint.config prettyprint debugger io.streams.string
 splitting continuations effects arrays.lib parser strings
-combinators.lib quotations ;
+combinators.lib quotations fry symbols accessors ;
 IN: logging
 
-SYMBOL: DEBUG
+SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;
-SYMBOL: NOTICE
-SYMBOL: WARNING
-SYMBOL: ERROR
-SYMBOL: CRITICAL
 
-: log-levels
+: log-levels { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
-    { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
 
 : send-to-log-server ( array string -- )
     prefix "log-server" get send ;
 
 SYMBOL: log-service
 
-: check-log-message
+: check-log-message ( msg word level -- msg word level )
-    pick string?
+    3dup [ string? ] [ word? ] [ word? ] tri* and and
-    pick word?
+    [ "Bad parameters to log-message" throw ] unless ; inline
-    pick word? and and
-    [ "Bad parameters to log-message" throw ] unless ;
 
 : log-message ( msg word level -- )
     check-log-message
     log-service get dup [
-        >r >r >r string-lines r> word-name r> word-name r>
+        [ [ string-lines ] [ word-name ] [ word-name ] tri* ] dip
         4array "log-message" send-to-log-server
     ] [
         4drop
@@ -69,7 +62,7 @@ SYMBOL: log-service
 PRIVATE>
 
 : (define-logging) ( word level quot -- )
-    >r >r dup r> r> 2curry annotate ;
+    [ dup ] 2dip 2curry annotate ;
 
 : call-logging-quot ( quot word level -- quot' )
     "called" -rot [ log-message ] 3curry prepose ;
@@ -79,31 +72,30 @@ PRIVATE>
 
 : log-stack ( n word level -- )
     log-service get [
-        >r >r [ ndup ] keep narray stack>message
+        [ [ ndup ] keep narray stack>message ] 2dip log-message
-        r> r> log-message
     ] [
         3drop
     ] if ; inline
 
-: input# stack-effect effect-in length ;
+: input# stack-effect in>> length ;
 
 : input-logging-quot ( quot word level -- quot' )
-    over input# -rot [ log-stack ] 3curry prepose ;
+    rot [ [ input# ] keep ] 2dip '[ , , , log-stack @ ] ;
 
 : add-input-logging ( word level -- )
     [ input-logging-quot ] (define-logging) ;
 
-: output# stack-effect effect-out length ;
+: output# stack-effect out>> length ;
 
 : output-logging-quot ( quot word level -- quot' )
-    over output# -rot [ log-stack ] 3curry compose ;
+    [ [ output# ] keep ] dip '[ @ , , , log-stack ] ;
 
 : add-output-logging ( word level -- )
     [ output-logging-quot ] (define-logging) ;
 
 : (log-error) ( object word level -- )
     log-service get [
-        >r >r [ print-error ] with-string-writer r> r> log-message
+        [ [ print-error ] with-string-writer ] 2dip log-message
     ] [
         2drop rethrow
     ] if ;
@@ -112,22 +104,21 @@ PRIVATE>
 
 : log-critical ( error word -- ) CRITICAL (log-error) ;
 
-: stack-balancer ( effect word -- quot )
+: stack-balancer ( effect -- quot )
-    >r dup effect-in length r> [ over >r ERROR log-stack r> ndrop ] 2curry
+    [ in>> length [ ndrop ] curry ]
-    swap effect-out length f <repetition> append >quotation ;
+    [ out>> length f <repetition> >quotation ]
+    bi append ;
 
 : error-logging-quot ( quot word -- quot' )
-    [ [ log-error ] curry ] keep
+    dup stack-effect stack-balancer
-    [ stack-effect ] keep stack-balancer compose
+    '[ , [ , log-error @ ] recover ] ;
-    [ recover ] 2curry ;
 
 : add-error-logging ( word level -- )
-    [ over >r input-logging-quot r> error-logging-quot ]
+    [ [ input-logging-quot ] 2keep drop error-logging-quot ]
     (define-logging) ;
 
 : LOG:
     #! Syntax: name level
-    CREATE-WORD
+    CREATE-WORD dup scan-word
-    dup scan-word
+    '[ 1array stack>message , , log-message ]
-    [ >r >r 1array stack>message r> r> log-message ] 2curry
     define ; parsing