import HsSyn ( HsExpr(..) , MatchGroup(..), HsMatchContext(..),
hsLMatchPats, pprMatches, pprMatchContext )
-import TcHsSyn ( mkHsLet, mkHsDictLam,
+import TcHsSyn ( mkHsDictLet, mkHsDictLam,
ExprCoFn, idCoercion, isIdCoercion, mkCoercion, (<.>), (<$>) )
import TypeRep ( Type(..), PredType(..), TyNote(..) )
TcTyVarSet, TcThetaType, Expected(..), TcTyVarDetails(..),
SkolemInfo( GenSkol ), MetaDetails(..),
pprTcTyVar, isTauTy, isSigmaTy, mkFunTy, mkFunTys, mkTyConApp,
- tcSplitAppTy_maybe, tcSplitTyConApp_maybe,
+ tcSplitAppTy_maybe, tcSplitTyConApp_maybe, tcEqType,
tyVarsOfType, mkPhiTy, mkTyVarTy, mkPredTy,
typeKind, tcSplitFunTy_maybe, mkForAllTys, mkAppTy,
tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars,
n_pats = length (hsLMatchPats match)
msg = case ctxt of
FunRhs fun -> ptext SLIT("The equation(s) for") <+> quotes (ppr fun)
- <+> ptext SLIT("have") <+> speakN n_pats <+> ptext SLIT("arguments")
+ <+> ptext SLIT("have") <+> speakNOf n_pats (ptext SLIT("argument"))
LambdaExpr -> sep [ ptext SLIT("The lambda expression")
<+> quotes (pprSetDepth 1 $ pprMatches ctxt group),
-- The pprSetDepth makes the abstraction print briefly
- ptext SLIT("has") <+> speakN n_pats <+> ptext SLIT("arguments")]
+ ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("arguments"))]
other -> pprPanic "subFunTys" (pprMatchContext ctxt)
mk_msg n_actual
= error_herald <> comma $$
sep [ptext SLIT("but its type") <+> quotes (pprType ty),
- ptext SLIT("has only") <+> speakN n_actual]
+ if n_actual == 0 then ptext SLIT("has none")
+ else ptext SLIT("has only") <+> speakN n_actual]
unify_fun_ty :: Bool -> Arity -> TcRhoType
-> TcM (Bool, -- Arity satisfied?
-- See Note [Pattern coercions] in TcPat
-- However, we can't call unify directly, because both types might be
-- polymorphic; hence the call to tcSub, followed by a check for
--- the identity coercion
+-- equal types. (We can't just check for the identity coercion, because
+-- in the polymorphic case we might get back something eta-equivalent to
+-- the identity coercion, but that's not easy to tell.)
tcSubPat sig_ty (Infer hole)
= do { sig_ty' <- zonkTcType sig_ty
; writeMutVar hole sig_ty' -- See notes with tcSubExp above
; return () }
+-- This tcSub followed by tcEqType checks for identical types
+-- It'd be done more neatly by augmenting the unifier to deal with
+-- (identically shaped) for-all types.
+
tcSubPat sig_ty (Check exp_ty)
= do { co_fn <- tcSub sig_ty exp_ty
-
- ; if isIdCoercion co_fn then
+ ; sig_ty' <- zonkTcType sig_ty
+ ; exp_ty' <- zonkTcType exp_ty
+ ; if tcEqType sig_ty' exp_ty' then
return ()
- else
- unifyMisMatch sig_ty exp_ty }
+ else do
+ { (env, msg) <- misMatchMsg sig_ty' exp_ty'
+ ; failWithTcM (env, msg $$ extra) } }
+ where
+ extra | isTauTy sig_ty = empty
+ | otherwise = ptext SLIT("Polymorphic types must match exactly in patterns")
\end{code}
-- It's a bit out of place here, but using AbsBind involves inventing
-- a couple of new names which seems worse.
dict_ids = map instToId dicts
- co_fn e = TyLam forall_tvs (mkHsDictLam dict_ids (mkHsLet inst_binds (noLoc e)))
+ co_fn e = TyLam forall_tvs (mkHsDictLam dict_ids (mkHsDictLet inst_binds (noLoc e)))
; returnM (mkCoercion co_fn, result) }
where
free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs
pp2 = ppr ty2' <+> dcolon <+> ppr (typeKind ty2)
unifyMisMatch ty1 ty2
+ = do { (env, msg) <- misMatchMsg ty1 ty2
+ ; failWithTcM (env, msg) }
+
+misMatchMsg ty1 ty2
= do { (env1, pp1, extra1) <- ppr_ty emptyTidyEnv ty1
; (env2, pp2, extra2) <- ppr_ty env1 ty2
- ; let msg = sep [sep [ptext SLIT("Couldn't match") <+> pp1, nest 7 (ptext SLIT("against") <+> pp2)],
- nest 2 extra1, nest 2 extra2]
- in
- failWithTcM (env2, msg) }
+ ; return (env2, sep [sep [ptext SLIT("Couldn't match") <+> pp1,
+ nest 7 (ptext SLIT("against") <+> pp2)],
+ nest 2 extra1, nest 2 extra2]) }
ppr_ty :: TidyEnv -> TcType -> TcM (TidyEnv, SDoc, SDoc)
ppr_ty env ty