Use FractionalLit more extensively to improve other pretty printers
[ghc-hetmet.git] / compiler / typecheck / TcHsSyn.lhs
index 074ab39..12b50ac 100644 (file)
@@ -35,19 +35,24 @@ import TcRnMonad
 import PrelNames
 import TcType
 import TcMType
+import Coercion
 import TysPrim
 import TysWiredIn
 import DataCon
 import Name
+import NameSet
 import Var
 import VarSet
 import VarEnv
+import DynFlags( DynFlag(..) )
 import Literal
 import BasicTypes
 import Maybes
 import SrcLoc
 import Bag
+import FastString
 import Outputable
+-- import Data.Traversable( traverse )
 \end{code}
 
 \begin{code}
@@ -79,7 +84,6 @@ hsPatType :: Pat Id -> Type
 hsPatType (ParPat pat)                = hsLPatType pat
 hsPatType (WildPat ty)                = ty
 hsPatType (VarPat var)                = idType var
-hsPatType (VarPatOut var _)           = idType var
 hsPatType (BangPat pat)               = hsLPatType pat
 hsPatType (LazyPat pat)               = hsLPatType pat
 hsPatType (LitPat lit)                = hsLitType lit
@@ -117,7 +121,7 @@ shortCutLit (HsIntegral i) ty
   | isIntTy ty && inIntRange i   = Just (HsLit (HsInt i))
   | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
   | isIntegerTy ty              = Just (HsLit (HsInteger i ty))
-  | otherwise                   = shortCutLit (HsFractional (fromInteger i)) ty
+  | otherwise                   = shortCutLit (HsFractional (integralFractionalLit i)) ty
        -- The 'otherwise' case is important
        -- Consider (3 :: Float).  Syntactically it looks like an IntLit,
        -- so we'll call shortCutIntLit, but of course it's a float
@@ -265,29 +269,55 @@ zonkTopExpr e = zonkExpr emptyZonkEnv e
 zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
 zonkTopLExpr e = zonkLExpr emptyZonkEnv e
 
