]> matita.cs.unibo.it Git - helm.git/blob - helm/uwobo/uwobo_styles.ml
tex notation for compatibility with texTermEditor
[helm.git] / helm / uwobo / uwobo_styles.ml
1 (*
2  * Copyright (C) 2003:
3  *    Stefano Zacchiroli <zack@cs.unibo.it>
4  *    for the HELM Team http://helm.cs.unibo.it/
5  *
6  *  This file is part of HELM, an Hypertextual, Electronic
7  *  Library of Mathematics, developed at the Computer Science
8  *  Department, University of Bologna, Italy.
9  *
10  *  HELM is free software; you can redistribute it and/or
11  *  modify it under the terms of the GNU General Public License
12  *  as published by the Free Software Foundation; either version 2
13  *  of the License, or (at your option) any later version.
14  *
15  *  HELM is distributed in the hope that it will be useful,
16  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
17  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18  *  GNU General Public License for more details.
19  *
20  *  You should have received a copy of the GNU General Public License
21  *  along with HELM; if not, write to the Free Software
22  *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
23  *  MA  02111-1307, USA.
24  *
25  *  For details, see the HELM World-Wide-Web page,
26  *  http://helm.cs.unibo.it/
27  *)
28
29 open Printf;;
30 open Uwobo_common;;
31
32 exception Stylesheet_not_found of string ;;
33 exception Stylesheet_already_in of string ;;
34 exception Unsupported_property of string;;
35
36 let xslNS = Gdome.domString "http://www.w3.org/1999/XSL/Transform"
37 let outputS = Gdome.domString "output"
38 let q_outputS = Gdome.domString "xsl:output"
39
40 let default_properties = [] (* no default properties *)
41
42   (** apply an output property to an xslt stylesheet *)
43 let apply_property logger (element: Gdome.element) (name, value) =
44   if Uwobo_common.is_supported_property name then begin
45     logger#log `Debug (sprintf "Setting property: %s = %s" name value);
46     element#setAttribute (Gdome.domString name) (Gdome.domString value)
47   end else
48     raise (Unsupported_property name)
49
50   (** set a list of output properties in an xslt stylesheet, return a copy of
51   the given stylesheet modified as needed, given stylesheet wont be changed by
52   this operation.
53   Before applying "props" properties applies a set of default properties as
54   defined in "default_properties" *)
55 let apply_properties logger last_stylesheet props =
56   let last_stylesheet =
57     new Gdome.document_of_node (last_stylesheet#cloneNode ~deep:true)
58   in
59   let output_element =
60     let node_list = last_stylesheet#getElementsByTagNameNS xslNS outputS in
61     (match node_list#item 0 with
62     | None -> (* no xsl:output element, create it from scratch *)
63         logger#log `Debug "Creating xsl:output node ...";
64         let elt = last_stylesheet#createElementNS (Some xslNS) q_outputS in
65         let root = last_stylesheet#get_documentElement in
66         ignore (root#appendChild (elt :> Gdome.node));
67         elt
68     | Some node -> new Gdome.element_of_node node)
69   in
70   List.iter
71     (apply_property logger (output_element :> Gdome.element))
72     (default_properties @ props);
73   last_stylesheet
74
75 class styles =
76   object (self)
77     (* INVARIANT: 'stylesheets' and 'uris' are in sync *)
78
79      (** association list: key * props -> I_gdome_xslt.processed_stylesheet
80          It is the cache of the processed stylesheets *)
81     val mutable p_stylesheets = []
82     val mutable stylesheets = []  (** association list: key -> Gdome.document *)
83     val mutable uris = []         (** association list: key -> uri *)
84
85     val domImpl = Gdome.domImplementation ()
86
87       (** process an XSLT stylesheet *)
88     method private process uri =
89       let dom = domImpl#createDocumentFromURI ~uri () in
90       dom, Gdome_xslt.processStylesheet dom  (* produce libXSLT messages in
91                                                 case of errors *)
92
93     (* stylesheets management *)
94
95     method add key uri =
96       if (List.mem_assoc key uris) then
97         raise (Stylesheet_already_in key)
98       else begin
99         uris <- (key, uri) :: uris;
100         let stylesheet, p_stylesheet = self#process uri in
101          stylesheets <- (key, stylesheet) :: stylesheets ;
102          p_stylesheets <- ((key,[]), p_stylesheet) :: p_stylesheets ;
103       end
104
105     method remove key =
106       if not (List.mem_assoc key uris) then
107         raise (Stylesheet_not_found key)
108       else begin
109         uris <- List.remove_assoc key uris;
110         stylesheets <- List.remove_assoc key stylesheets ;
111         p_stylesheets <-
112          List.filter (function ((key',_),_) -> key = key') p_stylesheets
113       end
114
115     method removeAll =
116       uris <- [];
117       stylesheets <- [];
118       p_stylesheets <- []
119
120     method reload key =
121       (try
122         let uri = List.assoc key uris in
123         let stylesheet,p_stylesheet = self#process uri in
124         stylesheets <-
125           (key, stylesheet) :: (List.remove_assoc key stylesheets) ;
126         (* we remove the processed stylesheet from the cache *)
127         p_stylesheets <-
128           List.filter (function ((key',_),_) -> key = key') p_stylesheets ;
129         p_stylesheets <- ((key,[]),p_stylesheet)::p_stylesheets
130       with Not_found ->
131         raise (Stylesheet_not_found key))
132
133     method reloadAll =
134       let (stylesheets',p_stylesheets') =
135        let processed =
136         List.map (fun (key, uri) -> (key, self#process uri)) uris
137        in
138         List.map (function (key,(stylesheet,_)) -> key,stylesheet) processed,
139         List.map
140          (function (key,(_,p_stylesheet)) -> (key,[]),p_stylesheet) processed
141       in
142        stylesheets <- stylesheets' ;
143        p_stylesheets <- p_stylesheets'
144
145     (* stylesheets usage *)
146
147     method keys = List.map fst uris
148
149     method list =
150       List.map
151         (fun (key, uri) ->
152           sprintf "key = %s, uri = %s" key (List.assoc key uris))
153         uris
154
155     method get keys props (logger : Uwobo_logger.sysLogger) =
156       match List.rev keys with
157          [] -> assert false
158        | last_key::rev_keys ->
159           let last_stylesheet =
160            try
161             List.assoc last_key stylesheets
162            with Not_found -> raise (Stylesheet_not_found last_key)
163           in
164           let p_last_stylesheet =
165            try
166             List.assoc (last_key,props) p_stylesheets
167            with
168             Not_found ->
169              (* Cache miss *)
170              let last_stylesheet' =
171                try
172                  apply_properties logger last_stylesheet props
173                with Unsupported_property prop ->
174                  raise (Uwobo_failure (sprintf "Unsupported property: %s" prop))
175              in
176              let p_last_stylesheet =
177               Gdome_xslt.processStylesheet last_stylesheet
178              in
179               p_stylesheets <-
180                ((last_key,props),p_last_stylesheet)::p_stylesheets ;
181               p_last_stylesheet
182           in
183            let p_stylesheets =
184             List.fold_left
185               (fun collected_styles key ->
186                 let p_stylesheet =
187                  try
188                   List.assoc (key,[]) p_stylesheets
189                  with
190                   Not_found ->
191                    (* Cache miss *)
192 prerr_endline ("##### CACHE MISS: " ^ key) ;
193                    let stylesheet =
194                      try
195                        List.assoc key stylesheets
196                      with Not_found -> raise (Stylesheet_not_found key)
197                    in
198                    let p_stylesheet = 
199                     Gdome_xslt.processStylesheet stylesheet
200                    in
201                     p_stylesheets <- ((key,[]),p_stylesheet)::p_stylesheets ;
202                     p_stylesheet
203                 in
204                  (key,p_stylesheet)::collected_styles)
205               [last_key,p_last_stylesheet]
206               rev_keys
207            in
208             p_stylesheets, last_stylesheet
209   end