101 (* message channels *) |
101 (* message channels *) |
102 |
102 |
103 local |
103 local |
104 |
104 |
105 fun chunk s = [string_of_int (size s), "\n", s]; |
105 fun chunk s = [string_of_int (size s), "\n", s]; |
106 |
106 fun flush channel = ignore (try System_Channel.flush channel); |
107 fun message do_flush mbox name raw_props body = |
107 |
|
108 datatype target = |
|
109 Channel of System_Channel.T | |
|
110 Mailbox of (string list * bool) Mailbox.T; |
|
111 |
|
112 fun message do_flush target name raw_props body = |
108 let |
113 let |
109 val robust_props = map (pairself YXML.embed_controls) raw_props; |
114 val robust_props = map (pairself YXML.embed_controls) raw_props; |
110 val header = YXML.string_of (XML.Elem ((name, robust_props), [])); |
115 val header = YXML.string_of (XML.Elem ((name, robust_props), [])); |
111 in Mailbox.send mbox (chunk header @ chunk body, do_flush) end; |
116 val msg = chunk header @ chunk body; |
112 |
117 in |
113 fun standard_message mbox opt_serial name body = |
118 (case target of |
114 if body = "" then () |
119 Channel channel => (List.app (fn s => System_Channel.output channel s) msg; flush channel) |
115 else |
120 | Mailbox mbox => Mailbox.send mbox (msg, do_flush)) |
116 message false mbox name |
121 end; |
117 ((case opt_serial of SOME i => cons (Markup.serialN, Markup.print_int i) | _ => I) |
|
118 (Position.properties_of (Position.thread_data ()))) body; |
|
119 |
122 |
120 fun message_output mbox channel = |
123 fun message_output mbox channel = |
121 let |
124 let |
122 fun flush () = ignore (try System_Channel.flush channel); |
|
123 fun loop receive = |
125 fun loop receive = |
124 (case receive mbox of |
126 (case receive mbox of |
125 SOME (msg, do_flush) => |
127 SOME (msg, do_flush) => |
126 (List.app (fn s => System_Channel.output channel s) msg; |
128 (List.app (fn s => System_Channel.output channel s) msg; |
127 if do_flush then flush () else (); |
129 if do_flush then flush channel else (); |
128 loop (Mailbox.receive_timeout (seconds 0.02))) |
130 loop (Mailbox.receive_timeout (seconds 0.02))) |
129 | NONE => (flush (); loop (SOME o Mailbox.receive))); |
131 | NONE => (flush channel; loop (SOME o Mailbox.receive))); |
130 in fn () => loop (SOME o Mailbox.receive) end; |
132 in fn () => loop (SOME o Mailbox.receive) end; |
131 |
133 |
132 in |
134 in |
133 |
135 |
134 fun init_channels channel = |
136 fun init_channels channel = |
135 let |
137 let |
136 val _ = TextIO.StreamIO.setBufferMode (TextIO.getOutstream TextIO.stdOut, IO.LINE_BUF); |
138 val _ = TextIO.StreamIO.setBufferMode (TextIO.getOutstream TextIO.stdOut, IO.LINE_BUF); |
137 val _ = TextIO.StreamIO.setBufferMode (TextIO.getOutstream TextIO.stdErr, IO.LINE_BUF); |
139 val _ = TextIO.StreamIO.setBufferMode (TextIO.getOutstream TextIO.stdErr, IO.LINE_BUF); |
138 |
140 |
139 val mbox = Mailbox.create () : (string list * bool) Mailbox.T; |
141 val target = |
140 val _ = Simple_Thread.fork false (message_output mbox channel); |
142 if Multithreading.available then |
|
143 let |
|
144 val mbox = Mailbox.create (); |
|
145 val _ = Simple_Thread.fork false (message_output mbox channel); |
|
146 in Mailbox mbox end |
|
147 else Channel channel; |
|
148 |
|
149 fun standard_message opt_serial name body = |
|
150 if body = "" then () |
|
151 else |
|
152 message false target name |
|
153 ((case opt_serial of SOME i => cons (Markup.serialN, Markup.print_int i) | _ => I) |
|
154 (Position.properties_of (Position.thread_data ()))) body; |
141 in |
155 in |
142 Output.Private_Hooks.status_fn := standard_message mbox NONE Markup.statusN; |
156 Output.Private_Hooks.status_fn := standard_message NONE Markup.statusN; |
143 Output.Private_Hooks.report_fn := standard_message mbox NONE Markup.reportN; |
157 Output.Private_Hooks.report_fn := standard_message NONE Markup.reportN; |
144 Output.Private_Hooks.result_fn := |
158 Output.Private_Hooks.result_fn := (fn (i, s) => standard_message (SOME i) Markup.resultN s); |
145 (fn (i, s) => standard_message mbox (SOME i) Markup.resultN s); |
|
146 Output.Private_Hooks.writeln_fn := |
159 Output.Private_Hooks.writeln_fn := |
147 (fn s => standard_message mbox (SOME (serial ())) Markup.writelnN s); |
160 (fn s => standard_message (SOME (serial ())) Markup.writelnN s); |
148 Output.Private_Hooks.tracing_fn := |
161 Output.Private_Hooks.tracing_fn := |
149 (fn s => (update_tracing (); standard_message mbox (SOME (serial ())) Markup.tracingN s)); |
162 (fn s => (update_tracing (); standard_message (SOME (serial ())) Markup.tracingN s)); |
150 Output.Private_Hooks.warning_fn := |
163 Output.Private_Hooks.warning_fn := |
151 (fn s => standard_message mbox (SOME (serial ())) Markup.warningN s); |
164 (fn s => standard_message (SOME (serial ())) Markup.warningN s); |
152 Output.Private_Hooks.error_fn := |
165 Output.Private_Hooks.error_fn := |
153 (fn (i, s) => standard_message mbox (SOME i) Markup.errorN s); |
166 (fn (i, s) => standard_message (SOME i) Markup.errorN s); |
154 Output.Private_Hooks.protocol_message_fn := message true mbox Markup.protocolN; |
167 Output.Private_Hooks.protocol_message_fn := message true target Markup.protocolN; |
155 Output.Private_Hooks.urgent_message_fn := ! Output.Private_Hooks.writeln_fn; |
168 Output.Private_Hooks.urgent_message_fn := ! Output.Private_Hooks.writeln_fn; |
156 Output.Private_Hooks.prompt_fn := ignore; |
169 Output.Private_Hooks.prompt_fn := ignore; |
157 message true mbox Markup.initN [] (Session.welcome ()) |
170 message true target Markup.initN [] (Session.welcome ()) |
158 end; |
171 end; |
159 |
172 |
160 end; |
173 end; |
161 |
174 |
162 |
175 |