- ; reportTidyFrozens tidy_env tidy_frozen_errors_zonked
- ; reportTidyWanteds err_ctxt tidy_unsolved }
- where
- unsolved = Bag.mapBag WcEvVar unsolved_flats `unionBags`
- Bag.mapBag WcImplic unsolved_implics
-
- zonk_frozen (FrozenError frknd fl ty1 ty2)
- = do { ty1z <- zonkTcType ty1
- ; ty2z <- zonkTcType ty2
- ; return (FrozenError frknd fl ty1z ty2z) }
-
- tyVarsOfFrozen fr
- = unionVarSets $ bagToList (mapBag tvs_of_frozen fr)
- tvs_of_frozen (FrozenError _ _ ty1 ty2) = tyVarsOfTypes [ty1,ty2]
-
- tidyFrozen env fr = mapBag (tidy_frozen env) fr
- tidy_frozen env (FrozenError frknd fl ty1 ty2)
- = FrozenError frknd fl (tidyType env ty1) (tidyType env ty2)
-
-reportTidyFrozens :: TidyEnv -> Bag FrozenError -> TcM ()
-reportTidyFrozens tidy_env fr = mapBagM_ (reportTidyFrozen tidy_env) fr
-
-reportTidyFrozen :: TidyEnv -> FrozenError -> TcM ()
-reportTidyFrozen tidy_env err@(FrozenError _ fl _ty1 _ty2)
- = do { let dec_errs = decompFrozenError err
- init_err_ctxt = CEC { cec_encl = []
- , cec_extra = empty
- , cec_tidy = tidy_env }
- ; mapM_ (report_dec_err init_err_ctxt) dec_errs }
- where
- report_dec_err err_ctxt (ty1,ty2)
- -- The only annoying thing here is that in the given case,
- -- the ``Inaccessible code'' message will be printed once for
- -- each decomposed equality.
- = do { (tidy_env2,extra2)
- <- if isGiven fl
- then return (cec_tidy err_ctxt, inaccessible_msg)
- else getWantedEqExtra emptyTvSubst (cec_tidy err_ctxt) loc_orig ty1 ty2
- ; let err_ctxt2 = err_ctxt { cec_tidy = tidy_env2
- , cec_extra = cec_extra err_ctxt $$ extra2 }
- ; setCtFlavorLoc fl $
- reportEqErr err_ctxt2 ty1 ty2
- }
-
- loc_orig | Wanted loc <- fl = ctLocOrigin loc
- | Derived loc _ <- fl = ctLocOrigin loc
- | otherwise = pprPanic "loc_orig" empty
-
- inaccessible_msg
- | Given loc <- fl
- = hang (ptext (sLit "Inaccessible code in")) 2 (mk_what loc)
- | otherwise = pprPanic "inaccessible_msg" empty
-
- mk_what loc
- = case ctLocOrigin loc of
- PatSkol dc mc -> sep [ ptext (sLit "a pattern with constructor")
- <+> quotes (ppr dc) <> comma
- , ptext (sLit "in") <+> pprMatchContext mc ]
- other_skol -> pprSkolInfo other_skol
-
-
-decompFrozenError :: FrozenError -> [(TcType,TcType)]
--- Postcondition: will always return a non-empty list
-decompFrozenError (FrozenError errk _fl ty1 ty2)
- | OccCheckError <- errk
- = dec_occ_check ty1 ty2
- | otherwise
- = [(ty1,ty2)]
- where dec_occ_check :: TcType -> TcType -> [(TcType,TcType)]
- -- This error arises from an original:
- -- a ~ Maybe a
- -- But by now the a has been substituted away, eg:
- -- Int ~ Maybe Int
- -- Maybe b ~ Maybe (Maybe b)
- dec_occ_check ty1 ty2
- | tcEqType ty1 ty2 = []
- dec_occ_check ty1@(TyVarTy {}) ty2 = [(ty1,ty2)]
- dec_occ_check (FunTy s1 t1) (FunTy s2 t2)
- = let errs1 = dec_occ_check s1 s2
- errs2 = dec_occ_check t1 t2
- in errs1 ++ errs2
- dec_occ_check ty1@(TyConApp fn1 tys1) ty2@(TyConApp fn2 tys2)
- | fn1 == fn2 && length tys1 == length tys2
- , not (isSynFamilyTyCon fn1)
- = concatMap (\(t1,t2) -> dec_occ_check t1 t2) (zip tys1 tys2)
- | otherwise
- = [(ty1,ty2)]
- dec_occ_check ty1 ty2
- | Just (s1,t1) <- tcSplitAppTy_maybe ty1
- , Just (s2,t2) <- tcSplitAppTy_maybe ty2
- = let errs1 = dec_occ_check s1 s2
- errs2 = dec_occ_check t1 t2
- in errs1 ++ errs2
- dec_occ_check ty1 ty2 = [(ty1,ty2)]
-
-reportUnsolvedWantedEvVars :: Bag WantedEvVar -> TcM ()
-reportUnsolvedWantedEvVars wanteds
- | isEmptyBag wanteds
- = return ()
- | otherwise
- = do { wanteds <- mapBagM zonkWantedEvVar wanteds
- ; env0 <- tcInitTidyEnv
- ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfWantedEvVars wanteds)
- tidy_unsolved = tidyWantedEvVars tidy_env wanteds
- err_ctxt = CEC { cec_encl = []
- , cec_extra = empty
- , cec_tidy = tidy_env }
- ; groupErrs (reportFlat err_ctxt) (bagToList tidy_unsolved) }