ocaml/console.ml

   1 type fancyobj = <
   2   to_string : unit -> string;
   3   to_html : unit -> string
   4 >;;
   5
   6 let sepx = "\xe2\xbf\x96";;
   7 let endx = "\xe2\xbf\x97";;
   8
   9 let socket_name = "/tmp/fancy.log";;
  10
  11 let html_enabled = Sys.file_exists socket_name;;
  12
  13 let socket = let open Unix in
  14   if html_enabled
  15   then socket PF_UNIX SOCK_STREAM 0
  16   else socket PF_INET SOCK_STREAM 0;;
  17
  18 let html_enabled = if html_enabled then
  19   try
  20     let _ = Unix.connect socket (Unix.ADDR_UNIX socket_name) in true
  21   with Unix.Unix_error _ -> false
  22   else false
  23 ;;
  24
  25 let cols =
  26   let process_output_to_list2 = fun command ->
  27     let chan = Unix.open_process_in command in
  28     let res = ref ([] : string list) in
  29     let rec process_otl_aux () =
  30       let e = input_line chan in
  31       res := e::!res;
  32       process_otl_aux() in
  33     try process_otl_aux ()
  34     with End_of_file ->
  35       let stat = Unix.close_process_in chan in (List.rev !res,stat)
  36   in let cmd_to_list command =
  37     let (l,_) = process_output_to_list2 command in l
  38   in try let lines = cmd_to_list "tput cols" in int_of_string (List.hd (lines))
  39   with _ -> 100 (* default value *)
  40 ;;
  41
  42 let writeall s =
  43   let _ = Unix.send socket s 0 (String.length s) [] in ()
  44 ;;
  45
  46 let concat ls = (String.concat sepx ls) ^ endx;;
  47
  48 (* HELO message *)
  49 if html_enabled then
  50   writeall(concat["helo"; String.concat " " (Array.to_list Sys.argv)])
  51 ;;
  52
  53
  54 (* let logs objs =
  55   if html_enabled then (
  56     let strs = (List.map (fun x -> x#to_html()) objs) in
  57     writeall (concat ("log" :: strs))
  58   ); prerr_endline (String.concat " " (List.map (fun x -> x#to_string()) objs))
  59 ;; *)
  60
  61 let html_escape s =
  62   let m = [("&", "&amp;"); (">", "&gt;"); ("<", "&lt;"); ("&quot;", "\""); ("&#39;", "'")]
  63   in let m = List.map (fun (x,y) -> Str.regexp x, y) m
  64   in List.fold_right (fun (x,y) z -> Str.global_replace x y z) m s;; (* FIXME TODO *)
  65
  66 let fancy_of_string s : fancyobj = object
  67   method to_string () = s
  68   method to_html () = html_escape s
  69 end;;
  70
  71 let empty = fancy_of_string "";;
  72
  73 let line = ref empty;;
  74
  75 let (/) a b = object
  76   method to_string () = a
  77   method to_html () = b
  78 end;;
  79
  80 let (^^) a b = object
  81   method to_string () = (a#to_string () ^ "" ^ b#to_string ())
  82   method to_html () = a#to_html () ^ " " ^ b#to_html ()
  83 end;;
  84
  85 (* Output functions on standard output *)
  86
  87 let print_string s =
  88   line := !line ^^ fancy_of_string s
  89 ;;
  90
  91 let print_char c =
  92   print_string (String.make 1 c)
  93 ;;
  94
  95 (* let print_bytes : bytes -> unit *)
  96
  97 let print_int n =
  98   print_string (string_of_int n)
  99 ;;
 100
 101 (* val print_float : float -> unit *)
 102
 103 let print_newline () =
 104   if !line <> empty then (
 105   Pervasives.print_endline (!line#to_string());
 106   if html_enabled then (writeall (concat ["log"; !line#to_html()]));
 107   line := empty
 108   )
 109 ;;
 110
 111 let print f =
 112   line := !line ^^ f
 113 ;;
 114
 115 let print_string_endline f =
 116   print (fancy_of_string f); print_newline ()
 117 ;;
 118
 119 let print_endline f =
 120   print f; print_newline ()
 121 ;;
 122
 123 let print_hline () =
 124   print_newline ();
 125   print_endline ( String.make cols '-' / "<hr>")
 126 ;;
 127
 128 let print_heading s =
 129   print_newline ();
 130   print_endline (("# " ^ s) / ("<h2>" ^ html_escape s ^ "</h2>"))
 131 ;;
 132
 133 let print_bullet f =
 134   print_newline ();
 135   print_endline (("- " / "<ul><li>") ^^ f ^^ ("" / "</ul>"))
 136 ;;
 137
 138 let print_math s =
 139   print_endline ( s / "" );
 140   if html_enabled then (writeall (concat ["math"; s]))
 141 ;;