basis/io/monitors/recursive/recursive.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors sequences assocs arrays continuations
   4 destructors combinators kernel threads concurrency.messaging
   5 concurrency.mailboxes concurrency.promises io.files io.monitors
   6 debugger ;
   7 IN: io.monitors.recursive
   8
   9 ! Simulate recursive monitors on platforms that don't have them
  10
  11 TUPLE: recursive-monitor < monitor children thread ready disposed ;
  12
  13 : notify? ( -- ? ) monitor tget ready>> promise-fulfilled? ;
  14
  15 DEFER: add-child-monitor
  16
  17 : qualify-path ( path -- path' )
  18     monitor tget path>> prepend-path ;
  19
  20 : add-child-monitors ( path -- )
  21     #! We yield since this directory scan might take a while.
  22     directory* [ first add-child-monitor ] each yield ;
  23
  24 : add-child-monitor ( path -- )
  25     notify? [ dup { +add-file+ } monitor tget queue-change ] when
  26     qualify-path dup link-info type>> +directory+ eq? [
  27         [ add-child-monitors ]
  28         [
  29             [
  30                 [ f my-mailbox (monitor) ] keep
  31                 monitor tget children>> set-at
  32             ] curry ignore-errors
  33         ] bi
  34     ] [ drop ] if ;
  35
  36 : remove-child-monitor ( monitor -- )
  37     monitor tget children>> delete-at* [ dispose ] [ drop ] if ;
  38
  39 M: recursive-monitor dispose*
  40     [ "stop" swap thread>> send-synchronous drop ]
  41     [ queue>> dispose ]
  42     bi ;
  43
  44 : stop-pump ( -- )
  45     monitor tget children>> [ nip dispose ] assoc-each ;
  46
  47 : pump-step ( msg -- )
  48     first3 path>> swap >r prepend-path r> monitor tget 3array
  49     monitor tget queue>>
  50     mailbox-put ;
  51
  52 : child-added ( path monitor -- )
  53     path>> prepend-path add-child-monitor ;
  54
  55 : child-removed ( path monitor -- )
  56     path>> prepend-path remove-child-monitor ;
  57
  58 : update-hierarchy ( msg -- )
  59     first3 swap [
  60         {
  61             { +add-file+ [ child-added ] }
  62             { +remove-file+ [ child-removed ] }
  63             { +rename-file-old+ [ child-removed ] }
  64             { +rename-file-new+ [ child-added ] }
  65             [ 3drop ]
  66         } case
  67     ] with with each ;
  68
  69 : pump-loop ( -- )
  70     receive dup synchronous? [
  71         >r stop-pump t r> reply-synchronous
  72     ] [
  73         [ [ update-hierarchy ] curry ignore-errors ] [ pump-step ] bi
  74         pump-loop
  75     ] if ;
  76
  77 : monitor-ready ( error/t -- )
  78     monitor tget ready>> fulfill ;
  79
  80 : pump-thread ( monitor -- )
  81     monitor tset
  82     [ "" add-child-monitor t monitor-ready ]
  83     [ [ self <linked-error> monitor-ready ] keep rethrow ]
  84     recover
  85     pump-loop ;
  86
  87 : start-pump-thread ( monitor -- )
  88     dup [ pump-thread ] curry
  89     "Recursive monitor pump" spawn
  90     >>thread drop ;
  91
  92 : wait-for-ready ( monitor -- )
  93     ready>> ?promise ?linked drop ;
  94
  95 : <recursive-monitor> ( path mailbox -- monitor )
  96     >r (normalize-path) r>
  97     recursive-monitor new-monitor
  98         H{ } clone >>children
  99         <promise> >>ready
 100     dup start-pump-thread
 101     dup wait-for-ready ;