basis/logging/logging.factor

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