[commit: ghc] wip/T14880: bugfixes (3732bfc)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T14880
Link       : http://ghc.haskell.org/trac/ghc/changeset/3732bfc8f8a210b6ef75cbc2c55d8df37d0863ea/ghc

>---------------------------------------------------------------

commit 3732bfc8f8a210b6ef75cbc2c55d8df37d0863ea
Author: Richard Eisenberg <rae at cs.brynmawr.edu>
Date:   Thu May 31 22:41:59 2018 -0400

    bugfixes


>---------------------------------------------------------------

3732bfc8f8a210b6ef75cbc2c55d8df37d0863ea
 compiler/typecheck/TcTyClsDecls.hs | 23 +++++++++++++----------
 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 58d8df6..8175c32 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 85b540b..7686035 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)