needs lib/str lib/struct
unit io/log

4 const HANDLERSCNT
enum LOW MEDIUM HIGH CRITICAL STORAGE MEMORY NETWORK IO TIME OTHER
OTHER value lastcat
: newcategoryid doto lastcat 1+ dup | ;

struct LogEvent {
  *LogEvent prev ;
  uint category nargs logcnt ;
  [uint,HANDLERSCNT] handlers ;
  [uchar,0] name ;
}

variable toplogevent
: createlogevent ( nargs category "name" -- )
  create here toplogevent @! , , , 0 , HANDLERSCNT 4* allot0 CURWORD @ s, ;

: freespot# ( handlers -- a )
  0 over HANDLERSCNT 1- idx not ?abort"out of handler slots" 4* + ;

: callhandlers ( ... logevent handlers -- ... logevent )
  >r [ begin \ RSP+0=a
    RSP) A>) @, A) S>) @+, RSP) A>) !,
    0 i) S>) =) if, 4 rs+, popexit, then
    S) &) brr, again

create globalhdls HANDLERSCNT 4* allot0
: handleall ( xt -- ) globalhdls freespot# ! ;
: handleevent ( xt logevent -- ) handlers freespot# ! ;

: reseteventhandlers ( logevent -- ) handlers HANDLERSCNT 0 fill ;
: resetallhandlers
  globalhdls HANDLERSCNT 0 fill
  toplogevent @ begin ?dup while ( e )
    dup reseteventhandlers prev repeat ;

\ copy/paste to not depend on lib/psrs
code ndrop ( ... n -- )
  2 i) <<, PSP) &) +, PSP) &) !,
  drop, exit,
code ps[] ( ... n -- ... a u )
  PSP) &) S>) @, PSP) S>) -!, exit,

0 value handling?
:quithook 0 to handling? ;

:~ ( ... logevent -- ... logevent )
  dup doto logcnt 1+ |
  doto handling? 1 | if exit then
  dup handlers callhandlers
  globalhdls callhandlers
  0 to handling? ;
: log ( ... logevent -- ) ~ nargs ndrop ;
: logk ( ... logevent -- ... ) ~ drop ;

: .logstats ( -- )
  toplogevent @ begin ?dup while ( e )
    dup name dup stype c@ 12 swap- max0 nspcs
    dup category . spc> dup nargs . spc> dup logcnt . nl>
    prev repeat ;

: log. ( ... logevent -- ... logevent )
  r! name stype spc> r@ nargs ps[] ( ... a u )
  0 do @+ .x spc> loop drop nl> flush. r> ;

:~ ( ... logevent xt categories -- ... logevent )
   oover category swap @+ idx nip if execute then ;
: categoryfilter ( ... n xt -- xt ) >r dup 1+ n,@ ['] ~ bind> r> swap bind> ;