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