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
169c58ca
Commit
169c58ca
authored
Sep 10, 2014
by
Pietro Abate
Browse files
Fix printer for parametric types
parent
abbc0f5d
Changes
5
Hide whitespace changes
Inline
Side-by-side
schema/schema_converter.ml
View file @
169c58ca
...
...
@@ -171,7 +171,7 @@ let load_schema schema_name uri =
let
schema_name
=
schema_name
^
"."
in
let
log_schema_component
kind
name
cd_type
=
if
not
(
Schema_builtin
.
is
name
)
then
begin
Types
.
Print
.
register_global
(
schema_name
,
name
)
cd_type
;
Types
.
Print
.
register_global
(
schema_name
,
name
,
[
||
]
)
cd_type
;
(* Format.fprintf Format.std_formatter "Registering schema %s: %a@." kind
Ns.QName.print name; *)
...
...
types/builtin.ml
View file @
169c58ca
...
...
@@ -32,7 +32,7 @@ let env =
List
.
fold_left
(
fun
accu
(
n
,
t
)
->
let
n
=
(
Ns
.
empty
,
Ident
.
U
.
mk
n
)
in
Types
.
Print
.
register_global
(
""
,
n
)
t
;
Types
.
Print
.
register_global
(
""
,
n
,
[
||
]
)
t
;
Typer
.
enter_type
(
Ident
.
ident
n
)
t
accu
)
Typer
.
empty_env
...
...
types/types.ml
View file @
169c58ca
...
...
@@ -1642,7 +1642,7 @@ module Print = struct
let
is_regexp
t
=
subtype
t
seqs_descr
type
gname
=
string
*
Ns
.
QName
.
t
type
gname
=
string
*
Ns
.
QName
.
t
*
t
array
type
nd
=
{
id
:
int
;
...
...
@@ -1699,18 +1699,18 @@ module Print = struct
let
named
=
ref
DescrMap
.
empty
let
named_xml
=
ref
DescrPairMap
.
empty
let
register_global
(
cu
,
name
)
d
=
let
register_global
(
cu
,
name
,
al
)
d
=
let
d
=
uniq
d
in
if
equal
{
d
with
xml
=
BoolPair
.
empty
}
empty
then
begin
match
Product
.
get
~
kind
:
`XML
d
with
|
[(
t1
,
t2
)]
->
if
DescrPairMap
.
mem
(
t1
,
t2
)
!
named_xml
then
()
else
named_xml
:=
DescrPairMap
.
add
(
t1
,
t2
)
(
cu
,
name
)
!
named_xml
named_xml
:=
DescrPairMap
.
add
(
t1
,
t2
)
(
cu
,
name
,
al
)
!
named_xml
|
_
->
()
end
;
if
DescrMap
.
mem
d
!
named
then
()
else
named
:=
DescrMap
.
add
d
(
cu
,
name
)
!
named
else
named
:=
DescrMap
.
add
d
(
cu
,
name
,
al
)
!
named
let
unregister_global
d
=
let
d
=
uniq
d
in
...
...
@@ -1950,9 +1950,7 @@ module Print = struct
in
(* sequence type. We do not want to split types such as
Any into Any \ [ Any *] | Any, and likewise, write
Atom \ [] | [].
*)
Atom \ [] | []. *)
let
finite_atoms
=
try
match
BoolAtoms
.
get
tt
.
atoms
with
|
[
(
[
`Atm
bdd
]
,
[]
)
]
->
...
...
@@ -2109,14 +2107,14 @@ module Print = struct
let
rec
assign_name
s
=
incr
gen
;
match
s
.
state
with
|
`None
->
let
g
=
!
gen
in
s
.
state
<-
`Marked
;
List
.
iter
assign_name_rec
s
.
def
;
(* + 8 allows to disable sharing for small subtrees *)
if
(
s
.
state
==
`Marked
)
&&
(
!
gen
<
g
+
8
)
then
s
.
state
<-
`None
|
`Marked
->
s
.
state
<-
`Named
(
name
()
);
to_print
:=
s
::
!
to_print
|
_
->
()
|
`None
->
let
g
=
!
gen
in
s
.
state
<-
`Marked
;
List
.
iter
assign_name_rec
s
.
def
;
(* + 8 allows to disable sharing for small subtrees *)
if
(
s
.
state
==
`Marked
)
&&
(
!
gen
<
g
+
8
)
then
s
.
state
<-
`None
|
`Marked
->
s
.
state
<-
`Named
(
name
()
);
to_print
:=
s
::
!
to_print
|
_
->
()
and
assign_name_rec
=
function
|
Neg
t
->
assign_name
t
|
Abs
t
->
assign_name
t
...
...
@@ -2141,9 +2139,6 @@ module Print = struct
|
Pretty
.
Star
r
|
Pretty
.
Plus
r
->
assign_name_regexp
r
|
Pretty
.
Trans
t
->
assign_name
t
let
print_gname
ppf
(
cu
,
n
)
=
Format
.
fprintf
ppf
"%s%a"
cu
Ns
.
QName
.
print
n
(* operator precedences:
20 names, constants, ...
10 : <t1 >
...
...
@@ -2202,7 +2197,11 @@ module Print = struct
loop
(
List
.
rev
l
);
cpar
ppf
~
level
:
pri_op
pri
let
get_name
=
function
|
{
state
=
`Named
n
}
->
n
|
_
->
assert
false
let
rec
do_print_slot
(
pri
:
Level
.
t
)
ppf
s
=
match
s
.
state
with
|
`Named
n
->
U
.
print
ppf
n
...
...
@@ -2315,11 +2314,13 @@ module Print = struct
(
List
.
rev
(
c
::
accu
)
,
None
)
|
r
->
(
List
.
rev
accu
,
Some
r
)
let
get_name
=
function
|
{
state
=
`Named
n
}
->
n
|
_
->
assert
false
and
print_gname
ppf
=
function
|
(
cu
,
n
,
[
||
])
->
Format
.
fprintf
ppf
"%s%a"
cu
Ns
.
QName
.
print
n
|
(
cu
,
n
,
al
)
->
Format
.
fprintf
ppf
"%s%a(%s)"
cu
Ns
.
QName
.
print
n
(
String
.
concat
","
(
List
.
map
(
Utils
.
string_of_formatter
pp_type
)
(
Array
.
to_list
al
)))
let
pp_type
ppf
t
=
and
pp_type
ppf
t
=
let
t
=
uniq
t
in
let
t
=
prepare
t
in
assign_name
t
;
...
...
@@ -2342,7 +2343,7 @@ module Print = struct
to_print
:=
[]
;
DescrHash
.
clear
memo
let
pp_noname
ppf
t
=
and
pp_noname
ppf
t
=
let
old_named
=
!
named
in
let
old_named_xml
=
!
named_xml
in
unregister_global
t
;
...
...
@@ -2385,13 +2386,9 @@ struct
Format
.
pp_print_flush
ppf
()
;
Buffer
.
contents
b
let
get_gname
(
cu
,
n
)
=
Ns
.
QName
.
to_string
n
;;
let
get_gtype
t
=
get_gname
t
;;
let
get_gname
(
cu
,
n
,_
)
=
Ns
.
QName
.
to_string
n
(* from ns:atom, returns :atom. *)
(* from ns:atom, returns :atom. *)
let
strip_namespace
tagname
=
let
len
=
String
.
length
tagname
in
let
cur
=
ref
len
in
...
...
@@ -2420,7 +2417,7 @@ struct
|
`Named
n
->
trace
(
"debug:convert "
^
(
U
.
to_string
n
))
;
convert_real
name
s
.
Print
.
def
|
`GlobalName
n
->
let
t
=
get_g
typ
e
n
in
let
t
=
get_g
nam
e
n
in
trace
(
"debug:convert:globalname: "
^
t
);
(
match
t
with
|
"Int"
|
"String"
|
"Float"
|
"Bool"
...
...
@@ -2487,8 +2484,6 @@ struct
trace
(
"debug:convert_attrs:Named "
^
(
U
.
to_string
n
));
convert_record
flags
(
r
,
some
,
none
)
(* convert_real name s.Print.def *)
(* | `GlobalName n -> get_gtype n name *)
|
_
->
trace
"convert_attrs:_"
;
()
and
convert_record
flags
(
r
,
some
,
none
)
=
List
.
iter
...
...
types/types.mli
View file @
169c58ca
...
...
@@ -331,7 +331,7 @@ val cond_partition: t -> (t * t) list -> t list
to answer all the questions. *)
module
Print
:
sig
type
gname
=
string
*
Ns
.
QName
.
t
type
gname
=
string
*
Ns
.
QName
.
t
*
t
array
val
register_global
:
gname
->
t
->
unit
val
pp_const
:
Format
.
formatter
->
const
->
unit
val
pp_type
:
Format
.
formatter
->
t
->
unit
...
...
typing/typer.ml
View file @
169c58ca
...
...
@@ -193,7 +193,7 @@ let iter_values env f =
let
register_types
cu
env
=
Env
.
iter
(
fun
x
->
function
|
Type
(
t
,_
)
->
Types
.
Print
.
register_global
(
cu
,
(
Ident
.
value
x
))
t
|
Type
(
t
,_
)
->
Types
.
Print
.
register_global
(
cu
,
(
Ident
.
value
x
)
,
[
||
]
)
t
|
_
->
()
)
env
.
ids
...
...
@@ -460,7 +460,9 @@ module IType = struct
(
v'
,
t
,
al
)
)
b
b'
in
List
.
iter
(
fun
(
v
,
t
,_
)
->
Types
.
Print
.
register_global
(
""
,
v
)
t
)
b
;
List
.
iter
(
fun
(
v
,
t
,
al
)
->
Types
.
Print
.
register_global
(
""
,
v
,
Array
.
map
Types
.
var
al
)
t
)
b
;
enter_types
b
env
let
type_defs
env
b
=
...
...
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