Compiler Explorer

Source code

module Region :
  sig
    type region
    val ( #: )   : region -> ('a -> unit) -> 'a -> unit
    val ( let& ) : (region -> 'a) -> ('a -> 'b) -> 'b
  end =
struct

type finalizer = unit -> unit

type region = finalizer list ref
  
  let make () = ref []
  
  let ( #: ) r f v =
    r := (fun () -> f v) :: !r
 
  let rec exit r =
    match !r with
    | []    -> ()
    | f::fs ->
      begin
        f () ;
        r := fs ;
        exit r
      end
  
  let ( let& ) : (region -> 'a) -> ('a -> 'b) -> 'b
    = fun constr proc ->
      let region = make () in
      Fun.protect
        ~finally:(fun () -> exit region)
        begin fun () ->
          let res = constr region in
          proc res
        end

end

open Region

module File :
  sig
    type t
    val open_rw    : string -> region -> t
    val read_line  : t -> string option
    val write_line : t -> string -> unit
  end =
struct

type t =
    {         path : string
    ; mutable data : string list }
  
  let rec open_rw path region =
    Printf.printf "++++ OPEN %s\n" path ;
    let f = { path ; data = ["foo";"bar";"gee";"qux"] } in
    region #: close f ;
    f
  
  and close f =
    f.data <- [] ;
    Printf.printf "---- CLOSE %s\n" f.path
  
  let read_line f =
    match f.data with
    | [] ->
      begin
        Printf.printf "EOF\n" ;
        None
      end
    | line::rest ->
      begin
        f.data <- rest ;
        Printf.printf "READ %s FROM %s\n" line f.path ;
        Some line
      end
  
  let write_line f line =
    Printf.printf "WRITE %s TO %s\n" line f.path ;
    f.data <- List.append f.data [line]
 
end

module SQL_DB :
  sig
    type t
    val connect : string -> region -> t
    val select  : t -> string list
    val insert  : t -> string -> unit
  end =
struct

type t =
    {         table : string
    ; mutable rows  : string list }
  
  let rec connect table region =
    Printf.printf "++++ CONNECT TO %s\n" table ;
    let c = { table ; rows = ["foo";"bar"] } in
    region #: disconnect c ;
    c
  
  and disconnect conn =
    conn.rows <- [] ;
    Printf.printf "---- DISCONNECT FROM %s\n" conn.table
  
  let select conn =
    Printf.printf "SELECT * FROM %s\n" conn.table ;
    conn.rows
  
  let insert conn value =
    Printf.printf "INSERT INTO %s VALUE \"%s\"\n" conn.table value ;
    conn.rows <- value :: conn.rows
  
end

module Transfer :
  sig
    type t
    val make     : db:string -> file:string -> region -> t
    val upload   : t -> unit
    val download : t -> unit
  end =
struct

type t =
    { db : SQL_DB.t
    ; fd : File.t }

let make ~db:conn_str ~file:path region =
    let db = SQL_DB.connect conn_str region in
    let fd = File.open_rw path region in
    { db : SQL_DB.t
    ; fd : File.t }
  
  let upload { db ; fd } =
    let rec loop () =
      match File.read_line fd with
      | None -> ()
      | Some line ->
        begin
          SQL_DB.insert db line ;
          loop ()
        end
    in loop ()

let download { db ; fd } =
    let lines = SQL_DB.select db in
    List.iter (File.write_line fd) lines

end

let _ =
  ( let& users = Transfer.make ~db:"users" ~file:"/tmp/users" in
    Transfer.upload   users ;
    Transfer.download users );
  
  print_endline "--------------------------------" ;

( let& posts = Transfer.make ~db:"posts" ~file:"/tmp/posts" in
    Transfer.download posts ;
    Transfer.upload   posts );
  
  print_endline "--------------------------------" ;

( let& users = Transfer.make ~db:"users" ~file:"/tmp/users" in
    let& posts = Transfer.make ~db:"posts" ~file:"/tmp/posts" in
    Transfer.download users ;
    Transfer.download posts )