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
83f3cacc
Commit
83f3cacc
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2003-06-29 20:28:52 by cvscast] Continuing namespaces : records and print_xml -- Alain
Original author: cvscast Date: 2003-06-29 20:28:53+00:00
parent
00c2cd22
Changes
18
Hide whitespace changes
Inline
Side-by-side
Makefile.distrib
View file @
83f3cacc
...
...
@@ -62,7 +62,7 @@ CLEAN_DIRS = $(DIRS) tools tests
OBJECTS
=
\
misc/state.cmo misc/pool.cmo misc/encodings.cmo misc/bool.cmo
\
misc/pretty.cmo
\
misc/pretty.cmo
misc/ns.cmo
\
\
types/sortedList.cmo types/boolean.cmo types/ident.cmo
\
types/intervals.cmo types/chars.cmo types/atoms.cmo
\
...
...
depend
View file @
83f3cacc
...
...
@@ -8,30 +8,34 @@ misc/bool.cmo: misc/q_symbol.cmo misc/bool.cmi
misc/bool.cmx: misc/q_symbol.cmo misc/bool.cmi
misc/pretty.cmo: misc/q_symbol.cmo misc/pretty.cmi
misc/pretty.cmx: misc/q_symbol.cmo misc/pretty.cmi
misc/ns.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/pool.cmi misc/state.cmi misc/ns.cmi
misc/ns.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/pool.cmx misc/state.cmx misc/ns.cmi
types/sortedList.cmo: misc/q_symbol.cmo types/sortedList.cmi
types/sortedList.cmx: misc/q_symbol.cmo types/sortedList.cmi
types/boolean.cmo: misc/q_symbol.cmo types/sortedList.cmi types/boolean.cmi
types/boolean.cmx: misc/q_symbol.cmo types/sortedList.cmx types/boolean.cmi
types/ident.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/pool.cmi types/sortedList.cmi
types/ident.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/pool.cmx types/sortedList.cmx
types/ident.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/ns.cmi misc/pool.cmi \
types/sortedList.cmi
types/ident.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/ns.cmx misc/pool.cmx \
types/sortedList.cmx
types/intervals.cmo: misc/q_symbol.cmo types/intervals.cmi
types/intervals.cmx: misc/q_symbol.cmo types/intervals.cmi
types/chars.cmo: misc/q_symbol.cmo types/chars.cmi
types/chars.cmx: misc/q_symbol.cmo types/chars.cmi
types/ns.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/pool.cmi types/ns.cmi
types/ns.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/pool.cmx types/ns.cmi
types/atoms.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/pool.cmi types/sortedList.cmi \
types/atoms.cmi
types/atoms.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/pool.cmx types/sortedList.cmx \
types/atoms.cmi
types/atoms.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/ns.cmi misc/pool.cmi \
types/sortedList.cmi types/atoms.cmi
types/atoms.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/ns.cmx misc/pool.cmx \
types/sortedList.cmx types/atoms.cmi
types/normal.cmo: misc/q_symbol.cmo types/normal.cmi
types/normal.cmx: misc/q_symbol.cmo types/normal.cmi
types/types.cmo: misc/q_symbol.cmo types/atoms.cmi misc/bool.cmi types/chars.cmi \
misc/encodings.cmi types/ident.cmo types/intervals.cmi types/normal.cmi \
misc/pretty.cmi types/sortedList.cmi misc/state.cmi types/types.cmi
misc/ns.cmi misc/pretty.cmi types/sortedList.cmi misc/state.cmi \
types/types.cmi
types/types.cmx: misc/q_symbol.cmo types/atoms.cmx misc/bool.cmx types/chars.cmx \
misc/encodings.cmx types/ident.cmx types/intervals.cmx types/normal.cmx \
misc/pretty.cmx types/sortedList.cmx misc/state.cmx types/types.cmi
misc/ns.cmx misc/pretty.cmx types/sortedList.cmx misc/state.cmx \
types/types.cmi
types/patterns.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi types/ident.cmo \
types/sortedList.cmi misc/state.cmi types/types.cmi types/patterns.cmi
types/patterns.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx types/ident.cmx \
...
...
@@ -45,17 +49,17 @@ types/builtin_defs.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi types/
types/builtin_defs.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx types/intervals.cmx \
types/sequence.cmx types/types.cmx types/builtin_defs.cmi
runtime/value.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/encodings.cmi \
types/ident.cmo types/intervals.cmi
types/sequence
.cmi types/
types
.cmi \
runtime/value.cmi
types/ident.cmo types/intervals.cmi
misc/ns
.cmi types/
sequence
.cmi \
types/types.cmi
runtime/value.cmi
runtime/value.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx misc/encodings.cmx \
types/ident.cmx types/intervals.cmx
types/sequence
.cmx types/
types
.cmx \
runtime/value.cmi
types/ident.cmx types/intervals.cmx
misc/ns
.cmx types/
sequence
.cmx \
types/types.cmx
runtime/value.cmi
schema/schema_types.cmo: misc/q_symbol.cmo runtime/value.cmi schema/schema_types.cmi
schema/schema_types.cmx: misc/q_symbol.cmo runtime/value.cmx schema/schema_types.cmi
schema/schema_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi
runtime/value
.cmi \
schema/schema_xml.cmi
schema/schema_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx
runtime/value
.cmx \
schema/schema_xml.cmi
schema/schema_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi
misc/ns
.cmi \
runtime/value.cmi
schema/schema_xml.cmi
schema/schema_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx
misc/ns
.cmx \
runtime/value.cmx
schema/schema_xml.cmi
schema/schema_builtin.cmo: misc/q_symbol.cmo types/builtin_defs.cmi types/intervals.cmi \
schema/schema_types.cmi types/types.cmi runtime/value.cmi \
schema/schema_builtin.cmi
...
...
@@ -78,36 +82,38 @@ parser/location.cmo: misc/q_symbol.cmo parser/location.cmi
parser/location.cmx: misc/q_symbol.cmo parser/location.cmi
parser/wlexer.cmo: misc/q_symbol.cmo misc/encodings.cmi parser/location.cmi
parser/wlexer.cmx: misc/q_symbol.cmo misc/encodings.cmx parser/location.cmx
parser/ast.cmo: misc/q_symbol.cmo types/ident.cmo parser/location.cmi
schema/schema_type
s.cmi \
types/types.cmi
parser/ast.cmx: misc/q_symbol.cmo types/ident.cmx parser/location.cmx
schema/schema_type
s.cmx \
types/types.cmx
parser/ast.cmo: misc/q_symbol.cmo types/ident.cmo parser/location.cmi
misc/n
s.cmi \
schema/schema_types.cmi
types/types.cmi
parser/ast.cmx: misc/q_symbol.cmo types/ident.cmx parser/location.cmx
misc/n
s.cmx \
schema/schema_types.cmx
types/types.cmx
parser/parser.cmo: misc/q_symbol.cmo parser/ast.cmo types/atoms.cmi types/chars.cmi \
misc/encodings.cmi types/ident.cmo types/intervals.cmi \
parser/location.cmi schema/schema_parser.cmi schema/schema_xml.cmi \
types/sequence.cmi types/types.cmi parser/wlexer.cmo parser/parser.cmi
parser/location.cmi misc/ns.cmi schema/schema_parser.cmi \
schema/schema_xml.cmi types/sequence.cmi types/types.cmi \
parser/wlexer.cmo parser/parser.cmi
parser/parser.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/chars.cmx \
misc/encodings.cmx types/ident.cmx types/intervals.cmx \
parser/location.cmx schema/schema_parser.cmx schema/schema_xml.cmx \
types/sequence.cmx types/types.cmx parser/wlexer.cmx parser/parser.cmi
parser/location.cmx misc/ns.cmx schema/schema_parser.cmx \
schema/schema_xml.cmx types/sequence.cmx types/types.cmx \
parser/wlexer.cmx parser/parser.cmi
typing/typed.cmo: misc/q_symbol.cmo types/ident.cmo parser/location.cmi types/patterns.cmi \
types/types.cmi runtime/value.cmi
typing/typed.cmx: misc/q_symbol.cmo types/ident.cmx parser/location.cmx types/patterns.cmx \
types/types.cmx runtime/value.cmx
typing/typer.cmo: misc/q_symbol.cmo parser/ast.cmo types/atoms.cmi types/chars.cmi \
types/ident.cmo parser/location.cmi types/patterns.cmi \
types/ident.cmo parser/location.cmi
misc/ns.cmi
types/patterns.cmi \
schema/schema_builtin.cmi schema/schema_types.cmi \
schema/schema_validator.cmi types/sequence.cmi misc/state.cmi \
typing/typed.cmo types/types.cmi typing/typer.cmi
typing/typer.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/chars.cmx \
types/ident.cmx parser/location.cmx types/patterns.cmx \
types/ident.cmx parser/location.cmx
misc/ns.cmx
types/patterns.cmx \
schema/schema_builtin.cmx schema/schema_types.cmx \
schema/schema_validator.cmx types/sequence.cmx misc/state.cmx \
typing/typed.cmx types/types.cmx typing/typer.cmi
runtime/load_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi types/ident.cmo \
parser/location.cmi runtime/value.cmi runtime/load_xml.cmi
parser/location.cmi
misc/ns.cmi
runtime/value.cmi runtime/load_xml.cmi
runtime/load_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx types/ident.cmx \
parser/location.cmx runtime/value.cmx runtime/load_xml.cmi
parser/location.cmx
misc/ns.cmx
runtime/value.cmx runtime/load_xml.cmi
runtime/run_dispatch.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/encodings.cmi \
types/ident.cmo types/patterns.cmi types/types.cmi runtime/value.cmi \
runtime/run_dispatch.cmi
...
...
@@ -115,9 +121,11 @@ runtime/run_dispatch.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx misc
types/ident.cmx types/patterns.cmx types/types.cmx runtime/value.cmx \
runtime/run_dispatch.cmi
runtime/print_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi types/ident.cmo \
parser/location.cmi types/sequence.cmi runtime/value.cmi
parser/location.cmi misc/ns.cmi types/sequence.cmi typing/typer.cmi \
runtime/value.cmi
runtime/print_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx types/ident.cmx \
parser/location.cmx types/sequence.cmx runtime/value.cmx
parser/location.cmx misc/ns.cmx types/sequence.cmx typing/typer.cmx \
runtime/value.cmx
runtime/eval.cmo: misc/q_symbol.cmo types/ident.cmo types/patterns.cmi runtime/run_dispatch.cmi \
schema/schema_validator.cmi schema/schema_xml.cmi typing/typed.cmo \
typing/typer.cmi types/types.cmi runtime/value.cmi runtime/eval.cmi
...
...
@@ -126,22 +134,22 @@ runtime/eval.cmx: misc/q_symbol.cmo types/ident.cmx types/patterns.cmx runtime/r
typing/typer.cmx types/types.cmx runtime/value.cmx runtime/eval.cmi
types/builtin.cmo: misc/q_symbol.cmo parser/ast.cmo types/atoms.cmi types/builtin_defs.cmi \
types/chars.cmi types/ident.cmo types/intervals.cmi runtime/load_xml.cmi \
parser/location.cmi runtime/print_xml.cmo types/sequence.cmi \
parser/location.cmi
misc/ns.cmi
runtime/print_xml.cmo types/sequence.cmi \
typing/typed.cmo typing/typer.cmi types/types.cmi runtime/value.cmi \
types/builtin.cmi
types/builtin.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/builtin_defs.cmx \
types/chars.cmx types/ident.cmx types/intervals.cmx runtime/load_xml.cmx \
parser/location.cmx runtime/print_xml.cmx types/sequence.cmx \
parser/location.cmx
misc/ns.cmx
runtime/print_xml.cmx types/sequence.cmx \
typing/typed.cmx typing/typer.cmx types/types.cmx runtime/value.cmx \
types/builtin.cmi
driver/cduce.cmo: misc/q_symbol.cmo parser/ast.cmo runtime/eval.cmi types/ident.cmo \
parser/location.cmi parser/parser.cmi types/patterns.cmi
types/sample.cmi
\
misc/state.cmi typing/typed.cmo typing/typer.cmi
types/types.cmi
\
runtime/value.cmi parser/wlexer.cmo driver/cduce.cmi
parser/location.cmi
misc/ns.cmi
parser/parser.cmi types/patterns.cmi \
types/sample.cmi
misc/state.cmi typing/typed.cmo typing/typer.cmi \
types/types.cmi
runtime/value.cmi parser/wlexer.cmo driver/cduce.cmi
driver/cduce.cmx: misc/q_symbol.cmo parser/ast.cmx runtime/eval.cmx types/ident.cmx \
parser/location.cmx parser/parser.cmx types/patterns.cmx
types/sample.cmx
\
misc/state.cmx typing/typed.cmx typing/typer.cmx
types/types.cmx
\
runtime/value.cmx parser/wlexer.cmx driver/cduce.cmi
parser/location.cmx
misc/ns.cmx
parser/parser.cmx types/patterns.cmx \
types/sample.cmx
misc/state.cmx typing/typed.cmx typing/typer.cmx \
types/types.cmx
runtime/value.cmx parser/wlexer.cmx driver/cduce.cmi
driver/run.cmo: misc/q_symbol.cmo driver/cduce.cmi types/ident.cmo runtime/load_xml.cmi \
parser/location.cmi types/sequence.cmi misc/state.cmi runtime/value.cmi \
parser/wlexer.cmo
...
...
@@ -152,9 +160,9 @@ driver/webiface.cmo: misc/q_symbol.cmo driver/cduce.cmi driver/examples.cmo pars
misc/state.cmi
driver/webiface.cmx: misc/q_symbol.cmo driver/cduce.cmx driver/examples.cmx parser/location.cmx \
misc/state.cmx
misc/ns.cmi: misc/q_symbol.cmo misc/encodings.cmi
types/boolean.cmi: misc/q_symbol.cmo types/sortedList.cmi
types/ns.cmi: misc/q_symbol.cmo misc/encodings.cmi
types/atoms.cmi: misc/q_symbol.cmo misc/encodings.cmi
types/atoms.cmi: misc/q_symbol.cmo misc/encodings.cmi misc/ns.cmi
types/types.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi types/ident.cmo \
types/intervals.cmi types/sortedList.cmi
types/patterns.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi types/ident.cmo \
...
...
@@ -171,8 +179,8 @@ schema/schema_validator.cmi: misc/q_symbol.cmo schema/schema_types.cmi runtime/v
schema/schema_parser.cmi: misc/q_symbol.cmo schema/schema_types.cmi schema/schema_xml.cmi
parser/parser.cmi: misc/q_symbol.cmo parser/ast.cmo
typing/typer.cmi: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo parser/location.cmi \
schema/schema_types.cmi schema/schema_validator.cmi
typing/typed.cmo
\
types/types.cmi
misc/ns.cmi
schema/schema_types.cmi schema/schema_validator.cmi \
typing/typed.cmo
types/types.cmi
runtime/load_xml.cmi: misc/q_symbol.cmo runtime/value.cmi
runtime/run_dispatch.cmi: misc/q_symbol.cmo types/patterns.cmi runtime/value.cmi
runtime/eval.cmi: misc/q_symbol.cmo types/ident.cmo typing/typed.cmo runtime/value.cmi
...
...
driver/cduce.ml
View file @
83f3cacc
...
...
@@ -44,7 +44,7 @@ let dump_env ppf =
)
!
eval_env
;
Format
.
fprintf
ppf
"Namespaces:@."
;
Atoms
.
Ns
.
dump_prefix_table
ppf
Ns
.
dump_prefix_table
ppf
let
rec
print_exn
ppf
=
function
...
...
@@ -60,7 +60,7 @@ let rec print_exn ppf = function
U
.
print
(
Id
.
value
v
)
|
Typer
.
WrongLabel
(
t
,
l
)
->
Format
.
fprintf
ppf
"Wrong record selection; field %a "
U
.
print
(
LabelPool
.
value
l
);
Label
.
print
(
LabelPool
.
value
l
);
Format
.
fprintf
ppf
"not present in an expression of type:@.%a@."
print_norm
t
|
Typer
.
ShouldHave
(
t
,
msg
)
->
...
...
parser/ast.ml
View file @
83f3cacc
...
...
@@ -13,7 +13,7 @@ and pmodule_item' =
|
SchemaDecl
of
string
*
Schema_types
.
schema
(* name, schema *)
|
LetDecl
of
ppat
*
pexpr
|
FunDecl
of
pexpr
|
Namespace
of
U
.
t
*
Atoms
.
Ns
.
t
|
Namespace
of
U
.
t
*
Ns
.
t
|
EvalStatement
of
pexpr
|
Debug
of
debug_directive
|
Directive
of
toplevel_directive
...
...
@@ -32,7 +32,7 @@ and toplevel_directive =
and
pconst
=
|
Const_internal
of
Types
.
const
|
Const_atom
of
U
.
t
*
U
.
t
|
Const_atom
of
U
.
t
and
pexpr
=
|
LocatedExpr
of
loc
*
pexpr
...
...
@@ -65,7 +65,7 @@ and pexpr =
|
Try
of
pexpr
*
branches
(* Other *)
|
NamespaceIn
of
U
.
t
*
Atoms
.
Ns
.
t
*
pexpr
|
NamespaceIn
of
U
.
t
*
Ns
.
t
*
pexpr
and
abstr
=
{
fun_name
:
id
option
;
...
...
@@ -82,7 +82,8 @@ and ppat' =
|
PatVar
of
U
.
t
|
SchemaVar
of
(* type/pattern schema variable *)
schema_item_kind
*
string
*
string
|
AtomT
of
U
.
t
*
(
U
.
t
option
)
|
AtomT
of
U
.
t
|
NsT
of
U
.
t
|
Recurs
of
ppat
*
(
U
.
t
*
ppat
)
list
|
Internal
of
Types
.
descr
|
Or
of
ppat
*
ppat
...
...
parser/parser.ml
View file @
83f3cacc
...
...
@@ -21,6 +21,7 @@ let parse_ident = U.mk_latin1
let
id_dummy
=
ident
(
U
.
mk
"$$$"
)
(*
let split_qname s =
try
let i = String.index s ':' in
...
...
@@ -29,8 +30,10 @@ let split_qname s =
(parse_ident ns, parse_ident s)
with Not_found ->
(U.mk "", parse_ident s)
*)
let
label
s
=
LabelPool
.
mk
(
parse_ident
s
)
(* TODO: NS *)
let
label
s
=
LabelPool
.
mk
(
Ns
.
empty
,
parse_ident
s
)
let
ident
s
=
ident
(
parse_ident
s
)
let
prog
=
Grammar
.
Entry
.
create
gram
"prog"
...
...
@@ -121,7 +124,7 @@ EXTEND
let
schema
=
Schema_parser
.
parse_schema
schema_doc
in
[
mk
loc
(
SchemaDecl
(
name
,
schema
))]
|
(
name
,
ns
)
=
namespace_binding
->
Atoms
.
Ns
.
register_prefix
name
ns
;
Ns
.
register_prefix
name
ns
;
[
mk
loc
(
Namespace
(
name
,
ns
))
]
|
(
name
,
ns
)
=
namespace_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
let
e
=
exp
loc
(
NamespaceIn
(
name
,
ns
,
e2
))
in
...
...
@@ -293,15 +296,12 @@ EXTEND
];
tag
:
[
[
a
=
[
LIDENT
|
UIDENT
|
keyword
]
->
let
(
ns
,
l
)
=
split_qname
a
in
Const_atom
(
ns
,
l
)
]
];
Const_atom
(
parse_ident
a
)
]
];
tag_type
:
[
[
LIDENT
"_"
->
mk
loc
(
Internal
(
Types
.
atom
Atoms
.
any
))
|
a
=
[
LIDENT
|
UIDENT
|
keyword
]
->
let
(
ns
,
l
)
=
split_qname
a
in
mk
loc
(
AtomT
(
ns
,
Some
l
))
|
t
=
ANY_IN_NS
->
mk
loc
(
AtomT
(
parse_ident
t
,
None
))
|
a
=
[
LIDENT
|
UIDENT
|
keyword
]
->
mk
loc
(
AtomT
(
parse_ident
a
))
|
t
=
ANY_IN_NS
->
mk
loc
(
NsT
(
parse_ident
t
))
]
];
...
...
@@ -320,7 +320,7 @@ EXTEND
parse_ident
name
|
->
U
.
mk
""
];
uri
=
STRING2
->
let
ns
=
Atoms
.
Ns
.
mk
(
parse_ident
uri
)
in
let
ns
=
Ns
.
mk
(
parse_ident
uri
)
in
(
name
,
ns
)
]
];
...
...
@@ -464,9 +464,8 @@ EXTEND
|
"`"
;
c
=
tag_type
->
c
|
c
=
const
->
(
match
c
with
|
Const_atom
(
ns
,
l
)
->
mk
loc
(
AtomT
(
ns
,
Some
l
))
|
Const_internal
c
->
mk
loc
(
Internal
(
Types
.
constant
c
))
|
Const_atom
l
->
mk
loc
(
AtomT
l
)
|
Const_internal
c
->
mk
loc
(
Internal
(
Types
.
constant
c
))
)
|
"("
;
l
=
LIST1
pat
SEP
","
;
")"
->
multi_prod
loc
l
|
"["
;
r
=
[
r
=
regexp
->
r
|
->
Epsilon
];
...
...
runtime/load_xml.ml
View file @
83f3cacc
...
...
@@ -48,11 +48,12 @@ let string s q =
let
attrib
att
=
let
att
=
List
.
map
(
fun
(
l
,
v
)
->
LabelPool
.
mk
(
U
.
mk
l
)
,
string
v
nil
)
att
in
LabelMap
.
from_list
(
fun
_
_
->
assert
false
)
att
(* TODO: better error message *)
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
att
child
=
Xml
(
Atom
(
Atoms
.
mk
Atoms
.
Ns
.
empty
(
U
.
mk
tag
)
)
,
Record
(
attrib
att
)
,
child
)
let
elem
(
tag
_ns
,
tag
)
att
child
=
Xml
(
Atom
(
Atoms
.
mk
tag_ns
tag
)
,
Record
(
attrib
att
)
,
child
)
(*
class warner = object method warn w = print_endline ("PXP WARNING: " ^ w) end
...
...
@@ -60,24 +61,28 @@ class warner = object method warn w = print_endline ("PXP WARNING: " ^ w) end
type
token
=
|
Element
of
Value
.
t
|
Start
of
string
*
(
string
*
string
)
list
|
Start
of
Ns
.
qname
*
(
Ns
.
qname
*
Utf8
.
t
)
list
*
Ns
.
table
|
String
of
string
let
stack
=
ref
[]
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
)
::
st
->
stack
:=
Element
(
elem
name
att
accu
)
::
st
|
Start
(
name
,
att
,
table
)
::
st
->
stack
:=
Element
(
elem
name
att
accu
)
::
st
;
ns_table
:=
table
|
[]
->
assert
false
let
start_element_handler
name
att
=
if
not
(
only_ws
txt
.
buffer
txt
.
pos
)
then
stack
:=
String
(
String
.
sub
txt
.
buffer
0
txt
.
pos
)
::
!
stack
;
txt
.
pos
<-
0
;
stack
:=
Start
(
name
,
att
)
::
!
stack
txt
.
pos
<-
0
;
let
(
table
,
name
,
att
)
=
Ns
.
process_start_tag
!
ns_table
name
att
in
stack
:=
Start
(
name
,
att
,!
ns_table
)
::
!
stack
;
ns_table
:=
table
let
end_element_handler
_
=
let
accu
=
...
...
@@ -171,7 +176,8 @@ let load_html s =
|
Nethtml
.
Data
data
->
if
(
only_ws
data
(
String
.
length
data
))
then
q
else
string
data
q
|
Nethtml
.
Element
(
tag
,
att
,
child
)
->
Pair
(
elem
tag
att
(
val_of_docs
child
)
,
q
)
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
)
and
val_of_docs
=
function
|
[]
->
nil
|
h
::
t
->
val_of_doc
(
val_of_docs
t
)
h
...
...
runtime/print_xml.ml
View file @
83f3cacc
...
...
@@ -10,10 +10,11 @@ let exn_print_xml = CDuceExn (Pair (
Atom
(
Atoms
.
mk_ascii
"Invalid_argument"
)
,
string_latin1
"print_xml"
))
let
string_of_xml
~
utf8
v
=
let
string_of_xml
~
utf8
ns_table
v
=
let
to_enc
=
if
utf8
then
`Enc_utf8
else
`Enc_iso88591
in
let
buffer
=
Buffer
.
create
127
in
let
printer
=
Ns
.
Printer
.
printer
ns_table
in
let
wms
=
write_markup_string
...
...
@@ -28,20 +29,51 @@ let string_of_xml ~utf8 v=
(
`Out_buffer
buffer
)
(
U
.
get_str
s
)
in
let
write_att
(
n
,
v
)
=
wms
(
" "
^
(
U
.
get_str
n
)
^
"=
\"
"
);
wds
v
;
wms
"
\"
"
in
let
element_start
name
attrs
=
wms
(
"<"
^
(
U
.
get_str
name
));
List
.
iter
write_att
attrs
;
wms
">"
and
empty_element
name
attrs
=
wms
(
"<"
^
(
U
.
get_str
name
));
List
.
iter
write_att
attrs
;
wms
"/>"
and
element_end
name
=
wms
(
"</"
^
(
U
.
get_str
name
)
^
">"
)
let
write_att
(
n
,
v
)
=
wms
(
" "
^
(
Ns
.
Printer
.
attr
printer
n
)
^
"=
\"
"
);
wds
v
;
wms
"
\"
"
in
let
write_xmlns
(
pr
,
ns
)
=
let
pr
=
U
.
get_str
pr
in
if
pr
=
""
then
wms
" xmlns"
else
(
wms
" xmlns:"
;
wms
pr
);
wms
"=
\"
"
;
wds
(
Ns
.
value
ns
);
wms
"
\"
"
in
let
element_start
n
xmlns
attrs
=
wms
(
"<"
^
(
Ns
.
Printer
.
tag
printer
n
));
List
.
iter
write_xmlns
xmlns
;
List
.
iter
write_att
attrs
;
wms
">"
and
empty_element
n
xmlns
attrs
=
wms
(
"<"
^
(
Ns
.
Printer
.
tag
printer
n
));
List
.
iter
write_xmlns
xmlns
;
List
.
iter
write_att
attrs
;
wms
"/>"
and
element_end
n
=
wms
(
"</"
^
(
Ns
.
Printer
.
attr
printer
n
)
^
">"
)
and
document_start
()
=
(* wms ("<?xml version='1.0' encoding='" ^
Netconversion.string_of_encoding to_enc ^
"'?>\n") *)
()
()
in
let
rec
print_elt
=
function
let
rec
register_elt
=
function
|
Xml
(
Atom
tag
,
Record
attrs
,
content
)
->
List
.
iter
(
fun
(
n
,_
)
->
Ns
.
Printer
.
register_attr
printer
(
LabelPool
.
value
n
))
(
LabelMap
.
get
attrs
);
Ns
.
Printer
.
register_tag
printer
(
Atoms
.
value
tag
);
register_content
content
|
_
->
()
and
register_content
=
function
|
String_utf8
(
_
,_,_,
q
)
|
String_latin1
(
_
,_,_,
q
)
->
register_content
q
|
Pair
(
x
,
q
)
->
register_elt
x
;
register_content
q
|
_
->
()
in
register_elt
v
;
let
rec
print_elt
xmlns
=
function
|
Xml
(
Atom
tag
,
Record
attrs
,
content
)
->
let
tag
=
Atoms
.
value
tag
in
let
attrs
=
LabelMap
.
mapi_to_list
...
...
@@ -49,13 +81,14 @@ let string_of_xml ~utf8 v=
if
not
(
is_str
v
)
then
raise
exn_print_xml
;
let
(
s
,
q
)
=
get_string_utf8
v
in
match
q
with
|
Atom
a
when
a
=
Sequence
.
nil_atom
->
LabelPool
.
value
n
,
s
|
Atom
a
when
a
=
Sequence
.
nil_atom
->
(
LabelPool
.
value
n
)
,
s
|
_
->
raise
exn_print_xml
)
attrs
in
(
match
content
with
|
Atom
a
when
a
=
Sequence
.
nil_atom
->
empty_element
tag
attrs
|
Atom
a
when
a
=
Sequence
.
nil_atom
->
empty_element
tag
xmlns
attrs
|
_
->
element_start
tag
attrs
;
element_start
tag
xmlns
attrs
;
print_content
content
;
element_end
tag
)
|
_
->
raise
exn_print_xml
...
...
@@ -63,17 +96,17 @@ let string_of_xml ~utf8 v=
let
(
s
,
q
)
=
get_string_utf8
v
in
wds
s
;
match
q
with
|
Pair
(
x
,
q
)
->
print_elt
x
;
print_content
q
|
Pair
(
x
,
q
)
->
print_elt
[]
x
;
print_content
q
|
Atom
a
when
a
=
Sequence
.
nil_atom
->
()
|
_
->
raise
exn_print_xml
in
document_start
()
;
print_elt
v
;
print_elt
(
Ns
.
Printer
.
prefixes
printer
)
v
;
Buffer
.
contents
buffer
let
print_xml
~
utf8
s
=
let
print_xml
~
utf8
ns_table
s
=
try
let
s
=
string_of_xml
~
utf8
s
in
let
s
=
string_of_xml
~
utf8
ns_table
s
in
if
utf8
then
string_utf8
(
U
.
mk
s
)
else
string_latin1
s
with
exn
->
raise
...
...
runtime/value.ml
View file @
83f3cacc
...
...
@@ -25,14 +25,15 @@ let vtrue = Atom (Atoms.mk_ascii "true")
let
vfalse
=
Atom
(
Atoms
.
mk_ascii
"false"
)
let
vbool
x
=
if
x
then
vtrue
else
vfalse
(* TODO: namespaces for the two following functions *)
let
vrecord
l
=
let
l
=
List
.
map
(
fun
(
l
,
v
)
->
LabelPool
.
mk
(
U
.
mk
l
)
,
v
)
l
in
let
l
=
List
.
map
(
fun
(
l
,
v
)
->
LabelPool
.
mk
(
Ns
.
empty
,
U
.
mk
l
)
,
v
)
l
in
Record
(
LabelMap
.
from_list
(
fun
_
_
->
assert
false
)
l
)
let
get_fields
=
function
|
Record
map
->
LabelMap
.
mapi_to_list
(
fun
k
v
->
Utf8
.
to_string
(
LabelPool
.
value
k
)
,
v
)
(
fun
k
v
->
Utf8
.
to_string
(
snd
(
LabelPool
.
value
k
)
)
,
v
)
map
|
_
->
assert
false
...
...
@@ -192,7 +193,7 @@ and print_record ppf = function
|
f
::
rem
->
Format
.
fprintf
ppf
" %a;%a"
print_field
f
print_record
rem
and
print_field
ppf
(
l
,
v
)
=
Format
.
fprintf
ppf
"%a=%a"
U
.
print
(
LabelPool
.
value
l
)
print
v
Format
.
fprintf
ppf
"%a=%a"
Label
.
print
(
LabelPool
.
value
l
)
print
v
let
normalize_string_latin1
i
j
s
q
=
if
i
=
j
then
q
else
...
...
schema/schema_xml.ml
View file @
83f3cacc
...
...
@@ -151,7 +151,9 @@ let pxp_stream_of_value v =
what is still to be visited *)
(
match
!
stack
with
|
(
Fully
((
Value
.
Xml
(
Value
.
Atom
a
,
attrs
,
_
))
as
v
))
::
tl
->
let
tag_ascii
=
Encodings
.
Utf8
.
to_string
(
Atoms
.
value
a
)
in
let
(
ns
,
a
)
=
Atoms
.
value
a
in
assert
(
ns
==
Ns
.
empty
);
let
tag_ascii
=
Encodings
.
Utf8
.
to_string
a
in
let
attrs_ascii
=
List
.
map
(
fun
(
k
,
v
)
->
(
k
,
Value
.
get_string_latin1
v
))
(
Value
.
get_fields
attrs
)
...
...
@@ -170,7 +172,9 @@ let pxp_stream_of_value v =
stack
:=
(
List
.
rev
!
children
)
@
!
stack
;
event
|
(
Half
(
Value
.
Xml
(
Value
.
Atom
a
,
_
,
_
)))
::
tl
->
let
tag_ascii
=
Encodings
.
Utf8
.
to_string
(
Atoms
.
value
a
)
in
let
(
ns
,
a
)
=
Atoms
.
value
a
in
assert
(
ns
==
Ns
.
empty
);
let
tag_ascii
=
Encodings
.
Utf8
.
to_string
a
in
let
event
=
Some
(
E_end_tag
(
tag_ascii
,
eid
))
in
stack
:=
tl
;
event
...
...
types/atoms.ml
View file @
83f3cacc
open
Encodings
module
Ns
=
struct
include
Pool
.
Make
(
Utf8
)
let
prefixes_to_ns
=
State
.
ref
"Ns.prefixes"
(
Hashtbl
.
create
63
)
let
ns_to_prefixes
=
State
.
ref
"Ns.prefixes"
(
Hashtbl
.
create
63
)
let
register_prefix
p
ns
=
if
(
Hashtbl
.
mem
!
prefixes_to_ns
p
)
||
(
Hashtbl
.
mem
!
ns_to_prefixes
ns
)
then
()
else
(
Hashtbl
.
add
!
ns_to_prefixes
ns
p
;
Hashtbl
.
add
!
prefixes_to_ns
p
ns
)
let
counter
=
State
.
ref
"Ns.prefixes"
0
let
rec
fresh_prefix
()
=
incr
counter
;
let
s
=
Utf8
.
mk
(
Printf
.
sprintf
"ns%i"
!
counter
)
in
if
(
Hashtbl
.
mem
!
prefixes_to_ns
s
)
then
fresh_prefix
()
else
s
let
prefix
ns
=
try
Hashtbl
.
find
!
ns_to_prefixes
ns
with
Not_found
->
let
p
=
fresh_prefix
()
in
register_prefix
p
ns
;
p
let
dump_prefix_table
ppf
=
Hashtbl
.
iter
(
fun
ns
p
->
Format
.
fprintf
ppf
"%a=>%a@."
Utf8
.
print
p
Utf8
.
print
(
value
ns
))
!
ns_to_prefixes
let
empty
=
mk
(
Utf8
.
mk
""
)
let
_
=
register_prefix
(
Utf8
.
mk
""
)
empty
end
module
Symbol
=
Pool
.
Make
(
Utf8
)
type
v
=
Ns
.
t
*
Symbol
.
t
...
...
@@ -58,20 +21,10 @@ let mk ns x =
let
mk_ascii
s
=
mk
Ns
.
empty
(
Utf8
.
mk
s
)
let
value
(
ns
,
x
)
=
assert
(
ns
==
Ns
.
empty
);
Symbol
.
value
x
(* get rid of this function *)
let
print_prefix
ppf
ns
=
if
ns
==
Ns
.
empty
then
()
else
Format
.
fprintf
ppf
"%a:"
Utf8
.
print
(
Ns
.
prefix
ns
)
let
print_symbol
ppf
x
=
Utf8
.
print
ppf
(
Symbol
.
value
x
)
let
value
(
ns
,
x
)
=
(
ns
,
Symbol
.
value
x
)
let
vprint
ppf
((
ns
,
x
)
:
v
)
=
Format
.
fprintf
ppf
"%a%a"
print_prefix
ns
print_symbol
x
Ns
.
print_qname
ppf
(
ns
,
Symbol
.
value
x
)
let
print_any_in_ns
ppf
ns
=
let
ns
=
Ns
.
prefix
ns
in
...
...
types/atoms.mli
View file @
83f3cacc
open
Encodings
module
Ns
:
sig
type
t
val
mk
:
Utf8
.
t
->
t
val
value
:
t
->
Utf8
.
t
val
empty
:
t
val
register_prefix
:
Utf8
.
t
->
t
->
unit