-! Copyright (C) 2003, 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: logging.server sequences namespaces concurrency.messaging\r
-words kernel arrays shuffle tools.annotations\r
-prettyprint.config prettyprint debugger io.streams.string\r
-splitting continuations effects generalizations parser strings\r
-quotations fry accessors math assocs math.order\r
-sequences.generalizations ;\r
-IN: logging\r
-\r
-SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;\r
-\r
-SYMBOL: log-level\r
-\r
-log-level [ DEBUG ] initialize\r
-\r
-: log-levels ( -- assoc )\r
- H{\r
- { DEBUG 0 }\r
- { NOTICE 10 }\r
- { WARNING 20 }\r
- { ERROR 30 }\r
- { CRITICAL 40 }\r
- } ; inline\r
-\r
-ERROR: undefined-log-level ;\r
-\r
-: log-level<=> ( log-level log-level -- <=> )\r
- [ log-levels at* [ undefined-log-level ] unless ] compare ;\r
-\r
-: log? ( log-level -- ? )\r
- log-level get log-level<=> +lt+ = not ;\r
-\r
-: send-to-log-server ( array string -- )\r
- prefix "log-server" get send ;\r
-\r
-SYMBOL: log-service\r
-\r
-ERROR: bad-log-message-parameters msg word level ;\r
-\r
-: check-log-message ( msg word level -- msg word level )\r
- 3dup [ string? ] [ word? ] [ word? ] tri* and and\r
- [ bad-log-message-parameters ] unless ; inline\r
-\r
-: log-message ( msg word level -- )\r
- check-log-message\r
- log-service get\r
- 2dup [ log? ] [ ] bi* and [\r
- [ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip\r
- 4array "log-message" send-to-log-server\r
- ] [\r
- 4drop\r
- ] if ;\r
-\r
-: rotate-logs ( -- )\r
- { } "rotate-logs" send-to-log-server ;\r
-\r
-: close-logs ( -- )\r
- { } "close-logs" send-to-log-server ;\r
-\r
-: with-logging ( service quot -- )\r
- [ log-service ] dip with-variable ; inline\r
-\r
-! Aspect-oriented programming idioms\r
-\r
-<PRIVATE\r
-\r
-: stack>message ( obj -- inputs>message )\r
- dup array? [ dup length 1 = [ first ] when ] when\r
- dup string? [\r
- [\r
- boa-tuples? on\r
- string-limit? off\r
- 1 line-limit set\r
- 3 nesting-limit set\r
- 0 margin set\r
- unparse\r
- ] with-scope\r
- ] unless ;\r
-\r
-PRIVATE>\r
-\r
-: (define-logging) ( word level quot -- )\r
- [ dup ] 2dip 2curry annotate ; inline\r
-\r
-: call-logging-quot ( quot word level -- quot' )\r
- [ "called" ] 2dip [ log-message ] 3curry prepose ;\r
-\r
-: add-logging ( word level -- )\r
- [ call-logging-quot ] (define-logging) ;\r
-\r
-: log-stack ( n word level -- )\r
- log-service get [\r
- [ [ ndup ] keep narray stack>message ] 2dip log-message\r
- ] [\r
- 3drop\r
- ] if ; inline\r
-\r
-: input# ( word -- n ) stack-effect in>> length ;\r
-\r
-: input-logging-quot ( quot word level -- quot' )\r
- rot [ [ input# ] keep ] 2dip '[ _ _ _ log-stack @ ] ;\r
-\r
-: add-input-logging ( word level -- )\r
- [ input-logging-quot ] (define-logging) ;\r
-\r
-: output# ( word -- n ) stack-effect out>> length ;\r
-\r
-: output-logging-quot ( quot word level -- quot' )\r
- [ [ output# ] keep ] dip '[ @ _ _ _ log-stack ] ;\r
-\r
-: add-output-logging ( word level -- )\r
- [ output-logging-quot ] (define-logging) ;\r
-\r
-: (log-error) ( object word level -- )\r
- log-service get [\r
- [ [ print-error ] with-string-writer ] 2dip log-message\r
- ] [\r
- 2drop rethrow\r
- ] if ;\r
-\r
-: log-error ( error word -- ) ERROR (log-error) ;\r
-\r
-: log-critical ( error word -- ) CRITICAL (log-error) ;\r
-\r
-: stack-balancer ( effect -- quot )\r
- [ in>> length [ ndrop ] curry ]\r
- [ out>> length f <repetition> >quotation ]\r
- bi append ;\r
-\r
-: error-logging-quot ( quot word -- quot' )\r
- dup stack-effect stack-balancer\r
- '[ _ [ _ log-error @ ] recover ] ;\r
-\r
-: add-error-logging ( word level -- )\r
- [ [ input-logging-quot ] 2keep drop error-logging-quot ]\r
- (define-logging) ;\r
-\r
-SYNTAX: LOG:\r
- #! Syntax: name level\r
- scan-new-word dup scan-word\r
- '[ 1array stack>message _ _ log-message ]\r
- ( message -- ) define-declared ;\r
-\r
-USE: vocabs\r
-\r
-"logging.parser" require\r
-"logging.analysis" require\r
+! Copyright (C) 2003, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: logging.server sequences namespaces concurrency.messaging
+words kernel arrays shuffle tools.annotations
+prettyprint.config prettyprint debugger io.streams.string
+splitting continuations effects generalizations parser strings
+quotations fry accessors math assocs math.order
+sequences.generalizations ;
+IN: logging
+
+SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;
+
+SYMBOL: log-level
+
+log-level [ DEBUG ] initialize
+
+: log-levels ( -- assoc )
+ H{
+ { DEBUG 0 }
+ { NOTICE 10 }
+ { WARNING 20 }
+ { ERROR 30 }
+ { CRITICAL 40 }
+ } ; inline
+
+ERROR: undefined-log-level ;
+
+: log-level<=> ( log-level log-level -- <=> )
+ [ log-levels at* [ undefined-log-level ] unless ] compare ;
+
+: log? ( log-level -- ? )
+ log-level get log-level<=> +lt+ = not ;
+
+: send-to-log-server ( array string -- )
+ prefix "log-server" get send ;
+
+SYMBOL: log-service
+
+ERROR: bad-log-message-parameters msg word level ;
+
+: check-log-message ( msg word level -- msg word level )
+ 3dup [ string? ] [ word? ] [ word? ] tri* and and
+ [ bad-log-message-parameters ] unless ; inline
+
+: log-message ( msg word level -- )
+ check-log-message
+ log-service get
+ 2dup [ log? ] [ ] bi* and [
+ [ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip
+ 4array "log-message" send-to-log-server
+ ] [
+ 4drop
+ ] if ;
+
+: rotate-logs ( -- )
+ { } "rotate-logs" send-to-log-server ;
+
+: close-logs ( -- )
+ { } "close-logs" send-to-log-server ;
+
+: with-logging ( service quot -- )
+ [ log-service ] dip with-variable ; inline
+
+! Aspect-oriented programming idioms
+
+<PRIVATE
+
+: stack>message ( obj -- inputs>message )
+ dup array? [ dup length 1 = [ first ] when ] when
+ dup string? [
+ [
+ boa-tuples? on
+ string-limit? off
+ 1 line-limit set
+ 3 nesting-limit set
+ 0 margin set
+ unparse
+ ] with-scope
+ ] unless ;
+
+PRIVATE>
+
+: (define-logging) ( word level quot -- )
+ [ dup ] 2dip 2curry annotate ; inline
+
+: call-logging-quot ( quot word level -- quot' )
+ [ "called" ] 2dip [ log-message ] 3curry prepose ;
+
+: add-logging ( word level -- )
+ [ call-logging-quot ] (define-logging) ;
+
+: log-stack ( n word level -- )
+ log-service get [
+ [ [ ndup ] keep narray stack>message ] 2dip log-message
+ ] [
+ 3drop
+ ] if ; inline
+
+: input# ( word -- n ) stack-effect in>> length ;
+
+: input-logging-quot ( quot word level -- quot' )
+ rot [ [ input# ] keep ] 2dip '[ _ _ _ log-stack @ ] ;
+
+: add-input-logging ( word level -- )
+ [ input-logging-quot ] (define-logging) ;
+
+: output# ( word -- n ) stack-effect out>> length ;
+
+: output-logging-quot ( quot word level -- quot' )
+ [ [ output# ] keep ] dip '[ @ _ _ _ log-stack ] ;
+
+: add-output-logging ( word level -- )
+ [ output-logging-quot ] (define-logging) ;
+
+: (log-error) ( object word level -- )
+ log-service get [
+ [ [ print-error ] with-string-writer ] 2dip log-message
+ ] [
+ 2drop rethrow
+ ] if ;
+
+: log-error ( error word -- ) ERROR (log-error) ;
+
+: log-critical ( error word -- ) CRITICAL (log-error) ;
+
+: stack-balancer ( effect -- quot )
+ [ in>> length [ ndrop ] curry ]
+ [ out>> length f <repetition> >quotation ]
+ bi append ;
+
+: error-logging-quot ( quot word -- quot' )
+ dup stack-effect stack-balancer
+ '[ _ [ _ log-error @ ] recover ] ;
+
+: add-error-logging ( word level -- )
+ [ [ input-logging-quot ] 2keep drop error-logging-quot ]
+ (define-logging) ;
+
+SYNTAX: LOG:
+ #! Syntax: name level
+ scan-new-word dup scan-word
+ '[ 1array stack>message _ _ log-message ]
+ ( message -- ) define-declared ;
+
+USE: vocabs
+
+"logging.parser" require
+"logging.analysis" require
projects / factor.git / blobdiff