src/Pure/System/isabelle_process.ML
changeset 52580 36aa39694ab4
parent 52578 bd94e26e4388
child 52582 31467a4b1466
equal deleted inserted replaced
52579:59bf099448bf 52580:36aa39694ab4
   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