(*
 * 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;;

exception Stylesheet_not_found of string ;;
exception Stylesheet_already_in of string ;;
exception Unsupported_property of string;;

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

let default_properties = [] (* no default properties *)

  (** apply an output property to an xslt stylesheet *)
let apply_property logger (element: Gdome.element) (name, value) =
  if Uwobo_common.is_supported_property name then begin
    logger#log `Debug (sprintf "Setting property: %s = %s" name value);
    element#setAttribute (Gdome.domString name) (Gdome.domString value)
  end else
    raise (Unsupported_property name)

  (** set a list of output properties in an xslt stylesheet, return a copy of
  the given stylesheet modified as needed, given stylesheet wont be changed by
  this operation.
  Before applying "props" properties applies a set of default properties as
  defined in "default_properties" *)
let apply_properties logger last_stylesheet props =
  let last_stylesheet =
    new Gdome.document_of_node (last_stylesheet#cloneNode ~deep:true)
  in
  let output_element =
    let node_list = last_stylesheet#getElementsByTagNameNS xslNS outputS in
    (match node_list#item 0 with
    | None -> (* no xsl:output element, create it from scratch *)
        logger#log `Debug "Creating xsl:output node ...";
        let elt = last_stylesheet#createElementNS (Some xslNS) q_outputS in
        let root = last_stylesheet#get_documentElement in
        ignore (root#appendChild (elt :> Gdome.node));
        elt
    | Some node -> new Gdome.element_of_node node)
  in
  List.iter
    (apply_property logger (output_element :> Gdome.element))
    (default_properties @ props);
  last_stylesheet

class styles =
  object (self)
    (* INVARIANT: 'stylesheets' and 'uris' are in sync *)

     (** association list: key * props -> I_gdome_xslt.processed_stylesheet
         It is the cache of the processed stylesheets *)
    val mutable p_stylesheets = []
    val mutable stylesheets = []  (** association list: key -> Gdome.document *)
    val mutable uris = []         (** association list: key -> uri *)

    val domImpl = Gdome.domImplementation ()

      (** process an XSLT stylesheet *)
    method private process uri =
      let dom = domImpl#createDocumentFromURI ~uri () in
      dom, Gdome_xslt.processStylesheet dom  (* produce libXSLT messages in
                                                case of errors *)

    (* stylesheets management *)

    method add key uri =
      if (List.mem_assoc key uris) then
        raise (Stylesheet_already_in key)
      else begin
        uris <- (key, uri) :: uris;
        let stylesheet, p_stylesheet = self#process uri in
         stylesheets <- (key, stylesheet) :: stylesheets ;
         p_stylesheets <- ((key,[]), p_stylesheet) :: p_stylesheets ;
      end

    method remove key =
      if not (List.mem_assoc key uris) then
        raise (Stylesheet_not_found key)
      else begin
        uris <- List.remove_assoc key uris;
        stylesheets <- List.remove_assoc key stylesheets ;
        p_stylesheets <-
         List.filter (function ((key',_),_) -> key = key') p_stylesheets
      end

    method removeAll =
      uris <- [];
      stylesheets <- [];
      p_stylesheets <- []

    method reload key =
      (try
        let uri = List.assoc key uris in
        let stylesheet,p_stylesheet = self#process uri in
        stylesheets <-
          (key, stylesheet) :: (List.remove_assoc key stylesheets) ;
        (* we remove the processed stylesheet from the cache *)
        p_stylesheets <-
          List.filter (function ((key',_),_) -> key = key') p_stylesheets ;
        p_stylesheets <- ((key,[]),p_stylesheet)::p_stylesheets
      with Not_found ->
        raise (Stylesheet_not_found key))

    method reloadAll =
      let (stylesheets',p_stylesheets') =
       let processed =
        List.map (fun (key, uri) -> (key, self#process uri)) uris
       in
        List.map (function (key,(stylesheet,_)) -> key,stylesheet) processed,
        List.map
         (function (key,(_,p_stylesheet)) -> (key,[]),p_stylesheet) processed
      in
       stylesheets <- stylesheets' ;
       p_stylesheets <- p_stylesheets'

    (* stylesheets usage *)

    method keys = List.map fst uris

    method list =
      List.map
        (fun (key, uri) ->
          sprintf "key = %s, uri = %s" key (List.assoc key uris))
        uris

    method get keys props (logger : Uwobo_logger.sysLogger) =
      match List.rev keys with
         [] -> assert false
       | last_key::rev_keys ->
          let last_stylesheet =
           try
            List.assoc last_key stylesheets
           with Not_found -> raise (Stylesheet_not_found last_key)
          in
          let p_last_stylesheet =
           try
            List.assoc (last_key,props) p_stylesheets
           with
            Not_found ->
             (* Cache miss *)
             let last_stylesheet' =
               try
                 apply_properties logger last_stylesheet props
               with Unsupported_property prop ->
                 raise (Uwobo_failure (sprintf "Unsupported property: %s" prop))
             in
             let p_last_stylesheet =
              Gdome_xslt.processStylesheet last_stylesheet
             in
              p_stylesheets <-
               ((last_key,props),p_last_stylesheet)::p_stylesheets ;
              p_last_stylesheet
          in
           let p_stylesheets =
            List.fold_left
              (fun collected_styles key ->
                let p_stylesheet =
                 try
                  List.assoc (key,[]) p_stylesheets
                 with
                  Not_found ->
                   (* Cache miss *)
                   let stylesheet =
                     try
                       List.assoc key stylesheets
                     with Not_found -> raise (Stylesheet_not_found key)
                   in
                   let p_stylesheet = 
                    Gdome_xslt.processStylesheet stylesheet
                   in
                    p_stylesheets <- ((key,[]),p_stylesheet)::p_stylesheets ;
                    p_stylesheet
                in
                 (key,p_stylesheet)::collected_styles)
              [last_key,p_last_stylesheet]
              rev_keys
           in
            p_stylesheets, last_stylesheet
  end