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