From: Simon Peyton Jones Date: Fri, 6 May 2011 14:56:06 +0000 (+0100) Subject: Merge master into the ghc-new-co branch X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=ca53c38335cdc671f0b1e0949aa1514fc3fd72a5;p=ghc-hetmet.git Merge master into the ghc-new-co branch --- ca53c38335cdc671f0b1e0949aa1514fc3fd72a5 diff --cc compiler/deSugar/DsExpr.lhs index 5db2175,4088e44..e33b113 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@@ -927,24 -810,28 +810,28 @@@ conversionName \begin{code} -- Warn about certain types of values discarded in monadic bindings (#3263) - warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM () - warnDiscardedDoBindings rhs container_ty returning_ty = do { - -- Warn about discarding non-() things in 'monadic' binding - ; warn_unused <- doptDs Opt_WarnUnusedDoBind - ; if warn_unused && not (returning_ty `eqType` unitTy) - then warnDs (unusedMonadBind rhs returning_ty) - else do { - -- Warn about discarding m a things in 'monadic' binding of the same type, - -- but only if we didn't already warn due to Opt_WarnUnusedDoBind - ; warn_wrong <- doptDs Opt_WarnWrongDoBind - ; case tcSplitAppTy_maybe returning_ty of - Just (returning_container_ty, _) -> when (warn_wrong && container_ty `eqType` returning_container_ty) $ - warnDs (wrongMonadBind rhs returning_ty) - _ -> return () } } + warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM () + warnDiscardedDoBindings rhs rhs_ty + | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty + = do { -- Warn about discarding non-() things in 'monadic' binding + ; warn_unused <- doptDs Opt_WarnUnusedDoBind + ; if warn_unused && not (isUnitTy elt_ty) + then warnDs (unusedMonadBind rhs elt_ty) + else + -- Warn about discarding m a things in 'monadic' binding of the same type, + -- but only if we didn't already warn due to Opt_WarnUnusedDoBind + do { warn_wrong <- doptDs Opt_WarnWrongDoBind + ; case tcSplitAppTy_maybe elt_ty of - Just (elt_m_ty, _) | warn_wrong, m_ty `tcEqType` elt_m_ty ++ Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty + -> warnDs (wrongMonadBind rhs elt_ty) + _ -> return () } } + + | otherwise -- RHS does have type of form (m ty), which is wierd + = return () -- but at lesat this warning is irrelevant unusedMonadBind :: LHsExpr Id -> Type -> SDoc - unusedMonadBind rhs returning_ty - = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$ + unusedMonadBind rhs elt_ty + = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$ ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$ ptext (sLit "or by using the flag -fno-warn-unused-do-bind") diff --cc compiler/hsSyn/HsUtils.lhs index 3316634,5e8dda3..d86b632 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@@ -19,9 -19,9 +19,9 @@@ module HsUtils mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt, mkSimpleMatch, unguardedGRHSs, unguardedRHS, mkMatchGroup, mkMatch, mkHsLam, mkHsIf, - mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI, - coiToHsWrapper, mkHsLams, mkHsDictLet, - mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCoI, + mkHsWrap, mkLHsWrap, mkHsWrapCo, mkLHsWrapCo, + coToHsWrapper, mkHsDictLet, mkHsLams, - mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCo, ++ mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, diff --cc compiler/iface/IfaceSyn.lhs index 48bef49,950021e..ef0ef5c --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@@ -231,19 -232,18 +232,19 @@@ data IfaceUnfoldin -------------------------------- data IfaceExpr - = IfaceLcl IfLclName + = IfaceLcl IfLclName | IfaceExt IfExtName | IfaceType IfaceType - | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted - | IfaceLam IfaceBndr IfaceExpr - | IfaceApp IfaceExpr IfaceExpr - | IfaceCase IfaceExpr IfLclName IfaceType [IfaceAlt] - | IfaceLet IfaceBinding IfaceExpr - | IfaceNote IfaceNote IfaceExpr + | IfaceCo IfaceType -- We re-use IfaceType for coercions + | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted + | IfaceLam IfaceBndr IfaceExpr + | IfaceApp IfaceExpr IfaceExpr + | IfaceCase IfaceExpr IfLclName [IfaceAlt] + | IfaceLet IfaceBinding IfaceExpr + | IfaceNote IfaceNote IfaceExpr | IfaceCast IfaceExpr IfaceCoercion - | IfaceLit Literal - | IfaceFCall ForeignCall IfaceType + | IfaceLit Literal + | IfaceFCall ForeignCall IfaceType | IfaceTick Module Int data IfaceNote = IfaceSCC CostCentre @@@ -831,19 -837,19 +841,19 @@@ freeNamesIfUnfold (IfLclWrapper {} freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr (dfunArgExprs vs) freeNamesIfExpr :: IfaceExpr -> NameSet - freeNamesIfExpr (IfaceExt v) = unitNameSet v + freeNamesIfExpr (IfaceExt v) = unitNameSet v freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty +freeNamesIfExpr (IfaceCo co) = freeNamesIfType co freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfType co - freeNamesIfExpr (IfaceNote _n r) = freeNamesIfExpr r + freeNamesIfExpr (IfaceNote _n r) = freeNamesIfExpr r -freeNamesIfExpr (IfaceCase s _ ty alts) - = freeNamesIfExpr s +freeNamesIfExpr (IfaceCase s _ alts) + = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts - &&& freeNamesIfType ty where fn_alt (_con,_bs,r) = freeNamesIfExpr r diff --cc compiler/typecheck/TcHsSyn.lhs index 06cbe33,d179a0e..35da655 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@@ -1113,28 -1116,4 +1117,28 @@@ zonkTypeZapping t zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv) ; writeMetaTyVar tv ty ; return ty } + +zonkTcCoToCo :: ZonkEnv -> Coercion -> TcM Coercion +zonkTcCoToCo env co + = go co + where + go (CoVarCo cv) = return (CoVarCo (zonkEvVarOcc env cv)) + go (Refl ty) = do { ty' <- zonkTcTypeToType env ty + ; return (Refl ty') } + go (TyConAppCo tc cos) = do { cos' <- mapM go cos; return (mkTyConAppCo tc cos') } + go (AxiomInstCo ax cos) = do { cos' <- mapM go cos; return (AxiomInstCo ax cos') } + go (AppCo co1 co2) = do { co1' <- go co1; co2' <- go co2 + ; return (mkAppCo co1' co2') } + go (PredCo pco) = do { pco' <- go `traverse` pco; return (mkPredCo pco') } + go (UnsafeCo t1 t2) = do { t1' <- zonkTcTypeToType env t1 + ; t2' <- zonkTcTypeToType env t2 + ; return (mkUnsafeCo t1' t2') } + go (SymCo co) = do { co' <- go co; return (mkSymCo co') } + go (NthCo n co) = do { co' <- go co; return (mkNthCo n co') } + go (TransCo co1 co2) = do { co1' <- go co1; co2' <- go co2 + ; return (mkTransCo co1' co2') } + go (InstCo co ty) = do { co' <- go co; ty' <- zonkTcTypeToType env ty + ; return (mkInstCo co' ty') } + go (ForAllCo tv co) = ASSERT( isImmutableTyVar tv ) + do { co' <- go co; return (mkForAllCo tv co') } - \end{code} + \end{code} diff --cc compiler/typecheck/TcMatches.lhs index f912039,48fdf77..ce6c2fc --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@@ -28,9 -30,8 +30,8 @@@ import TysWiredI import Id import TyCon import TysPrim - import Coercion ( mkSymCo ) -import Coercion ( isIdentityCoI, mkSymCoI ) ++import Coercion ( isReflCo, mkSymCo ) import Outputable - import BasicTypes ( Arity ) import Util import SrcLoc import FastString @@@ -238,36 -242,33 +242,33 @@@ tcGRHS ctxt res_ty (GRHS guards rhs \begin{code} tcDoStmts :: HsStmtContext Name -> [LStmt Name] - -> LHsExpr Name -> TcRhoType -> TcM (HsExpr TcId) -- Returns a HsDo - tcDoStmts ListComp stmts body res_ty + tcDoStmts ListComp stmts res_ty = do { (coi, elt_ty) <- matchExpectedListTy res_ty - ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts - elt_ty $ - tcBody body - ; return $ mkHsWrapCo coi - (HsDo ListComp stmts' body' (mkListTy elt_ty)) } + ; let list_ty = mkListTy elt_ty + ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty - ; return $ mkHsWrapCoI coi (HsDo ListComp stmts' list_ty) } ++ ; return $ mkHsWrapCo coi (HsDo ListComp stmts' list_ty) } - tcDoStmts PArrComp stmts body res_ty + tcDoStmts PArrComp stmts res_ty = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty - ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts - elt_ty $ - tcBody body - ; return $ mkHsWrapCo coi - (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) } + ; let parr_ty = mkPArrTy elt_ty + ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty - ; return $ mkHsWrapCoI coi (HsDo PArrComp stmts' parr_ty) } ++ ; return $ mkHsWrapCo coi (HsDo PArrComp stmts' parr_ty) } + + tcDoStmts DoExpr stmts res_ty + = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty + ; return (HsDo DoExpr stmts' res_ty) } - tcDoStmts DoExpr stmts body res_ty - = do { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts res_ty $ - tcBody body - ; return (HsDo DoExpr stmts' body' res_ty) } + tcDoStmts MDoExpr stmts res_ty + = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty + ; return (HsDo MDoExpr stmts' res_ty) } - tcDoStmts MDoExpr stmts body res_ty - = do { (stmts', body') <- tcStmts MDoExpr tcDoStmt stmts res_ty $ - tcBody body - ; return (HsDo MDoExpr stmts' body' res_ty) } + tcDoStmts MonadComp stmts res_ty + = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty + ; return (HsDo MonadComp stmts' res_ty) } - tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) + tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId) tcBody body res_ty