Merge master into the ghc-new-co branch

diff --cc compiler/deSugar/Check.lhs
Simple merge

diff --cc compiler/deSugar/DsExpr.lhs
index 5db2175,4088e44..e33b113
--- 1/compiler/deSugar/DsExpr.lhs
--- 2/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/deSugar/Match.lhs
Simple merge

diff --cc compiler/ghc.cabal.in
Simple merge

diff --cc compiler/hsSyn/HsPat.lhs
Simple merge

diff --cc compiler/hsSyn/HsUtils.lhs
index 3316634,5e8dda3..d86b632
--- 1/compiler/hsSyn/HsUtils.lhs
--- 2/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
--- 1/compiler/iface/IfaceSyn.lhs
--- 2/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/main/DynFlags.hs
Simple merge

diff --cc compiler/prelude/PrelNames.lhs
Simple merge

diff --cc compiler/rename/RnBinds.lhs
Simple merge

diff --cc compiler/typecheck/TcArrows.lhs
Simple merge

diff --cc compiler/typecheck/TcExpr.lhs
Simple merge

diff --cc compiler/typecheck/TcGenDeriv.lhs
Simple merge

diff --cc compiler/typecheck/TcHsSyn.lhs
index 06cbe33,d179a0e..35da655
--- 1/compiler/typecheck/TcHsSyn.lhs
--- 2/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
--- 1/compiler/typecheck/TcMatches.lhs
--- 2/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

diff --cc compiler/typecheck/TcPat.lhs
Simple merge

diff --cc compiler/typecheck/TcRnDriver.lhs
Simple merge

diff --cc compiler/typecheck/TcRnMonad.lhs
Simple merge

diff --cc compiler/typecheck/TcRnTypes.lhs
Simple merge

diff --cc compiler/typecheck/TcSMonad.lhs
Simple merge

diff --cc compiler/typecheck/TcUnify.lhs
Simple merge