import Outputable
import SrcLoc ( Located(..) )
import Maybes
-import MonadUtils
import FastString
-- standard
--
normaliseEqs :: [Inst] -> TcM EqConfig
normaliseEqs eqs
- = do { ASSERTM2( allM wantedEqInstIsUnsolved eqs, ppr eqs )
+ = do { WARNM2( anyM wantedEqInstIsUnsolved eqs, ppr eqs )
; traceTc $ ptext (sLit "Entering normaliseEqs")
; eqss <- mapM normEqInst eqs
-- NB: Special cased for efficiency - could be handled as type application
go (TyConApp con1 args1) (TyConApp con2 args2)
| con1 == con2
- && not (isOpenSynTyCon con1) -- don't match family synonym apps
+ && isInjectiveTyCon con1 -- don't match family synonym apps
= do { co_args <- mkTyConEqInstCo co con1 (zip args1 args2)
; eqss <- zipWith3M (\ty1 ty2 co -> checkOrientation ty1 ty2 co inst)
args1 args2 co_args
thisRewriteFam : concat args_eqss)
}
- -- data constructor application => flatten subtypes
+ -- datatype constructor application => flatten subtypes
-- NB: Special cased for efficiency - could be handled as type application
go ty@(TyConApp con args)
| not (isOpenSynTyCon con) -- don't match oversaturated family apps
= do { (args', cargs, args_eqss) <- mapAndUnzip3M go args
- ; if null args_eqss
+ ; let args_eqs = concat args_eqss
+ ; if null args_eqs
then -- unchanged, keep the old type with folded synonyms
return (ty, ty, [])
else
return (mkTyConApp con args',
mkTyConApp con cargs,
- concat args_eqss)
+ args_eqs)
}
-- function type => flatten subtypes
| otherwise
= panic "TcTyFuns.flattenType: synonym family in a rank-n type"
- -- we should never see a predicate type
- go (PredTy _)
- = panic "TcTyFuns.flattenType: unexpected PredType"
+ -- predicate type => handle like a datatype constructor application
+ go (PredTy (ClassP cls tys))
+ = do { (tys', ctys, tys_eqss) <- mapAndUnzip3M go tys
+ ; let tys_eqs = concat tys_eqss
+ ; if null tys_eqs
+ then -- unchanged, keep the old type with folded synonyms
+ return (ty, ty, [])
+ else
+ return (PredTy (ClassP cls tys'),
+ PredTy (ClassP cls ctys),
+ tys_eqs)
+ }
+
+ -- implicit parameter => flatten subtype
+ go ty@(PredTy (IParam ipn ity))
+ = do { (ity', co, eqs) <- go ity
+ ; if null eqs
+ then return (ty, ty, [])
+ else return (PredTy (IParam ipn ity'),
+ PredTy (IParam ipn co),
+ eqs)
+ }
+
+ -- we should never see a equality
+ go (PredTy (EqPred _ _))
+ = panic "TcTyFuns.flattenType: malformed type"
go _ = panic "TcTyFuns: suppress bogus warning"
eqInstMisMatch :: Inst -> TcM a
eqInstMisMatch inst
= ASSERT( isEqInst inst )
- setErrCtxt ctxt $ failWithMisMatch ty_act ty_exp
+ setInstCtxt (instLoc inst) $ failWithMisMatch ty_act ty_exp
where
(ty_act, ty_exp) = eqInstTys inst
- InstLoc _ _ ctxt = instLoc inst
-----------------------
failWithMisMatch :: TcType -> TcType -> TcM a
msg = sep [sep [ptext (sLit "Couldn't match expected type") <+> pp_exp,
nest 7 $
ptext (sLit "against inferred type") <+> pp_act],
- nest 2 (extra_exp $$ extra_act)]
+ nest 2 (extra_exp $$ extra_act $$ extra_tyfun) ]
+ -- See Note [Non-injective type functions]
in
(env2, msg)
where
+ extra_tyfun
+ = case (tcSplitTyConApp_maybe ty_act, tcSplitTyConApp_maybe ty_exp) of
+ (Just (tc_act,_), Just (tc_exp,_)) | tc_act == tc_exp
+ -> if isOpenSynTyCon tc_act then pp_open_tc tc_act
+ else WARN( True, ppr tc_act) -- If there's a mis-match, then
+ empty -- it should be a family
+ _ -> empty
+
+ pp_open_tc tc = ptext (sLit "NB:") <+> quotes (ppr tc)
+ <+> ptext (sLit "is a type function") <> pp_inj
+ where
+ pp_inj | isInjectiveTyCon tc = empty
+ | otherwise = ptext (sLit (", and may not be injective"))
+
ppr_ty :: TidyEnv -> TcType -> (TidyEnv, SDoc, SDoc)
ppr_ty env ty
= let (env1, tidy_ty) = tidyOpenType env ty
ppr_extra env _ty = (env, empty) -- Normal case
\end{code}
+Note [Non-injective type functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's very confusing to get a message like
+ Couldn't match expected type `Depend s'
+ against inferred type `Depend s1'
+so pp_open_tc adds:
+ NB: `Depend' is type function, and hence may not be injective
+
Warn of loopy local equalities that were dropped.
\begin{code}