diff options
| author | Richard Eisenberg <rae@cs.brynmawr.edu> | 2018-05-31 22:41:59 -0400 |
|---|---|---|
| committer | Richard Eisenberg <rae@cs.brynmawr.edu> | 2018-05-31 22:41:59 -0400 |
| commit | 3732bfc8f8a210b6ef75cbc2c55d8df37d0863ea (patch) | |
| tree | b7043dbd85d72cb9b0502eedea057db14197ba53 | |
| parent | 3d085b4ac152972a5bad57dcb1f9c9c75d10348c (diff) | |
| download | haskell-3732bfc8f8a210b6ef75cbc2c55d8df37d0863ea.tar.gz | |
bugfixes
| -rw-r--r-- | compiler/typecheck/TcTyClsDecls.hs | 23 | ||||
| -rw-r--r-- | compiler/typecheck/TcValidity.hs | 11 |
2 files changed, 20 insertions, 14 deletions
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 58d8df6fe9..8175c32ee0 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -421,14 +421,16 @@ kcTyClGroup decls user_tyvars = tcTyConUserTyVars tc -- See Note [checkValidDependency] - ; checkValidDependency tc_binders tc_res_kind + ; dependency_ok <- checkValidDependency tc_binders tc_res_kind -- See Note [Bad telescopes] in TcValidity - ; checkValidTelescope tc_binders user_tyvars + ; telescope_ok <- checkValidTelescope tc_binders user_tyvars ; kvs <- kindGeneralize (mkTyConKind tc_binders tc_res_kind) -- See Note [Bad telescopes] in TcValidity - ; checkKvsToGeneralize kvs tc_binders user_tyvars + ; when (telescope_ok && dependency_ok) $ + -- avoid double-reporting trouble as in dependent/should_fail/BadTelescope3 + checkKvsToGeneralize kvs tc_binders user_tyvars ; let all_binders = mkNamedTyConBinders Inferred kvs ++ tc_binders @@ -3102,15 +3104,16 @@ Type -> k -> Type, where k is unbound. (It won't use a forall for a -- | See Note [checkValidDependency] checkValidDependency :: [TyConBinder] -- zonked -> TcKind -- zonked (result kind) - -> TcM () + -> TcM Bool -- True <=> everything is ok checkValidDependency binders res_kind - = go (tyCoVarsOfType res_kind) (reverse binders) + = go (tyCoVarsOfType res_kind) (reverse binders) True where go :: TyCoVarSet -- fvs from scope -> [TyConBinder] -- binders, in reverse order - -> TcM () - go _ [] = return () -- all set - go fvs (tcb : tcbs) + -> Bool -- everything OK so far + -> TcM Bool + go _ [] ok = return ok -- all set + go fvs (tcb : tcbs) ok | not (isNamedTyConBinder tcb) && tcb_var `elemVarSet` fvs = do { setSrcSpan (getSrcSpan tcb_var) $ addErrTc (vcat [ text "Type constructor argument" <+> quotes (ppr tcb_var) <+> @@ -3121,10 +3124,10 @@ checkValidDependency binders res_kind 2 (vcat (map pp_binder binders)) , text "Suggestion: use" <+> quotes (ppr tcb_var) <+> text "in a kind to make the dependency clearer." ]) - ; go new_fvs tcbs } + ; go new_fvs tcbs False } | otherwise - = go new_fvs tcbs + = go new_fvs tcbs ok where new_fvs = fvs `delVarSet` tcb_var `unionVarSet` tyCoVarsOfType tcb_kind diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index 85b540bdad..7686035525 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -1881,14 +1881,17 @@ check works for `forall x y z.` written in a type. -- k in a's type.) See also Note [Bad telescopes]. checkValidTelescope :: [TyConBinder] -- explicit vars (zonked) -> SDoc -- original, user-written telescope - -> TcM () + -> TcM Bool -- True <=> everything is OK checkValidTelescope tvbs user_tyvars - = do { let tvs = binderVars tvbs - ; unless (go [] emptyVarSet tvs) $ + = do { unless all_ok $ addErr $ - bad_telescope_err tvs user_tyvars } + bad_telescope_err tvs user_tyvars + ; return all_ok } where + tvs = binderVars tvbs + all_ok = go [] emptyVarSet tvs + go :: [TyVar] -- misplaced variables -> TyVarSet -> [TyVar] -> Bool go errs in_scope [] = null (filter (`elemVarSet` in_scope) errs) |