src/tree.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                               TAToo                                 *)
   4 (*                                                                     *)
   5 (*                     Kim Nguyen, LRI UMR8623                         *)
   6 (*                   Université Paris-Sud & CNRS                       *)
   7 (*                                                                     *)
   8 (*  Copyright 2010-2012 Université Paris-Sud and Centre National de la *)
   9 (*  Recherche Scientifique. All rights reserved.  This file is         *)
  10 (*  distributed under the terms of the GNU Lesser General Public       *)
  11 (*  License, with the special exception on linking described in file   *)
  12 (*  ../LICENSE.                                                        *)
  13 (*                                                                     *)
  14 (***********************************************************************)
  15 open Misc
  16
  17 (** The different kind of XML nodes and utility functions *)
  18
  19 module NodeKind =
  20   struct
  21     type t =
  22       Document | Element | Text | Comment | Attribute
  23     | ProcessingInstruction | Node
  24
  25     let to_string =
  26       function
  27     Document -> "document"
  28     | Element -> "element"
  29     | Attribute -> "attribute"
  30     | Text -> "text"
  31     | Comment -> "comment"
  32     | ProcessingInstruction -> "processing-instruction"
  33     | Node -> "node"
  34
  35     let print ppf k = Format.fprintf ppf "%s" (to_string k)
  36
  37
  38     let is_a k1 k2 =
  39       k1 == Node || k2 == Node || k1 == k2
  40 end
  41
  42
  43 module NodeSummary =
  44 struct
  45   (* Pack into an integer the result of the is_* and has_ predicates
  46      for a given node *)
  47   type t = int
  48   let dummy = -1
  49   (*
  50     ...44443210
  51     ...4444 -> kind
  52     3 -> has_right
  53     2 -> has_left
  54     1 -> is_right
  55     0 -> is_left
  56   *)
  57   let is_left (s : t) : bool =
  58     s land 1 != 0
  59
  60   let is_right (s : t) : bool =
  61     s land 0b10 != 0
  62
  63   let has_left (s : t) : bool =
  64     s land 0b100 != 0
  65
  66   let has_right (s : t) : bool =
  67     s land 0b1000 != 0
  68
  69   let kind (s : t) : NodeKind.t =
  70     Obj.magic (s lsr 4)
  71
  72   let make is_left is_right has_left has_right kind =
  73     (int_of_bool is_left) lor
  74       ((int_of_bool is_right) lsl 1) lor
  75       ((int_of_bool has_left) lsl 2) lor
  76       ((int_of_bool has_right) lsl 3) lor
  77       ((Obj.magic kind) lsl 4)
  78 end
  79
  80
  81 (** Signatures for trees *)
  82
  83 exception Parse_error of string
  84
  85 module type S =
  86 sig
  87   type node
  88   (** The type of a tree node *)
  89
  90   type t
  91   (** The type of trees *)
  92
  93   val size : t -> int
  94   (** Return the number of nodes *)
  95
  96   val nil : node
  97   (** Nil node, denoting the first/second child of a leaf or the parent of
  98       the root *)
  99
 100   val dummy : node
 101   (** Dummy node that is guaranteed to never occur in any tree *)
 102
 103   val load_xml_file : in_channel -> t
 104   (** Takes a file descriptor and returns the XML data stored in the
 105       corresponding file. Start at the current position in the file
 106       descriptor (which is not necessarily the begining of file)
 107   *)
 108
 109   val load_xml_string : string -> t
 110   (** Loads XML data stored in a string *)
 111
 112   val print_xml : out_channel -> t -> node -> unit
 113   (** Outputs the tree as an XML document on the given output_channel *)
 114
 115   val root : t -> node
 116   (** Returns the root of the tree *)
 117
 118   val first_child : t -> node -> node
 119   (** [first_child t n] returns the first child of node [n] in tree [t].
 120       Returns [nil] if [n] is a leaf. Returns [nil] if [n == nil].
 121   *)
 122
 123   val next_sibling : t -> node -> node
 124   (** [next_sibling t n] returns the next_sibling of node [n] in tree [t].
 125       Returns [nil] if [n] is the last child of a node.
 126       Returns [nil] if [n == nil].
 127   *)
 128
 129   val parent : t -> node -> node
 130   (** [next_sibling t n] returns the parent of node [n] in tree [t].
 131       Returns [nil] if [n] is the root of the tree.
 132       Returns [nil] if [n == nil].
 133   *)
 134
 135   val tag : t -> node -> QName.t
 136   (** Returns the label of a given node *)
 137
 138   val data : t -> node -> string
 139   (** Returns the character data associated with a node.
 140       The only node having character data are those whose label is
 141       QName.text, QName.cdata_section or QName.comment
 142   *)
 143
 144   val kind : t -> node -> NodeKind.t
 145   (** Returns the kind of the given node *)
 146
 147   val summary : t -> node -> NodeSummary.t
 148   (** Returns the summary of the given node *)
 149
 150   val preorder : t -> node -> int
 151   (** [preorder t n] returns the pre-order position of [n] in [t].
 152       [preodrder t (root t) == 0] and [preorder t nil < 0].
 153   *)
 154
 155   val by_preorder : t -> int -> node
 156   (** [by_preorder t i] returns the node with preorder [i]
 157   *)
 158   val print_node : Format.formatter -> node -> unit
 159
 160   val dispatch ('a -> 'b -> QName.t -> NodeSummary.t -> node -> node
 161 end