(*
 * Copyright (C) 2003:
 *    Stefano Zacchiroli <zack@cs.unibo.it>
 *    for the HELM Team http://helm.cs.unibo.it/
 *
 *  This file is part of HELM, an Hypertextual, Electronic
 *  Library of Mathematics, developed at the Computer Science
 *  Department, University of Bologna, Italy.
 *
 *  HELM is free software; you can redistribute it and/or
 *  modify it under the terms of the GNU General Public License
 *  as published by the Free Software Foundation; either version 2
 *  of the License, or (at your option) any later version.
 *
 *  HELM 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 General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with HELM; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
 *  MA  02111-1307, USA.
 *
 *  For details, see the HELM World-Wide-Web page,
 *  http://helm.cs.unibo.it/
 *)

open Printf;;
open Uwobo_common;;

  (** set this to true and uwobo will save transformation's intermediate results
  in /tmp/uwobo_intermediate_<seqno>_<pid>.xml *)
let save_intermediate_results = false;;

let xslNS = Gdome.domString "http://www.w3.org/1999/XSL/Transform"
let outputS = Gdome.domString "output"

  (** given a Gdome.document representing an XSLT stylesheet and an output
  property return 'Some value' where 'value' is the property value, or None if
  it's not defined *)
let get_property name (document: Gdome.document) =
  let node_list = document#getElementsByTagNameNS xslNS outputS in
  match node_list#item 0 with
  | None -> None
  | Some node ->
      let element = new Gdome.element_of_node node in
      let domName = Gdome.domString name in
      if element#hasAttribute domName then
        Some (element#getAttribute domName)#to_string
      else
        None
;;

let namespaceURI = Some (Gdome.domString Uwobo_common.uwobo_namespace) ;;

  (** output type wrt adding of debugging/error messages *)
type outputType =
  | XmlOutput of Gdome.node
  | TextPlainOutput of Gdome.text
  | NoOutput
;;

exception Found of int ;;

  (** add debugging and/or error messages to a Gdome document. Handle three
  distinct cases: (1) output contains an XML tree, (2) output contains only one
  text node, (3) output contains no data.
  If output contains an XML tree then users wishes are preserved and messages
  are either not included or included as comments or included as XML ndoes.
  If output contains only a text node comments are either not included or
  included at the beginning of the textual output.
  If output contains no data (i.e. DOM superroot node with no element or text
  children) messages are embedded as XML comments or not embedded at all *)
let add_msgs ~errormode ~debugmode ~msgs (doc: Gdome.document) =
  let getOutputType (doc: Gdome.document) =
    let children = doc#get_childNodes in
    let len = children#get_length in
    let rec find_element i =
      if i > len then
        raise Not_found
      else
        (match children#item i with
        | Some node when node#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE ->
            XmlOutput node
        | _ -> find_element (i + 1))
    in
    let rec find_text i =
      if i > len then
        raise Not_found
      else
        (match children#item i with
        | Some node when node#get_nodeType = GdomeNodeTypeT.TEXT_NODE ->
            TextPlainOutput (new Gdome.text_of_node node)
        | _ -> find_element (i + 1))
    in
    if len = 0 then
      NoOutput
    else
      (try find_element 0 with Not_found ->
        (try find_text 0 with Not_found -> NoOutput))
  in
  match getOutputType (doc :> Gdome.document) with
  | XmlOutput node ->
    let add_generic_msg mode build tagname =
      (match mode with
      | LibXsltMsgIgnore -> (fun msg -> ())
      | LibXsltMsgComment ->
          (fun msg ->
(*                 let contents = string_of_xslt_msg (build msg) ^ "<br />" in *)
            let contents = string_of_xslt_msg (build msg) in
            ignore (node#insertBefore
              ~newChild:(doc#createComment
                (Gdome.domString contents) :> Gdome.node)
              ~refChild:node#get_firstChild))
      | LibXsltMsgEmbed ->
          (fun msg ->
(*                 let contents = string_of_xslt_msg (build msg) ^ "<br />" in *)
            let contents = string_of_xslt_msg (build msg) in
            let element =
              doc#createElementNS
                ~namespaceURI ~qualifiedName:(Gdome.domString tagname)
            in
            ignore (element#appendChild
              (doc#createTextNode
                ~data:(Gdome.domString contents) :> Gdome.node));
            ignore (node#insertBefore
              ~newChild:(element :> Gdome.node)
              ~refChild:node#get_firstChild)))
    in
    let add_error_msg =
      add_generic_msg
        errormode (fun msg -> LibXsltErrorMsg msg) "uwobo:error"
    in
    let add_debug_msg =
      add_generic_msg
        debugmode (fun msg -> LibXsltDebugMsg msg) "uwobo:debug"
    in
    List.iter
      (function
        | LibXsltErrorMsg msg -> add_error_msg msg
        | LibXsltDebugMsg msg -> add_debug_msg msg)
      (List.rev msgs) (* because each msg is added as 1st children *)
| TextPlainOutput text ->
    let add_generic_msg mode build =
      (match mode with
      | LibXsltMsgIgnore -> (fun _ -> ())
      | LibXsltMsgComment | LibXsltMsgEmbed ->
          (fun msg ->
            text#insertData ~offset:0
              ~arg:(Gdome.domString
                (string_of_xslt_msg (build msg) ^ "\n"))))
    in
    let add_error_msg =
      add_generic_msg errormode (fun msg -> LibXsltErrorMsg msg)
    in
    let add_debug_msg =
      add_generic_msg debugmode (fun msg -> LibXsltDebugMsg msg)
    in
    List.iter
      (function
        | LibXsltErrorMsg msg -> add_error_msg msg
        | LibXsltDebugMsg msg -> add_debug_msg msg)
      (List.rev msgs) (* because each msg is added as 1st children *)
| NoOutput ->
    let add_generic_msg mode build =
      (match mode with
      | LibXsltMsgIgnore -> (fun _ -> ())
      | LibXsltMsgComment | LibXsltMsgEmbed ->
          (fun msg ->
            let comment_node =
              (* use comments anyway because text nodes aren't allowed in DOM as
              superroot children *)
              doc#createComment
                (Gdome.domString (string_of_xslt_msg (build msg)))
            in
            ignore (doc#insertBefore ~newChild:(comment_node :> Gdome.node)
              ~refChild:doc#get_firstChild)))
    in
    let add_error_msg =
      add_generic_msg errormode (fun msg -> LibXsltErrorMsg msg)
    in
    let add_debug_msg =
      add_generic_msg debugmode (fun msg -> LibXsltDebugMsg msg)
    in
    List.iter
      (function
        | LibXsltErrorMsg msg -> add_error_msg msg
        | LibXsltDebugMsg msg -> add_debug_msg msg)
      (List.rev msgs) (* because each msg is added as 1st children *)
;;

let apply
  ~(logger: Uwobo_logger.sysLogger)
  ~(styles: Uwobo_styles.styles)
  ~keys ~params ~props
  ~(veillogger: Uwobo_common.libXsltLogger)
  ?(errormode = LibXsltMsgIgnore) ?(debugmode = LibXsltMsgIgnore)
  input
  =
    (* "p_" prefix means "processed" *)
  let (p_stylesheets,last_stylesheet) = styles#get keys props logger in
  logger#log `Debug "Creating input document ...";
  let intermediate_results_seqno = ref 0 in
  let result = (* Gdome.document *)
    List.fold_left
      (fun source (key, stylesheet) ->
        logger#log `Debug (sprintf "Applying stylesheet %s ..." key);
        try
          let params =
            List.map
             (fun (key,value) ->
               let quoted_value =
                if String.contains value '\'' then
                 if String.contains value '"' then
                  raise
                   (Failure
                     ("A parameter value can not contain both single and " ^
                      "double quotes, since it must be a valid XPath string " ^
                      "literal"))
                 else
                  "\"" ^ value ^ "\""
                else
                 "'" ^ value ^ "'"
               in
                (key,quoted_value)
             ) (params key)
          in
          logger#log `Debug
            (sprintf "Gdome_xslt.applyStylesheet params=%s"
              (String.concat ", " (List.map (fun (k,v) -> k^": "^v) params)));
          let res = Gdome_xslt.applyStylesheet ~source ~stylesheet ~params in
          if save_intermediate_results then begin
            let domImpl = Gdome.domImplementation () in
            ignore
              (domImpl#saveDocumentToFile
                ~doc:res
                ~name:(sprintf "/tmp/uwobo_intermediate_%d_%d.xml"
                  !intermediate_results_seqno (Unix.getpid()))
                ());
            incr intermediate_results_seqno;
          end;
          res
        with e -> raise (Uwobo_failure (Printexc.to_string e)))
      input
      p_stylesheets
  in
    (* add error and debugging messages to result document *)
  add_msgs ~errormode ~debugmode ~msgs:veillogger#msgs result;
(*
  (* DEBUGGING *)
  add_msgs
    ~errormode:LibXsltMsgEmbed ~debugmode:LibXsltMsgEmbed
    ~msgs:[LibXsltErrorMsg "error1"; LibXsltDebugMsg "debug1"]
    result;
*)
  let p_last_stylesheet = snd (List.hd (List.rev p_stylesheets)) in
  ((fun outchan ->                              (* serialization function *)
      Gdome_xslt.saveResultToChannel ~outchan ~result
        ~stylesheet:p_last_stylesheet),
   (get_property "media-type" last_stylesheet), (* media-type *)
   (get_property "encoding" last_stylesheet))   (* encoding *)