basis/logging/logging.factor

   1 ! Copyright (C) 2003, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs concurrency.messaging
   4 continuations debugger effects generalizations io.streams.string
   5 kernel math.order namespaces parser prettyprint
   6 prettyprint.config quotations sequences
   7 sequences.generalizations splitting strings tools.annotations
   8 vocabs words ;
   9 IN: logging
  10
  11 SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;
  12
  13 SYMBOL: log-level
  14
  15 log-level [ DEBUG ] initialize
  16
  17 : log-levels ( -- assoc )
  18     H{
  19         { DEBUG 0 }
  20         { NOTICE 10 }
  21         { WARNING 20 }
  22         { ERROR 30 }
  23         { CRITICAL 40 }
  24     } ; inline
  25
  26 ERROR: undefined-log-level ;
  27
  28 : log-level<=> ( log-level log-level -- <=> )
  29     [ log-levels at* [ undefined-log-level ] unless ] compare ;
  30
  31 : log? ( log-level -- ? )
  32     log-level get log-level<=> +lt+ = not ;
  33
  34 : send-to-log-server ( array string -- )
  35     prefix "log-server" get send ;
  36
  37 SYMBOL: log-service
  38
  39 ERROR: bad-log-message-parameters msg word level ;
  40
  41 : check-log-message ( msg word level -- msg word level )
  42     3dup [ string? ] [ word? ] [ word? ] tri* and and
  43     [ bad-log-message-parameters ] unless ; inline
  44
  45 : log-message ( msg word level -- )
  46     check-log-message
  47     log-service get
  48     2dup [ log? ] [ ] bi* and [
  49         [ [ split-lines ] [ name>> ] [ name>> ] tri* ] dip
  50         4array "log-message" send-to-log-server
  51     ] [
  52         4drop
  53     ] if ;
  54
  55 : rotate-logs ( -- )
  56     { } "rotate-logs" send-to-log-server ;
  57
  58 : close-logs ( -- )
  59     { } "close-logs" send-to-log-server ;
  60
  61 : with-logging ( service quot -- )
  62     [ log-service ] dip with-variable ; inline
  63
  64 ! Aspect-oriented programming idioms
  65
  66 <PRIVATE
  67
  68 : stack>message ( obj -- inputs>message )
  69     dup array? [ dup length 1 = [ first ] when ] when
  70     dup string? [
  71         [
  72             boa-tuples? on
  73             string-limit? off
  74             1 line-limit set
  75             3 nesting-limit set
  76             0 margin set
  77             unparse
  78         ] with-scope
  79     ] unless ;
  80
  81 PRIVATE>
  82
  83 : (define-logging) ( word level quot -- )
  84     [ dup ] 2dip 2curry annotate ; inline
  85
  86 : call-logging-quot ( quot word level -- quot' )
  87     [ "called" ] 2dip [ log-message ] 3curry prepose ;
  88
  89 : add-logging ( word level -- )
  90     [ call-logging-quot ] (define-logging) ;
  91
  92 : log-stack ( n word level -- )
  93     log-service get [
  94         [ [ ndup ] keep narray stack>message ] 2dip log-message
  95     ] [
  96         3drop
  97     ] if ; inline
  98
  99 : input# ( word -- n ) stack-effect in>> length ;
 100
 101 : input-logging-quot ( quot word level -- quot' )
 102     rot [ [ input# ] keep ] 2dip '[ _ _ _ log-stack @ ] ;
 103
 104 : add-input-logging ( word level -- )
 105     [ input-logging-quot ] (define-logging) ;
 106
 107 : output# ( word -- n ) stack-effect out>> length ;
 108
 109 : output-logging-quot ( quot word level -- quot' )
 110     [ [ output# ] keep ] dip '[ @ _ _ _ log-stack ] ;
 111
 112 : add-output-logging ( word level -- )
 113     [ output-logging-quot ] (define-logging) ;
 114
 115 : error>string ( error -- string )
 116     [ print-error :c ] with-string-writer ;
 117
 118 : (log-error) ( object word level -- )
 119     log-service get [
 120         [ error>string ] 2dip log-message
 121     ] [ 2drop rethrow ] if ;
 122
 123 : log-error ( error word -- ) ERROR (log-error) ;
 124
 125 : log-critical ( error word -- ) CRITICAL (log-error) ;
 126
 127 : stack-balancer ( effect -- quot )
 128     [ in>> length [ ndrop ] curry ]
 129     [ out>> length f <repetition> >quotation ]
 130     bi append ;
 131
 132 : error-logging-quot ( quot word -- quot' )
 133     dup stack-effect stack-balancer
 134     '[ _ [ _ log-error @ ] recover ] ;
 135
 136 : add-error-logging ( word level -- )
 137     [ [ input-logging-quot ] keepd error-logging-quot ]
 138     (define-logging) ;
 139
 140 SYNTAX: LOG:
 141     ! Syntax: name level
 142     scan-new-word dup scan-word
 143     '[ 1array stack>message _ _ log-message ]
 144     ( message -- ) define-declared ;
 145
 146 "logging.parser" require
 147 "logging.analysis" require