summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2010-10-10 20:33:10 -0400
committerGravatar Adam Chlipala <adam@chlipala.net>2010-10-10 20:33:10 -0400
commit4e608544ebe87dd991d53ded5267f14f5df93b8b (patch)
tree4de957d9837f39c79ebc56b5ac2935e31a28d0b5 /src
parent42d55420b84994ee61c0a4645d21d275dbbea2cd (diff)
:::_ notation; switch to TooDeep error message
Diffstat (limited to 'src')
-rw-r--r--src/elab_err.sig1
-rw-r--r--src/elab_err.sml2
-rw-r--r--src/elaborate.sml4
-rw-r--r--src/urweb.grm12
-rw-r--r--src/urweb.lex1
5 files changed, 16 insertions, 4 deletions
diff --git a/src/elab_err.sig b/src/elab_err.sig
index fbe55a5b..3dfd5d4e 100644
--- a/src/elab_err.sig
+++ b/src/elab_err.sig
@@ -58,6 +58,7 @@ signature ELAB_ERR = sig
| CRecordFailure of Elab.con * Elab.con * (Elab.con * Elab.con * Elab.con) option
| TooLifty of ErrorMsg.span * ErrorMsg.span
| TooUnify of Elab.con * Elab.con
+ | TooDeep
val cunifyError : ElabEnv.env -> cunify_error -> unit
diff --git a/src/elab_err.sml b/src/elab_err.sml
index f8a16294..7d5e6be8 100644
--- a/src/elab_err.sml
+++ b/src/elab_err.sml
@@ -121,6 +121,7 @@ datatype cunify_error =
| CRecordFailure of con * con * (con * con * con) option
| TooLifty of ErrorMsg.span * ErrorMsg.span
| TooUnify of con * con
+ | TooDeep
fun cunifyError env err =
case err of
@@ -162,6 +163,7 @@ fun cunifyError env err =
(ErrorMsg.errorAt (#2 c1) "Substitution in constructor is blocked by a too-deep unification variable";
eprefaces' [("Replacement", p_con env c1),
("Body", p_con env c2)])
+ | TooDeep => ErrorMsg.error "Can't reverse-engineer unification variable lifting"
datatype exp_error =
UnboundExp of ErrorMsg.span * string
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 7bf687e2..dcae4650 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1079,13 +1079,13 @@
err COccursCheckFailed
else
(r := SOME (squish nl c2All)
- handle CantSquish => err CIncompatible)
+ handle CantSquish => err (fn _ => TooDeep))
| (_, L'.CUnif (nl, _, _, _, r)) =>
if occursCon r c1All then
err COccursCheckFailed
else
(r := SOME (squish nl c1All)
- handle CantSquish => err CIncompatible)
+ handle CantSquish => err (fn _ => TooDeep))
| (L'.CUnit, L'.CUnit) => ()
diff --git a/src/urweb.grm b/src/urweb.grm
index 0c85ad7f..21c4a50c 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -212,7 +212,7 @@ fun tnamesOf (e, _) =
| STRING of string | INT of Int64.int | FLOAT of Real64.real | CHAR of char
| SYMBOL of string | CSYMBOL of string
| LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
- | EQ | COMMA | COLON | DCOLON | DCOLONWILD | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR
+ | EQ | COMMA | COLON | DCOLON | DCOLONWILD | TCOLON | TCOLONWILD | DOT | HASH | UNDER | UNDERUNDER | BAR
| PLUS | MINUS | DIVIDE | DOTDOTDOT | MOD | AT
| CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS
| DATATYPE | OF
@@ -394,7 +394,7 @@ fun tnamesOf (e, _) =
%left ANDALSO
%left ORELSE
%nonassoc COLON
-%nonassoc DCOLON TCOLON
+%nonassoc DCOLON TCOLON DCOLONWILD TCOLONWILD
%left UNION INTERSECT EXCEPT
%right COMMA
%right JOIN INNER CROSS OUTER LEFT RIGHT FULL
@@ -1111,6 +1111,14 @@ earga : LBRACK SYMBOL RBRACK (fn (e, t) =>
((ECAbs (kcolon, SYMBOL, kind, e), loc),
(TCFun (kcolon, SYMBOL, kind, t), loc))
end)
+ | LBRACK SYMBOL TCOLONWILD RBRACK (fn (e, t) =>
+ let
+ val loc = s (LBRACKleft, RBRACKright)
+ val kind = (KWild, loc)
+ in
+ ((ECAbs (Implicit, SYMBOL, kind, e), loc),
+ (TCFun (Implicit, SYMBOL, kind, t), loc))
+ end)
| LBRACK cexp TWIDDLE cexp RBRACK(fn (e, t) =>
let
val loc = s (LBRACKleft, RBRACKright)
diff --git a/src/urweb.lex b/src/urweb.lex
index a6df5f1b..fa8c5dde 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -371,6 +371,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
<INITIAL> "<=" => (Tokens.LE (pos yypos, pos yypos + size yytext));
<INITIAL> ">=" => (Tokens.GE (pos yypos, pos yypos + size yytext));
<INITIAL> "," => (Tokens.COMMA (pos yypos, pos yypos + size yytext));
+<INITIAL> ":::_" => (Tokens.TCOLONWILD (pos yypos, pos yypos + size yytext));
<INITIAL> ":::" => (Tokens.TCOLON (pos yypos, pos yypos + size yytext));
<INITIAL> "::_" => (Tokens.DCOLONWILD (pos yypos, pos yypos + size yytext));
<INITIAL> "::" => (Tokens.DCOLON (pos yypos, pos yypos + size yytext));