projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
checkTauTvUpdate: take synonym families into account
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcUnify.lhs
diff --git
a/compiler/typecheck/TcUnify.lhs
b/compiler/typecheck/TcUnify.lhs
index
de9c341
..
b8cb1f4
100644
(file)
--- a/
compiler/typecheck/TcUnify.lhs
+++ b/
compiler/typecheck/TcUnify.lhs
@@
-1366,7
+1366,11
@@
checkTauTvUpdate orig_tv orig_ty
; case mb_tys' of
Just tys' -> return (TyConApp tc tys')
-- Retain the synonym (the common case)
; case mb_tys' of
Just tys' -> return (TyConApp tc tys')
-- Retain the synonym (the common case)
- Nothing -> go (expectJust "checkTauTvUpdate"
+ Nothing | isOpenTyCon tc
+ -> notMonoArgs (TyConApp tc tys)
+ -- Synonym families must have monotype args
+ | otherwise
+ -> go (expectJust "checkTauTvUpdate"
(tcView (TyConApp tc tys)))
-- Try again, expanding the synonym
}
(tcView (TyConApp tc tys)))
-- Try again, expanding the synonym
}
@@
-1588,6
+1592,13
@@
notMonoType ty
msg = ptext SLIT("Cannot match a monotype with") <+> quotes (ppr tidy_ty)
; failWithTcM (env1, msg) }
msg = ptext SLIT("Cannot match a monotype with") <+> quotes (ppr tidy_ty)
; failWithTcM (env1, msg) }
+notMonoArgs ty
+ = do { ty' <- zonkTcType ty
+ ; env0 <- tcInitTidyEnv
+ ; let (env1, tidy_ty) = tidyOpenType env0 ty'
+ msg = ptext SLIT("Arguments of synonym family must be monotypes") <+> quotes (ppr tidy_ty)
+ ; failWithTcM (env1, msg) }
+
occurCheck tyvar ty
= do { env0 <- tcInitTidyEnv
; ty' <- zonkTcType ty
occurCheck tyvar ty
= do { env0 <- tcInitTidyEnv
; ty' <- zonkTcType ty