Commit e0b93c02 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Fix for 1st half of #2203

parent af97da87
...@@ -1486,22 +1486,26 @@ checkValidInstHead ty -- Should be a source type ...@@ -1486,22 +1486,26 @@ checkValidInstHead ty -- Should be a source type
check_inst_head :: DynFlags -> Class -> [Type] -> TcM () check_inst_head :: DynFlags -> Class -> [Type] -> TcM ()
check_inst_head dflags clas tys check_inst_head dflags clas tys
-- If GlasgowExts then check at least one isn't a type variable = do { -- If GlasgowExts then check at least one isn't a type variable
= do checkTc (dopt Opt_TypeSynonymInstances dflags || ; checkTc (dopt Opt_TypeSynonymInstances dflags ||
all tcInstHeadTyNotSynonym tys) all tcInstHeadTyNotSynonym tys)
(instTypeErr (pprClassPred clas tys) head_type_synonym_msg) (instTypeErr (pprClassPred clas tys) head_type_synonym_msg)
checkTc (dopt Opt_FlexibleInstances dflags || ; checkTc (dopt Opt_FlexibleInstances dflags ||
all tcInstHeadTyAppAllTyVars tys) all tcInstHeadTyAppAllTyVars tys)
(instTypeErr (pprClassPred clas tys) head_type_args_tyvars_msg) (instTypeErr (pprClassPred clas tys) head_type_args_tyvars_msg)
checkTc (dopt Opt_MultiParamTypeClasses dflags || ; checkTc (dopt Opt_MultiParamTypeClasses dflags ||
isSingleton tys) isSingleton tys)
(instTypeErr (pprClassPred clas tys) head_one_type_msg) (instTypeErr (pprClassPred clas tys) head_one_type_msg)
mapM_ check_mono_type tys -- May not contain type family applications
; mapM_ checkTyFamFreeness tys
; mapM_ check_mono_type tys
-- For now, I only allow tau-types (not polytypes) in -- For now, I only allow tau-types (not polytypes) in
-- the head of an instance decl. -- the head of an instance decl.
-- E.g. instance C (forall a. a->a) is rejected -- E.g. instance C (forall a. a->a) is rejected
-- One could imagine generalising that, but I'm not sure -- One could imagine generalising that, but I'm not sure
-- what all the consequences might be -- what all the consequences might be
}
where where
head_type_synonym_msg = parens ( head_type_synonym_msg = parens (
...@@ -1719,7 +1723,7 @@ checkFamInst lhsTys famInsts ...@@ -1719,7 +1723,7 @@ checkFamInst lhsTys famInsts
checkTyFamFreeness :: Type -> TcM () checkTyFamFreeness :: Type -> TcM ()
checkTyFamFreeness ty checkTyFamFreeness ty
= checkTc (isTyFamFree ty) $ = checkTc (isTyFamFree ty) $
tyFamInstInIndexErr ty tyFamInstIllegalErr ty
-- Check that a type does not contain any type family applications. -- Check that a type does not contain any type family applications.
-- --
...@@ -1728,9 +1732,9 @@ isTyFamFree = null . tyFamInsts ...@@ -1728,9 +1732,9 @@ isTyFamFree = null . tyFamInsts
-- Error messages -- Error messages
tyFamInstInIndexErr :: Type -> SDoc tyFamInstIllegalErr :: Type -> SDoc
tyFamInstInIndexErr ty tyFamInstIllegalErr ty
= hang (ptext (sLit "Illegal type family application in type instance") <> = hang (ptext (sLit "Illegal type synonym family application in instance") <>
colon) 4 $ colon) 4 $
ppr ty ppr ty
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment