Ocaml/FAQ/User Interfaces

let verbose = ref false
let debug = ref false
let output = ref ""
 
let () =
  Arg.parse
    [
      "-v", Arg.Set verbose, "Verbose mode";
      "-D", Arg.Set debug, "Debug mode";
      "-o", Arg.Set_string output, "Specify output file";
    ]
    (fun s ->
       raise (Arg.Bad (Printf.sprintf "unexpected argument `%s'" s)))
    (Printf.sprintf "Usage: %s [-v] [-d] [-o file]" Sys.argv.(0))
 
let () =
  if !verbose then print_endline "Verbose mode";
  if !debug then print_endline "Debug mode";
  if !output <> "" then print_endline ("Writing output to " ^ !output);

#load "unix.cma";;
 
let i_am_interactive () =
  Unix.isatty Unix.stdin && Unix.isatty Unix.stdout
 
let () =
  try
    while true do
      if i_am_interactive ()
      then print_string "Prompt: ";
      let line = read_line () in
      if line = "" then raise End_of_file;
      (* do something with the line *)
    done
  with End_of_file -> ()

#load "unix.cma";;
 
(* Run the clear command to clear the screen. *)
let () = ignore (Sys.command "clear")
 
(* Save the output to a string to avoid running a process each time. *)
let clear =
  try
    let proc = Unix.open_process_in "clear" in
    try
      let chars = input_line proc in
      ignore (Unix.close_process_in proc);
      chars
    with e -> ignore (Unix.close_process_in proc); ""
  with _ -> ""
let () = print_string clear

#load "unix.cma";;
 
(* UNIX only, due to "stty". *)
let get_terminal_size () =
  let in_channel = Unix.open_process_in "stty size" in
  try
    begin
      try
        Scanf.fscanf in_channel "%d %d"
          (fun rows cols ->
             ignore (Unix.close_process_in in_channel);
             (rows, cols))
      with End_of_file ->
        ignore (Unix.close_process_in in_channel);
        (0, 0)
    end
  with e ->
    ignore (Unix.close_process_in in_channel);
    raise e
 
(* Display a textual bar chart as wide as the console. *)
let () =
  let (height, width) = get_terminal_size () in
  if width < 10
  then (prerr_endline "You must have at least 10 characters";
        exit 255);
  let max_value = List.fold_left max 0.0 values in
  let ratio = (float width -. 10.0) /. max_value in
  List.iter
    (fun value ->
       Printf.printf "%8.1f %s\n"
         value
         (String.make (int_of_float (ratio *. value)) '*'))
    values

