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
1b67f651
Commit
1b67f651
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2003-06-30 21:35:52 by cvscast] Review internal pretting printing of namespaces -- Alain
Original author: cvscast Date: 2003-06-30 21:35:53+00:00
parent
a5d9af9b
Changes
8
Hide whitespace changes
Inline
Side-by-side
driver/cduce.ml
View file @
1b67f651
...
...
@@ -33,19 +33,18 @@ let print_value ppf v =
Location
.
protect
ppf
(
fun
ppf
->
Value
.
print
ppf
v
)
let
dump_env
ppf
=
Format
.
fprintf
ppf
"Global types:"
;
Typer
.
dump_global_types
ppf
;
Format
.
fprintf
ppf
".@."
;
Format
.
fprintf
ppf
"Types:%t.@."
Typer
.
dump_global_types
;
Format
.
fprintf
ppf
"Namespace prefixes:@
\n
%t"
Typer
.
dump_global_ns
;
Format
.
fprintf
ppf
"Namespace prefixes used for pretty-printing:%t@."
Ns
.
InternalPrinter
.
dump
;
Format
.
fprintf
ppf
"Values:@
\n
"
;
Env
.
iter
(
fun
x
v
->
let
t
=
Env
.
find
x
!
typing_env
in
Format
.
fprintf
ppf
"@[val %a : @[%a = %a@]@]@."
U
.
print
(
Id
.
value
x
)
print_norm
t
print_value
v
)
!
eval_env
;
Format
.
fprintf
ppf
"Namespaces:@."
;
Ns
.
dump_prefix_table
ppf
!
eval_env
let
rec
print_exn
ppf
=
function
|
Location
(
loc
,
w
,
exn
)
->
...
...
@@ -174,7 +173,7 @@ let rec phrases ppf phs = match phs with
Typer
.
register_schema
name
schema
;
phrases
ppf
rest
|
{
descr
=
Ast
.
Namespace
(
pr
,
ns
)
}
::
rest
->
Typer
.
register_
ns_prefix
pr
ns
;
Typer
.
register_
global_ns
pr
ns
;
phrases
ppf
rest
|
{
descr
=
Ast
.
EvalStatement
e
}
::
rest
->
let
(
fv
,
e
)
=
Typer
.
expr
e
in
...
...
misc/ns.ml
View file @
1b67f651
(* TODO:
special treatment of prefixes xml and xmlns *)
module
U
=
Encodings
.
Utf8
let
empty_str
=
U
.
mk
""
...
...
@@ -30,6 +33,13 @@ let add_prefix pr ns table =
if
(
U
.
get_str
pr
<>
""
)
then
Hashtbl
.
add
!
global_hints
ns
pr
;
Table
.
add
pr
ns
table
let
dump_table
ppf
table
=
Table
.
iter
(
fun
pr
ns
->
Format
.
fprintf
ppf
"%a=>
\"
%a
\"
@."
U
.
print
pr
U
.
print
(
value
ns
)
)
table
type
qname
=
t
*
U
.
t
exception
UnknownPrefix
of
U
.
t
...
...
@@ -64,50 +74,6 @@ let process_start_tag table tag attrs =
aux
table
[]
attrs
(* TODO: harmonize pretty-printing of values and of XML documents *)
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
=
U
.
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@."
U
.
print
p
U
.
print
(
value
ns
))
!
ns_to_prefixes
let
_
=
register_prefix
empty_str
empty
let
print_prefix
ppf
ns
=
if
ns
==
empty
then
()
else
Format
.
fprintf
ppf
"%a:"
U
.
print
(
prefix
ns
)
let
print_qname
ppf
(
ns
,
x
)
=
Format
.
fprintf
ppf
"%a%a"
print_prefix
ns
U
.
print
x
module
Printer
=
struct
(* TODO: detect the case when there is no unqualified tag.
In this case, it is possible to use a default namespace for
...
...
@@ -205,3 +171,29 @@ module Printer = struct
else
pr
^
":"
^
(
U
.
get_str
l
)
|
_
->
assert
false
end
module
InternalPrinter
=
struct
let
p
=
ref
(
Printer
.
printer
empty_table
)
let
set_table
t
=
p
:=
Printer
.
printer
t
let
ns
ns
=
U
.
to_string
(
value
ns
)
let
tag
x
=
Printer
.
register_tag
!
p
x
;
Printer
.
tag
!
p
x
let
attr
x
=
Printer
.
register_attr
!
p
x
;
Printer
.
attr
!
p
x
let
dump
ppf
=
List
.
iter
(
fun
(
pr
,
ns
)
->
Format
.
fprintf
ppf
"%a=>
\"
%a
\"
@."
U
.
print
pr
U
.
print
(
value
ns
)
)
(
Printer
.
prefixes
!
p
)
end
misc/ns.mli
View file @
1b67f651
...
...
@@ -10,19 +10,20 @@ val compare: t -> t -> int
val
hash
:
t
->
int
val
equal
:
t
->
t
->
bool
type
table
(* prefix => namespace *)
val
empty_table
:
table
(* Contains only xml -> "http://www.w3.org/XML/1998/namespace" *)
type
qname
=
t
*
Utf8
.
t
type
table
(* prefix => namespace *)
val
empty_table
:
table
(* Contains only xml *)
val
add_prefix
:
Utf8
.
t
->
t
->
table
->
table
val
dump_table
:
Format
.
formatter
->
table
->
unit
val
process_start_tag
:
table
->
string
->
(
string
*
string
)
list
->
table
*
qname
*
(
qname
*
Utf8
.
t
)
list
(*
val print_qname: Format.formatter -> qname -> unit
*)
val
map_tag
:
table
->
Utf8
.
t
->
qname
val
map_attr
:
table
->
Utf8
.
t
->
qname
...
...
@@ -44,7 +45,20 @@ end
(***)
module
InternalPrinter
:
sig
val
set_table
:
table
->
unit
val
ns
:
t
->
string
val
tag
:
qname
->
string
val
attr
:
qname
->
string
val
dump
:
Format
.
formatter
->
unit
end
(*
val register_prefix : Utf8.t -> t -> unit
val prefix : t -> Utf8.t
val dump_prefix_table : Format.formatter -> unit
*)
parser/parser.ml
View file @
1b67f651
...
...
@@ -111,7 +111,6 @@ EXTEND
let
schema
=
Schema_parser
.
parse_schema
schema_doc
in
[
mk
loc
(
SchemaDecl
(
name
,
schema
))]
|
(
name
,
ns
)
=
namespace_binding
->
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
...
...
types/atoms.ml
View file @
1b67f651
...
...
@@ -23,13 +23,13 @@ let mk_ascii s = mk Ns.empty (Utf8.mk s)
let
value
(
ns
,
x
)
=
(
ns
,
Symbol
.
value
x
)
let
vprint
ppf
(
(
ns
,
x
)
:
v
)
=
Ns
.
print_qname
ppf
(
ns
,
Symbol
.
value
x
)
let
vprint
ppf
(
ns
,
x
)
=
Format
.
fprintf
ppf
"%s"
(
Ns
.
InternalPrinter
.
tag
(
ns
,
Symbol
.
value
x
)
)
let
print_any_in_ns
ppf
ns
=
let
ns
=
Ns
.
prefix
ns
in
if
Utf8
.
get_str
ns
=
""
then
Format
.
fprintf
ppf
".:*"
else
Format
.
fprintf
ppf
"%
a
:*"
Utf8
.
print
ns
let
ns
=
Ns
.
InternalPrinter
.
ns
ns
in
if
ns
=
""
then
Format
.
fprintf
ppf
".:*"
else
Format
.
fprintf
ppf
"%
s
:*"
ns
let
print_v
ppf
a
=
Format
.
fprintf
ppf
"`%a"
vprint
a
...
...
types/ident.ml
View file @
1b67f651
...
...
@@ -14,12 +14,8 @@ module Label = struct
type
t
=
Ns
.
qname
let
equal
(
ns1
,
l1
)
(
ns2
,
l2
)
=
(
Ns
.
equal
ns1
ns2
)
&&
(
U
.
equal
l1
l2
)
let
hash
(
ns
,
l
)
=
Ns
.
hash
ns
+
17
*
U
.
hash
l
let
print
=
Ns
.
print_qname
let
to_string
x
=
let
b
=
Buffer
.
create
32
in
let
ppf
=
Format
.
formatter_of_buffer
b
in
print
ppf
x
;
Buffer
.
contents
b
let
to_string
x
=
Ns
.
InternalPrinter
.
attr
x
let
print
ppf
x
=
Format
.
fprintf
ppf
"%s"
(
to_string
x
)
end
module
LabelPool
=
Pool
.
Make
(
Label
)
...
...
typing/typer.ml
View file @
1b67f651
...
...
@@ -572,7 +572,7 @@ and pat_node s : Patterns.node =
Patterns
.
define
x
(
pat
(
descr
s
));
x
let
register_
global_
types
glb
b
=
let
register_types
glb
b
=
List
.
iter
(
fun
(
v
,
p
)
->
if
TypeEnv
.
mem
v
glb
.
tenv_names
...
...
@@ -596,12 +596,15 @@ let register_global_types glb b =
List
.
iter
(
fun
(
v
,
t
)
->
Types
.
Print
.
register_global
v
t
)
b
;
glb
let
register_ns
_prefix
glb
p
ns
=
let
register_ns
glb
p
ns
=
{
glb
with
tenv_nspref
=
Ns
.
add_prefix
p
ns
glb
.
tenv_nspref
}
let
dump_
global_
types
ppf
glb
=
let
dump_types
ppf
glb
=
TypeEnv
.
iter
(
fun
v
_
->
Format
.
fprintf
ppf
" %a"
U
.
print
v
)
glb
.
tenv_names
let
dump_ns
ppf
glb
=
Ns
.
dump_table
ppf
glb
.
tenv_nspref
let
do_typ
loc
r
=
let
s
=
compile_slot
r
in
flush_defs
()
;
...
...
@@ -735,7 +738,7 @@ let rec expr glb loc = function
and
(
fv2
,
b
)
=
branches
glb
b
in
exp
loc
(
Fv
.
cup
fv1
fv2
)
(
Typed
.
Try
(
e
,
b
))
|
NamespaceIn
(
pr
,
ns
,
e
)
->
let
glb
=
register_ns
_prefix
glb
pr
ns
in
let
glb
=
register_ns
glb
pr
ns
in
expr
glb
loc
e
...
...
@@ -790,10 +793,11 @@ let typ t = typ !glb t
let
expr
e
=
expr
!
glb
e
let
let_decl
p
e
=
let_decl
!
glb
p
e
let
register_global_types
l
=
glb
:=
register_
global_
types
!
glb
l
let
dump_global_types
ppf
=
dump_
global_
types
ppf
!
glb
let
register_global_types
l
=
glb
:=
register_types
!
glb
l
let
dump_global_types
ppf
=
dump_types
ppf
!
glb
let
register_ns_prefix
p
ns
=
glb
:=
register_ns_prefix
!
glb
p
ns
let
register_global_ns
p
ns
=
glb
:=
register_ns
!
glb
p
ns
let
dump_global_ns
ppf
=
dump_ns
ppf
!
glb
(* III. Type-checks *)
...
...
typing/typer.mli
View file @
1b67f651
...
...
@@ -14,9 +14,9 @@ type tenv
val
get_ns_table
:
tenv
->
Ns
.
table
val
register_global_types
:
(
U
.
t
*
Ast
.
ppat
)
list
->
unit
val
register_global_ns
:
U
.
t
->
Ns
.
t
->
unit
val
dump_global_types
:
Format
.
formatter
->
unit
val
register_ns_prefix
:
U
.
t
->
Ns
.
t
->
unit
val
dump_global_ns
:
Format
.
formatter
->
unit
val
typ
:
Ast
.
ppat
->
Typed
.
ttyp
val
pat
:
Ast
.
ppat
->
Typed
.
tpat
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment