[commit: ghc] wip/T15809: Wibbles (bd34111)

[git at git.haskell.org]

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

On branch  : wip/T15809
Link       : http://ghc.haskell.org/trac/ghc/changeset/bd34111a7b0a9168a442aaa4e8de6db4daffeeb6/ghc

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

commit bd34111a7b0a9168a442aaa4e8de6db4daffeeb6
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Nov 21 00:00:53 2018 +0000

    Wibbles


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

bd34111a7b0a9168a442aaa4e8de6db4daffeeb6
 compiler/typecheck/TcMType.hs                      | 15 +++++++++++++
 compiler/typecheck/TcRnTypes.hs                    |  8 ++++++-
 compiler/typecheck/TcTyClsDecls.hs                 | 25 +++++++++++-----------
 .../tests/indexed-types/should_fail/SimpleFail9.hs |  4 +++-
 4 files changed, 37 insertions(+), 15 deletions(-)

diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs
index 886a894..769a312 100644
--- a/compiler/typecheck/TcMType.hs
+++ b/compiler/typecheck/TcMType.hs
@@ -41,6 +41,7 @@ module TcMType (
   newEvVar, newEvVars, newDict,
   newWanted, newWanteds, newHoleCt, cloneWanted, cloneWC,
   emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars,
+  emitDerivedEqs,
   newTcEvBinds, newNoTcEvBinds, addTcEvBind,
 
   newCoercionHole, fillCoercionHole, isFilledCoercionHole,
@@ -232,6 +233,20 @@ emitWanted origin pty
        ; emitSimple $ mkNonCanonical ev
        ; return $ ctEvTerm ev }
 
+emitDerivedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM ()
+-- Emit some new derived nominal equalities
+emitDerivedEqs origin pairs
+  | null pairs
+  = return ()
+  | otherwise
+  = do { loc <- getCtLocM origin Nothing
+       ; emitSimples (listToBag (map (mk_one loc) pairs)) }
+  where
+    mk_one loc (ty1, ty2)
+       = mkNonCanonical $
+         CtDerived { ctev_pred = mkPrimEqPred ty1 ty2
+                   , ctev_loc = loc }
+
 -- | Emits a new equality constraint
 emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion
 emitWantedEq origin t_or_k role ty1 ty2
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index f7caacd..ad3122b 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -3511,8 +3511,10 @@ data CtOrigin
   | NegateOrigin                        -- Occurrence of syntactic negation
 
   | ArithSeqOrigin (ArithSeqInfo GhcRn) -- [x..], [x..y] etc
+  | AssocFamPatOrigin   -- When matching the patterns of an associated
+                        -- family instance with that of its parent class
   | SectionOrigin
-  | TupleOrigin                        -- (..,..)
+  | TupleOrigin         -- (..,..)
   | ExprSigOrigin       -- e :: ty
   | PatSigOrigin        -- p :: ty
   | PatOrigin           -- Instantiating a polytyped pattern at a constructor
@@ -3730,6 +3732,9 @@ pprCtOrigin (KindEqOrigin t1 (Just t2) _ _)
   = hang (ctoHerald <+> text "a kind equality arising from")
        2 (sep [ppr t1, char '~', ppr t2])
 
+pprCtOrigin AssocFamPatOrigin
+  = text "when matching a family LHS with its class instance head"
+
 pprCtOrigin (KindEqOrigin t1 Nothing _ _)
   = hang (ctoHerald <+> text "a kind equality when matching")
        2 (ppr t1)
@@ -3801,6 +3806,7 @@ pprCtO IfOrigin              = text "an if expression"
 pprCtO (LiteralOrigin lit)   = hsep [text "the literal", quotes (ppr lit)]
 pprCtO (ArithSeqOrigin seq)  = hsep [text "the arithmetic sequence", quotes (ppr seq)]
 pprCtO SectionOrigin         = text "an operator section"
+pprCtO AssocFamPatOrigin     = text "the LHS of a famly instance"
 pprCtO TupleOrigin           = text "a tuple"
 pprCtO NegateOrigin          = text "a use of syntactic negation"
 pprCtO (ScOrigin n)          = text "the superclasses of an instance declaration"
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 92977fb..7a8bc9e 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -39,7 +39,6 @@ import TcDeriv (DerivInfo)
 import TcHsType
 import Inst( tcInstTyBinders )
 import TcMType
-import TcUnify( unifyType )
 import TysWiredIn ( unitTy )
 import TcType
 import RnEnv( lookupConstructorFields )
@@ -1770,9 +1769,7 @@ tcTyFamInstEqn fam_tc mb_clsinfo
        ; (qtvs, pats, rhs_ty) <- tcFamTyPatsAndGen fam_tc mb_clsinfo
                                       imp_vars (mb_expl_bndrs `orElse` [])
                                       hs_pats
-                                      (\ res_kind ->
-                                         do { traceTc "tcTyFasmInstEqn" (ppr fam_tc $$ ppr hs_pats $$ ppr res_kind)
-                                            ; tcCheckLHsType rhs_hs_ty res_kind })
+                                      (tcCheckLHsType rhs_hs_ty res_kind)
 
        ; (ze, qtvs') <- zonkTyBndrs qtvs
        ; pats'       <- zonkTcTypesToTypesX ze pats
@@ -1932,16 +1929,19 @@ addConsistencyConstraints :: Maybe ClsInstInfo -> TyCon -> [Type] -> TcM ()
 --             F c x y a :: Type
 -- Here the first  arg of F should be the same as the third of C
 --  and the fourth arg of F should be the same as the first of C
-
+--
+-- We emit /Derived/ constraints (a bit like fundeps) to encourage
+-- unification to happen, but without actually reporting errors.
+-- If, despite the efforts, corresponding positions do not match,
+-- checkConsistentFamInst will complain
 addConsistencyConstraints Nothing _ _ = return ()
 addConsistencyConstraints (Just (_, _, inst_ty_env)) fam_tc pats
-  = mapM_ do_one (tyConTyVars fam_tc `zip` pats)
-  where
-    do_one (fam_tc_tv, pat)
-      | Just cls_arg_ty <- lookupVarEnv inst_ty_env fam_tc_tv
-      = discardResult (unifyType Nothing cls_arg_ty pat)
-      | otherwise
-      = return ()
+  = emitDerivedEqs AssocFamPatOrigin
+                   [ (cls_ty, pat)
+                   | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats
+                   , Just cls_ty <- [lookupVarEnv inst_ty_env fam_tc_tv] ]
+    -- Improve inference
+    -- Any mis-match is reports by checkConsistentFamInst
 
 {- Note [Constraints in patterns]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -3237,7 +3237,6 @@ checkFamFlag tc_name
 -- types.
 type ClsInstInfo = (Class, [TyVar], VarEnv Type)
 
-
 checkConsistentFamInst :: Maybe ClsInstInfo
                        -> TyCon     -- ^ Family tycon
                        -> [Type]    -- ^ Type patterns from instance
diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail9.hs b/testsuite/tests/indexed-types/should_fail/SimpleFail9.hs
index 9c1c4a8..0f20f78 100644
--- a/testsuite/tests/indexed-types/should_fail/SimpleFail9.hs
+++ b/testsuite/tests/indexed-types/should_fail/SimpleFail9.hs
@@ -2,8 +2,10 @@
 
 module ShouldFail where
 
+import Data.Kind
+
 class C7 a b where
-  data S7 b :: *
+  data S7 b :: Type
 
 instance C7 Char (a, Bool) where
   data S7 (a, Bool) = S7_1