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