X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=e3f29552c0b15dc28c854bb70b5fc685ec62e777;hb=1a9245caefb80a3c4c5965aaacdf9a607e792e1c;hp=cd3da492bf6016d7ad0431e33387013c621c6990;hpb=296058a1cafa80dec0b3f998348bce7c65f668b0;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index cd3da49..e3f2955 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -17,8 +17,6 @@ module TcSimplify ( tcSimplifyDeriv, tcSimplifyDefault, bindInstsOfLocalFuns, - tcSimplifyStagedExpr, - misMatchMsg ) where @@ -45,7 +43,6 @@ import Class import FunDeps import PrelInfo import PrelNames -import Type import TysWiredIn import ErrUtils import BasicTypes @@ -54,7 +51,6 @@ import VarEnv import FiniteMap import Bag import Outputable -import Maybes import ListSetOps import Util import SrcLoc @@ -1022,16 +1018,17 @@ makeImplicationBind loc all_tvs <.> mkWpTyApps eq_cotvs <.> mkWpTyApps (mkTyVarTys all_tvs) bind | [dict_irred_id] <- dict_irred_ids - = VarBind dict_irred_id rhs + = mkVarBind dict_irred_id rhs | otherwise - = PatBind { pat_lhs = lpat + = L span $ + PatBind { pat_lhs = lpat , pat_rhs = unguardedGRHSs rhs , pat_rhs_ty = hsLPatType lpat , bind_fvs = placeHolderNames } ; traceTc $ text "makeImplicationBind" <+> ppr implic_inst - ; return ([implic_inst], unitBag (L span bind)) + ; return ([implic_inst], unitBag bind) } ----------------------------------------------------------- @@ -1495,7 +1492,7 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds -- (for example) squash {Monad (ST s)} into {}. It's not enough -- just to float all constraints -- - -- At top level, we *do* squash methods becuase we want to + -- At top level, we *do* squash methods because we want to -- expose implicit parameters to the test that follows ; let is_nested_group = isNotTopLevel top_lvl try_me inst | isFreeWrtTyVars qtvs inst, @@ -1589,13 +1586,23 @@ Simpler, maybe, but alas not simple (see Trac #2494) tcSimplifyRuleLhs :: [Inst] -> TcM ([Inst], TcDictBinds) tcSimplifyRuleLhs wanteds = do { wanteds' <- zonkInsts wanteds - ; (irreds, binds) <- go [] emptyBag wanteds' + + -- Simplify equalities + -- It's important to do this: Trac #3346 for example + ; (_, wanteds'', tybinds, binds1) <- tcReduceEqs [] wanteds' + ; execTcTyVarBinds tybinds + + -- Simplify other constraints + ; (irreds, binds2) <- go [] emptyBag wanteds'' + + -- Report anything that is left ; let (dicts, bad_irreds) = partition isDict irreds ; traceTc (text "tcSimplifyrulelhs" <+> pprInsts bad_irreds) ; addNoInstanceErrs (nub bad_irreds) -- The nub removes duplicates, which has -- not happened otherwise (see notes above) - ; return (dicts, binds) } + + ; return (dicts, binds1 `unionBags` binds2) } where go :: [Inst] -> TcDictBinds -> [Inst] -> TcM ([Inst], TcDictBinds) go irreds binds [] @@ -1637,7 +1644,7 @@ this bracket again at its usage site. \begin{code} tcSimplifyBracket :: [Inst] -> TcM () tcSimplifyBracket wanteds - = do { tryHardCheckLoop doc wanteds + = do { _ <- tryHardCheckLoop doc wanteds ; return () } where doc = text "tcSimplifyBracket" @@ -2375,11 +2382,7 @@ reduceImplication env eq_cotvs = map instToVar extra_eq_givens dict_ids = map instToId extra_dict_givens - -- Note [Always inline implication constraints] - wrap_inline | null dict_ids = idHsWrapper - | otherwise = WpInline - co = wrap_inline - <.> mkWpTyLams tvs + co = mkWpTyLams tvs <.> mkWpTyLams eq_cotvs <.> mkWpLams dict_ids <.> WpLet (binds `unionBags` bind) @@ -2391,12 +2394,15 @@ reduceImplication env . filter (not . isEqInst) $ wanteds payload = mkBigLHsTup dict_bndrs - ; traceTc (vcat [text "reduceImplication" <+> ppr name, ppr simpler_implic_insts, text "->" <+> ppr rhs]) - ; return (unitBag (L loc (VarBind (instToId orig_implic) rhs)), + ; return (unitBag (L loc (VarBind { var_id= instToId orig_implic + , var_rhs = rhs + , var_inline = notNull dict_ids } + -- See Note [Always inline implication constraints] + )), simpler_implic_insts) } } @@ -2856,6 +2862,7 @@ disambiguate doc interactive dflags insts where extended_defaulting = interactive || dopt Opt_ExtendedDefaultRules dflags + -- See also Trac #1974 ovl_strings = dopt Opt_OverloadedStrings dflags unaries :: [(Inst, Class, TcTyVar)] -- (C tv) constraints @@ -2902,12 +2909,16 @@ disambigGroup :: [Type] -- The default types -> TcM () -- Just does unification, to fix the default types disambigGroup default_tys dicts - = try_default default_tys + = do { mb_chosen_ty <- try_default default_tys + ; case mb_chosen_ty of + Nothing -> return () + Just chosen_ty -> do { _ <- unifyType chosen_ty (mkTyVarTy tyvar) + ; warnDefault dicts chosen_ty } } where (_,_,tyvar) = ASSERT(not (null dicts)) head dicts -- Should be non-empty classes = [c | (_,c,_) <- dicts] - try_default [] = return () + try_default [] = return Nothing try_default (default_ty : default_tys) = tryTcLIE_ (try_default default_tys) $ do { tcSimplifyDefault [mkClassPred clas [default_ty] | clas <- classes] @@ -2917,10 +2928,7 @@ disambigGroup default_tys dicts -- For example, if Real a is reqd, but the only type in the -- default list is Int. - -- After this we can't fail - ; warnDefault dicts default_ty - ; unifyType default_ty (mkTyVarTy tyvar) - ; return () -- TOMDO: do something with the coercion + ; return (Just default_ty) -- TOMDO: do something with the coercion } @@ -3047,25 +3055,6 @@ tcSimplifyDefault theta = do doc = ptext (sLit "default declaration") \end{code} -@tcSimplifyStagedExpr@ performs a simplification but does so at a new -stage. This is used when typechecking annotations and splices. - -\begin{code} - -tcSimplifyStagedExpr :: ThStage -> TcM a -> TcM (a, TcDictBinds) --- Type check an expression that runs at a top level stage as if --- it were going to be spliced and then simplify it -tcSimplifyStagedExpr stage tc_action - = setStage stage $ do { - -- Typecheck the expression - (thing', lie) <- getLIE tc_action - - -- Solve the constraints - ; const_binds <- tcSimplifyTop lie - - ; return (thing', const_binds) } - -\end{code} %************************************************************************ @@ -3097,7 +3086,7 @@ groupErrs report_err (inst:insts) (friends, others) = partition is_friend insts loc_msg = showSDoc (pprInstLoc (instLoc inst)) is_friend friend = showSDoc (pprInstLoc (instLoc friend)) == loc_msg - do_one insts = addInstCtxt (instLoc (head insts)) (report_err insts) + do_one insts = setInstCtxt (instLoc (head insts)) (report_err insts) -- Add location and context information derived from the Insts -- Add the "arising from..." part to a message about bunch of dicts @@ -3306,7 +3295,7 @@ monomorphism_fix dflags warnDefault :: [(Inst, Class, Var)] -> Type -> TcM () warnDefault ups default_ty = do warn_flag <- doptM Opt_WarnTypeDefaults - addInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg) + setInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg) where dicts = [d | (d,_,_) <- ups]