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
eda0779c
Commit
eda0779c
authored
Jun 10, 2014
by
Pietro Abate
Browse files
Better error handling for astprinter
parent
94aec9e0
Changes
4
Hide whitespace changes
Inline
Side-by-side
tests/lambda/Makefile
View file @
eda0779c
...
...
@@ -13,7 +13,7 @@ INEXTFILES = misc/custom.ml misc/encodings.ml misc/upool.ml misc/ns.ml\
schema/schema_common.ml runtime/eval.mli runtime/eval.ml
\
compile/compile.ml types/compunit.mli types/compunit.ml types/var.ml
\
types/boolVar.ml misc/imap.ml types/atoms.ml types/intervals.ml
\
types/chars.mli types/chars.ml misc/bool.mli misc/bool.ml types/types.mli
\
types/chars.mli types/chars.ml misc/bool.mli misc/bool.ml types/types.mli
types/sample.ml
\
misc/stats.mli misc/stats.ml types/normal.mli types/normal.ml misc/pretty.mli
\
misc/pretty.ml types/types.ml compile/auto_pat.mli runtime/value.mli
\
runtime/value.ml schema/schema_types.mli schema/schema_validator.mli
\
...
...
tests/lambda/src/astprinter.ml
View file @
eda0779c
Printexc
.
record_backtrace
true
;;
let
verbose
=
ref
false
let
typed
=
ref
false
...
...
tests/lambda/src/testlib.ml
View file @
eda0779c
open
Camlp4
.
PreCast
Printexc
.
record_backtrace
true
;;
module
BIN
=
struct
open
Builtin_defs
...
...
@@ -40,22 +42,114 @@ module BIN = struct
types
end
let
wrap
f
s
=
try
f
s
with
|
Compute
.
Error
->
exit
3
|
Loc
.
Exc_located
(
loc
,
exn
)
->
let
l
=
Loc
.
start_line
loc
in
let
cbegin
=
Loc
.
start_off
loc
-
Loc
.
start_bol
loc
in
let
cend
=
Loc
.
stop_off
loc
-
Loc
.
start_bol
loc
in
Printf
.
eprintf
"File %s, line %d, characters %d-%d:
\n
"
(
Loc
.
file_name
loc
)
l
cbegin
cend
;
raise
exn
|
e
->
Printf
.
eprintf
"Runtime error.
\n
"
;
raise
e
let
print_norm
ppf
d
=
Types
.
Print
.
print
ppf
((
*
Types
.
normalize
*
)
d
)
let
print_sample
ppf
s
=
Sample
.
print
ppf
s
let
print_protect
ppf
s
=
Format
.
fprintf
ppf
"%s"
s
let
print_value
ppf
v
=
Value
.
print
ppf
v
let
rec
print_exn
ppf
=
function
|
Cduce_loc
.
Location
(
loc
,
w
,
exn
)
->
Cduce_loc
.
print_loc
ppf
(
loc
,
w
);
Cduce_loc
.
html_hilight
(
loc
,
w
);
print_exn
ppf
exn
|
Value
.
CDuceExn
v
->
Format
.
fprintf
ppf
"Uncaught CDuce exception: @[%a@]@."
print_value
v
|
Typer
.
WrongLabel
(
t
,
l
)
->
Format
.
fprintf
ppf
"Wrong record selection; field %a "
Ns
.
Label
.
print_attr
l
;
Format
.
fprintf
ppf
"not present in an expression of type:@.%a@."
print_norm
t
|
Typer
.
ShouldHave
(
t
,
msg
)
->
Format
.
fprintf
ppf
"This expression should have type:@.%a@.%a@."
print_norm
t
print_protect
msg
|
Typer
.
ShouldHave2
(
t1
,
msg
,
t2
)
->
Format
.
fprintf
ppf
"This expression should have type:@.%a@.%a %a@."
print_norm
t1
print_protect
msg
print_norm
t2
|
Typer
.
Error
s
->
Format
.
fprintf
ppf
"%a@."
print_protect
s
|
Typer
.
Constraint
(
s
,
t
)
->
Format
.
fprintf
ppf
"This expression should have type:@.%a@."
print_norm
t
;
Format
.
fprintf
ppf
"but its inferred type is:@.%a@."
print_norm
s
;
Format
.
fprintf
ppf
"which is not a subtype, as shown by the sample:@.%a@."
print_sample
(
Sample
.
get
(
Types
.
diff
s
t
))
|
Typer
.
NonExhaustive
t
->
Format
.
fprintf
ppf
"This pattern matching is not exhaustive@."
;
Format
.
fprintf
ppf
"Residual type:@.%a@."
print_norm
t
;
Format
.
fprintf
ppf
"Sample:@.%a@."
print_sample
(
Sample
.
get
t
)
|
Typer
.
UnboundId
(
x
,
tn
)
->
Format
.
fprintf
ppf
"Unbound identifier %a%s@."
Ident
.
print
x
(
if
tn
then
" (it is a type name)"
else
""
)
|
Ulexer
.
Error
(
i
,
j
,
s
)
->
let
loc
=
Cduce_loc
.
loc_of_pos
(
i
,
j
)
,
`Full
in
Cduce_loc
.
print_loc
ppf
loc
;
Cduce_loc
.
html_hilight
loc
;
Format
.
fprintf
ppf
"%s"
s
|
Parser
.
Error
s
|
Stream
.
Error
s
->
Format
.
fprintf
ppf
"Parsing error: %a@."
print_protect
s
|
Cduce_loc
.
Generic
s
->
Format
.
fprintf
ppf
"%a@."
print_protect
s
|
Ns
.
Label
.
Not_unique
((
ns1
,
s1
)
,
(
ns2
,
s2
))
->
Format
.
fprintf
ppf
"Collision on label hash: {%a}:%a, {%a}:%a"
Ns
.
U
.
print
(
Ns
.
Uri
.
value
ns1
)
Ns
.
U
.
print
s1
Ns
.
U
.
print
(
Ns
.
Uri
.
value
ns2
)
Ns
.
U
.
print
s2
|
Ns
.
Uri
.
Not_unique
(
ns1
,
ns2
)
->
Format
.
fprintf
ppf
"Collision on namespaces hash: %a, %a"
Ns
.
U
.
print
ns1
Ns
.
U
.
print
ns2
|
Sequence
.
Error
(
Sequence
.
CopyTag
(
t
,
expect
))
->
Format
.
fprintf
ppf
"Tags in %a will be copied, but only %a are allowed.@.Counter-example:%a@."
Types
.
Print
.
print
t
Types
.
Print
.
print
expect
Sample
.
print
(
Sample
.
get
(
Types
.
diff
t
expect
))
|
Sequence
.
Error
(
Sequence
.
CopyAttr
(
t
,
expect
))
->
Format
.
fprintf
ppf
"Attributes in %a will be copied, but only %a are allowed.@.Counter-example:%a@."
Types
.
Print
.
print
t
Types
.
Print
.
print
expect
Sample
.
print
(
Sample
.
get
(
Types
.
diff
t
expect
))
|
Sequence
.
Error
(
Sequence
.
UnderTag
(
t
,
exn
))
->
Format
.
fprintf
ppf
"Under tag %a:@."
Types
.
Print
.
print
t
;
print_exn
ppf
exn
|
exn
->
Format
.
fprintf
ppf
"%a@."
print_protect
(
Printexc
.
to_string
exn
)
let
catch_exn
ppf_err
exn
=
match
exn
with
|
(
End_of_file
|
Failure
_
|
Not_found
|
Invalid_argument
_
|
Sys
.
Break
)
as
e
->
raise
e
|
exn
->
print_exn
ppf_err
exn
;
Format
.
fprintf
ppf_err
"@."
;
raise
exn
;;
(* Cduce program -> Typed *)
let
parse_cduce
?
(
verbose
=
false
)
s
=
let
astexpr
=
Parser
.
expr
(
Stream
.
of_string
s
)
in
let
texpr
=
fst
(
Typer
.
type_expr
BIN
.
env
astexpr
)
in
let
astexpr
=
try
Parser
.
expr
(
Stream
.
of_string
s
)
with
exn
->
catch_exn
Format
.
err_formatter
exn
in
let
texpr
=
try
fst
(
Typer
.
type_expr
BIN
.
env
astexpr
)
with
exn
->
catch_exn
Format
.
err_formatter
exn
in
if
verbose
then
Format
.
printf
"Cduce Typed %s ====>
\n
%s
\n
%!@."
s
(
Typed
.
Print
.
typed_to_string
texpr
);
texpr
...
...
@@ -70,36 +164,42 @@ let parse_texpr ?(verbose=false) s =
(* --> Lambda *)
let
parse_lexpr
?
(
verbose
=
false
)
texpr
=
let
lambdaexpr
,
lsize
=
Compile
.
compile_expr
Compile
.
empty_toplevel
texpr
in
let
lambdaexpr
,
lsize
=
try
Compile
.
compile_expr
Compile
.
empty_toplevel
texpr
with
exn
->
catch_exn
Format
.
err_formatter
exn
in
if
verbose
then
Format
.
printf
"Lambda : %s
\n
"
(
Lambda
.
Print
.
lambda_to_string
lambdaexpr
);
Format
.
printf
"Lambda : %s
\n
%!@.
"
(
Lambda
.
Print
.
lambda_to_string
lambdaexpr
);
lambdaexpr
,
lsize
(* --> Value *)
let
parse_vexpr
?
(
verbose
=
false
)
(
lambdaexpr
,
lsize
)
=
let
evalexpr
=
Eval
.
expr
lambdaexpr
lsize
in
let
evalexpr
=
try
Eval
.
expr
lambdaexpr
lsize
with
exn
->
catch_exn
Format
.
err_formatter
exn
in
if
verbose
then
Format
.
printf
"Value : %s
\n
"
(
Value
.
value_to_string
evalexpr
);
Format
.
printf
"Value : %s
\n
%!@.
"
(
Value
.
value_to_string
evalexpr
);
evalexpr
(* Cduce program -> Lambda *)
let
parse_cduce_lexpr
?
(
verbose
=
false
)
s
=
let
texpr
=
wrap
(
parse_cduce
~
verbose
)
s
in
let
texpr
=
parse_cduce
~
verbose
s
in
parse_lexpr
~
verbose
:
true
texpr
(* Cduce program -> Value *)
let
parse_cduce_vexpr
?
(
verbose
=
false
)
s
=
let
texpr
=
wrap
(
parse_cduce
~
verbose
)
s
in
let
texpr
=
parse_cduce
~
verbose
s
in
let
lambdaexpr
,
lsize
=
parse_lexpr
~
verbose
texpr
in
parse_vexpr
~
verbose
:
true
(
lambdaexpr
,
lsize
)
(* Typed AST -> Lambda *)
let
parse_texpr_lexpr
?
(
verbose
=
false
)
s
=
let
texpr
=
wrap
(
parse_texpr
~
verbose
)
s
in
let
texpr
=
parse_texpr
~
verbose
s
in
parse_lexpr
~
verbose
:
true
texpr
(* Typed AST -> Value *)
let
parse_texpr_vexpr
?
(
verbose
=
false
)
s
=
let
texpr
=
wrap
(
parse_texpr
~
verbose
)
s
in
let
texpr
=
parse_texpr
~
verbose
s
in
let
lambdaexpr
,
lsize
=
parse_lexpr
~
verbose
texpr
in
parse_vexpr
~
verbose
:
true
(
lambdaexpr
,
lsize
)
tests/lambda/src/typedTests.ml
View file @
eda0779c
...
...
@@ -2,8 +2,8 @@ open OUnit2
open
Testlib
let
run_test_typer
msg
expected
totest
_
=
let
expected
=
wrap
parse_texpr
expected
in
let
totest
=
wrap
parse_cduce
totest
in
let
expected
=
parse_texpr
expected
in
let
totest
=
parse_cduce
totest
in
assert_equal
~
msg
:
msg
~
printer
:
(
fun
x
->
Typed
.
Print
.
typed_to_string
x
)
expected
totest
let
run_test_compile
msg
expected
totest
_
=
...
...
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