Skip to content
GitLab
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
1d82d5dc
Commit
1d82d5dc
authored
May 06, 2014
by
Pietro Abate
Browse files
Remove Variance from parser and cleanup stale code
parent
a94cbb16
Changes
4
Hide whitespace changes
Inline
Side-by-side
tests/libtest/tallyingTest.ml
View file @
1d82d5dc
open
OUnit
open
Types
let
parse_typ
?
(
variance
=
`Covariant
)
s
=
let
parse_typ
s
=
let
st
=
Stream
.
of_string
s
in
let
astpat
=
Parser
.
pat
st
in
let
nodepat
=
Typer
.
typ
~
variance
Builtin
.
env
astpat
in
let
nodepat
=
Typer
.
typ
Builtin
.
env
astpat
in
Types
.
descr
nodepat
;;
...
...
@@ -34,11 +34,7 @@ end)
module
MSet
=
OUnitDiff
.
SetMake
(
struct
type
t
=
Tallying
.
CS
.
m
let
compare
=
(* the abstract field is ignored in the comparison *)
let
a
=
Types
.
abstract
Abstract
.
any
in
let
cmp
t1
t2
=
Types
.
compare
(
diff
t1
a
)
(
diff
t2
a
)
in
Tallying
.
CS
.
M
.
compare
(*cmp *)
let
compare
=
Tallying
.
CS
.
M
.
compare
let
pp_printer
=
Tallying
.
CS
.
pp_m
let
pp_print_sep
=
OUnitDiff
.
pp_comma_separator
end
)
...
...
@@ -58,18 +54,10 @@ let mk_s ll =
)
Tallying
.
CS
.
S
.
empty
ll
let
mk_union_res
l1
l2
=
let
aux_merge
k
v1
v2
=
match
(
k
,
v1
,
v2
)
with
|
(
k
,
None
,
None
)
->
assert
false
|
(
k
,
Some
v
,
None
)
->
Some
v
|
(
k
,
None
,
Some
v
)
->
Some
v
|
((
_
,
v
)
,
Some
x
,
Some
y
)
when
Types
.
equiv
x
y
->
Some
x
|
((
true
,
v
)
,
Some
x
,
Some
y
)
->
assert
false
|
((
false
,
v
)
,
Some
x
,
Some
y
)
->
assert
false
in
let
aux
l
=
List
.
fold_left
(
fun
acc
->
function
|
P
(
V
v
,
s
)
->
Tallying
.
CS
.
M
.
merge
(*aux_merge*)
acc
(
Tallying
.
CS
.
M
.
singleton
(
(
*
true
,*
)
Var
.
mk
v
)
(
Types
.
empty
,
parse_typ
s
))
|
N
(
s
,
V
v
)
->
Tallying
.
CS
.
M
.
merge
(*aux_merge*)
acc
(
Tallying
.
CS
.
M
.
singleton
(
(
*
false
,*
)
Var
.
mk
v
)
(
parse_typ
s
,
Types
.
any
))
|
P
(
V
v
,
s
)
->
Tallying
.
CS
.
M
.
merge
acc
(
Tallying
.
CS
.
M
.
singleton
(
Var
.
mk
v
)
(
Types
.
empty
,
parse_typ
s
))
|
N
(
s
,
V
v
)
->
Tallying
.
CS
.
M
.
merge
acc
(
Tallying
.
CS
.
M
.
singleton
(
Var
.
mk
v
)
(
parse_typ
s
,
Types
.
any
))
)
Tallying
.
CS
.
M
.
empty
l
in
match
l1
,
l2
with
...
...
types/var.ml
View file @
1d82d5dc
type
t
=
{
mutable
variance
:
[
`Covariant
|
`ContraVariant
|
`Both
|
`None
]
;
fresh
:
bool
;
id
:
String
.
t
;
}
let
make_id
?
(
fresh
=
false
)
?
(
variance
=
`None
)
id
=
{
id
=
id
;
variance
=
variance
;
fresh
=
fresh
}
let
make_id
?
(
fresh
=
false
)
id
=
{
id
=
id
;
fresh
=
fresh
}
let
dump
ppf
t
=
let
to_string
=
function
|
`ContraVariant
->
"contravariant"
|
`Covariant
->
"covariant"
|
`Both
->
"invariant"
|
`None
->
"indetermined"
in
Format
.
fprintf
ppf
"{id=%s;variance=%s;fresh=%b}"
t
.
id
(
to_string
t
.
variance
)
t
.
fresh
let
dump
ppf
t
=
Format
.
fprintf
ppf
"{id=%s;fresh=%b}"
t
.
id
t
.
fresh
let
compare
x
y
=
Pervasives
.
compare
x
.
id
y
.
id
let
equal
x
y
=
Pervasives
.
compare
x
.
id
y
.
id
=
0
...
...
@@ -28,17 +20,6 @@ let print ppf (`Var x) = Format.fprintf ppf "`$%s" x.id
let
compare
(
`Var
x
)
(
`Var
y
)
=
compare
x
y
let
equal
v1
v2
=
(
compare
v1
v2
)
=
0
let
ch_variance
variance
(
`Var
t
)
=
match
t
.
variance
,
variance
with
|
`None
,_
->
t
.
variance
<-
variance
|
`Both
,_
->
()
|
`ContraVariant
,
`ContraVariant
|
`Covariant
,
`Covariant
->
()
|_,_
->
t
.
variance
<-
`Both
let
set_variance
variance
(
`Var
t
)
=
t
.
variance
<-
variance
let
variance
(
`Var
t
)
=
t
.
variance
let
id
(
`Var
t
)
=
t
.
id
let
is_fresh
(
`Var
t
)
=
t
.
fresh
...
...
@@ -76,14 +57,14 @@ module Make (X : Custom.T) = struct
|
`Var
x
->
dump
ppf
(
`Var
x
)
end
let
mk
?
fresh
?
variance
id
=
`Var
(
make_id
?
fresh
?
variance
id
)
let
mk
?
fresh
id
=
`Var
(
make_id
?
fresh
id
)
let
fresh
:
?
pre
:
string
->
?
variance
:
[
`None
|
`Both
|
`ContraVariant
|
`Covariant
]
->
unit
->
[
>
var
]
=
let
fresh
:
?
pre
:
string
->
unit
->
[
>
var
]
=
let
counter
=
ref
0
in
fun
?
(
pre
=
"_fresh_"
)
->
fun
?
variance
->
fun
_
->
fun
?
(
pre
=
"_fresh_"
)
->
fun
_
->
let
id
=
(
Printf
.
sprintf
"%s%d"
pre
!
counter
)
in
let
v
=
mk
~
fresh
:
true
?
variance
id
in
let
v
=
mk
~
fresh
:
true
id
in
incr
counter
;
v
typing/typer.ml
View file @
1d82d5dc
...
...
@@ -314,57 +314,42 @@ module IType = struct
all_delayed
:=
[]
;
List
.
iter
check_one_delayed
l
let
rec
derecurs
variance
env
p
=
let
neg
=
function
|
`Covariant
->
`ContraVariant
|
`ContraVariant
->
`Covariant
|
cv
->
cv
in
let
rec
derecurs
env
p
=
match
p
.
descr
with
|
TVar
s
->
begin
try
let
v
=
Hashtbl
.
find
env
.
penv_var
s
in
Var
.
ch_variance
variance
v
;
mk_type
(
Types
.
var
v
)
with
Not_found
->
begin
let
v
=
Var
.
mk
~
variance
s
in
Hashtbl
.
add
env
.
penv_var
s
v
;
mk_type
(
Types
.
var
v
)
end
end
|
TVar
s
->
mk_type
(
Types
.
var
(
Var
.
mk
s
))
|
PatVar
ids
->
derecurs_var
env
p
.
loc
ids
|
Recurs
(
p
,
b
)
->
derecurs
variance
(
fst
(
derecurs_def
variance
env
b
))
p
|
Recurs
(
p
,
b
)
->
derecurs
(
fst
(
derecurs_def
env
b
))
p
|
Internal
t
->
mk_type
t
|
NsT
ns
->
mk_type
(
Types
.
atom
(
Atoms
.
any_in_ns
(
parse_ns
env
.
penv_tenv
p
.
loc
ns
)))
|
Or
(
p1
,
p2
)
->
mk_or
(
derecurs
variance
env
p1
)
(
derecurs
variance
env
p2
)
|
And
(
p1
,
p2
)
->
mk_and
(
derecurs
variance
env
p1
)
(
derecurs
variance
env
p2
)
|
Diff
(
p1
,
p2
)
->
mk_diff
(
derecurs
variance
env
p1
)
(
derecurs
(
neg
variance
)
env
p2
)
|
Prod
(
p1
,
p2
)
->
mk_prod
(
derecurs
variance
env
p1
)
(
derecurs
variance
env
p2
)
|
XmlT
(
p1
,
p2
)
->
mk_xml
(
derecurs
variance
env
p1
)
(
derecurs
variance
env
p2
)
|
Arrow
(
p1
,
p2
)
->
mk_arrow
(
derecurs
(
neg
variance
)
env
p1
)
(
derecurs
variance
env
p2
)
|
Optional
p
->
mk_optional
(
derecurs
variance
env
p
)
|
Or
(
p1
,
p2
)
->
mk_or
(
derecurs
env
p1
)
(
derecurs
env
p2
)
|
And
(
p1
,
p2
)
->
mk_and
(
derecurs
env
p1
)
(
derecurs
env
p2
)
|
Diff
(
p1
,
p2
)
->
mk_diff
(
derecurs
env
p1
)
(
derecurs
env
p2
)
|
Prod
(
p1
,
p2
)
->
mk_prod
(
derecurs
env
p1
)
(
derecurs
env
p2
)
|
XmlT
(
p1
,
p2
)
->
mk_xml
(
derecurs
env
p1
)
(
derecurs
env
p2
)
|
Arrow
(
p1
,
p2
)
->
mk_arrow
(
derecurs
env
p1
)
(
derecurs
env
p2
)
|
Optional
p
->
mk_optional
(
derecurs
env
p
)
|
Record
(
o
,
r
)
->
let
aux
=
function
|
(
p
,
Some
e
)
->
(
derecurs
variance
env
p
,
Some
(
derecurs
variance
env
e
))
|
(
p
,
None
)
->
derecurs
variance
env
p
,
None
in
|
(
p
,
Some
e
)
->
(
derecurs
env
p
,
Some
(
derecurs
env
e
))
|
(
p
,
None
)
->
derecurs
env
p
,
None
in
mk_record
o
(
parse_record
env
.
penv_tenv
p
.
loc
aux
r
)
|
Constant
(
x
,
c
)
->
mk_constant
(
ident
env
.
penv_tenv
p
.
loc
x
)
(
const
env
.
penv_tenv
p
.
loc
c
)
|
Cst
c
->
mk_type
(
Types
.
constant
(
const
env
.
penv_tenv
p
.
loc
c
))
|
Regexp
r
->
rexp
(
derecurs_regexp
variance
env
r
)
|
Concat
(
p1
,
p2
)
->
mk_concat
(
derecurs
variance
env
p1
)
(
derecurs
variance
env
p2
)
|
Merge
(
p1
,
p2
)
->
mk_merge
(
derecurs
variance
env
p1
)
(
derecurs
variance
env
p2
)
|
Regexp
r
->
rexp
(
derecurs_regexp
env
r
)
|
Concat
(
p1
,
p2
)
->
mk_concat
(
derecurs
env
p1
)
(
derecurs
env
p2
)
|
Merge
(
p1
,
p2
)
->
mk_merge
(
derecurs
env
p1
)
(
derecurs
env
p2
)
and
derecurs_regexp
variance
env
=
function
and
derecurs_regexp
env
=
function
|
Epsilon
->
mk_epsilon
|
Elem
p
->
mk_elem
(
derecurs
variance
env
p
)
|
Guard
p
->
mk_guard
(
derecurs
variance
env
p
)
|
Seq
(
p1
,
p2
)
->
mk_seq
(
derecurs_regexp
variance
env
p1
)
(
derecurs_regexp
variance
env
p2
)
|
Alt
(
p1
,
p2
)
->
mk_alt
(
derecurs_regexp
variance
env
p1
)
(
derecurs_regexp
variance
env
p2
)
|
Star
p
->
mk_star
(
derecurs_regexp
variance
env
p
)
|
WeakStar
p
->
mk_weakstar
(
derecurs_regexp
variance
env
p
)
|
SeqCapture
(
loc
,
x
,
p
)
->
mk_seqcapt
(
ident
env
.
penv_tenv
loc
x
)
(
derecurs_regexp
variance
env
p
)
|
Elem
p
->
mk_elem
(
derecurs
env
p
)
|
Guard
p
->
mk_guard
(
derecurs
env
p
)
|
Seq
(
p1
,
p2
)
->
mk_seq
(
derecurs_regexp
env
p1
)
(
derecurs_regexp
env
p2
)
|
Alt
(
p1
,
p2
)
->
mk_alt
(
derecurs_regexp
env
p1
)
(
derecurs_regexp
env
p2
)
|
Star
p
->
mk_star
(
derecurs_regexp
env
p
)
|
WeakStar
p
->
mk_weakstar
(
derecurs_regexp
env
p
)
|
SeqCapture
(
loc
,
x
,
p
)
->
mk_seqcapt
(
ident
env
.
penv_tenv
loc
x
)
(
derecurs_regexp
env
p
)
and
derecurs_var
env
loc
ids
=
match
ids
with
...
...
@@ -377,7 +362,7 @@ module IType = struct
|
ids
->
mk_type
(
find_global_type
env
.
penv_tenv
loc
ids
)
and
derecurs_def
variance
env
b
=
and
derecurs_def
env
b
=
let
seen
=
ref
IdSet
.
empty
in
let
b
=
List
.
map
...
...
@@ -393,11 +378,11 @@ module IType = struct
let
n
=
List
.
fold_left
(
fun
env
(
v
,
p
,
s
)
->
Env
.
add
v
s
env
)
env
.
penv_derec
b
in
let
env
=
{
env
with
penv_derec
=
n
}
in
List
.
iter
(
fun
(
v
,
p
,
s
)
->
link
s
(
derecurs
variance
env
p
))
b
;
List
.
iter
(
fun
(
v
,
p
,
s
)
->
link
s
(
derecurs
env
p
))
b
;
(
env
,
b
)
let
derec
?
(
variance
=
`Covariant
)
penv
p
=
let
d
=
derecurs
variance
penv
p
in
let
derec
penv
p
=
let
d
=
derecurs
penv
p
in
elim_concats
()
;
check_delayed
()
;
internalize
d
;
...
...
@@ -413,7 +398,7 @@ module IType = struct
(
"Capture variable not allowed: "
^
(
Ident
.
to_string
x
))
let
type_defs
env
b
=
let
_
,
b'
=
derecurs_def
`Covariant
(
penv
env
)
b
in
let
_
,
b'
=
derecurs_def
(
penv
env
)
b
in
elim_concats
()
;
check_delayed
()
;
let
aux
loc
d
=
...
...
@@ -437,9 +422,9 @@ module IType = struct
try
type_defs
env
b
with
exn
->
clean_on_err
()
;
raise
exn
let
typ
?
(
variance
=
`Covariant
)
env
t
=
let
typ
env
t
=
try
let
d
=
derec
~
variance
(
penv
env
)
t
in
let
d
=
derec
(
penv
env
)
t
in
check_no_fv
t
.
loc
d
;
try
typ_node
d
with
Patterns
.
Error
s
->
raise_loc_generic
t
.
loc
s
...
...
typing/typer.mli
View file @
1d82d5dc
...
...
@@ -22,7 +22,7 @@ val find_value: id -> t -> Types.t
val
enter_type
:
id
->
Types
.
t
->
t
->
t
val
iter_values
:
t
->
(
id
->
Types
.
t
->
unit
)
->
unit
val
typ
:
?
variance
:
[
`Covariant
|
`ContraVariant
|
`Both
|
`None
]
->
t
->
Ast
.
ppat
->
Types
.
Node
.
t
val
typ
:
t
->
Ast
.
ppat
->
Types
.
Node
.
t
val
pat
:
t
->
Ast
.
ppat
->
Patterns
.
node
val
dump_types
:
Format
.
formatter
->
t
->
unit
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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