(* Form-ing web continuations, or asking several questions at once *)
(* Inspired by the conversation with Chung-chieh Shan *)


(* Preliminaries *)
(* Open the DelimCC library
  http://pobox.com/~oleg/ftp/Computation/Continuations.html#caml-shift
 Make sure OCaml top level is invoked as

 $ LD_LIBRARY_PATH=. ocamltopcc
 and the current directory contains the delimcc DLL (shared object).
*)

open Delimcc;;
let shift p f = take_subcont p (fun sk () ->
  push_prompt p (fun () -> (f (fun c -> 
    push_prompt p (fun () -> push_subcont sk (fun () -> c))))))
;;

let abort p v = take_subcont p (fun sk () -> v);;


(* ------------------------------------------------------------------------ *)
(* Warm-up and setting the stage:
   Reproducing the standard example of using continuations to program 
   web interactions: we ask the user for two integers n1 and n2
   and send the 'page' showing their difference. 
   Each question comes on its own `form'.
   This is essentially the example from Quiennec's ICFP2000 paper
   (only he used currency conversion).

   We emulate web interactions by those at the OCaml top level prompt.
   To invoke a server computation, rather than entering a URL
   into a web browser, we type the corresponding expression at the prompt.
   When the computation finishes, the top level prints its result (in the
   `natural' rather than HTML form). The result, which may be a `web form',
   can be `bookmarked' (that is, bound to a top-level variable) and then
   reinvoked none or many times. 
*)

(* The type of web pages shown to the user *)
(* One should read the value [Done x] as if it were a web page
   showing the result [x].
   If the `server' computation gave the result [Req str k],
   imagine it were a web form containing the string [str], with the
   continuation [k] embedded as a hidden form parameter.
   We should use the procedure [answer req reply_str] to `submit'
   such a form.
*)
type 'a req = 
  | Done of 'a
  | Req of string * (string -> 'a req)
;;


(* The following is the implementation of our servlet library *)

let topp = new_prompt ();;

(* The function to run the servlet *)
let run th = push_prompt topp th;;

(* The servlet calls [exit v] to send the `final web page'
   with the computed answer.
*)
let exit v = abort topp (Done v);;

(* A procedure to ask a question. The second argument is the conversion
   function, from string to the desired reply type. The function may raise
   an exception Scanf.Scan_failure if the conversion fails. The library
   then repeats the question, so the user can enter the acceptable
   answer this time.
*)
let question (str:string) cnv =
  let rec loop errstr = 
    let ans = shift topp (fun k -> Req ((errstr ^ str),k)) in
    try cnv ans with Scanf.Scan_failure e -> loop e
  in loop ""
;;

