File: xforest.ml

package info (click to toggle)
marionnet 0.90.6+bzr508-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 9,532 kB
  • sloc: ml: 18,130; sh: 5,384; xml: 1,152; makefile: 1,003; ansic: 275
file content (128 lines) | stat: -rw-r--r-- 4,419 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
(* This file is part of Marionnet, a virtual network laboratory
   Copyright (C) 2007  Jean-Vincent Loddo
   Copyright (C) 2008  Luca Saiu
   Copyright (C) 2007, 2008  Université Paris 13

   This program 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.

   This program 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 this program.  If not, see <http://www.gnu.org/licenses/>. *)


(** A forest concretization very close to XML. The type of nodes is
    [string * (string * string list)] where the first element is the
    tag and the second is the list of attributes, i.e. bindings in the
    form (key,value) where both key and value are strings. *)

type tag = string ;;

type attribute  = (string * string) ;;
type attributes = attribute list ;;

type node   = tag * attributes ;;

(** The forest concretization and its aliases. *)

type forest = node Forest.t ;;
type t      = forest ;;
type tree   = node * forest ;; (* the root and its children *)


(* *************************** *
        Class interpreter
 * *************************** *)

(** An Xforest interpreter is an object able to update itself
    reading an Xforest and, conversely, able to encode itself
    into an Xforest *)
class virtual interpreter () = object (self)

 (** Interpret a tree. The tag is ignored here. *)
 method from_tree ((tag,attrs):node) (children:forest) =
  begin
   (* Interpret attributes *)
   Log.printf1 "About to interpret *attributes* with tag \"%s\"\n" tag;
   List.iter self#eval_forest_attribute attrs;

   (* Interpret children *)
   Log.printf1 "About to interpret *children* with tag \"%s\"\n" tag;
   let l = Forest.to_treelist children in
   List.iter (self#eval_forest_child) l
  end

 (** The default interpretation of an attribute is ignore. *)
 method eval_forest_attribute : (attribute -> unit) =
   fun attr -> ()

 (** The default interpretation of a child is ignore. *)
 method eval_forest_child : (tree -> unit) =
  fun tree -> ()

 (** Encode self into an xtree. Typically this method calls
     recursively the same method of its children in order to construct
      its representation as forest. *)
 method virtual to_tree : tree

 (** May be redefined. Otherwise, by default, is simply a call to the method constructing
     the tree which is transformed in a forest (singleton). *)
 method to_forest : forest =
   Forest.of_tree self#to_tree

end;; (* class interpreter *)


(** print_forest specialization for xforest *)
let rec print_xforest ?level ~channel forest =
 let string_of_attr (name,value) = (name^"="^"\""^value^"\"") in
 let fold_strings = function
  | []   -> ""
  | [x]  -> x
  | x::r -> List.fold_left (fun a b -> a ^ " " ^ b) x r  in
 let string_of_attrs attrs = fold_strings (List.map string_of_attr attrs) in
 let string_of_node (tag,attrs) = ("<" ^ tag ^ "[" ^ (string_of_attrs attrs) ^ "]>") in
 Forest.print_forest ?level ~string_of_node ~channel forest
;;

(** Facilities for encoding/decoding fields in an object which are not strings. *)

let encode x = Marshal.to_string   x [Marshal.No_sharing] ;;
let decode y = Marshal.from_string y 0 ;;

(** EXAMPLE 1 *)

(* In a class, just add method like:

method to_tree =
 Forest.leaf ("cable",[("name","xxx");("label","xxx")]);;

method eval_forest_attribute : (string * string) -> unit = function
 | ("name",name) -> self#set_name name
 | ("kind",kind) -> self#set_kind kind
 | _ -> () *)

(** EXAMPLE 2 *)

(*method to_tree =
 let name = Forest.tree ("name",[]) (Forest.leaf ("xxx",[]))
 let kind = Forest.tree ("kind",[]) (Forest.leaf ("yyy",[]))
 in Forest.node ("cable",[]) (Forest.of_treelist [name; kind])

(** EXAMPLE 2 *)
method eval_forest_child (root,children) = match root with
 | ("name", attrs) ->
     let name = new name () in (* nel new senza argomenti l'essenza della backward-compatibility *)
     name#from_tree x;       (* chiamata ricorsiva al from_forest *)
     self#set_name = name;     (* oppure potrei accumulare... *)
 ...
 | _ -> ()
 *)