HCoop
/
hcoop
/
domtool2.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Custom base types
[hcoop/domtool2.git]
/
src
/
tycheck.sml
diff --git
a/src/tycheck.sml
b/src/tycheck.sml
index
fa006df
..
30a1d86
100644
(file)
--- a/
src/tycheck.sml
+++ b/
src/tycheck.sml
@@
-281,6
+281,18
@@
fun whnorm (tAll as (t, loc)) =
TUnif (_, ref (SOME tAll)) => whnorm tAll
| _ => tAll
TUnif (_, ref (SOME tAll)) => whnorm tAll
| _ => tAll
+fun hasTyp (e, t1, t2) =
+ case whnorm t2 of
+ (TBase name, _) =>
+ (case typeRule name of
+ NONE => subTyp (t1, t2)
+ | SOME rule =>
+ if rule e then
+ ()
+ else
+ subTyp (t1, t2))
+ | _ => subTyp (t1, t2)
+
fun checkTyp G (tAll as (t, loc)) =
let
val err = ErrorMsg.error (SOME loc)
fun checkTyp G (tAll as (t, loc)) =
let
val err = ErrorMsg.error (SOME loc)
@@
-316,7
+328,7
@@
fun checkExp G (eAll as (e, loc)) =
let
val t' = checkExp G e'
in
let
val t' = checkExp G e'
in
- (
subTyp (
t', t);
+ (
hasTyp (eAll,
t', t);
if isError t' then
(TList (TError, loc), loc)
else
if isError t' then
(TList (TError, loc), loc)
else
@@
-356,8
+368,8
@@
fun checkExp G (eAll as (e, loc)) =
val tf = checkExp G func
val ta = checkExp G arg
in
val tf = checkExp G func
val ta = checkExp G arg
in
- (
subTyp (
tf, (TArrow (dom, ran), loc));
-
subTyp (
ta, dom)
+ (
hasTyp (func,
tf, (TArrow (dom, ran), loc));
+
hasTyp (arg,
ta, dom)
handle Unify ue =>
dte (WrongType ("Function argument",
arg,
handle Unify ue =>
dte (WrongType ("Function argument",
arg,
@@
-637,7
+649,7
@@
fun checkDecl G (d, _, loc) =
val t = checkExp G e
in
val t = checkExp G e
in
-
subTyp (
t, to)
+
hasTyp (e,
t, to)
handle Unify ue =>
describe_type_error loc
(WrongType ("Bound value",
handle Unify ue =>
describe_type_error loc
(WrongType ("Bound value",
@@
-658,7
+670,7
@@
fun checkFile G tInit (ds, eo) =
let
val t = checkExp G' e
in
let
val t = checkExp G' e
in
-
subTyp (
t, tInit)
+
hasTyp (e,
t, tInit)
handle Unify ue =>
(ErrorMsg.error (SOME loc) "Bad type for final expression of source file.";
preface ("Actual:", p_typ t);
handle Unify ue =>
(ErrorMsg.error (SOME loc) "Bad type for final expression of source file.";
preface ("Actual:", p_typ t);