(* A sample conversion function, to convert user's answer to an int *)
let read_int (str: string) : int = Scanf.sscanf str "%i" (fun x -> x);;

(* If [req] is a `web form' sent by a `server computation',
   we should use [answer req reply_str] to `submit' the form with
   our reply.
*)
let answer (Req (_,k)) reply_str = k reply_str;;

(* --- end of the library code *)


(* The servlet example itself: ask for two numbers and compute their
   difference
*)

let test1 () =
  let n1 = question "Enter 1st number" read_int in
  let n2 = question "Enter 2nd number" read_int in
  exit (n1 - n2);;

(* Sample interaction:
   User's phrases start at column 0; the replies from the server are
   indented.

let it =  run test1;;     (* Type the test1 `URL' and get the form in reply *)
  val it : int req = Req ("Enter 1st number", <fun>)

let bookmark1 = it;;

let it = answer it "456";;  (* Submit the web form, get another one *)
  val it : int req = Req ("Enter 2nd number", <fun>)

let it = answer it "123";;  (* Submit it too, get the answer *)
  val it : int req = Done 333

let it = answer bookmark1 "111";; (* Go back to bookmarked form 1 *)
  val it : int req = Req ("Enter 2nd number", <fun>)

let it = answer it "xyz";;   (* If the answer is unacceptable, we are *)
                             (* asked to repeat it *)
  val it : int req =
    Req ("scanf: bad input at char number 1: xEnter 2nd number", <fun>)

let it = answer it "10";;
  val it : int req = Done 101

*)

(* ------------------------------------------------------------------------ *)
(* Asking several questions at once: ask-by-need *)
(* When the servlet submits a question, we delay generating the form,
   until the answer is really needed. At that point, we make a `web form'
   with all outstanding questions and send it to the user.
   After the form is submitted, we split the user replies, 
   match them to the questions, and validate the replies. If replies 
   to some of the questions turn out unacceptable, we generate an 
   error form listing all the questions and the received replies with 
   the corresponding error messages. The user is given a chance to correct 
   the replies and re-submit the form.
   All the error handling is done by our library and is transparent to
   the servlet programmer.
   We use the module Lazy for call-by-need programming. The programmer
   has to write Lazy.force explicitly, but OCaml will tell the programmer
   where forcing is really required. The programmer should insert Lazy.force
   then -- or at some earlier point, if the programmer so chooses.
   If the programmer forces the answer after asking each question, we
   get back the sequential behavior of asking questions one-by-one
   (see test21 below).
*)

(* A new servlet library code, the extension of the earlier library *)

(* To keep track of outstanding questions and not-yet consumed replies,
   we maintain the queue of [qq] values, identified by [qid].
*)
type qid = int;;
type qq = {qq_str    : string;         (* question string *)
	   qq_answer : string option;  (* received answer, if any *)
	   qq_id     : qid;
	   qq_validate : string -> string option};;


(* The following data type describes the protocol within the library, between
   the lower-level and the QnA supervisor. The lower-level may submit a
   question, receiving [qid]. The lower-level may ask the supervisor to
   provide the answer to the question identified by [qid].
*)
type qreq = 
  | QReq of string * (string -> string option) * (qid -> qreq)
  | QRes of qid    * (string -> qreq)
;;

let qp : qreq prompt = new_prompt ();;

(* should have been in the standard library... *)
let maybe n j = function Some x -> j x | None -> n ()

let splitby str char =
  let s = Stream.of_string str in
  let b = Buffer.create 16 in
  let iseof s = maybe (fun () -> true) (fun _ -> false) (Stream.peek s) in
  let rec loop found =
    match Stream.peek s with
    | None -> List.rev (Buffer.contents b :: found)
    | Some c when c = char ->
	let _ = Stream.next s in
	let found = Buffer.contents b :: found in
	let () = Buffer.reset b in
	if iseof s then List.rev found else loop found
    | Some c -> let _ = Stream.next s in Buffer.add_char b c; loop found
  in loop []
;;

(*
# splitby "abc" '&';;
- : string list = ["abc"]
# splitby "abc&" '&';;
- : string list = ["abc"]
# splitby "abc&&" '&';;
- : string list = ["abc"; ""]
# splitby "&abc&&" '&';;
- : string list = [""; "abc"; ""]
*)

(* We re-define the question function, keeping its interface.
   This function no longer sends any form to the user. Rather, we
   submit the question to the QnA supervisor and make the promise
   to resolve the received [qid] into the real answer.
*)
let question (str:string) cnv =
  let qq_validate = 
    fun str -> try cnv str; None with Scanf.Scan_failure e -> Some e in
  let qid = shift qp (fun k -> QReq (str, qq_validate, k)) in
  lazy (cnv (shift qp (fun k -> QRes (qid,k))))
;;

(* Ask a bunch of questions and return the list of qq with the answers.
   Given a list of questions, [qq list], we make the web form and send
   to the client. Upon the submission of the form, we parse and validate
   the result. If fewer or more replies are given, or some of the replies
   are not valid, we make and send an error form.
   The answers contained in the returned [qq list] are assured to
   be valid then.
*)

let questions (qes : qq list) : qq list =
  let suffix = "Needed " ^ (string_of_int (List.length qes)) ^
               " answers. Separate with & character" in
  let rec loop err_pref errs =
    let qs = err_pref ^ List.fold_right2 
	(fun e qe acc -> qe.qq_str ^ ": " ^ e ^ "; " ^ acc) errs qes suffix in
    let ans_str = shift topp (fun k -> Req (qs,k)) in
    let ans = splitby ans_str '&' in
    let (ok,err_pref,errs) = try List.fold_right2
	(fun qq ans (ok,pref,errs) -> 
	  match qq.qq_validate ans with
	  | None -> (ok, pref, ans::errs)
	  | Some err -> (false, pref, (err ^ " in " ^ ans)::errs)) 
         qes ans (true, "", [])
	with Invalid_argument _ -> (false, "incorrect number of ans",errs) in
    if ok then 
      List.map2 (fun qq ans -> {qq with qq_answer = Some ans}) qes ans
    else loop err_pref errs
  in loop "" (List.map (fun _ -> "") qes)
;;


(* The QnA supervisor.
   It handles submission of questions and resolving them to the answers
*)

let topqq th = 
 let rec loop cnt queue = function
   |  QReq (qstr, qval, k) ->		(* Schedule a new qq, return its qid*)
       print_endline "qreq received";
       loop (succ cnt) ({qq_str = qstr;
			 qq_answer = None;
			 qq_validate = qval;
			 qq_id = cnt}
			:: queue) (k cnt)
   | QRes (qid,k) as req ->
       print_endline "qres received";
       let ([qe],queue) = List.partition (fun qe -> qe.qq_id = qid) queue in
       (match qe.qq_answer with
       | Some s ->  (* question is answered already *)
	   loop cnt queue (k s)
       | None -> 
	   let (unanswered,queue) = 
	     List.partition (function {qq_answer = None} -> true | _ -> false)
	       queue
	   in loop cnt (questions (qe::unanswered) @ queue) req)
 in
 loop 0 [] (push_prompt qp th)
;;

(* --- end of the library code *)

(* First we reproduce the old sequential behavior: we force the answer right
   after asking a question (cf test1).
*)

let test21 () =
  let n1 = Lazy.force (question "Enter 1st number" read_int) in
  let n2 = Lazy.force (question "Enter 2nd number" read_int) in
  exit (n1 - n2);;

(* Sample interaction:

let it = run (fun () -> topqq test21);;
  qreq received
  qres received
  val it : int req =
    Req ("Enter 1st number: ; Needed 1 answers. Separate with & character",
     <fun>)

let it = answer it "456";;  (* Submit the web form, get another one *)
  qres received
  qreq received
  qres received
  val it : int req =
    Req ("Enter 2nd number: ; Needed 1 answers. Separate with & character",
     <fun>)

let it = answer it "123";;  (* Submit it too, get the answer *)
  qres received
  val it : int req = Done 333
*)

(* We are ready to show of parallel behavior: asking several questions
   at once. We insert Lazy.force only where the typechecker tells us to,
   but not earlier. We emulate call-by-need.
*)
let test2 () =
  let n1 = question "Enter 1st number" read_int in
  let n2 = question "Enter 2nd number" read_int in
  exit (Lazy.force n1 - Lazy.force n2);;

(* Sample interaction:
   (* enter the `URL' and see the form with two questions *)
let bm2 = run (fun () -> topqq test2);;
  qreq received
  qreq received
  qres received
  val bm2 : int req =
    Req
     ("Enter 2nd number: ; Enter 1st number: ; 
       Needed 2 answers. Separate with & character",
   <fun>)

let it = answer bm2 "xxx";;
  val it : int req =
    Req
     ("incorrect number of ansEnter 2nd number: ; Enter 1st number: ;
       Needed 2 answers. Separate with & character",
   <fun>)

  (* Both numbers failed validation, and so two error messages are given *)
let it = answer it "xxx&aaa";;
  val it : int req =
    Req
     ("Enter 2nd number: scanf: bad input at char number 1: x in xxx; 
       Enter 1st number: scanf: bad input at char number 1: a in aaa; 
       Needed 2 answers. Separate with & character",
   <fun>)

   (* The first number was acceptable. We still include it into the form *)
let it = answer it "xxx&123";;
  val it : int req =
    Req
     ("Enter 2nd number: scanf: bad input at char number 1: x in xxx; 
       Enter 1st number: 123; 
       Needed 2 answers. Separate with & character",
   <fun>)

   (* finally we give an acceptable answer, and the servlet may proceed *)
let it = answer it "456&123";;
  qres received
  qres received
  val it : int req = Done (-333)

*)

(* Switching the order of numbers *)
let test2' () =
  let n1 = question "Enter 1st number" read_int in
  let n2 = question "Enter 2nd number" read_int in
  exit (Lazy.force n2 - Lazy.force n1);;

let it = run (fun () -> topqq test2');;
(*
  qreq received
  qreq received
  qres received
  val it : int req =
   Req
    ("Enter 1st number: ; Enter 2nd number: ; 
      Needed 2 answers. Separate with & character",
   <fun>)
*)
let it = answer it "456&123";;
(*
  qres received
  qres received
  val it : int req = Done (-333)
*)