Source file ppx_eliom_type.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 module generates the file used to infer types (hence wrappers) of server
   escaped values.

   Server-specific and escaped expression will be kept only for
   type-checking. In order to export type of escaped expressions: it
   generates for each escaped expression a toplevel definition that
   looks like:

     let $global_id$ = ref None

   And client-side expressions are replaced by lists of initializers
   (one per escaped expressions):

     $global_id$ := Some $expr$

*)
open Ppxlib
open Ast_helper
open Ppx_eliom_utils

module Pass = struct
  (* accumulator, push and flush for typing expression
     $gen_id := Some $orig_expr *)
  let push_typing_expr, flush_typing_expr =
    let typing_expr = ref [] in
    let add orig_expr id =
      if List.for_all (function id', _ -> id.txt <> id'.txt) !typing_expr
      then
        let frag_eid = eid id in
        typing_expr :=
          ( id
          , let loc = orig_expr.pexp_loc in
            [%expr [%e frag_eid] := Some [%e orig_expr]] )
          :: !typing_expr
    in
    let flush () =
      let res = List.rev (List.map snd !typing_expr) in
      typing_expr := [];
      sequence res
    in
    add, flush

  (* accumulator, push and flush for typing str
     let $id = ref None
  *)
  let push_typing_str_item, flush_typing_str_item =
    let typing_strs = ref [] in
    let add orig_expr id =
      if List.for_all (function id', _ -> id'.txt <> id.txt) !typing_strs
      then
        typing_strs :=
          ( id
          , let loc = orig_expr.pexp_loc in
            [%stri let [%p Pat.var id] = Stdlib.ref None] )
          :: !typing_strs
    in
    let flush () =
      let res = List.map snd !typing_strs in
      typing_strs := [];
      res
    in
    add, flush

  (** Syntax extension *)

  let client_str item =
    let loc = item.pstr_loc in
    flush_typing_str_item () @ [%str let () = [%e flush_typing_expr ()]]

  let server_str _ item = flush_typing_str_item () @ [item]

  let shared_str _ item =
    let loc = item.pstr_loc in
    flush_typing_str_item () @ [%str let () = [%e flush_typing_expr ()]] @ [item]

  let fragment ~loc ?typ ~context:_ ~num:_ ~id ~unsafe:_ expr =
    let frag_eid = eid id in
    push_typing_str_item expr id;
    let typ = match typ with Some typ -> typ | None -> Typ.any ~loc () in
    [%expr
      [%e flush_typing_expr ()];
      [%e frag_eid] :=
        Some (Eliom_syntax.client_value "" 0 : [%t typ] Eliom_client_value.t);
      (Stdlib.Option.get ![%e frag_eid] : _ Eliom_client_value.t)]

  let escape_inject ~loc ?ident:_ ~(context : Context.escape_inject) ~id
      ~unsafe:_ expr
    =
    push_typing_str_item expr id;
    push_typing_expr expr id;
    match context with
    | `Escaped_value _ -> [%expr assert false]
    | `Injection `Shared -> expr
    | `Injection `Client -> [%expr assert false]

  let prelude _ = []
  let postlude _ = []
  let shared_sig _ = []
  let server_sig _ = []
  let client_sig _ = []
end

include Make (Pass)

let () =
  Ppxlib.Driver.register_transformation ~impl:mapper#structure "ppx_eliom_types"