(* Requires the ANSITerminal library by Christophe Troestler,
   available at http://math.umh.ac.be/an/software.php#x4-80007 *)
 
#load "ANSITerminal.cma";;
open ANSITerminal
 
let () =
  print_string [red] "Danger Will Robinson!\n";
  print_string [] "This is just normal text.\n";
  print_string [Blink] "<BLINK>Do you hurt yet?</BLINK>\n"
 
(*-----------------------------*)
 
let () =
  set_autoreset false;
  (* rhyme for the deadly coral snake *)
  print_string [red; on_black] "venom lack\n";
  print_string [red; on_yellow] "kill that fellow\n";
  print_string [green; on_cyan; Blink] "garish!\n";
  print_string [Reset] ""
 
(*-----------------------------*)
 
let () =
  set_autoreset true;
  List.iter
    (print_string [red; on_white; Bold; Blink])
    ["This way\n";
     "each line\n";
     "has its own\n";
     "attribute set.\n"]

#load "unix.cma";;
 
let with_cbreak f x =
  let term_init = Unix.tcgetattr Unix.stdin in
  let term_cbreak = { term_init with Unix.c_icanon = false } in
  Unix.tcsetattr Unix.stdin Unix.TCSANOW term_cbreak;
  try
    let result = f x in
    Unix.tcsetattr Unix.stdin Unix.TCSADRAIN term_init;
    result
  with e ->
    Unix.tcsetattr Unix.stdin Unix.TCSADRAIN term_init;
    raise e
 
let key = with_cbreak input_char stdin
 
(*-----------------------------*)
 
(* sascii - Show ASCII values for keypresses *)
let sascii () =
  while true do
    let char = Char.code (input_char stdin) in
    Printf.printf " Decimal: %d\tHex: %x\n" char char;
    flush stdout
  done
let () =
  print_endline
    "Press keys to see their ASCII values.  Use Ctrl-C to quit.";
  with_cbreak sascii ()

(* OCaml doesn't recognize '\a'; instead use '\007'. *)
let () = print_endline "\007Wake up!"
 
(* Use the "tput" command to produce a visual bell. *)
let () = ignore (Sys.command "tput flash")

#!/usr/bin/ocaml
(* demo POSIX termios *)
 
#load "unix.cma";;
 
let uncontrol c =
  if c >= '\128' && c <= '\255'
  then Printf.sprintf "M-%c" (Char.chr (Char.code c land 127))
  else if (c >= '\000' && c < '\031') || c = '\127'
  then Printf.sprintf "^%c" (Char.chr (Char.code c lxor 64))
  else String.make 1 c
 
let term = Unix.tcgetattr Unix.stdin
let erase = term.Unix.c_verase
let kill = term.Unix.c_vkill
 
let () =
  Printf.printf "Erase is character %d, %s\n"
    (Char.code erase)
    (uncontrol erase);
  Printf.printf "Kill is character %d, %s\n"
    (Char.code kill)
    (uncontrol kill)
 
let () =
  term.Unix.c_verase <- '#';
  term.Unix.c_vkill <- '@';
  Unix.tcsetattr Unix.stdin Unix.TCSANOW term;
  Printf.printf "erase is #, kill is @; type something: %!";
  let line = input_line stdin in
  Printf.printf "You typed: %s\n" line;
  term.Unix.c_verase <- erase;
  term.Unix.c_vkill <- kill;
  Unix.tcsetattr Unix.stdin Unix.TCSANOW term
 
(*-----------------------------*)
 
module HotKey :
sig
  val cbreak : unit -> unit
  val cooked : unit -> unit
  val readkey : unit -> char
end =
struct
  open Unix
 
  let oterm = {(tcgetattr stdin) with c_vtime = 0}
  let noecho = {oterm with
                  c_vtime = 1;
                  c_echo = false;
                  c_echok = false;
                  c_icanon = false}
 
  let cbreak () = tcsetattr stdin TCSANOW noecho
  let cooked () = tcsetattr stdin TCSANOW oterm
 
  let readkey () =
    cbreak ();
    let key = input_char (Pervasives.stdin) in
    cooked ();
    key
 
  let () = cooked ()
end

#load "unix.cma";;
 
let () =
  Unix.set_nonblock Unix.stdin;
  try
    let char = with_cbreak input_char stdin in
    (* input was waiting and it was char *)
    ()
  with Sys_blocked_io ->
    (* no input was waiting *)
    ()

#load "unix.cma";;
 
(* Thanks to David Mentre, Remi Vanicat, and David Brown's posts on
   caml-list. Works on Unix only, unfortunately, due to tcsetattr. *)
let read_password () =
  let term_init = Unix.tcgetattr Unix.stdin in
  let term_no_echo = { term_init with Unix.c_echo = false } in
  Unix.tcsetattr Unix.stdin Unix.TCSANOW term_no_echo;
  try
    let password = read_line () in
    print_newline ();
    Unix.tcsetattr Unix.stdin Unix.TCSAFLUSH term_init;
    password
  with e ->
    Unix.tcsetattr Unix.stdin Unix.TCSAFLUSH term_init;
    raise e
 
let () =
  print_string "Enter your password: ";
  let password = read_password () in
  Printf.printf "You said: %s\n" password

(* ledit is a pure-OCaml readline clone by Daniel de Rauglaudre.
   Source is available here: http://pauillac.inria.fr/~ddr/ledit/
 
   It is designed to be used as a command-line wrapper, but it
   can also be embedded in another program by building it normally
   and copying cursor.cmo, ledit.cmi, ledit.cmo, and ledit.mli into
   your project.
 
   A guide to compiling and embedding ledit can be found on the
   OCaml Tutorial Wiki: http://www.ocaml-tutorial.org/ledit
   At present, this guide applies to ledit 1.11. This recipe uses
   ledit 1.15, which is slightly different due to the addition of
   Unicode support (Ledit.input_char now returns a string instead
   of a char). *)
 
#load "unix.cma";;
#load "cursor.cmo";;
#load "ledit.cmo";;
 
let readline prompt =
  Ledit.set_prompt prompt;
  let buffer = Buffer.create 256 in
  let rec loop = function
    | "\n" ->
        Buffer.contents buffer
    | string ->
        Buffer.add_string buffer string;
        loop (Ledit.input_char stdin) in
  loop (Ledit.input_char stdin)
 
let () =
  let prompt = "Prompt: " in
  let line = readline prompt in
  Printf.printf "You said: %s\n" line
 
(*-----------------------------*)
 
(* If you would prefer to use the real GNU Readline library, you can use
  camlidl to generate an interface to it. Here's a basic readline.idl: *)
 
quote(c, "#include <stdio.h>");
quote(c, "#include <readline/readline.h>");
quote(c, "#include <readline/history.h>");
 
[string, unique] char * readline ([string, unique] const char *prompt)
    quote(dealloc, "free(_res);");
 
void add_history ([string] const char *string);
 
(* And here is a test program: *)
 
let () =
  while true do
    Printf.printf "You said: %s\n%!"
      (match Readline.readline (Some "Prompt: ") with
         | Some s -> Readline.add_history s; s
         | None -> exit 0)
  done
 
(*-----------------------------*)
 
(* vbsh - very bad shell *)
let () =
  try
    while true do
      let cmd = readline "$ " in
      begin
        match Unix.system cmd with
          | Unix.WEXITED _ -> ()
          | Unix.WSIGNALED signal_num ->
              Printf.printf "Program killed by signal %d\n"
                signal_num
          | Unix.WSTOPPED signal_num ->
              Printf.printf "Program stopped by signal %d\n"
                signal_num
      end;
      flush stdout
    done
  with End_of_file -> ()

#!/usr/bin/ocaml
(* rep - screen repeat command *)
 
#load "unix.cma";;
 
(* http://www.nongnu.org/ocaml-tmk/ *)
#directory "+curses";;
#load "curses.cma";;
 
let timeout = 10.0
 
let (timeout, command) =
  match Array.length Sys.argv with
    | 0 | 1 -> (timeout, [| |])
    | len ->
        if Sys.argv.(1) <> "" && Sys.argv.(1).[0] = '-'
        then (float_of_string
                (String.sub Sys.argv.(1)
                   1 (String.length Sys.argv.(1) - 1)),
              Array.sub Sys.argv 2 (len - 2))
        else (timeout, Array.sub Sys.argv 1 (len - 1))
 
let () =
  if Array.length command = 0
  then (Printf.printf "usage: %s [ -timeout ] cmd args\n" Sys.argv.(0);
        exit 255)
 
let window = Curses.initscr ()          (* start screen *)
let _ = Curses.noecho ()
let _ = Curses.cbreak ()
let _ = Curses.nodelay window true      (* so getch() is non-blocking *)
 
let done' s _ = Curses.endwin (); print_endline s; exit 0
let () = Sys.set_signal Sys.sigint (Sys.Signal_handle (done' "Ouch!"))
 
let cols, lines = Curses.getmaxyx window
 
let days = [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |]
let months = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun";
                "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |]
 
let format_time time =
  let tm = Unix.localtime time in
  Printf.sprintf "%s %s %2d %02d:%02d:%02d %04d"
    days.(tm.Unix.tm_wday)
    months.(tm.Unix.tm_mon)
    tm.Unix.tm_mday
    tm.Unix.tm_hour
    tm.Unix.tm_min
    tm.Unix.tm_sec
    (tm.Unix.tm_year + 1900)
 
let time = fst (Unix.mktime {Unix.tm_sec=50; tm_min=45; tm_hour=3;
                             tm_mday=18; tm_mon=0; tm_year=73;
                             tm_wday=0; tm_yday=0; tm_isdst=false})
 
let () =
  while true do
    let key = ref (-1) in
    while key := Curses.getch (); !key <> -1 do
      if !key = Char.code 'q' then done' "See ya" ()
    done;
 
    let in_channel =
      Unix.open_process_in (String.concat " " (Array.to_list command)) in
    begin
      try
        for i = 0 to lines - 1 do
          let line = input_line in_channel in
          ignore (Curses.mvaddstr i 0 line);
 
          Curses.standout ();
          ignore (Curses.mvaddstr (lines - 1) (cols - 24)
                    (format_time (Unix.time ())));
          Curses.standend ();
 
          ignore (Curses.move 0 0);
          ignore (Curses.refresh ());
        done;
        ignore (Unix.close_process_in in_channel)
      with End_of_file ->
        ignore (Unix.close_process_in in_channel)
    end;
 
    ignore (Unix.select [Unix.stdin] [] [] timeout)
  done
 
(*-----------------------------*)
 
let err = Curses.keypad window true     (* enable keypad mode *)
let key = Curses.getch ()
let () =
  if (key = (Char.code 'k') ||          (* vi mode *)
      key = 16 ||                       (* emacs mode *)
      key = Curses.Key.up)              (* arrow mode *)
  then
    begin
      (* do something *)
    end

(* Use perl4caml to integrate OCaml with Perl:
   http://merjis.com/developers/perl4caml *)
#directory "+perl";;
#load "perl4caml.cma";;
 
(* Wrap the needed functionality from CPAN's Expect module: *)
module Expect = struct
  open Perl
  let _ = eval "use Expect"
 
  exception Error of string
 
  type match_pattern = Ex of string | Re of string
 
  class expect () = object (self)
    val sv = call_class_method "Expect" "new" []
 
    method log_stdout =
      bool_of_sv (call_method sv "log_stdout" [])
 
    method set_log_stdout bool =
      ignore (call_method sv "log_stdout" [sv_of_bool bool])
 
    method spawn command parameters =
      let result =
        call_method sv "spawn"
          (sv_of_string command :: List.map sv_of_string parameters) in
      if not (bool_of_sv result)
      then raise (Error (string_of_sv (eval "$!")))
 
    method expect timeout match_patterns =
      let svs_of_pattern = function
        | Ex s -> [sv_of_string "-ex"; sv_of_string s]
        | Re s -> [sv_of_string "-re"; sv_of_string s] in
      let timeout =
        match timeout with
          | Some i -> sv_of_int i
          | None -> sv_undef () in
      let result =
        call_method sv "expect"
          (timeout ::
             List.flatten (List.map svs_of_pattern match_patterns)) in
      if sv_is_undef result
      then None
      else Some (int_of_sv result - 1)
 
    method send string =
      ignore (call_method sv "send" [sv_of_string string])
 
    method soft_close () =
      ignore (call_method sv "soft_close" [])
 
    method hard_close () =
      ignore (call_method sv "hard_close" [])
  end
 
  let spawn command parameters =
    let exp = new expect () in
    exp#spawn command parameters;
    exp
end
 
(* start the program *)
let command =
  try Expect.spawn "program to run" ["arg 1"; "arg 2"]
  with Expect.Error e ->
    Printf.eprintf "Couldn't start program: %s\n%!" e;
    exit 1
 
let () =
  (* prevent the program's output from being shown on our stdout *)
  command#set_log_stdout false;
 
  (* wait 10 seconds for "login:" to appear *)
  if command#expect (Some 10) [Expect.Ex "login"] = None
  then failwith "timed out";
 
  (* wait 20 seconds for something that matches /[Pp]assword: ?/ *)
  if command#expect (Some 20) [Expect.Re "[Pp]assword: ?"] = None
  then failwith "timed out";
 
  (* wait forever for "invalid" to appear *)
  if command#expect None [Expect.Ex "invalid"] = None
  then failwith "error occurred; the program probably went away";
 
  (* send "Hello, world" and a carriage return to the program *)
  command#send "Hello, world\r";
 
  (* if the program will terminate by itself, finish up with *)
  command#soft_close ();
 
  (* if the program must be explicitly killed, finish up with *)
  command#hard_close ()
 
(* wait for multiple strings *)
let () =
  match command#expect (Some 30)
    [Expect.Ex "invalid"; Expect.Ex "succes";
     Expect.Ex "error"; Expect.Ex "boom"] with
      | Some which ->
          (* found one of those strings *)
          ()
      | None ->
          ()

(* LablTk is included in the OCaml standard library. *)
#directory "+labltk";;
#load "labltk.cma";;
 
open Tk
 
let main = openTk ()
 
(* Create a horizontal space at the top of the window for the
   menu to live in. *)
let menubar = Frame.create ~relief:`Raised ~borderwidth:2 main
let () = pack ~anchor:`Nw ~fill:`X [menubar]
 
(* Create a button labeled "File" that brings up a menu *)
let file_menubutton = Menubutton.create ~text:"File" ~underline:1 menubar
let () = pack ~side:`Left [file_menubutton]
 
(* Create entries in the "File" menu *)
let file_menu = Menu.create file_menubutton
let () = Menubutton.configure ~menu:file_menu file_menubutton
let () = Menu.add_command ~label:"Print" ~command:print file_menu
let () = Menu.add_command ~label:"Save" ~command:save file_menu
 
(*-----------------------------*)
 
(* Create a menu item using an anonymous callback *)
let () =
  Menu.add_command
    ~label:"Quit Immediately"
    ~command:(fun () -> exit 0)
    file_menu
 
(*-----------------------------*)
 
(* Add a separator (a horizontal line) to the menu *)
let () = Menu.add_separator file_menu
 
(*-----------------------------*)
 
(* Create a checkbutton menu item *)
let debug = Textvariable.create ~on:options_menu ()
let () =
  Menu.add_checkbutton
    ~label:"Create Debugging File"
    ~variable:debug
    ~onvalue:"1"
    ~offvalue:"0"
    options_menu
 
(*-----------------------------*)
 
(* Create radiobutton menu items *)
let log_level = Textvariable.create ~on:options_menu ()
let () =
  Menu.add_radiobutton
    ~label:"Level 1"
    ~variable:log_level
    ~value:"1"
    debug_menu
let () =
  Menu.add_radiobutton
    ~label:"Level 2"
    ~variable:log_level
    ~value:"2"
    debug_menu
let () =
  Menu.add_radiobutton
    ~label:"Level 3"
    ~variable:log_level
    ~value:"3"
    debug_menu
 
(*-----------------------------*)
 
(* Create a nested menu *)
let font_menu = Menu.create format_menubutton
let () = Menu.add_cascade ~label:"Font" ~menu:font_menu format_menu
let font_name = Textvariable.create ~on:font_menu ()
let () =
  Menu.add_radiobutton
    ~label:"Courier"
    ~variable:font_name
    ~value:"courier"
    font_menu
let () =
  Menu.add_radiobutton
    ~label:"Times Roman"
    ~variable:font_name
    ~value:"times"
    font_menu
 
(*-----------------------------*)
 
(* To disable tearoffs, use ~tearoff:false when calling Menu.create *)
let font_menu = Menu.create ~tearoff:false format_menubutton
 
(*-----------------------------*)
 
(* Start the Tk event loop and display the interface *)
let () = Printexc.print mainLoop ()

(* Tk::DialogBox is a CPAN module that replaces Tk's standard Dialog
   widget with one that can be customized with additional inputs. To
   get this effect in OCaml would require translating the whole CPAN
   module; instead, for this simple example, we will use the built-in
   Dialog. *)
 
#directory "+labltk";;
#load "labltk.cma";;
 
open Tk
 
let main = openTk ()
 
let dialog =
  Dialog.create
    ~title:"Register This Program"
    ~buttons:["Register"; "Cancel"]
    ~parent:main
    ~message:"..."
 
let () =
  match dialog () with
    | 0 -> print_endline "Register"
    | 1 -> print_endline "Cancel"
    | _ -> failwith "this shouldn't happen"
 
let () = Printexc.print mainLoop ()
 
(*-----------------------------*)
 
(* Normally, uncaught exceptions are printed to standard error. However,
   by overriding the "camlcb" callback, a custom error handler can be
   installed which creates dialogs instead. *)
 
#directory "+labltk";;
#load "labltk.cma";;
 
open Tk
 
let main = openTk ()
 
let show_error =
  let dialog =
    Dialog.create
      ~title:"Error"
      ~buttons:["Acknowledge"]
      ~parent:main in
  fun message -> ignore (dialog ~message ())
 
(* Override the "camlcb" callback. Note that this is an undocumented
   feature that relies on some internals of Labltk. *)
let () =
  Callback.register "camlcb"
    (fun id args ->
       try (Hashtbl.find Protocol.callback_naming_table id) args
       with e -> show_error (Printexc.to_string e))
 
let make_error () = failwith "This is an error"
 
let button1 =
  Button.create ~text:"Make An Error" ~command:make_error main
let () = pack ~side:`Left [button1]
 
let button2 =
  Button.create ~text:"Quit" ~command:(fun () -> exit 0) main
let () = pack ~side:`Left [button2]
 
let () = Printexc.print mainLoop ()

open Tk
 
let main = openTk ()
 
(* Prevent the user from resizing the window. *)
let () =
  bind main
    ~events:[`Configure]
    ~action:(fun _ ->
               let width = Winfo.width main in
               let height = Winfo.height main in
               Wm.minsize_set main width height;
               Wm.maxsize_set main width height)
 
(* Or, use pack to control how widgets are resized. *)
let () = pack ~fill:`Both ~expand:true [widget]
let () = pack ~fill:`X ~expand:true [widget]
 
(* Make the main area expand horizontally and vertically. *)
let () = pack ~fill:`Both ~expand:true [mainarea]
 
(* Make the menu bar only expand horizontally. *)
let () = pack ~fill:`X ~expand:true [menubar]
 
(* Anchor the menu bar to the top-left corner. *)
let () = pack ~fill:`X ~expand:true ~anchor:`Nw [menubar]

(* Use Harry Chomsky's mkwinapp.ml from the OCaml-Win32 project:
 
   http://ocaml-win32.sourceforge.net/
 
   Compile your program using the native compiler and run mkwinapp.exe
   on the result. *)
 
C:\MyProg> ocamlopt myprog.ml -o myprog.exe
C:\MyProg> ocamlopt unix.cmxa mkwinapp.ml -o mkwinapp.exe
C:\MyProg> mkwinapp myprog.exe
 
(* Now you can run "myprog" and you won't get a console window. *)

#!/usr/bin/ocaml
 
#directory "+curses";;
#load "curses.cma";;
#load "unix.cma";;
 
let delay = 0.005
 
(* Bounce lines around the screen until the user interrupts with
   Ctrl-C. *)
let zip () =
  Curses.clear ();
  let maxcol, maxrow = Curses.get_size () in
 
  let chars = ref ['*'; '-'; '/'; '|'; '\\'; '_'] in
  let circle () = chars := List.tl !chars @ [List.hd !chars] in
 
  let row, col = ref 0, ref 0 in
  let row_sign, col_sign = ref 1, ref 1 in
 
  while true do
    ignore (Curses.mvaddch !col !row (Char.code (List.hd !chars)));
    ignore (Curses.refresh ());
    (try ignore (Unix.select [] [] [] delay) with _ -> ());
    row := !row + !row_sign;
    col := !col + !col_sign;
    if !row = maxrow then (row_sign := -1; circle ())
    else if !row = 0 then (row_sign :=  1; circle ());
    if !col = maxcol then (col_sign := -1; circle ())
    else if !col = 0 then (col_sign :=  1; circle ())
  done
 
let () =
  ignore (Curses.initscr ());
  at_exit Curses.endwin;
  zip ()

#!/usr/bin/ocaml
(* tkshufflepod - reorder =head1 sections in a pod file *)
#directory "+labltk";;
#load "labltk.cma";;
 
open Tk
 
(* Custom text viewer widget. *)
 
class viewer parent =
  let toplevel = Toplevel.create parent in
  let frame = Frame.create toplevel in
  let text = Text.create ~width:80 ~height:30 ~state:`Disabled frame in
  let vscroll = Scrollbar.create ~orient:`Vertical frame in
 
object (self)
  initializer
    self#hide ();
    Text.configure ~yscrollcommand:(Scrollbar.set vscroll) text;
    Scrollbar.configure ~command:(Text.yview text) vscroll;
    pack ~side:`Right ~fill:`Y [vscroll];
    pack ~side:`Left ~fill:`Both ~expand:true [text];
    pack ~side:`Right ~fill:`Both ~expand:true [frame];
    Wm.protocol_set toplevel "WM_DELETE_WINDOW" self#hide
 
  method show () = Wm.deiconify toplevel; raise_window toplevel
  method hide () = Wm.withdraw toplevel
 
  method set_title = Wm.title_set toplevel
  method set_body body =
    Text.configure ~state:`Normal text;
    Text.delete ~start:(`Atxy (0, 0), []) ~stop:(`End, []) text;
    Text.insert ~index:(`End, []) ~text:body text;
    Text.configure ~state:`Disabled text
end
 
(* Give list references a similar interface to Tk
   listbox widgets so we can keep the two in sync. *)
 
let listref_get listref index =
  match index with
    | `Num i -> List.nth !listref i
    | _ -> failwith "listref_get"
 
let listref_delete listref index =
  match index with
    | `Num i ->
        let rec loop current list =
          match list with
            | head :: tail when current = i -> loop (current + 1) tail
            | head :: tail -> head :: loop (current + 1) tail
            | [] -> [] in
        listref := loop 0 !listref
    | _ -> failwith "listref_delete"
 
let listref_insert listref index elt =
  match index with
    | `Num i ->
        let rec loop current list =
          match list with
            | head :: tail when current = i ->
                elt :: head :: loop (current + 1) tail
            | head :: [] when current = i - 1 -> head :: [elt]
            | head :: tail -> head :: loop (current + 1) tail
            | [] -> [] in
        listref := loop 0 !listref
    | _ -> failwith "listref_insert"
 
(* Use a line stream to produce a stream of POD chunks. *)
 
let line_stream_of_channel channel =
  Stream.from
    (fun _ -> try Some (input_line channel) with End_of_file -> None)
 
let pod_stream_of_channel channel =
  let lines = line_stream_of_channel channel in
  let is_head s = String.length s >= 6 && String.sub s 0 6 = "=head1" in
  let rec next pod_head pod_lines i =
    match Stream.peek lines, pod_head, pod_lines with
      | None, "", _ ->
          (* EOF, no POD found, return EOF *)
          None
      | None, _, _ ->
          (* EOF, POD found, return POD *)
          Some (pod_head, List.rev pod_lines)
      | Some head, "", _ when is_head head ->
          (* Head found *)
          Stream.junk lines;
          next head [] i
      | _, "", _ ->
          (* No head found, keep looking *)
          Stream.junk lines;
          next "" [] i
      | Some head, _, _ when is_head head ->
          (* Next head found, return POD *)
          Some (pod_head, List.rev pod_lines)
      | Some line, _, _ ->
          (* Line found, buffer and continue reading *)
          Stream.junk lines;
          next pod_head (line :: pod_lines) i in
  Stream.from (next "" [])
 
(* Read the POD file into memory, and split it into sections. *)
 
let podfile =
  if Array.length Sys.argv < 2
  then "-"
  else Sys.argv.(1)
 
let sections = ref []
 
(* Turn !sections into a list of (text, head) pairs. *)
 
let () =
  let channel = if podfile = "-" then stdin else open_in podfile in
  Stream.iter
    (fun (head, lines) ->
       sections := (String.concat "\n" lines, head) :: !sections)
    (pod_stream_of_channel channel);
  sections := List.rev !sections;
  close_in channel
 
(* Fire up Tk and display the list of sections. *)
let main = openTk ()
let listbox = Listbox.create ~width:60 main
let dragging = ref None
 
(* Singleton viewer instance. *)
let viewer = new viewer main
 
(* Called when the user clicks on an item in the Listbox. *)
let down event =
  dragging := Some (Listbox.nearest listbox event.ev_MouseY)
 
(* Called when the user releases the mouse button in the Listbox. *)
let up event =
  dragging := None
 
(* Called when the user moves the mouse in the Listbox. *)
let move event =
  let dest = Listbox.nearest listbox event.ev_MouseY in
  match !dragging with
    | Some src when src <> dest ->
        let elt = listref_get sections src in
        listref_delete sections src;
        listref_insert sections dest elt;
        let elt = Listbox.get listbox src in
        Listbox.delete listbox ~first:src ~last:src;
        Listbox.insert listbox ~index:dest ~texts:[elt];
        dragging := Some dest
    | _ -> ()
 
(* Called to save the list of sections. *)
let save event =
  let channel = if podfile = "-" then stdout else open_out podfile in
  List.iter
    (fun (text, head) ->
       output_string channel head;
       output_string channel "\n";
       output_string channel text;
       output_string channel "\n";
       flush channel)
    !sections;
  if podfile <> "-" then close_out channel
 
(* Called to display the widget.  Uses the viewer widget. *)
let view event =
  dragging := None; (* cancel drag *)
  List.iter
    (fun (`Num i) ->
       let (text, head) = List.nth !sections i in
       viewer#set_title head;
       viewer#set_body (head ^ "\n" ^ text);
       viewer#show ())
    (Listbox.curselection listbox)
 
let () =
  pack ~expand:true ~fill:`Both [listbox];
 
  List.iter
    (fun (text, title) -> Listbox.insert listbox `End [title])
    !sections;
 
  (* Permit dragging by binding to the Listbox widget. *)
  bind ~events:[`ButtonPress] ~fields:[`MouseY] ~action:down listbox;
  bind ~events:[`ButtonRelease] ~action:up listbox;
  bind ~events:[`Motion] ~fields:[`MouseY] ~action:move listbox;
 
  (* Permit viewing by binding double-click. *)
  bind ~events:[`Modified ([`Double], `ButtonRelease)] ~action:view listbox;
 
  (* 'q' quits and 's' saves *)
  bind ~events:[`KeyPressDetail "s"] ~action:save main;
  bind ~events:[`KeyPressDetail "q"] ~action:(fun _ -> exit 0) main;
 
  Printexc.print mainLoop ()