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 arrays.lib parser strings\r
   7 combinators.lib 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 ] [ word-name ] [ word-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 : one-string? ( obj -- ? )\r
  46     {\r
  47         [ dup array? ]\r
  48         [ dup length 1 = ]\r
  49         [ dup first string? ]\r
  50     } && nip ;\r
  51 \r
  52 : stack>message ( obj -- inputs>message )\r
  53     dup one-string? [ first ] [\r
  54         H{\r
  55             { string-limit f }\r
  56             { line-limit 1 }\r
  57             { nesting-limit 3 }\r
  58             { margin 0 }\r
  59         } clone [ unparse ] bind\r
  60     ] if ;\r
  61 \r
  62 PRIVATE>\r
  63 \r
  64 : (define-logging) ( word level quot -- )\r
  65     [ dup ] 2dip 2curry annotate ;\r
  66 \r
  67 : call-logging-quot ( quot word level -- quot' )\r
  68     "called" -rot [ log-message ] 3curry prepose ;\r
  69 \r
  70 : add-logging ( word level -- )\r
  71     [ call-logging-quot ] (define-logging) ;\r
  72 \r
  73 : log-stack ( n word level -- )\r
  74     log-service get [\r
  75         [ [ ndup ] keep narray stack>message ] 2dip log-message\r
  76     ] [\r
  77         3drop\r
  78     ] if ; inline\r
  79 \r
  80 : input# ( word -- n ) stack-effect in>> length ;\r
  81 \r
  82 : input-logging-quot ( quot word level -- quot' )\r
  83     rot [ [ input# ] keep ] 2dip '[ , , , log-stack @ ] ;\r
  84 \r
  85 : add-input-logging ( word level -- )\r
  86     [ input-logging-quot ] (define-logging) ;\r
  87 \r
  88 : output# ( word -- n ) stack-effect out>> length ;\r
  89 \r
  90 : output-logging-quot ( quot word level -- quot' )\r
  91     [ [ output# ] keep ] dip '[ @ , , , log-stack ] ;\r
  92 \r
  93 : add-output-logging ( word level -- )\r
  94     [ output-logging-quot ] (define-logging) ;\r
  95 \r
  96 : (log-error) ( object word level -- )\r
  97     log-service get [\r
  98         [ [ print-error ] with-string-writer ] 2dip log-message\r
  99     ] [\r
 100         2drop rethrow\r
 101     ] if ;\r
 102 \r
 103 : log-error ( error word -- ) ERROR (log-error) ;\r
 104 \r
 105 : log-critical ( error word -- ) CRITICAL (log-error) ;\r
 106 \r
 107 : stack-balancer ( effect -- quot )\r
 108     [ in>> length [ ndrop ] curry ]\r
 109     [ out>> length f <repetition> >quotation ]\r
 110     bi append ;\r
 111 \r
 112 : error-logging-quot ( quot word -- quot' )\r
 113     dup stack-effect stack-balancer\r
 114     '[ , [ , log-error @ ] recover ] ;\r
 115 \r
 116 : add-error-logging ( word level -- )\r
 117     [ [ input-logging-quot ] 2keep drop error-logging-quot ]\r
 118     (define-logging) ;\r
 119 \r
 120 : LOG:\r
 121     #! Syntax: name level\r
 122     CREATE-WORD dup scan-word\r
 123     '[ 1array stack>message , , log-message ]\r
 124     (( message -- )) define-declared ; parsing\r