-zonkTopDecls :: Bag EvBind -> LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
-            -> TcM ([Id], 
-                    Bag EvBind,
-                    Bag (LHsBind  Id),
-                    [LForeignDecl Id],
-                    [LRuleDecl    Id])
-zonkTopDecls ev_binds binds rules fords
-  = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
-
-        ; (env2, binds') <- zonkRecMonoBinds env1 binds
-                       -- Top level is implicitly recursive
-       ; rules' <- zonkRules env2 rules
-       ; fords' <- zonkForeignExports env2 fords
-       ; return (zonkEnvIds env2, ev_binds', binds', fords', rules') }
+zonkTopDecls :: Bag EvBind 
+             -> LHsBinds TcId -> NameSet
+             -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
+             -> TcM ([Id], 
+                     Bag EvBind,
+                     Bag (LHsBind  Id),
+                     [LForeignDecl Id],
+                     [LTcSpecPrag],
+                     [LRuleDecl    Id],
+                     [LVectDecl    Id])
+zonkTopDecls ev_binds binds sig_ns rules vects imp_specs fords
+  = do  { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
+
+        -- Warn about missing signatures
+        -- Do this only when we we have a type to offer
+        ; warn_missing_sigs <- doptM Opt_WarnMissingSigs
+        ; let sig_warn | warn_missing_sigs = topSigWarn sig_ns
+                       | otherwise         = noSigWarn
+
+        ; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds
+                        -- Top level is implicitly recursive
+        ; rules' <- zonkRules env2 rules
+        ; vects' <- zonkVects env2 vects
+        ; specs' <- zonkLTcSpecPrags env2 imp_specs
+        ; fords' <- zonkForeignExports env2 fords
+        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') }
 
 ---------------------------------------------
 zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
 zonkLocalBinds env EmptyLocalBinds
   = return (env, EmptyLocalBinds)
 
-zonkLocalBinds env (HsValBinds binds)
-  = do { (env1, new_binds) <- zonkValBinds env binds
-       ; return (env1, HsValBinds new_binds) }
+zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
+  = panic "zonkLocalBinds" -- Not in typechecker output
+
+zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs))
+  = do { warn_missing_sigs <- doptM Opt_WarnMissingLocalSigs
+        ; let sig_warn | not warn_missing_sigs = noSigWarn
+                       | otherwise             = localSigWarn sig_ns
+              sig_ns = getTypeSigNames vb
+       ; (env1, new_binds) <- go env sig_warn binds
+        ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) }
+  where
+    go env _ []
+      = return (env, [])
+    go env sig_warn ((r,b):bs) 
+      = do { (env1, b')  <- zonkRecMonoBinds env sig_warn b
+          ; (env2, bs') <- go env1 sig_warn bs
+          ; return (env2, (r,b'):bs') }
 
 zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
   = mappM (wrapLocM zonk_ip_bind) binds        `thenM` \ new_binds ->
@@ -302,62 +332,98 @@ zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
          zonkLExpr env e                       `thenM` \ e' ->
          returnM (IPBind n' e')
 
-
----------------------------------------------
-zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id)
-zonkValBinds _ (ValBindsIn _ _) 
-  = panic "zonkValBinds" -- Not in typechecker output
-zonkValBinds env (ValBindsOut binds sigs) 
-  = do         { (env1, new_binds) <- go env binds
-       ; return (env1, ValBindsOut new_binds sigs) }
-  where
-    go env []         = return (env, [])
-    go env ((r,b):bs) = do { (env1, b')  <- zonkRecMonoBinds env b
-                          ; (env2, bs') <- go env1 bs
-                          ; return (env2, (r,b'):bs') }
-
 ---------------------------------------------
-zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
-zonkRecMonoBinds env binds 
+zonkRecMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
+zonkRecMonoBinds env sig_warn binds 
  = fixM (\ ~(_, new_binds) -> do 
        { let env1 = extendZonkEnv env (collectHsBindsBinders new_binds)
-        ; binds' <- zonkMonoBinds env1 binds
+        ; binds' <- zonkMonoBinds env1 sig_warn binds
         ; return (env1, binds') })
 
 ---------------------------------------------
-zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
-zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
+type SigWarn = Bool -> [Id] -> TcM ()  
+     -- Missing-signature warning
+     -- The Bool is True for an AbsBinds, False otherwise
+
+noSigWarn :: SigWarn
+noSigWarn _ _ = return ()
+
+topSigWarn :: NameSet -> SigWarn
+topSigWarn sig_ns _ ids = mapM_ (topSigWarnId sig_ns) ids
+
+topSigWarnId :: NameSet -> Id -> TcM ()
+-- The NameSet is the Ids that *lack* a signature
+-- We have to do it this way round because there are
+-- lots of top-level bindings that are generated by GHC
+-- and that don't have signatures
+topSigWarnId sig_ns id
+  | idName id `elemNameSet` sig_ns = warnMissingSig msg id
+  | otherwise                      = return ()
+  where
+    msg = ptext (sLit "Top-level binding with no type signature:")
+
+localSigWarn :: NameSet -> SigWarn
+localSigWarn sig_ns is_abs_bind ids
+  | not is_abs_bind = return ()
+  | otherwise       = mapM_ (localSigWarnId sig_ns) ids
+
+localSigWarnId :: NameSet -> Id -> TcM ()
+-- NameSet are the Ids that *have* type signatures
+localSigWarnId sig_ns id
+  | not (isSigmaTy (idType id))    = return ()
+  | idName id `elemNameSet` sig_ns = return ()
+  | otherwise                      = warnMissingSig msg id
+  where
+    msg = ptext (sLit "Polymophic local binding with no type signature:")
+
+warnMissingSig :: SDoc -> Id -> TcM ()
+warnMissingSig msg id
+  = do  { env0 <- tcInitTidyEnv
+        ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
+        ; addWarnTcM (env1, mk_msg tidy_ty) }
+  where
+    mk_msg ty = sep [ msg, nest 2 $ pprHsVar (idName id) <+> dcolon <+> ppr ty ]
+
+---------------------------------------------
+zonkMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (LHsBinds Id)
+zonkMonoBinds env sig_warn binds = mapBagM (wrapLocM (zonk_bind env sig_warn)) binds
 
-zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
-zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
+zonk_bind :: ZonkEnv -> SigWarn -> HsBind TcId -> TcM (HsBind Id)
+zonk_bind env sig_warn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
   = do { (_env, new_pat) <- zonkPat env pat            -- Env already extended
+        ; sig_warn False (collectPatBinders new_pat)
        ; new_grhss <- zonkGRHSs env grhss
        ; new_ty    <- zonkTcTypeToType env ty
        ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
 
-zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
-  = zonkIdBndr env var                         `thenM` \ new_var ->
-    zonkLExpr env expr                 `thenM` \ new_expr ->
-    returnM (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl })
-
-zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms
-                            , fun_co_fn = co_fn })
-  = wrapLocM (zonkIdBndr env) var      `thenM` \ new_var ->
-    zonkCoFn env co_fn                 `thenM` \ (env1, new_co_fn) ->
-    zonkMatchGroup env1 ms             `thenM` \ new_ms ->
-    returnM (bind { fun_id = new_var, fun_matches = new_ms
-                  , fun_co_fn = new_co_fn })
-
-zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs, abs_ev_binds = ev_binds,
-                         abs_exports = exports, abs_binds = val_binds })
+zonk_bind env sig_warn (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
+  = do { new_var  <- zonkIdBndr env var
+       ; sig_warn False [new_var]
+       ; new_expr <- zonkLExpr env expr
+       ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }
+
+zonk_bind env sig_warn bind@(FunBind { fun_id = L loc var, fun_matches = ms
+                                     , fun_co_fn = co_fn })
+  = do { new_var <- zonkIdBndr env var
+       ; sig_warn False [new_var]
+       ; (env1, new_co_fn) <- zonkCoFn env co_fn
+       ; new_ms <- zonkMatchGroup env1 ms
+       ; return (bind { fun_id = L loc new_var, fun_matches = new_ms
+                      , fun_co_fn = new_co_fn }) }
+
+zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
+                                 , abs_ev_binds = ev_binds
+                                , abs_exports = exports
+                                 , abs_binds = val_binds })
   = ASSERT( all isImmutableTyVar tyvars )
     do { (env1, new_evs) <- zonkEvBndrsX env evs
        ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
        ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
         do { let env3 = extendZonkEnv env2 (collectHsBindsBinders new_val_binds)
-           ; new_val_binds <- zonkMonoBinds env3 val_binds
+           ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds
            ; new_exports   <- mapM (zonkExport env3) exports
            ; return (new_val_binds, new_exports) } 
+       ; sig_warn True [b | (_,b,_,_) <- new_exports]
        ; return (AbsBinds { abs_tvs = tyvars, abs_ev_vars = new_evs, abs_ev_binds = new_ev_binds
                          , abs_exports = new_exports, abs_binds = new_val_bind }) }
   where
@@ -369,12 +435,16 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs, abs_ev_binds = ev
 
 zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
 zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
-zonkSpecPrags env (SpecPrags ps)  = do { ps' <- mapM zonk_prag ps
+zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
                                        ; return (SpecPrags ps') }
+
+zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
+zonkLTcSpecPrags env ps
+  = mapM zonk_prag ps
   where
-    zonk_prag (L loc (SpecPrag co_fn inl))
+    zonk_prag (L loc (SpecPrag id co_fn inl))
        = do { (_, co_fn') <- zonkCoFn env co_fn
-            ; return (L loc (SpecPrag co_fn' inl)) }
+            ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
 \end{code}
 
 %************************************************************************
@@ -498,23 +568,22 @@ zonkExpr env (HsCase expr ms)
     zonkMatchGroup env ms      `thenM` \ new_ms ->
     returnM (HsCase new_expr new_ms)
 
-zonkExpr env (HsIf e1 e2 e3)
-  = zonkLExpr env e1   `thenM` \ new_e1 ->
-    zonkLExpr env e2   `thenM` \ new_e2 ->
-    zonkLExpr env e3   `thenM` \ new_e3 ->
-    returnM (HsIf new_e1 new_e2 new_e3)
+zonkExpr env (HsIf e0 e1 e2 e3)
+  = do { new_e0 <- fmapMaybeM (zonkExpr env) e0
+       ; new_e1 <- zonkLExpr env e1
+       ; new_e2 <- zonkLExpr env e2
+       ; new_e3 <- zonkLExpr env e3
+       ; returnM (HsIf new_e0 new_e1 new_e2 new_e3) }
 
 zonkExpr env (HsLet binds expr)
   = zonkLocalBinds env binds   `thenM` \ (new_env, new_binds) ->
     zonkLExpr new_env expr     `thenM` \ new_expr ->
     returnM (HsLet new_binds new_expr)
 
-zonkExpr env (HsDo do_or_lc stmts body ty)
-  = zonkStmts env stmts        `thenM` \ (new_env, new_stmts) ->
-    zonkLExpr new_env body     `thenM` \ new_body ->
+zonkExpr env (HsDo do_or_lc stmts ty)
+  = zonkStmts env stmts        `thenM` \ (_, new_stmts) ->
     zonkTcTypeToType env ty    `thenM` \ new_ty   ->
-    zonkDo env do_or_lc                `thenM` \ new_do_or_lc ->
-    returnM (HsDo new_do_or_lc new_stmts new_body new_ty)
+    returnM (HsDo do_or_lc new_stmts new_ty)
 
 zonkExpr env (ExplicitList ty exprs)
   = zonkTcTypeToType env ty    `thenM` \ new_ty ->
@@ -608,7 +677,7 @@ zonkCoFn env WpHole   = return (env, WpHole)
 zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
                                    ; (env2, c2') <- zonkCoFn env1 c2
                                    ; return (env2, WpCompose c1' c2') }
-zonkCoFn env (WpCast co)    = do { co' <- zonkTcTypeToType env co
+zonkCoFn env (WpCast co)    = do { co' <- zonkTcCoToCo env co
                                 ; return (env, WpCast co') }
 zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
                                 ; return (env', WpEvLam ev') }
@@ -622,13 +691,6 @@ zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs
                                 ; return (env1, WpLet bs') }
 
 -------------------------------------------------------------------------
-zonkDo :: ZonkEnv -> HsStmtContext Name -> TcM (HsStmtContext Name)
--- Only used for 'do', so the only Ids are in a MDoExpr table
-zonkDo env (MDoExpr tbl) = do { tbl' <- mapSndM (zonkExpr env) tbl
-                              ; return (MDoExpr tbl') }
-zonkDo _   do_or_lc      = return do_or_lc
-
--------------------------------------------------------------------------
 zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
 zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
   = do { ty' <- zonkTcTypeToType env ty
@@ -667,22 +729,26 @@ zonkStmts env (s:ss) = do { (env1, s')  <- wrapLocSndM (zonkStmt env) s
                          ; return (env2, s' : ss') }
 
 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
-zonkStmt env (ParStmt stmts_w_bndrs)
+zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op)
   = mappM zonk_branch stmts_w_bndrs    `thenM` \ new_stmts_w_bndrs ->
     let 
        new_binders = concat (map snd new_stmts_w_bndrs)
        env1 = extendZonkEnv env new_binders
     in
-    return (env1, ParStmt new_stmts_w_bndrs)
+    zonkExpr env1 mzip_op   `thenM` \ new_mzip ->
+    zonkExpr env1 bind_op   `thenM` \ new_bind ->
+    zonkExpr env1 return_op `thenM` \ new_return ->
+    return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind new_return)
   where
     zonk_branch (stmts, bndrs) = zonkStmts env stmts   `thenM` \ (env1, new_stmts) ->
                                 returnM (new_stmts, zonkIdOccs env1 bndrs)
 
 zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
                       , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id
-                      , recS_rec_rets = rets, recS_dicts = binds })
+                      , recS_rec_rets = rets, recS_ret_ty = ret_ty })
   = do { new_rvs <- zonkIdBndrs env rvs
        ; new_lvs <- zonkIdBndrs env lvs
+       ; new_ret_ty  <- zonkTcTypeToType env ret_ty
        ; new_ret_id  <- zonkExpr env ret_id
        ; new_mfix_id <- zonkExpr env mfix_id
        ; new_bind_id <- zonkExpr env bind_id
@@ -691,34 +757,38 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id
        -- Zonk the ret-expressions in an envt that 
        -- has the polymorphic bindings in the envt
        ; new_rets <- mapM (zonkExpr env2) rets
-       ; let env3 = extendZonkEnv env new_lvs  -- Only the lvs are needed
-       ; (env4, new_binds) <- zonkTcEvBinds env3 binds
-       ; return (env4,
+       ; return (extendZonkEnv env new_lvs,     -- Only the lvs are needed
                  RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
                          , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
                          , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
-                         , recS_rec_rets = new_rets, recS_dicts = new_binds }) }
+                         , recS_rec_rets = new_rets, recS_ret_ty = new_ret_ty }) }
 
-zonkStmt env (ExprStmt expr then_op ty)
+zonkStmt env (ExprStmt expr then_op guard_op ty)
   = zonkLExpr env expr         `thenM` \ new_expr ->
     zonkExpr env then_op       `thenM` \ new_then ->
+    zonkExpr env guard_op      `thenM` \ new_guard ->
     zonkTcTypeToType env ty    `thenM` \ new_ty ->
-    returnM (env, ExprStmt new_expr new_then new_ty)
+    returnM (env, ExprStmt new_expr new_then new_guard new_ty)
 
-zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr)
-  = do { (env', stmts') <- zonkStmts env stmts 
-    ; let binders' = zonkIdOccs env' binders
-    ; usingExpr' <- zonkLExpr env' usingExpr
-    ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr
-    ; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr') }
-    
-zonkStmt env (GroupStmt stmts binderMap by using)
+zonkStmt env (LastStmt expr ret_op)
+  = zonkLExpr env expr         `thenM` \ new_expr ->
+    zonkExpr env ret_op                `thenM` \ new_ret ->
+    returnM (env, LastStmt new_expr new_ret)
+
+zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
+                        , trS_by = by, trS_form = form, trS_using = using
+                        , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op })
   = do { (env', stmts') <- zonkStmts env stmts 
     ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
-    ; by' <- fmapMaybeM (zonkLExpr env') by
-    ; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using
+    ; by'        <- fmapMaybeM (zonkLExpr env') by
+    ; using'     <- zonkLExpr env using
+    ; return_op' <- zonkExpr env' return_op
+    ; bind_op'   <- zonkExpr env' bind_op
+    ; liftM_op'  <- zonkExpr env' liftM_op
     ; let env'' = extendZonkEnv env' (map snd binderMap')
-    ; return (env'', GroupStmt stmts' binderMap' by' using') }
+    ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
+                               , trS_by = by', trS_form = form, trS_using = using'
+                               , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) }
   where
     zonkBinderMapEntry env (oldBinder, newBinder) = do 
         let oldBinder' = zonkIdOcc env oldBinder
