Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
cduce
cduce
Commits
db932d00
Commit
db932d00
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2005-03-15 23:31:43 by afrisch] Namespaces bindings in data model
Original author: afrisch Date: 2005-03-15 23:31:45+00:00
parent
89ab8897
Changes
20
Hide whitespace changes
Inline
Side-by-side
compile/compile.ml
View file @
db932d00
...
...
@@ -68,9 +68,11 @@ and compile_aux env tail = function
|
Typed
.
Abstraction
a
->
compile_abstr
env
a
|
Typed
.
Cst
c
->
Const
c
|
Typed
.
Pair
(
e1
,
e2
)
->
Pair
(
compile
env
false
e1
,
compile
env
tail
e2
)
|
Typed
.
Xml
(
e1
,
{
Typed
.
exp_descr
=
Typed
.
Pair
(
e2
,
e3
)
})
->
|
Typed
.
Xml
(
e1
,
{
Typed
.
exp_descr
=
Typed
.
Pair
(
e2
,
e3
)
}
,
None
)
->
Xml
(
compile
env
false
e1
,
compile
env
false
e2
,
compile
env
tail
e3
)
|
Typed
.
Xml
(
_
,_
)
->
assert
false
|
Typed
.
Xml
(
e1
,
{
Typed
.
exp_descr
=
Typed
.
Pair
(
e2
,
e3
)
}
,
Some
t
)
->
XmlNs
(
compile
env
false
e1
,
compile
env
false
e2
,
compile
env
tail
e3
,
t
)
|
Typed
.
Xml
_
->
assert
false
|
Typed
.
RecordLitt
r
->
Record
(
LabelMap
.
map
(
compile
env
false
)
r
)
|
Typed
.
String
(
i
,
j
,
s
,
q
)
->
String
(
i
,
j
,
s
,
compile
env
tail
q
)
|
Typed
.
Match
(
e
,
brs
)
->
Match
(
compile
env
false
e
,
compile_branches
env
tail
brs
)
...
...
@@ -245,6 +247,10 @@ let namespace (tenv,cenv,codes) pr ns =
let
tenv
=
Typer
.
type_ns
tenv
pr
ns
in
(
tenv
,
cenv
,
codes
)
let
keep_ns
(
tenv
,
cenv
,
codes
)
k
=
let
tenv
=
Typer
.
type_keep_ns
tenv
k
in
(
tenv
,
cenv
,
codes
)
let
schema
(
tenv
,
cenv
,
codes
)
x
sch
=
let
tenv
=
Typer
.
type_schema
tenv
x
sch
in
(
tenv
,
cenv
,
codes
)
...
...
@@ -278,6 +284,8 @@ let rec phrases ~run ~show ~loading ~directive =
loop
(
schema
accu
name
uri
)
rest
|
{
descr
=
Ast
.
Namespace
(
pr
,
ns
)
}
::
rest
->
loop
(
namespace
accu
pr
ns
)
rest
|
{
descr
=
Ast
.
KeepNs
b
}
::
rest
->
loop
(
keep_ns
accu
b
)
rest
|
{
descr
=
Ast
.
Using
(
x
,
cu
)
}
::
rest
->
let
cu
=
find_cu
accu
cu
in
loading
cu
;
...
...
compile/lambda.ml
View file @
db932d00
...
...
@@ -50,6 +50,7 @@ type expr =
|
Const
of
Types
.
Const
.
t
|
Pair
of
expr
*
expr
|
Xml
of
expr
*
expr
*
expr
|
XmlNs
of
expr
*
expr
*
expr
*
Ns
.
table
|
Record
of
expr
label_map
|
String
of
U
.
uindex
*
U
.
uindex
*
U
.
t
*
expr
...
...
@@ -164,7 +165,15 @@ module Put = struct
bits
nbits
s
5
;
expr
s
e1
;
expr
s
e2
;
expr
s
e3
expr
s
e3
;
bool
s
false
|
XmlNs
(
e1
,
e2
,
e3
,
ns
)
->
bits
nbits
s
5
;
expr
s
e1
;
expr
s
e2
;
expr
s
e3
;
bool
s
true
;
Ns
.
serialize_table
s
ns
|
Record
r
->
bits
nbits
s
6
;
LabelMap
.
serialize
expr
s
r
...
...
@@ -293,7 +302,11 @@ module Get = struct
let
e1
=
expr
s
in
let
e2
=
expr
s
in
let
e3
=
expr
s
in
Xml
(
e1
,
e2
,
e3
)
if
bool
s
then
let
ns
=
Ns
.
deserialize_table
s
in
XmlNs
(
e1
,
e2
,
e3
,
ns
)
else
Xml
(
e1
,
e2
,
e3
)
|
6
->
Record
(
LabelMap
.
deserialize
expr
s
)
|
7
->
let
st
=
U
.
deserialize
s
in
...
...
compile/lambda.mli
View file @
db932d00
...
...
@@ -22,6 +22,7 @@ type expr =
|
Const
of
Types
.
Const
.
t
|
Pair
of
expr
*
expr
|
Xml
of
expr
*
expr
*
expr
|
XmlNs
of
expr
*
expr
*
expr
*
Ns
.
table
|
Record
of
expr
label_map
|
String
of
U
.
uindex
*
U
.
uindex
*
U
.
t
*
expr
...
...
driver/librarian.ml
View file @
db932d00
...
...
@@ -43,7 +43,7 @@ let mk ((typing,compile,code),types,ext) =
stub
=
None
}
let
magic
=
"CDUCE:compunit:0000
4
"
let
magic
=
"CDUCE:compunit:0000
5
"
let
obj_path
=
ref
[
""
]
...
...
misc/ns.ml
View file @
db932d00
...
...
@@ -3,6 +3,10 @@
Disallow: namespace xml="..."
*)
(* TODO:
It is very important to hash-cons table when
serializing/deserializing code with many XmlNs literals ... *)
module
U
=
Encodings
.
Utf8
let
empty_str
=
U
.
mk
""
...
...
@@ -31,36 +35,76 @@ module Table = Map.Make(U)
type
table
=
t
Table
.
t
let
empty_table
=
List
.
fold_left
(
fun
table
(
pr
,
ns
)
->
Table
.
add
(
U
.
mk
pr
)
ns
table
)
Table
.
empty
[
""
,
empty
;
"xml"
,
xml_ns
]
module
TableData
=
Custom
.
List
(
Custom
.
Pair
(
U
)(
U
))
module
TableHash
=
Hashtbl
.
Make
(
TableData
)
let
get_table
table
:
TableData
.
t
=
Table
.
fold
(
fun
prefix
ns
r
->
let
std
=
try
equal
(
Table
.
find
prefix
empty_table
)
ns
with
Not_found
->
false
in
if
std
then
r
else
(
prefix
,
value
ns
)
::
r
)
table
[]
let
mk_table
=
List
.
fold_left
(
fun
table
(
pr
,
ns
)
->
Table
.
add
pr
(
mk
ns
)
table
)
empty_table
let
ser_prop
=
Serialize
.
Put
.
mk_property
(
fun
t
->
(
ref
0
,
TableHash
.
create
17
))
let
serialize_table
s
table
=
Table
.
iter
(
fun
prefix
ns
->
Serialize
.
Put
.
bool
s
true
;
U
.
serialize
s
prefix
;
P
.
serialize
s
ns
)
table
;
Serialize
.
Put
.
bool
s
false
let
(
nb
,
tbl
)
=
Serialize
.
Put
.
get_property
ser_prop
s
in
let
p
=
get_table
table
in
try
let
i
=
TableHash
.
find
tbl
p
in
Serialize
.
Put
.
int
s
i
with
Not_found
->
let
i
=
!
nb
in
incr
nb
;
TableHash
.
add
tbl
p
i
;
Serialize
.
Put
.
int
s
i
;
TableData
.
serialize
s
p
let
deser_prop
=
Serialize
.
Get
.
mk_property
(
fun
t
->
ref
[
||
])
let
deserialize_table
s
=
let
rec
aux
table
=
if
not
(
Serialize
.
Get
.
bool
s
)
then
table
else
let
prefix
=
U
.
deserialize
s
in
let
ns
=
P
.
deserialize
s
in
aux
(
Table
.
add
prefix
ns
table
)
let
tbl
=
Serialize
.
Get
.
get_property
deser_prop
s
in
let
i
=
Serialize
.
Get
.
int
s
in
(
if
(
i
>=
Array
.
length
!
tbl
)
then
let
ntbl
=
Array
.
create
(
2
*
i
+
10
)
None
in
Array
.
blit
!
tbl
0
ntbl
0
(
Array
.
length
!
tbl
);
tbl
:=
ntbl
);
let
p
=
match
!
tbl
.
(
i
)
with
|
None
->
let
p
=
TableData
.
deserialize
s
in
(
!
tbl
)
.
(
i
)
<-
Some
p
;
p
|
Some
p
->
p
in
aux
Table
.
empty
mk_table
p
(* TODO: avoid re-inserting the same hint for the same
namespace ==> otherwise memory leak with load_xml ... *)
let
global_hints
=
State
.
ref
"Ns.prefixes"
(
Hashtbl
.
create
63
)
let
empty_table
=
let
def_table
=
List
.
fold_left
(
fun
table
(
pr
,
ns
)
->
Table
.
add
(
U
.
mk
pr
)
ns
table
)
Table
.
empty
[
""
,
empty
;
"xml"
,
xml_ns
;
"xsd"
,
xsd_ns
;
"xsi"
,
xsi_ns
]
empty_table
[
"xsd"
,
xsd_ns
;
"xsi"
,
xsi_ns
]
let
add_prefix
pr
ns
table
=
if
(
U
.
get_str
pr
<>
""
)
then
Hashtbl
.
add
!
global_hints
ns
pr
;
Table
.
add
pr
ns
table
...
...
@@ -222,7 +266,7 @@ end
module
InternalPrinter
=
struct
let
p
=
State
.
ref
"Ns.InternalPrinter"
(
Printer
.
printer
empty
_table
)
let
p
=
State
.
ref
"Ns.InternalPrinter"
(
Printer
.
printer
def
_table
)
let
set_table
t
=
p
:=
Printer
.
printer
t
...
...
misc/ns.mli
View file @
db932d00
...
...
@@ -9,6 +9,7 @@ val mk: Utf8.t -> t
val
mk_ascii
:
string
->
t
val
value
:
t
->
Utf8
.
t
val
empty
:
t
val
value
:
t
->
Utf8
.
t
val
xml_ns
:
t
...
...
@@ -24,9 +25,12 @@ type table (* prefix => namespace *)
val
serialize_table
:
table
Serialize
.
Put
.
f
val
deserialize_table
:
table
Serialize
.
Get
.
f
val
empty_table
:
table
(* Contains only xml *)
val
def_table
:
table
(* Contains xml,xsd,xsi *)
val
add_prefix
:
Utf8
.
t
->
t
->
table
->
table
val
dump_table
:
Format
.
formatter
->
table
->
unit
val
get_table
:
table
->
(
Utf8
.
t
*
Utf8
.
t
)
list
val
process_start_tag
:
table
->
string
->
(
string
*
string
)
list
->
table
*
qname
*
(
qname
*
Utf8
.
t
)
list
...
...
parser/ast.ml
View file @
db932d00
...
...
@@ -12,6 +12,7 @@ and pmodule_item' =
|
LetDecl
of
ppat
*
pexpr
|
FunDecl
of
pexpr
|
Namespace
of
U
.
t
*
Ns
.
t
|
KeepNs
of
bool
|
Using
of
U
.
t
*
U
.
t
|
EvalStatement
of
pexpr
|
Directive
of
toplevel_directive
...
...
@@ -71,6 +72,7 @@ and pexpr =
(* Other *)
|
NamespaceIn
of
U
.
t
*
Ns
.
t
*
pexpr
|
KeepNsIn
of
bool
*
pexpr
|
Forget
of
pexpr
*
ppat
|
Check
of
pexpr
*
ppat
|
Ref
of
pexpr
*
ppat
...
...
parser/parser.ml
View file @
db932d00
...
...
@@ -146,11 +146,18 @@ EXTEND
|
"schema"
;
name
=
IDENT
;
"="
;
uri
=
STRING2
->
protect_op
"schema"
;
[
mk
loc
(
SchemaDecl
(
U
.
mk
name
,
uri
))
]
|
(
name
,
ns
)
=
namespace_binding
->
[
mk
loc
(
Namespace
(
name
,
ns
))
]
|
(
name
,
ns
)
=
namespace_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
let
e
=
exp
loc
(
NamespaceIn
(
name
,
ns
,
e2
))
in
[
mk
loc
(
EvalStatement
(
exp
loc
e
))
]
|
n
=
namespace_binding
->
let
d
=
match
n
with
|
`Prefix
(
name
,
ns
)
->
Namespace
(
name
,
ns
)
|
`Keep
b
->
KeepNs
b
in
[
mk
loc
d
]
|
n
=
namespace_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
let
e
=
match
n
with
|
`Prefix
(
name
,
ns
)
->
NamespaceIn
(
name
,
ns
,
e2
)
|
`Keep
b
->
KeepNsIn
(
b
,
e2
)
in
[
mk
loc
(
EvalStatement
(
exp
loc
e
))
]
|
"debug"
;
d
=
debug_directive
->
[
mk
loc
(
Directive
(
`Debug
d
))
]
|
"#"
;
IDENT
"verbose"
->
[
mk
loc
(
Directive
`Verbose
)
]
|
"#"
;
IDENT
"silent"
->
[
mk
loc
(
Directive
`Silent
)
]
...
...
@@ -247,8 +254,10 @@ EXTEND
exp
loc
(
Abstraction
{
fun_name
=
f
;
fun_iface
=
a
;
fun_body
=
b
})
|
(
_
,
p
,
e1
)
=
let_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
exp
loc
(
let_in
e1
p
e2
)
|
(
name
,
ns
)
=
namespace_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
exp
loc
(
NamespaceIn
(
name
,
ns
,
e2
))
|
n
=
namespace_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
(
match
n
with
|
`Prefix
(
name
,
ns
)
->
exp
loc
(
NamespaceIn
(
name
,
ns
,
e2
))
|
`Keep
f
->
exp
loc
(
KeepNsIn
(
f
,
e2
)))
|
e
=
expr
;
":"
;
p
=
pat
->
exp
loc
(
Forget
(
e
,
p
))
|
e
=
expr
;
":"
;
"?"
;
p
=
pat
->
...
...
@@ -386,14 +395,16 @@ EXTEND
];
namespace_binding
:
[
[
"namespace"
;
name
=
[
name
=
[
IDENT
|
keyword
];
"="
->
ident
name
|
->
U
.
mk
""
];
uri
=
STRING2
->
let
ns
=
Ns
.
mk
(
ident
uri
)
in
(
name
,
ns
)
]
[
"namespace"
;
r
=
[
[
name
=
[
name
=
[
IDENT
|
keyword
];
"="
->
ident
name
|
->
U
.
mk
""
];
uri
=
STRING2
->
let
ns
=
Ns
.
mk
(
ident
uri
)
in
`Prefix
(
name
,
ns
)
|
IDENT
"on"
->
`Keep
true
|
IDENT
"off"
->
`Keep
false
]
]
->
r
]
];
...
...
runtime/eval.ml
View file @
db932d00
...
...
@@ -135,6 +135,11 @@ let rec eval env = function
let
v2
=
eval
env
e2
in
let
v3
=
eval
env
e3
in
Value
.
Xml
(
v1
,
v2
,
v3
)
|
XmlNs
(
e1
,
e2
,
e3
,
ns
)
->
let
v1
=
eval
env
e1
in
let
v2
=
eval
env
e2
in
let
v3
=
eval
env
e3
in
Value
.
XmlNs
(
v1
,
v2
,
v3
,
ns
)
|
Record
r
->
Value
.
Record
(
LabelMap
.
map
(
eval
env
)
r
)
|
String
(
i
,
j
,
s
,
q
)
->
Value
.
substring_utf8
i
j
s
(
eval
env
q
)
|
Match
(
e
,
brs
)
->
eval_branches
env
brs
(
eval
env
e
)
...
...
@@ -313,6 +318,9 @@ and eval_xtrans_aux env brs acc = function
|
Value
.
Xml
(
tag
,
attr
,
child
)
->
let
child
=
eval_xtrans
env
brs
child
in
Value
.
Xml
(
tag
,
attr
,
child
)
|
Value
.
XmlNs
(
tag
,
attr
,
child
,
ns
)
->
let
child
=
eval_xtrans
env
brs
child
in
Value
.
XmlNs
(
tag
,
attr
,
child
,
ns
)
|
x
->
x
in
let
acc'
=
Value
.
Pair
(
x
,
Absent
)
in
set_cdr
acc
acc'
;
...
...
runtime/load_xml.ml
View file @
db932d00
...
...
@@ -4,6 +4,7 @@ open Value
open
Ident
open
Encodings
let
keep_ns
=
ref
true
type
buf
=
{
mutable
buffer
:
string
;
...
...
@@ -43,12 +44,15 @@ let attrib att =
let
att
=
List
.
map
(
fun
(
n
,
v
)
->
LabelPool
.
mk
n
,
string_utf8
v
)
att
in
LabelMap
.
from_list
(
fun
_
_
->
failwith
"Invalid XML document: uniqueness of attributes"
)
att
let
elem
(
tag_ns
,
tag
)
att
child
=
Xml
(
Atom
(
Atoms
.
V
.
mk
tag_ns
tag
)
,
Record
(
attrib
att
)
,
child
)
let
elem
ns
(
tag_ns
,
tag
)
att
child
=
if
!
keep_ns
then
XmlNs
(
Atom
(
Atoms
.
V
.
mk
tag_ns
tag
)
,
Record
(
attrib
att
)
,
child
,
ns
)
else
Xml
(
Atom
(
Atoms
.
V
.
mk
tag_ns
tag
)
,
Record
(
attrib
att
)
,
child
)
type
stack
=
|
Element
of
Value
.
t
*
stack
|
Start
of
Ns
.
qname
*
(
Ns
.
qname
*
Utf8
.
t
)
list
*
Ns
.
table
*
stack
|
Start
of
Ns
.
table
*
Ns
.
qname
*
(
Ns
.
qname
*
Utf8
.
t
)
list
*
Ns
.
table
*
stack
|
String
of
string
*
stack
|
Empty
...
...
@@ -58,9 +62,9 @@ let ns_table = ref Ns.empty_table
let
rec
create_elt
accu
=
function
|
String
(
s
,
st
)
->
create_elt
(
string
s
accu
)
st
|
Element
(
x
,
st
)
->
create_elt
(
Pair
(
x
,
accu
))
st
|
Start
(
name
,
att
,
table
,
st
)
->
stack
:=
Element
(
elem
name
att
accu
,
st
);
ns_table
:=
table
|
Start
(
ns
,
name
,
att
,
old_
table
,
st
)
->
stack
:=
Element
(
elem
ns
name
att
accu
,
st
);
ns_table
:=
old_
table
|
Empty
->
assert
false
let
start_element_handler
name
att
=
...
...
@@ -69,7 +73,7 @@ let start_element_handler name att =
txt
.
pos
<-
0
;
let
(
table
,
name
,
att
)
=
Ns
.
process_start_tag
!
ns_table
name
att
in
stack
:=
Start
(
name
,
att
,!
ns_table
,
!
stack
);
stack
:=
Start
(
table
,
name
,
att
,!
ns_table
,
!
stack
);
ns_table
:=
table
let
end_element_handler
_
=
...
...
@@ -86,8 +90,9 @@ let text_handler = add_string txt
let
xml_parser
=
ref
(
fun
s
->
failwith
"No XML parser available"
)
let
load_xml
s
=
let
load_xml
?
(
ns
=
false
)
s
=
try
keep_ns
:=
ns
;
!
xml_parser
s
;
match
!
stack
with
|
Element
(
x
,
Empty
)
->
stack
:=
Empty
;
x
...
...
@@ -102,7 +107,7 @@ let load_html s =
if
(
only_ws
data
(
String
.
length
data
))
then
q
else
string
data
q
|
Nethtml
.
Element
(
tag
,
att
,
child
)
->
let
att
=
List
.
map
(
fun
(
n
,
v
)
->
((
Ns
.
empty
,
U
.
mk
n
)
,
U
.
mk
v
))
att
in
Pair
(
elem
(
Ns
.
empty
,
U
.
mk
tag
)
att
(
val_of_docs
child
)
,
q
)
Pair
(
elem
Ns
.
empty_table
(
Ns
.
empty
,
U
.
mk
tag
)
att
(
val_of_docs
child
)
,
q
)
and
val_of_docs
=
function
|
[]
->
nil
|
h
::
t
->
val_of_doc
(
val_of_docs
t
)
h
...
...
runtime/load_xml.mli
View file @
db932d00
val
load_xml
:
string
->
Value
.
t
val
load_xml
:
?
ns
:
bool
->
string
->
Value
.
t
val
load_html
:
string
->
Value
.
t
...
...
runtime/print_xml.ml
View file @
db932d00
...
...
@@ -129,7 +129,8 @@ let string_of_xml ~utf8 ns_table v =
in
let
rec
register_elt
=
function
|
Xml
(
Atom
tag
,
Record
attrs
,
content
)
->
|
Xml
(
Atom
tag
,
Record
attrs
,
content
)
|
XmlNs
(
Atom
tag
,
Record
attrs
,
content
,
_
)
->
List
.
iter
(
fun
(
n
,_
)
->
Ns
.
Printer
.
register_attr
printer
(
LabelPool
.
value
n
))
(
LabelMap
.
get
attrs
);
...
...
@@ -146,7 +147,8 @@ let string_of_xml ~utf8 ns_table v =
register_elt
v
;
let
rec
print_elt
xmlns
=
function
|
Xml
(
Atom
tag
,
Record
attrs
,
content
)
->
|
Xml
(
Atom
tag
,
Record
attrs
,
content
)
|
XmlNs
(
Atom
tag
,
Record
attrs
,
content
,
_
)
->
let
tag
=
Atoms
.
V
.
value
tag
in
let
attrs
=
LabelMap
.
mapi_to_list
(
fun
n
v
->
...
...
@@ -174,7 +176,7 @@ let string_of_xml ~utf8 ns_table v =
let
(
s
,
q
)
=
get_string_utf8
v
in
wds
s
;
match
q
with
|
Pair
(
Xml
_
as
x
,
q
)
->
print_elt
[]
x
;
print_content
q
|
Pair
(
(
Xml
_
|
XmlNs
_
)
as
x
,
q
)
->
print_elt
[]
x
;
print_content
q
|
Atom
a
when
a
=
Sequence
.
nil_atom
->
()
|
v
->
schema_value
~
wds
v
in
...
...
runtime/run_dispatch.ml
View file @
db932d00
...
...
@@ -190,7 +190,8 @@ let rec run_dispatcher d v =
and
run_disp_kind
actions
v
=
match
v
with
|
Pair
(
v1
,
v2
)
->
run_disp_prod
v
v1
v2
actions
.
prod
|
Xml
(
v1
,
v2
,
v3
)
->
run_disp_prod
v
v1
(
Pair
(
v2
,
v3
))
actions
.
xml
|
Xml
(
v1
,
v2
,
v3
)
|
XmlNs
(
v1
,
v2
,
v3
,_
)
->
run_disp_prod
v
v1
(
Pair
(
v2
,
v3
))
actions
.
xml
|
Record
r
->
run_disp_record
false
v
(
LabelMap
.
get
r
)
actions
.
record
|
String_latin1
(
i
,
j
,
s
,
q
)
->
(* run_disp_kind actions (Value.normalize v) *)
...
...
@@ -449,7 +450,8 @@ let rec run_dispatcher d v =
and
run_disp_kind
actions
v
=
match
v
with
|
Pair
(
v1
,
v2
)
->
run_disp_prod
v
v1
v2
actions
.
prod
|
Xml
(
v1
,
v2
,
v3
)
->
run_disp_prod
v
v1
(
Pair
(
v2
,
v3
))
actions
.
xml
|
Xml
(
v1
,
v2
,
v3
)
|
XmlNs
(
v1
,
v2
,
v3
,_
)
->
run_disp_prod
v
v1
(
Pair
(
v2
,
v3
))
actions
.
xml
|
Record
r
->
run_disp_record
!
cursor
false
v
(
LabelMap
.
get
r
)
actions
.
record
|
String_latin1
(
i
,
j
,
s
,
q
)
->
run_disp_kind
actions
(
Value
.
normalize
v
)
...
...
runtime/value.ml
View file @
db932d00
...
...
@@ -4,6 +4,7 @@ open Encodings
type
t
=
|
Pair
of
t
*
t
|
Xml
of
t
*
t
*
t
|
XmlNs
of
t
*
t
*
t
*
Ns
.
table
|
Record
of
t
label_map
|
Atom
of
Atoms
.
V
.
t
|
Integer
of
Intervals
.
V
.
t
...
...
@@ -81,7 +82,7 @@ let rec const = function
let
rec
inv_const
=
function
|
Pair
(
x
,
y
)
->
Types
.
Pair
(
inv_const
x
,
inv_const
y
)
|
Xml
(
x
,
y
,
z
)
->
|
Xml
(
x
,
y
,
z
)
|
XmlNs
(
x
,
y
,
z
,_
)
->
Types
.
Pair
(
inv_const
x
,
Types
.
Pair
(
inv_const
y
,
inv_const
z
))
|
Record
x
->
Types
.
Record
(
LabelMap
.
map
inv_const
x
)
|
Atom
a
->
Types
.
Atom
a
...
...
@@ -251,7 +252,7 @@ let rec print ppf v =
else
if
is_seq
v
then
Format
.
fprintf
ppf
"[ @[<hv>%a@]]"
print_seq
v
else
match
v
with
|
Pair
(
x
,
y
)
->
Format
.
fprintf
ppf
"(%a,%a)"
print
x
print
y
|
Xml
(
x
,
y
,
z
)
->
print_xml
ppf
x
y
z
|
Xml
(
x
,
y
,
z
)
|
XmlNs
(
x
,
y
,
z
,_
)
->
print_xml
ppf
x
y
z
|
Record
l
->
Format
.
fprintf
ppf
"{%a }"
print_record
(
LabelMap
.
get
l
)
|
Atom
a
->
Atoms
.
V
.
print_quote
ppf
a
|
Integer
i
->
Intervals
.
V
.
print
ppf
i
...
...
@@ -334,7 +335,7 @@ let dump_xml ppf v =
|
Pair
(
x
,
y
)
->
Format
.
fprintf
ppf
"@[<hv1>"
;
Format
.
fprintf
ppf
"<pair>@,%a@,%a@,</pair>@]"
aux
x
aux
y
|
Xml
(
x
,
y
,
z
)
->
|
Xml
(
x
,
y
,
z
)
|
XmlNs
(
x
,
y
,
z
,_
)
->
Format
.
fprintf
ppf
"@[<hv1>"
;
Format
.
fprintf
ppf
"<xml>@,%a@,%a@,%a@,</xml>@]"
aux
x
aux
y
aux
z
|
Record
x
->
...
...
@@ -389,7 +390,8 @@ let rec compare x y =
|
Pair
(
x1
,
x2
)
,
Pair
(
y1
,
y2
)
->
let
c
=
compare
x1
y1
in
if
c
<>
0
then
c
else
compare
x2
y2
|
Xml
(
x1
,
x2
,
x3
)
,
Xml
(
y1
,
y2
,
y3
)
->
|
(
Xml
(
x1
,
x2
,
x3
)
|
XmlNs
(
x1
,
x2
,
x3
,_
))
,
(
Xml
(
y1
,
y2
,
y3
)
|
XmlNs
(
y1
,
y2
,
y3
,_
))
->
let
c
=
compare
x1
y1
in
if
c
<>
0
then
c
else
let
c
=
compare
x2
y2
in
if
c
<>
0
then
c
else
compare
x3
y3
...
...
@@ -451,7 +453,8 @@ let rec compare x y =
|
_
,
String_utf8
(
i
,
j
,
s
,
q
)
->
compare
x
(
normalize_string_utf8
i
j
s
q
)
|
Pair
(
_
,_
)
,
_
->
-
1
|
_
,
Pair
(
_
,_
)
->
1
|
Xml
(
_
,_,_
)
,_
->
-
1
|
_
,
Xml
(
_
,_,_
)
->
1
|
(
Xml
(
_
,_,_
)
|
XmlNs
(
_
,_,_,_
))
,_
->
-
1
|
_
,
(
Xml
(
_
,_,_
)
|
XmlNs
(
_
,_,_,_
))
->
1
|
Record
_
,_
->
-
1
|
_
,
Record
_
->
1
|
Atom
_
,_
->
-
1
|
_
,
Atom
_
->
1
|
Integer
_
,_
->
-
1
|
_
,
Integer
_
->
1
...
...
@@ -476,9 +479,10 @@ let iter_xml pcdata_callback other_callback =
|
v
->
raise
(
Invalid_argument
"Value.iter_xml"
)
in
function
|
Xml
(
_
,_,
cont
)
->
aux
cont
|
Xml
(
_
,_,
cont
)
|
XmlNs
(
_
,_,
cont
,_
)
->
aux
cont
|
_
->
raise
(
Invalid_argument
"Value.iter_xml"
)
(*
let map_xml map_pcdata map_other =
let patch_string_utf8 cont = function
| String_utf8 (i, j, u, v) when compare v nil = 0 ->
...
...
@@ -498,7 +502,7 @@ let map_xml map_pcdata map_other =
function
| Xml (tag,attrs,cont) -> Xml (tag, attrs, aux cont)
| _ -> raise (Invalid_argument "Value.map_xml")
*)
let
tagged_tuple
tag
vl
=
let
ct
=
sequence
vl
in
...
...
runtime/value.mli
View file @
db932d00
...
...
@@ -5,6 +5,7 @@ type t =
(* Canonical representation *)
|
Pair
of
t
*
t
|
Xml
of
t
*
t
*
t
|
XmlNs
of
t
*
t
*
t
*
Ns
.
table
|
Record
of
t
label_map
|
Atom
of
Atoms
.
V
.
t
|
Integer
of
Intervals
.
V
.
t
...
...
@@ -73,8 +74,10 @@ val mk_ext_ref : Types.t option -> (unit -> t) -> (t -> unit) -> t
character children; second callback is invoked on other children values *)
val
iter_xml
:
(
U
.
t
->
unit
)
->
(
t
->
unit
)
->
t
->
unit
(*
(* as above for map *)
val map_xml : (U.t -> U.t) -> (t -> t) -> t -> t
*)
val
concat
:
t
->
t
->
t
val
flatten
:
t
->
t
...
...
types/builtin.ml
View file @
db932d00
...
...
@@ -4,6 +4,9 @@ let eval = ref (fun ppf err s -> assert false)
(* Types *)
let
namespaces
=
Sequence
.
star
(
Types
.
times
(
Types
.
cons
string
)
(
Types
.
cons
string
))
let
types
=
[
"Empty"
,
Types
.
empty
;
...
...
@@ -20,6 +23,7 @@ let types =
"Bool"
,
bool
;
"Float"
,
float
;
"AnyXml"
,
any_xml
;
"Namespaces"
,
namespaces
;
]
let
env
=
...
...
@@ -88,6 +92,12 @@ let exn_float_of =
Value
.
Pair
(
Value
.
Atom
(
Atoms
.
V
.
mk_ascii
"Invalid_argument"
)
,
Value
.
string_latin1
"float_of"
))
let
exn_namespaces
=
Value
.
CDuceExn
(
Value
.
Pair
(
Value
.
Atom
(
Atoms
.
V
.
mk_ascii
"Invalid_argument"
)
,
Value
.
string_latin1
"namespaces"
))
let
eval_load_file
~
utf8
e
=
Location
.
protect_op
"load_file"
;
...
...
@@ -146,6 +156,12 @@ register_fun "load_xml"
string_latin1
any_xml
(
fun
v
->
Location
.
protect_op
"load_xml"
;
Load_xml
.
load_xml
(
Value
.
get_string_latin1
v
));;
register_fun
"!load_xml"
string_latin1
any_xml
(
fun
v
->
Location
.
protect_op
"load_xml"
;
Load_xml
.
load_xml
~
ns
:
true
(
Value
.
get_string_latin1
v
));;
register_fun
"load_html"
string_latin1
Sequence
.
any
(
fun
v
->
Location
.
protect_op
"load_html"
;
Load_xml
.
load_html
(
Value
.
get_string_latin1
v
));;
...
...
@@ -302,7 +318,18 @@ unary_op_gen "flatten"
register_fun
"raise"
any
Types
.
empty
(
fun
v
->
raise
(
Value
.
CDuceExn
v
));;
register_fun
"namespaces"
any_xml
namespaces
(
function
Value
.
XmlNs
(
_
,_,_,
ns
)
->
Value
.
sequence_rev
(
List
.
map
(
fun
(
pr
,
ns
)
->
Value
.
Pair
(
Value
.
string_utf8
pr
,
Value
.
string_utf8
ns
))
(
Ns
.
get_table
ns
))
|
Value
.
Xml
_
->
raise
exn_namespaces
|
_
->
assert
false
);;