Source file ppx_eliom_server.ml

(* Ocsigen
 * http://www.ocsigen.org
 * Copyright (C) 2010-2011
 * Raphaël Proust, Grégoire Henry, Gabriel Radanne
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, with linking exception;
 * either version 2.1 of the License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 *)

(* This prepocessor generates the module to be loaded by Ocsigen server *)

open Ppxlib
open Ast_helper
open Ppx_eliom_utils

module Pass = struct
  let push_nongen_str_item, flush_nongen_str_item =
    let typing_strs = ref [] in
    let add ~fragment ~unsafe loc id =
      let typ =
        if fragment then [%type: _ Eliom_client_value.t] else [%type: _]
      in
      typing_strs :=
        (if unsafe || Mli.exists ()
         then [%stri let [%p Pat.var id] = fun y -> (y : [%t typ] :> [%t typ])]
         else
           [%stri
             let [%p Pat.var id] =
               let x = Stdlib.ref None in
               fun y ->
                 if false then x := Some y;
                 (y : [%t typ] :> [%t typ])])
        :: !typing_strs
    in
    let flush loc =
      let res = !typing_strs in
      typing_strs := [];
      Str.open_ ~loc (Opn.mk ~loc (Mod.structure ~loc res))
    in
    add, flush

  let one_char_location loc =
    { loc with
      Location.loc_end =
        { loc.Location.loc_start with
          pos_cnum = loc.Location.loc_start.Lexing.pos_cnum + 1 } }

  let push_escaped_binding, flush_escaped_bindings =
    let args = ref [] in
    let push loc orig_expr id ~unsafe =
      if List.for_all (function _, id', _, _ -> id.txt <> id'.txt) !args
      then args := (loc, id, orig_expr, unsafe) :: !args
    in
    let flush () =
      let res = List.rev !args in
      args := [];
      let aux (loc, id, arg, unsafe) =
        push_nongen_str_item ~fragment:false ~unsafe loc id;
        [%expr
          Eliom_syntax.escaped_value
            [%e
              let loc = one_char_location loc in
              [%expr [%e eid id] [%e arg]]]]
      in
      List.map aux res
    in
    push, flush

  module SSet = Set.Make (String)

  let push_injection, flush_injections =
    let buffer : (_ * _ * _ * _ * _) list ref = ref [] in
    let gen_ids = ref SSet.empty in
    let push loc ?ident id ~unsafe orig_expr =
      if not (SSet.mem id !gen_ids)
      then (
        gen_ids := SSet.add id !gen_ids;
        buffer := (loc, id, orig_expr, ident, unsafe) :: !buffer)
    in
    let flush_all () =
      let res = List.rev !buffer in
      gen_ids := SSet.empty;
      buffer := [];
      res
    in
    let global_known = ref SSet.empty in
    let flush () =
      let all = flush_all () in
      let novel =
        let is_fresh (_, gen_id, _, _, _) =
          not (SSet.mem gen_id !global_known)
        in
        List.filter is_fresh all
      in
      List.iter
        (function
           | _, gen_id, _, _, _ -> global_known := SSet.add gen_id !global_known)
        novel;
      all
    in
    push, flush

  (* For every injection of $orig_expr$ as $gen_id$:
     let $gen_id$ = $orig_expr$ and ...
     (Necessary for injections in shared section) *)
  let bind_injected_idents injections =
    assert (injections <> []);
    let bindings =
      List.map
        (fun (_, txt, expr, _, _) ->
           let loc = expr.pexp_loc in
           Vb.mk ~loc (Pat.var ~loc {txt; loc}) expr)
        injections
    in
    Str.value Nonrecursive bindings

  let close_server_section loc =
    [%stri
      let () = Eliom_syntax.close_server_section [%e eid @@ id_file_hash loc]]

  let may_close_server_section ~no_fragment loc =
    if no_fragment then [] else [close_server_section loc]

  let close_client_section loc injections =
    assert (injections <> []);
    let injection_list =
      List.fold_right
        (fun (loc0, txt, expr, ident, unsafe) sofar ->
           let loc = expr.pexp_loc in
           let loc_expr = position loc in
           let frag_eid = eid {txt; loc} in
           let ident =
             match ident with
             | None -> [%expr None]
             | Some i -> [%expr Some [%e str i]]
           in
           let _, num = Mli.get_injected_ident_info txt in
           let f_id = {txt = txt ^ "_f"; loc} in
           push_nongen_str_item ~fragment:false ~unsafe loc f_id;
           [%expr
             ( [%e int num]
             , Eliom_lib.to_poly
                 [%e
                   let loc = one_char_location loc0 in
                   [%expr [%e eid f_id] [%e frag_eid]]]
             , [%e loc_expr]
             , [%e ident] )
             :: [%e sofar]])
        injections [%expr []]
    in
    [%stri
      let () =
        Eliom_syntax.close_client_section
          [%e eid @@ id_file_hash loc]
          [%e injection_list]]

  (** Syntax extension *)

  let client_str item =
    let all_injections = flush_injections () in
    let loc = item.pstr_loc in
    let str =
      match all_injections with
      | [] -> []
      | l -> [bind_injected_idents l; close_client_section loc all_injections]
    in
    flush_nongen_str_item loc :: str

  let server_str no_fragment item =
    let loc = item.pstr_loc in
    flush_nongen_str_item loc :: item
    :: may_close_server_section ~no_fragment loc

  let shared_str no_fragment item =
    let all_injections = flush_injections () in
    let loc = item.pstr_loc in
    let cl =
      item
      :: may_close_server_section
           ~no_fragment:(no_fragment || all_injections <> [])
           loc
    in
    let str =
      match all_injections with
      | [] -> cl
      | l ->
          (bind_injected_idents l :: cl)
          @ [close_client_section loc all_injections]
    in
    flush_nongen_str_item loc :: str

  let fragment ~loc ?typ ~context:_ ~num ~id ~unsafe _ =
    let typ = match typ with Some typ -> typ | None -> [%type: _] in
    let e = format_args @@ flush_escaped_bindings () in
    push_nongen_str_item ~fragment:true ~unsafe loc id;
    [%expr
      [%e eid id]
        [%e
          let loc = one_char_location loc in
          [%expr
            (Eliom_syntax.client_value ~pos:[%e position loc] [%e str num]
               [%e e]
             : [%t typ] Eliom_client_value.t)]]]

  let escape_inject ~loc ?ident ~(context : Context.escape_inject) ~id ~unsafe
      expr
    =
    match context with
    | `Escaped_value _ ->
        push_escaped_binding loc expr id ~unsafe;
        [%expr assert false]
    | `Injection _ ->
        push_injection loc ?ident id.txt ~unsafe expr;
        eid id

  let set_global ~loc b =
    let b =
      Exp.construct ~loc
        {loc; txt = Longident.Lident (if b then "true" else "false")}
        None
    in
    [%stri let () = Eliom_syntax.set_global [%e b]]

  let prelude loc = [set_global ~loc true]
  let postlude loc = [set_global ~loc false]
  let shared_sig item = [item]
  let server_sig item = [item]
  let client_sig _ = []
end

include Make (Pass)

let () =
  Ppxlib.Driver.register_transformation ~impl:mapper#structure
    ~intf:mapper#signature "ppx_eliom_server"