@@ -736,11 +806,6 @@ zonkStmt env (BindStmt pat expr bind_op fail_op)
        ; new_fail <- zonkExpr env fail_op
        ; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
 
-zonkMaybeLExpr :: ZonkEnv -> Maybe (LHsExpr TcId) -> TcM (Maybe (LHsExpr Id))
-zonkMaybeLExpr _   Nothing  = return Nothing
-zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just)
-
-
 -------------------------------------------------------------------------
 zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
 zonkRecFields env (HsRecFields flds dd)
@@ -784,11 +849,6 @@ zonk_pat env (VarPat v)
   = do { v' <- zonkIdBndr env v
        ; return (extendZonkEnv1 env v', VarPat v') }
 
-zonk_pat env (VarPatOut v binds)
-  = do { v' <- zonkIdBndr env v
-       ; (env', binds') <- zonkTcEvBinds (extendZonkEnv1 env v') binds
-       ; returnM (env', VarPatOut v' binds') }
-
 zonk_pat env (LazyPat pat)
   = do { (env', pat') <- zonkPat env pat
        ; return (env',  LazyPat pat') }
@@ -841,10 +901,7 @@ zonk_pat env (SigPatOut pat ty)
 
 zonk_pat env (NPat lit mb_neg eq_expr)
   = do { lit' <- zonkOverLit env lit
-       ; mb_neg' <- case mb_neg of
-                       Nothing  -> return Nothing
-                       Just neg -> do { neg' <- zonkExpr env neg
-                                      ; return (Just neg') }
+       ; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg
        ; eq_expr' <- zonkExpr env eq_expr
        ; return (env, NPat lit' mb_neg' eq_expr') }
 
@@ -953,10 +1010,24 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
 
    zonk_it env v
      | isId v     = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') }
-     | isCoVar v  = do { v' <- zonkEvBndr env v; return (extendZonkEnv1 env v', v') }
      | otherwise  = ASSERT( isImmutableTyVar v) return (env, v)
 \end{code}
 
+\begin{code}
+zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id]
+zonkVects env = mappM (wrapLocM (zonkVect env))
+
+zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id)
+zonkVect env (HsVect v Nothing)
+  = do { v' <- wrapLocM (zonkIdBndr env) v
+       ; return $ HsVect v' Nothing
+       }
+zonkVect env (HsVect v (Just e))
+  = do { v' <- wrapLocM (zonkIdBndr env) v
+       ; e' <- zonkLExpr env e
+       ; return $ HsVect v' (Just e')
+       }
+\end{code}
 
 %************************************************************************
 %*                                                                     *
@@ -968,13 +1039,13 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
 zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
 zonkEvTerm env (EvId v)           = ASSERT2( isId v, ppr v ) 
                                     return (EvId (zonkIdOcc env v))
-zonkEvTerm env (EvCoercion co)    = do { co' <- zonkTcTypeToType env co
+zonkEvTerm env (EvCoercion co)    = do { co' <- zonkTcCoToCo env co
                                        ; return (EvCoercion co') }
 zonkEvTerm env (EvCast v co)      = ASSERT( isId v) 
-                                    do { co' <- zonkTcTypeToType env co
+                                    do { co' <- zonkTcCoToCo env co
                                        ; return (EvCast (zonkIdOcc env v) co') }
 zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n)
-zonkEvTerm env (EvDFunApp df tys tms) 
+zonkEvTerm env (EvDFunApp df tys tms)
   = do { tys' <- zonkTcTypeToTypes env tys
        ; let tms' = map (zonkEvVarOcc env) tms
        ; return (EvDFunApp (zonkIdOcc env df) tys' tms') }
@@ -1009,7 +1080,7 @@ zonkEvBind env (EvBind var term)
 
 %************************************************************************
 %*                                                                     *
-\subsection[BackSubst-Foreign]{Foreign exports}
+                         Zonking types
 %*                                                                     *
 %************************************************************************
 
@@ -1026,7 +1097,7 @@ zonkTypeCollecting unbound_tv_set
   = zonkType (mkZonkTcTyVar zonk_unbound_tyvar)
   where
     zonk_unbound_tyvar tv 
-       = do { tv' <- zonkQuantifiedTyVar tv
+        = do { tv' <- zonkQuantifiedTyVar tv
             ; tv_set <- readMutVar unbound_tv_set
             ; writeMutVar unbound_tv_set (extendVarSet tv_set tv')
             ; return (mkTyVarTy tv') }
@@ -1046,4 +1117,27 @@ zonkTypeZapping ty
     zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv)
                               ; writeMetaTyVar tv ty
                               ; return ty }
-\end{code}
\ No newline at end of file
+
+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 (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}