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 fry ;
   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     dup [
  23         [ append-path ] with map
  24         [ add-child-monitor ] each yield
  25     ] with-directory-files ;
  26
  27 : add-child-monitor ( path -- )
  28     notify? [ dup { +add-file+ } monitor tget queue-change ] when
  29     qualify-path dup link-info directory? [
  30         [ add-child-monitors ]
  31         [
  32             '[
  33                 _ [ f my-mailbox (monitor) ] keep
  34                 monitor tget children>> set-at
  35             ] ignore-errors
  36         ] bi
  37     ] [ drop ] if ;
  38
  39 : remove-child-monitor ( monitor -- )
  40     monitor tget children>> delete-at* [ dispose ] [ drop ] if ;
  41
  42 M: recursive-monitor dispose*
  43     [ "stop" swap thread>> send-synchronous drop ]
  44     [ queue>> dispose ]
  45     bi ;
  46
  47 : stop-pump ( -- )
  48     monitor tget children>> [ nip dispose ] assoc-each ;
  49
  50 : pump-step ( msg -- )
  51     first3 path>> swap [ prepend-path ] dip monitor tget 3array
  52     monitor tget queue>>
  53     mailbox-put ;
  54
  55 : child-added ( path monitor -- )
  56     path>> prepend-path add-child-monitor ;
  57
  58 : child-removed ( path monitor -- )
  59     path>> prepend-path remove-child-monitor ;
  60
  61 : update-hierarchy ( msg -- )
  62     first3 swap [
  63         {
  64             { +add-file+ [ child-added ] }
  65             { +remove-file+ [ child-removed ] }
  66             { +rename-file-old+ [ child-removed ] }
  67             { +rename-file-new+ [ child-added ] }
  68             [ 3drop ]
  69         } case
  70     ] with with each ;
  71
  72 : pump-loop ( -- )
  73     receive dup synchronous? [
  74         [ stop-pump t ] dip reply-synchronous
  75     ] [
  76         [ '[ _ update-hierarchy ] ignore-errors ] [ pump-step ] bi
  77         pump-loop
  78     ] if ;
  79
  80 : monitor-ready ( error/t -- )
  81     monitor tget ready>> fulfill ;
  82
  83 : pump-thread ( monitor -- )
  84     monitor tset
  85     [ "" add-child-monitor t monitor-ready ]
  86     [ [ self <linked-error> monitor-ready ] keep rethrow ]
  87     recover
  88     pump-loop ;
  89
  90 : start-pump-thread ( monitor -- )
  91     dup '[ _ pump-thread ]
  92     "Recursive monitor pump" spawn
  93     >>thread drop ;
  94
  95 : wait-for-ready ( monitor -- )
  96     ready>> ?promise ?linked drop ;
  97
  98 : <recursive-monitor> ( path mailbox -- monitor )
  99     [ (normalize-path) ] dip
 100     recursive-monitor new-monitor
 101         H{ } clone >>children
 102         <promise> >>ready
 103     dup start-pump-thread
 104     dup wait-for-ready ;