Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-constraint-solver
http://hackage.haskell.org/trac/ghc/changeset/38767f0d59d49718f73c86ce0ca2f210fb0e4823 >--------------------------------------------------------------- commit 38767f0d59d49718f73c86ce0ca2f210fb0e4823 Author: Dimitrios Vytiniotis <[email protected]> Date: Fri Oct 21 16:49:54 2011 +0100 Checkpoint: more small bugfixes throughout arising from testsuite validation. >--------------------------------------------------------------- compiler/coreSyn/CoreLint.lhs | 11 ++++++----- compiler/deSugar/DsBinds.lhs | 8 +------- compiler/typecheck/TcCanonical.lhs | 2 +- compiler/typecheck/TcInteract.lhs | 5 ++--- compiler/typecheck/TcRnTypes.lhs | 3 +-- compiler/typecheck/TcSMonad.lhs | 7 +------ 6 files changed, 12 insertions(+), 24 deletions(-) diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 9063366..daed3c6 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -289,12 +289,12 @@ lintCoreExpr e@(App _ _) , Just dc <- isDataConWorkId_maybe x , dc == eqBoxDataCon , [Type arg_ty1, Type arg_ty2, co_e] <- args - = do arg_kind1 <- lintType arg_ty1 - arg_kind2 <- lintType arg_ty2 - unless (arg_kind1 `eqKind` arg_kind2) + = do arg_ty1' <- lintInTy arg_ty1 + arg_ty2' <- lintInTy arg_ty2 + unless (typeKind arg_ty1' `eqKind` typeKind arg_ty2') (addErrL (mkEqBoxKindErrMsg arg_ty1 arg_ty2)) - lintCoreArg (mkCoercionType arg_ty1 arg_ty2 `mkFunTy` mkEqPred (arg_ty1, arg_ty2)) co_e + lintCoreArg (mkCoercionType arg_ty1' arg_ty2' `mkFunTy` mkEqPred (arg_ty1', arg_ty2')) co_e | otherwise = do { fun_ty <- lintCoreExpr fun ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args } @@ -701,7 +701,8 @@ lintCoercion (CoVarCo cv) 2 (ptext (sLit "With offending type:") <+> ppr (varType cv))) | otherwise = do { checkTyCoVarInScope cv - ; return (coVarKind cv) } + ; cv' <- lookupIdInScope cv + ; return (coVarKind cv') } lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = tvs , co_ax_lhs = lhs diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index dc9dfbe..367da46 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -260,13 +260,7 @@ dsLCoercion co k --------------------------------------- dsEvTerm :: EvTerm -> CoreExpr dsEvTerm (EvId v) = Var v --- Decompose, if coercion: -{- dsEvTerm (EvCast v co) - | isLCoVar v -- If it's a lifted coercion then treat it specially - = dsEvTerm (EvCoercionBox lco) - where lco = mkSymCo (mkNthCo 0 co) `mkTransCo` (mkEqVarLCo v) `mkTransCo` (mkNthCo 1 co) --} --- Otherwise + dsEvTerm (EvCast v co) = dsLCoercion co $ Cast (Var v) -- 'v' is always a lifted evidence variable so it is -- unnecessary to call varToCoreExpr v here. diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index bb39a5f..857a357 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -856,7 +856,7 @@ canEqLeaf :: SubGoalDepth -- Depth -- * one of the two arguments is not OtherCls -- * the two types are not equal (looking through synonyms) -canEqLeaf d _untch fl eqv cls1 cls2 +canEqLeaf _d _untch fl eqv cls1 cls2 -- First have a case for reflexivity since the guard in the top of canEq -- is not enough as the leaf equality may now be rewritten from some inerts. | ty1 <- unClassify cls1 diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index b98d85d..d7e705f 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -693,7 +693,7 @@ doInteractWithInert :: Ct -> Ct -> TcS InteractResult -- Identical class constraints. doInteractWithInert inertItem@(CDictCan { cc_id = d1, cc_flavor = fl1, cc_class = cls1, cc_tyargs = tys1 }) - workItem@(CDictCan { cc_id = d2, cc_flavor = fl2, cc_class = cls2, cc_tyargs = tys2 }) + workItem@(CDictCan { cc_id = _d2, cc_flavor = fl2, cc_class = cls2, cc_tyargs = tys2 }) | cls1 == cls2 = do { let pty1 = mkClassPred cls1 tys1 @@ -722,7 +722,7 @@ doInteractWithInert | otherwise -> irKeepGoing "NOP" -- Actual Functional Dependencies - Just (rewritten_tys2,cos2,fd_work) + Just (rewritten_tys2,_cos2,fd_work) | not (eqTypes tys1 rewritten_tys2) -- Standard thing: create derived fds and keep on going. Importantly we don't -- throw workitem back in the worklist because this can cause loops. See #5236. @@ -731,7 +731,6 @@ doInteractWithInert -- This WHOLE otherwise branch is an optimization where the fd made the things match | otherwise - , let dict_co = mkTyConAppCo (classTyCon cls1) cos2 -> case fl2 of Given {} -> pprPanic "Unexpected given!" (ppr inertItem $$ ppr workItem) diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index c4fd8d2..305d16d 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -56,7 +56,7 @@ module TcRnTypes( -- Pretty printing pprEvVarTheta, pprWantedEvVar, pprWantedsWithLocs, - pprEvVars, pprEvVarWithType, + pprEvVars, pprEvVarWithType, pprWantedEvVarWithLoc, pprArising, pprArisingAt, -- Misc other types @@ -98,7 +98,6 @@ import ListSetOps import FastString import Data.Set (Set) -import Pair \end{code} diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index d0444f1..b91f773 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -772,10 +772,7 @@ tryTcS :: TcS a -> TcS a -- Moreover, we will simply throw away all the evidence generated. tryTcS tcs = TcS (\env -> - do { wl_orig <- TcM.readTcRef (tcs_worklist env) - ; is_orig <- TcM.readTcRef (tcs_inerts env) - - ; wl_var <- TcM.newTcRef emptyWorkList + do { wl_var <- TcM.newTcRef emptyWorkList ; is_var <- TcM.newTcRef emptyInert ; ty_binds_var <- TcM.newTcRef emptyVarEnv @@ -808,8 +805,6 @@ updWorkListTcS f = do { wl_var <- getTcSWorkListRef ; wl_curr <- wrapTcS (TcM.readTcRef wl_var) ; let new_work = f wl_curr - ; traceTcS "updWorkListTcS" $ - text "WorkList set to:" <+> ppr new_work ; wrapTcS (TcM.writeTcRef wl_var new_work) } updInertSetTcS :: (InertSet -> (InertSet,a)) -> TcS a _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
