+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * 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://cs.unibo.it/helm/.
- *)
-
-let mathmlns = "http://www.w3.org/1998/Math/MathML";;
-let xmldiffns = "http://helm.cs.unibo.it/XmlDiff";;
-let helmns = "http://www.cs.unibo.it/helm";;
-
-let ds_selection = Gdome.domString "selection";;
-let ds_2 = Gdome.domString "2";;
-let ds_mathmlns = Gdome.domString mathmlns;;
-let ds_m_style = Gdome.domString "m:mstyle";;
-let ds_mathbackground = Gdome.domString "mathbackground";;
-let ds_xmldiffns = Gdome.domString xmldiffns;;
-let ds_xmldiff_type = Gdome.domString "xmldiff:type";;
-let ds_fake = Gdome.domString "fake";;
-let ds_helmns = Gdome.domString helmns;;
-let ds_xref = Gdome.domString "xref";;
-let ds_type = Gdome.domString "type";;
-let ds_yellow = Gdome.domString "yellow";;
-let ds_green = Gdome.domString "#00ff00";;
-let ds_maction = Gdome.domString "maction";;
-let ds_mtr = Gdome.domString "mtr";;
-let ds_mtd = Gdome.domString "mtd";;
-
-type highlighted_nodes = Gdome.node list;;
-
-let rec make_visible (n: Gdome.node) =
- match n#get_parentNode with
- None -> ()
- | Some p ->
- match p#get_namespaceURI, p#get_localName with
- Some nu, Some ln when
- nu#equals ds_mathmlns && ln#equals ds_maction ->
- (new Gdome.element_of_node p)#setAttribute
- ~name:ds_selection
- ~value:ds_2 ;
- make_visible p
- | _,_ -> make_visible p
-;;
-
-let highlight_node_total_time = ref 0.0;;
-
-let highlight_node ?(color=ds_yellow) (doc: Gdome.document) (n: Gdome.node) =
- let highlight (n: Gdome.node) =
- let highlighter =
- doc#createElementNS
- ~namespaceURI:(Some ds_mathmlns)
- ~qualifiedName:ds_m_style
- in
- highlighter#setAttribute ~name:ds_mathbackground ~value:color ;
- highlighter#setAttributeNS
- ~namespaceURI:(Some ds_xmldiffns)
- ~qualifiedName:ds_xmldiff_type
- ~value:ds_fake ;
- let parent =
- match n#get_parentNode with
- None -> assert false
- | Some p -> p
- in
- ignore
- (parent#replaceChild ~oldChild:n ~newChild:(highlighter :> Gdome.node)) ;
- ignore (highlighter#appendChild n) ;
- (highlighter :> Gdome.node)
- in
- let rec find_mstylable_node n =
- match n#get_namespaceURI, n#get_localName with
- Some nu, Some ln when
- nu#equals ds_mathmlns &&
- (not (ln#equals ds_mtr)) && (not (ln#equals ds_mtd)) -> n
- | Some nu, Some ln when
- nu#equals ds_mathmlns &&
- ln#equals ds_mtr || ln#equals ds_mtd ->
- let true_child =
- match n#get_firstChild with
- None -> assert false
- | Some n -> n
- in
- find_mstylable_node true_child
- | _,_ ->
- match n#get_parentNode with
- None -> assert false
- | Some p -> find_mstylable_node p
- in
- let highlighter = highlight (find_mstylable_node n) in
- make_visible highlighter ;
- highlighter
-;;
-
-let iter_children ~f (n:Gdome.node) =
- let rec aux =
- function
- None -> ()
- | Some n ->
- let sibling = n#get_nextSibling in
- (f n) ;
- aux sibling
- in
- aux n#get_firstChild
-;;
-
-let highlight_nodes ~xrefs (doc:Gdome.document) =
- let highlighted = ref [] in
- let rec aux (n:Gdome.element) =
- let attributeNS =
- (n#getAttributeNS ~namespaceURI:ds_helmns
- ~localName:ds_xref)#to_string in
- if List.mem attributeNS xrefs then
- highlighted :=
- (highlight_node ~color:ds_green doc (n :> Gdome.node))::
- !highlighted ;
- iter_children (n :> Gdome.node)
- ~f:(function n ->
- if n#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE then
- aux (new Gdome.element_of_node n))
- in
- aux doc#get_documentElement ;
- !highlighted
-;;
-
-let dim_nodes =
- List.iter
- (function (n : Gdome.node) ->
- assert
- (n#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE &&
- ((new Gdome.element_of_node n)#getAttributeNS
- ~namespaceURI:ds_xmldiffns
- ~localName:ds_type)#equals ds_fake) ;
- let true_child =
- match n#get_firstChild with
- None -> assert false
- | Some n -> n in
- let p =
- match n#get_parentNode with
- None -> assert false
- | Some n -> n
- in
- ignore (p#replaceChild ~oldChild:n ~newChild:true_child)
- )
-;;
-
-let update_dom ~(from : Gdome.document) (d : Gdome.document) =
- let rec aux (p: Gdome.node) (f: Gdome.node) (t: Gdome.node) =
- let replace t1 =
- if
- t1 = GdomeNodeTypeT.ELEMENT_NODE &&
- ((new Gdome.element_of_node f)#getAttributeNS
- ~namespaceURI:ds_xmldiffns
- ~localName:ds_type)#equals ds_fake
- then
- let true_child =
- match f#get_firstChild with
- None -> assert false
- | Some n -> n
- in
- begin
- ignore (p#replaceChild ~oldChild:f ~newChild:true_child) ;
- aux p true_child t
- end
- else
- let t' = from#importNode t true in
- ignore (p#replaceChild ~newChild:t' ~oldChild:f) ;
- ignore (highlight_node from t')
- in
- match
- f#get_nodeType,t#get_nodeType
- with
- GdomeNodeTypeT.TEXT_NODE,GdomeNodeTypeT.TEXT_NODE ->
- (match f#get_nodeValue, t#get_nodeValue with
- Some v, Some v' when v#equals v' -> ()
- | Some _, (Some _ as v') -> f#set_nodeValue v'
- | _,_ -> assert false)
- | GdomeNodeTypeT.ELEMENT_NODE as t1,GdomeNodeTypeT.ELEMENT_NODE ->
- (match
- f#get_namespaceURI,t#get_namespaceURI,f#get_localName,t#get_localName
- with
- Some nu, Some nu', Some ln, Some ln' when
- ln#equals ln' && nu#equals nu' ->
- begin
- match f#get_attributes, t#get_attributes with
- Some fattrs, Some tattrs ->
- let flen = fattrs#get_length in
- let tlen = tattrs#get_length in
- let processed = ref [] in
- for i = 0 to flen -1 do
- match fattrs#item i with
- None -> () (* CSC: sigh, togliere un nodo rompe fa decrescere la lunghezza ==> passare a un while *)
- | Some attr ->
- match attr#get_namespaceURI with
- None ->
- (* Back to DOM Level 1 ;-( *)
- begin
- let name = attr#get_nodeName in
- match tattrs#getNamedItem ~name with
- None ->
- ignore (fattrs#removeNamedItem ~name)
- | Some attr' ->
- processed :=
- (None,Some name)::!processed ;
- match attr#get_nodeValue, attr'#get_nodeValue with
- Some v1, Some v2 when
- v1#equals v2
- || (name#equals ds_selection &&
- nu#equals ds_mathmlns &&
- ln#equals ds_maction)
- ->
- ()
- | Some v1, Some v2 ->
- let attr'' = from#importNode attr' true in
- ignore (fattrs#setNamedItem attr'')
- | _,_ -> assert false
- end
- | Some namespaceURI ->
- let localName =
- match attr#get_localName with
- Some v -> v
- | None -> assert false
- in
- match
- tattrs#getNamedItemNS ~namespaceURI ~localName
- with
- None ->
- ignore
- (fattrs#removeNamedItemNS
- ~namespaceURI ~localName)
- | Some attr' ->
- processed :=
- (Some namespaceURI,Some localName)::!processed ;
- match attr#get_nodeValue, attr'#get_nodeValue with
- Some v1, Some v2 when
- v1#equals v2 ->
- ()
- | Some _, Some _ ->
- let attr'' = from#importNode attr' true in
- ignore (fattrs#setNamedItem attr'')
- | _,_ -> assert false
- done ;
- for i = 0 to tlen -1 do
- match tattrs#item i with
- None -> assert false
- | Some attr ->
- let namespaceURI,localName =
- match attr#get_namespaceURI with
- None ->
- None,attr#get_nodeName
- | Some namespaceURI as v ->
- v, match attr#get_localName with
- None -> assert false
- | Some v -> v
- in
- if
- not
- (List.exists
- (function
- None,Some localName' ->
- (match namespaceURI with
- None ->
- localName#equals localName'
- | Some _ -> false)
- | Some namespaceURI', Some localName' ->
- (match namespaceURI with
- None -> false
- | Some namespaceURI ->
- localName#equals localName' &&
- namespaceURI#equals namespaceURI'
- )
- | _,_ -> assert false
- ) !processed)
- then
- let attr' = from#importNode attr false in
- ignore (fattrs#setNamedItem attr')
- done
- | _,_ -> assert false
- end ;
- let rec dumb_diff =
- function
- [],[] -> ()
- | he1::tl1,he2::tl2 ->
- aux f he1 he2 ;
- dumb_diff (tl1,tl2)
- | [],tl2 ->
- List.iter
- (function n ->
- let n' = from#importNode n true in
- ignore (f#appendChild n') ;
- ignore (highlight_node from n')
- ) tl2
- | tl1,[] ->
- List.iter (function n -> ignore (f#removeChild n)) tl1
- in
- let node_list_of_nodeList n =
- let rec aux =
- function
- None -> []
- | Some n when
- n#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE
- or n#get_nodeType = GdomeNodeTypeT.TEXT_NODE ->
- n::(aux n#get_nextSibling)
- | Some n ->
- aux n#get_nextSibling
- in
- aux n#get_firstChild
- in
- dumb_diff
- (node_list_of_nodeList f, node_list_of_nodeList t)
- | _,_,_,_ -> replace t1
- )
- | t1,t2 when
- (t1 = GdomeNodeTypeT.ELEMENT_NODE || t1 = GdomeNodeTypeT.TEXT_NODE) &&
- (t2 = GdomeNodeTypeT.ELEMENT_NODE || t2 = GdomeNodeTypeT.TEXT_NODE) ->
- replace t1
- | _,_ -> assert false
- in
- try
- aux (d :> Gdome.node)
- (from#get_documentElement :> Gdome.node)
- (d#get_documentElement :> Gdome.node)
- with
- (GdomeInit.DOMException (e,msg) as ex) -> raise ex
- | e -> raise e
-;;
projects / helm.git / blobdiff