basis/logging/logging.factor

   1 ! Copyright (C) 2003, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: logging.server sequences namespaces concurrency.messaging
   4 words kernel arrays shuffle tools.annotations
   5 prettyprint.config prettyprint debugger io.streams.string
   6 splitting continuations effects generalizations parser strings
   7 quotations fry accessors math assocs math.order
   8 sequences.generalizations ;
   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         [ [ string-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 : (log-error) ( object word level -- )
 116     log-service get [
 117         [ [ print-error ] with-string-writer ] 2dip log-message
 118     ] [
 119         2drop rethrow
 120     ] if ;
 121
 122 : log-error ( error word -- ) ERROR (log-error) ;
 123
 124 : log-critical ( error word -- ) CRITICAL (log-error) ;
 125
 126 : stack-balancer ( effect -- quot )
 127     [ in>> length [ ndrop ] curry ]
 128     [ out>> length f <repetition> >quotation ]
 129     bi append ;
 130
 131 : error-logging-quot ( quot word -- quot' )
 132     dup stack-effect stack-balancer
 133     '[ _ [ _ log-error @ ] recover ] ;
 134
 135 : add-error-logging ( word level -- )
 136     [ [ input-logging-quot ] 2keep drop error-logging-quot ]
 137     (define-logging) ;
 138
 139 SYNTAX: LOG:
 140     ! Syntax: name level
 141     scan-new-word dup scan-word
 142     '[ 1array stack>message _ _ log-message ]
 143     ( message -- ) define-declared ;
 144
 145 USE: vocabs
 146
 147 "logging.parser" require
 148 "logging.analysis" require