X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=4cf93e83da60217c0249cc28a1b3a00745fa5caf;hb=8c554937f8824da81e03e504936320b3321022ed;hp=9b192ece5383a90488f17bac3e73513381043c95;hpb=32a5c61dc1df5e12aaf1f21e5928fbb261d62043;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 9b192ec..4cf93e8 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -16,6 +16,8 @@ module TcSimplify ( tcSimplifyDeriv, tcSimplifyDefault, bindInstsOfLocalFuns, + + tcSimplifyStagedExpr, misMatchMsg ) where @@ -58,6 +60,7 @@ import Util import SrcLoc import DynFlags import FastString + import Control.Monad import Data.List \end{code} @@ -656,7 +659,7 @@ tcSimplifyInfer doc tau_tvs wanted ; gbl_tvs <- tcGetGlobalTyVars ; let preds1 = fdPredsOfInsts wanted' gbl_tvs1 = oclose preds1 gbl_tvs - qtvs = grow preds1 tau_tvs1 `minusVarSet` gbl_tvs1 + qtvs = growInstsTyVars wanted' tau_tvs1 `minusVarSet` gbl_tvs1 -- See Note [Choosing which variables to quantify] -- To maximise sharing, remove from consideration any @@ -665,7 +668,7 @@ tcSimplifyInfer doc tau_tvs wanted ; extendLIEs free -- To make types simple, reduce as much as possible - ; traceTc (text "infer" <+> (ppr preds1 $$ ppr (grow preds1 tau_tvs1) $$ ppr gbl_tvs $$ + ; traceTc (text "infer" <+> (ppr preds1 $$ ppr (growInstsTyVars wanted' tau_tvs1) $$ ppr gbl_tvs $$ ppr gbl_tvs1 $$ ppr free $$ ppr bound)) ; (irreds1, binds1) <- tryHardCheckLoop doc bound @@ -706,7 +709,13 @@ tcSimplifyInfer doc tau_tvs wanted -- Then b is fixed by gbl_tvs, so (C a b) will be in free, and -- irreds2 will be empty. But we don't want to generalise over b! ; let preds2 = fdPredsOfInsts irreds2 -- irreds2 is zonked - qtvs = grow preds2 tau_tvs2 `minusVarSet` oclose preds2 gbl_tvs2 + qtvs = growInstsTyVars irreds2 tau_tvs2 `minusVarSet` oclose preds2 gbl_tvs2 + --------------------------------------------------- + -- BUG WARNING: there's a nasty bug lurking here + -- fdPredsOfInsts may return preds that mention variables quantified in + -- one of the implication constraints in irreds2; and that is clearly wrong: + -- we might quantify over too many variables through accidental capture + --------------------------------------------------- ; let (free, irreds3) = partition (isFreeWhenInferring qtvs) irreds2 ; extendLIEs free @@ -861,7 +870,7 @@ Note [NO TYVARS] The excitement comes when simplifying the bindings for h. Initially try to simplify {y @ [[t1]] t2, 0 @ t1}, with initial qtvs = {t2}. -From this we get t1:=:t2, but also various bindings. We can't forget +From this we get t1~t2, but also various bindings. We can't forget the bindings (because of [LOOP]), but in fact t1 is what g is polymorphic in. @@ -977,7 +986,7 @@ makeImplicationBind :: InstLoc -> [TcTyVar] -- (ir1, .., irn) = f qtvs givens -- where f is (evidence for) the new implication constraint -- f :: forall qtvs. givens => (ir1, .., irn) --- qtvs includes coercion variables. +-- qtvs includes coercion variables -- -- This binding must line up the 'rhs' in reduceImplication makeImplicationBind loc all_tvs @@ -997,7 +1006,7 @@ makeImplicationBind loc all_tvs name = mkInternalName uniq (mkVarOcc "ic") span implic_inst = ImplicInst { tci_name = name, tci_tyvars = all_tvs, - tci_given = (eq_givens ++ dict_givens), + tci_given = eq_givens ++ dict_givens, -- same order as binders tci_wanted = irreds, tci_loc = loc } @@ -1262,9 +1271,23 @@ the givens, as you can see from the derivation described above. Conclusion: in the very special case of tcSimplifySuperClasses we have one 'given' (namely the "this" dictionary) whose superclasses -must not be added to 'givens' by addGiven. That is the *whole* reason -for the red_given_scs field in RedEnv, and the function argument to -addGiven. +must not be added to 'givens' by addGiven. + +There is a complication though. Suppose there are equalities + instance (Eq a, a~b) => Num (a,b) +Then we normalise the 'givens' wrt the equalities, so the original +given "this" dictionary is cast to one of a different type. So it's a +bit trickier than before to identify the "special" dictionary whose +superclasses must not be added. See test + indexed-types/should_run/EqInInstance + +We need a persistent property of the dictionary to record this +special-ness. Current I'm using the InstLocOrigin (a bit of a hack, +but cool), which is maintained by dictionary normalisation. +Specifically, the InstLocOrigin is + NoScOrigin +then the no-superclass thing kicks in. WATCH OUT if you fiddle +with InstLocOrigin! \begin{code} tcSimplifySuperClasses @@ -1276,20 +1299,23 @@ tcSimplifySuperClasses -> TcM TcDictBinds tcSimplifySuperClasses loc this givens sc_wanteds = do { traceTc (text "tcSimplifySuperClasses") + + -- Note [Recursive instances and superclases] + ; no_sc_loc <- getInstLoc NoScOrigin + ; let no_sc_this = setInstLoc this no_sc_loc + + ; let env = RedEnv { red_doc = pprInstLoc loc, + red_try_me = try_me, + red_givens = no_sc_this : givens, + red_stack = (0,[]), + red_improve = False } -- No unification vars + + ; (irreds,binds1) <- checkLoop env sc_wanteds ; let (tidy_env, tidy_irreds) = tidyInsts irreds - ; reportNoInstances tidy_env (Just (loc, givens)) tidy_irreds + ; reportNoInstances tidy_env (Just (loc, givens)) [] tidy_irreds ; return binds1 } where - env = RedEnv { red_doc = pprInstLoc loc, - red_try_me = try_me, - red_givens = this:givens, - red_given_scs = add_scs, - red_stack = (0,[]), - red_improve = False } -- No unification vars - add_scs g | g==this = NoSCs - | otherwise = AddSCs - try_me _ = ReduceMe -- Try hard, so we completely solve the superclass -- constraints right here. See Note [SUPERCLASS-LOOP 1] \end{code} @@ -1412,7 +1438,7 @@ tcSimplifyRestricted -- Used for restricted binding groups tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds -- Zonk everything in sight = do { traceTc (text "tcSimplifyRestricted") - ; wanteds' <- zonkInsts wanteds + ; wanteds_z <- zonkInsts wanteds -- 'ReduceMe': Reduce as far as we can. Don't stop at -- dicts; the idea is to get rid of as many type @@ -1424,7 +1450,7 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds -- HOWEVER, some unification may take place, if we instantiate -- a method Inst with an equality constraint ; let env = mkNoImproveRedEnv doc (\_ -> ReduceMe) - ; (_imp, _binds, constrained_dicts) <- reduceContext env wanteds' + ; (_imp, _binds, constrained_dicts) <- reduceContext env wanteds_z -- Next, figure out the tyvars we will quantify over ; tau_tvs' <- zonkTcTyVarsAndFV (varSetElems tau_tvs) @@ -1452,6 +1478,13 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds ppr _binds, ppr constrained_tvs', ppr tau_tvs', ppr qtvs ]) + -- Zonk wanteds again! The first call to reduceContext may have + -- instantiated some variables. + -- FIXME: If red_improve would work, we could propagate that into + -- the equality solver, too, to prevent instantating any + -- variables. + ; wanteds_zz <- zonkInsts wanteds_z + -- The first step may have squashed more methods than -- necessary, so try again, this time more gently, knowing the exact -- set of type variables to quantify over. @@ -1473,7 +1506,7 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds (is_nested_group || isDict inst) = Stop | otherwise = ReduceMe env = mkNoImproveRedEnv doc try_me - ; (_imp, binds, irreds) <- reduceContext env wanteds' + ; (_imp, binds, irreds) <- reduceContext env wanteds_zz -- See "Notes on implicit parameters, Question 4: top level" ; ASSERT( all (isFreeWrtTyVars qtvs) irreds ) -- None should be captured @@ -1751,8 +1784,6 @@ data RedEnv -- Always dicts & equalities -- but see Note [Rigidity] - , red_given_scs :: Inst -> WantSCs -- See Note [Recursive instances and superclases] - , red_stack :: (Int, [Inst]) -- Recursion stack (for err msg) -- See Note [RedStack] } @@ -1775,7 +1806,6 @@ mkRedEnv :: SDoc -> (Inst -> WhatToDo) -> [Inst] -> RedEnv mkRedEnv doc try_me givens = RedEnv { red_doc = doc, red_try_me = try_me, red_givens = givens, - red_given_scs = const AddSCs, red_stack = (0,[]), red_improve = True } @@ -1784,7 +1814,6 @@ mkInferRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv mkInferRedEnv doc try_me = RedEnv { red_doc = doc, red_try_me = try_me, red_givens = [], - red_given_scs = const AddSCs, red_stack = (0,[]), red_improve = True } @@ -1793,7 +1822,6 @@ mkNoImproveRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv mkNoImproveRedEnv doc try_me = RedEnv { red_doc = doc, red_try_me = try_me, red_givens = [], - red_given_scs = const AddSCs, red_stack = (0,[]), red_improve = True } @@ -1877,8 +1905,7 @@ reduceContext env wanteds0 -- Build the Avail mapping from "given_dicts" ; (init_state, _) <- getLIE $ do - { init_state <- foldlM (addGiven (red_given_scs env)) - emptyAvails givens' + { init_state <- foldlM addGiven emptyAvails givens' ; return init_state } @@ -1915,22 +1942,24 @@ reduceContext env wanteds0 -- go round again. We do so in either of two cases: -- (1) If dictionary reduction or equality solving led to -- improvement (i.e., instantiated type variables). - -- (2) If we uncovered extra equalities. We will try to solve them - -- in the next iteration. - -- (3) If we reduced dictionaries (i.e., got dictionary bindings), + -- (2) If we reduced dictionaries (i.e., got dictionary bindings), -- they may have exposed further opportunities to normalise -- family applications. See Note [Dictionary Improvement] + -- + -- NB: We do *not* go around for new extra_eqs. Morally, we should, + -- but we can't without risking non-termination (see #2688). By + -- not going around, we miss some legal programs mixing FDs and + -- TFs, but we never claimed to support such programs in the + -- current implementation anyway. ; let all_irreds = dict_irreds ++ implic_irreds ++ extra_eqs avails_improved = availsImproved avails improvedFlexible = avails_improved || eq_improved - extraEqs = (not . null) extra_eqs reduced_dicts = not (isEmptyBag dict_binds) - improved = improvedFlexible || extraEqs || reduced_dicts + improved = improvedFlexible || reduced_dicts -- improvedHint = (if avails_improved then " [AVAILS]" else "") ++ - (if eq_improved then " [EQ]" else "") ++ - (if extraEqs then " [EXTRA EQS]" else "") + (if eq_improved then " [EQ]" else "") ; traceTc (text "reduceContext end" <+> (vcat [ text "----------------------", @@ -2590,14 +2619,19 @@ addWanted want_scs avails wanted rhs_expr wanteds where avail = Rhs rhs_expr wanteds -addGiven :: (Inst -> WantSCs) -> Avails -> Inst -> TcM Avails -addGiven want_scs avails given = addAvailAndSCs (want_scs given) avails given (Given given) - -- Conditionally add superclasses for 'givens' +addGiven :: Avails -> Inst -> TcM Avails +addGiven avails given + = addAvailAndSCs want_scs avails given (Given given) + where + want_scs = case instLocOrigin (instLoc given) of + NoScOrigin -> NoSCs + _other -> AddSCs + -- Conditionally add superclasses for 'given' -- See Note [Recursive instances and superclases] - -- - -- No ASSERT( not (given `elemAvails` avails) ) because in an instance - -- decl for Ord t we can add both Ord t and Eq t as 'givens', - -- so the assert isn't true + + -- No ASSERT( not (given `elemAvails` avails) ) because in an + -- instance decl for Ord t we can add both Ord t and Eq t as + -- 'givens', so the assert isn't true \end{code} \begin{code} @@ -2968,7 +3002,8 @@ tcSimplifyDeriv orig tyvars theta ; (irreds, _) <- tryHardCheckLoop doc wanteds ; let (tv_dicts, others) = partition ok irreds - ; addNoInstanceErrs others + (tidy_env, tidy_insts) = tidyInsts others + ; reportNoInstances tidy_env Nothing [alt_fix] tidy_insts -- See Note [Exotic derived instance contexts] in TcMType ; let rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars) @@ -2982,6 +3017,8 @@ tcSimplifyDeriv orig tyvars theta ok dict | isDict dict = validDerivPred (dictPred dict) | otherwise = False + alt_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration instead,"), + ptext (sLit "so you can specify the instance context yourself")] \end{code} @@ -2996,7 +3033,7 @@ tcSimplifyDefault :: ThetaType -- Wanted; has no type variables in it tcSimplifyDefault theta = do wanteds <- newDictBndrsO DefaultOrigin theta (irreds, _) <- tryHardCheckLoop doc wanteds - addNoInstanceErrs irreds + addNoInstanceErrs irreds if null irreds then return () else @@ -3005,6 +3042,26 @@ 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} + %************************************************************************ %* * @@ -3072,7 +3129,7 @@ addNoInstanceErrs :: [Inst] -- Wanted (can include implications) -> TcM () addNoInstanceErrs insts = do { let (tidy_env, tidy_insts) = tidyInsts insts - ; reportNoInstances tidy_env Nothing tidy_insts } + ; reportNoInstances tidy_env Nothing [] tidy_insts } reportNoInstances :: TidyEnv @@ -3080,14 +3137,15 @@ reportNoInstances -- Nothing => top level -- Just (d,g) => d describes the construct -- with givens g + -> [SDoc] -- Alternative fix for no-such-instance -> [Inst] -- What is wanted (can include implications) -> TcM () -reportNoInstances tidy_env mb_what insts - = groupErrs (report_no_instances tidy_env mb_what) insts +reportNoInstances tidy_env mb_what alt_fix insts + = groupErrs (report_no_instances tidy_env mb_what alt_fix) insts -report_no_instances :: TidyEnv -> Maybe (InstLoc, [Inst]) -> [Inst] -> TcM () -report_no_instances tidy_env mb_what insts +report_no_instances :: TidyEnv -> Maybe (InstLoc, [Inst]) -> [SDoc] -> [Inst] -> TcM () +report_no_instances tidy_env mb_what alt_fixes insts = do { inst_envs <- tcGetInstEnvs ; let (implics, insts1) = partition isImplicInst insts (insts2, overlaps) = partitionWith (check_overlap inst_envs) insts1 @@ -3105,7 +3163,7 @@ report_no_instances tidy_env mb_what insts complain_implic inst -- Recurse! = reportNoInstances tidy_env (Just (tci_loc inst, tci_given inst)) - (tci_wanted inst) + alt_fixes (tci_wanted inst) check_overlap :: (InstEnv,InstEnv) -> Inst -> Either Inst SDoc -- Right msg => overlap message @@ -3153,13 +3211,13 @@ report_no_instances tidy_env mb_what insts = vcat [ addInstLoc insts $ sep [ ptext (sLit "Could not deduce") <+> pprDictsTheta insts , nest 2 $ ptext (sLit "from the context") <+> pprDictsTheta givens] - , show_fixes (fix1 loc : fixes2) ] + , show_fixes (fix1 loc : fixes2 ++ alt_fixes) ] | otherwise -- Top level = vcat [ addInstLoc insts $ ptext (sLit "No instance") <> plural insts <+> ptext (sLit "for") <+> pprDictsTheta insts - , show_fixes fixes2 ] + , show_fixes (fixes2 ++ alt_fixes) ] where fix1 loc = sep [ ptext (sLit "add") <+> pprDictsTheta insts