X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsSyn.lhs;h=b5534531e617dbb30d64440fc5ba7d6f40719d1e;hp=c850bdf97e8ed015522bc5e2c4421b0498d03809;hb=bb7ffa1642e2110e26e1243c42a8a24adafa985d;hpb=16513d4899e167d20e120c2b3907230b7ff9dd83

diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index c850bdf..b553453 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -1,18 +1,22 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The AQUA Project, Glasgow University, 1996-1998
 %
-\section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker}
+
+TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker
 
 This module is an extension of @HsSyn@ syntax, for use in the type
 checker.
 
 \begin{code}
 module TcHsSyn (
-	mkHsTyApp, mkHsDictApp, mkHsConApp,
-	mkHsTyLam, mkHsDictLam, mkHsDictLet, mkHsApp,
-	hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt,
-	nlHsIntLit, mkVanillaTuplePat,
+	mkHsConApp, mkHsDictLet, mkHsApp,
+	hsLitType, hsLPatType, hsPatType, 
+	mkHsAppTy, mkSimpleHsAlt,
+	nlHsIntLit, mkVanillaTuplePat, 
+	shortCutLit, hsOverLitName,
 	
+	mkArbitraryType,	-- Put this elsewhere?
 
 	-- re-exported from TcMonad
 	TcId, TcIdSet, TcDictBinds,
@@ -27,33 +31,45 @@ module TcHsSyn (
 import HsSyn	-- oodles of it
 
 -- others:
-import Id	( idType, setIdType, Id )
+import Id
 
 import TcRnMonad
-import Type	  ( Type )
-import TcType	  ( TcType, TcTyVar, mkTyVarTy, mkTyConApp, isImmutableTyVar )
-import Kind	  ( isLiftedTypeKind, liftedTypeKind, isSubKind )
-import qualified  Type
-import TcMType	  ( zonkQuantifiedTyVar, zonkType, zonkTcType, writeMetaTyVar )
-import TysPrim	  ( charPrimTy, intPrimTy, floatPrimTy,
-		    doublePrimTy, addrPrimTy
-		  )
-import TysWiredIn ( charTy, stringTy, intTy, 
-		    mkListTy, mkPArrTy, mkTupleTy, unitTy,
-		    voidTy, listTyCon, tupleTyCon )
-import TyCon	  ( mkPrimTyCon, tyConKind, PrimRep(..) )
-import Kind	  ( splitKindFunTys )
-import Name	  ( Name, getOccName, mkInternalName, mkDerivedTyConOcc )
-import Var	  ( Var, isId, isLocalVar, tyVarKind )
+import PrelNames
+import Type
+import TcType
+import TcMType
+import TysPrim
+import TysWiredIn
+import TyCon
+import DataCon
+import Name
+import Var
 import VarSet
 import VarEnv
-import BasicTypes ( Boxity(..), IPName(..), ipNameName, mapIPName )
-import Maybes	  ( orElse )
-import Unique	  ( Uniquable(..) )
-import SrcLoc	  ( noSrcLoc, noLoc, Located(..), unLoc )
-import Util	  ( mapSnd )
+import Literal
+import BasicTypes
+import Maybes
+import Unique
+import SrcLoc
+import Util
 import Bag
 import Outputable
+import FastString
+\end{code}
+
+\begin{code}
+-- XXX
+thenM :: Monad a => a b -> (b -> a c) -> a c
+thenM = (>>=)
+
+thenM_ :: Monad a => a b -> a c -> a c
+thenM_ = (>>)
+
+returnM :: Monad m => a -> m a
+returnM = return
+
+mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
+mappM = mapM
 \end{code}
 
 
@@ -63,51 +79,85 @@ import Outputable
 %*									*
 %************************************************************************
 
-Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@,
+Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
 then something is wrong.
 \begin{code}
 mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
 -- A vanilla tuple pattern simply gets its type from its sub-patterns
 mkVanillaTuplePat pats box 
-  = TuplePat pats box (mkTupleTy box (length pats) (map hsPatType pats))
-
-hsPatType :: OutPat Id -> Type
-hsPatType (L _ pat) = pat_type pat
-
-pat_type (ParPat pat)		   = hsPatType pat
-pat_type (WildPat ty)		   = ty
-pat_type (VarPat var)		   = idType var
-pat_type (VarPatOut var _)	   = idType var
-pat_type (BangPat pat)		   = hsPatType pat
-pat_type (LazyPat pat)		   = hsPatType pat
-pat_type (LitPat lit)		   = hsLitType lit
-pat_type (AsPat var pat)	   = idType (unLoc var)
-pat_type (ListPat _ ty)		   = mkListTy ty
-pat_type (PArrPat _ ty)		   = mkPArrTy ty
-pat_type (TuplePat pats box ty)	   = ty
-pat_type (ConPatOut _ _ _ _ _ ty)  = ty
-pat_type (SigPatOut pat ty)	   = ty
-pat_type (NPat lit _ _ ty)	   = ty
-pat_type (NPlusKPat id _ _ _)      = idType (unLoc id)
-pat_type (DictPat ds ms)           = case (ds ++ ms) of
-				       []  -> unitTy
-				       [d] -> idType d
-				       ds  -> mkTupleTy Boxed (length ds) (map idType ds)
-
+  = TuplePat pats box (mkTupleTy box (length pats) (map hsLPatType pats))
+
+hsLPatType :: OutPat Id -> Type
+hsLPatType (L _ pat) = hsPatType pat
+
+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
+hsPatType (AsPat var _)               = idType (unLoc var)
+hsPatType (ViewPat _ _ ty)            = ty
+hsPatType (ListPat _ ty)              = mkListTy ty
+hsPatType (PArrPat _ ty)              = mkPArrTy ty
+hsPatType (TuplePat _ _ ty)           = ty
+hsPatType (ConPatOut { pat_ty = ty }) = ty
+hsPatType (SigPatOut _ ty)            = ty
+hsPatType (NPat lit _ _)              = overLitType lit
+hsPatType (NPlusKPat id _ _ _)        = idType (unLoc id)
+hsPatType (CoPat _ _ ty)              = ty
+hsPatType p                           = pprPanic "hsPatType" (ppr p)
 
 hsLitType :: HsLit -> TcType
-hsLitType (HsChar c)       = charTy
-hsLitType (HsCharPrim c)   = charPrimTy
-hsLitType (HsString str)   = stringTy
-hsLitType (HsStringPrim s) = addrPrimTy
-hsLitType (HsInt i)	   = intTy
-hsLitType (HsIntPrim i)    = intPrimTy
-hsLitType (HsInteger i ty) = ty
-hsLitType (HsRat _ ty)	   = ty
-hsLitType (HsFloatPrim f)  = floatPrimTy
-hsLitType (HsDoublePrim d) = doublePrimTy
+hsLitType (HsChar _)       = charTy
+hsLitType (HsCharPrim _)   = charPrimTy
+hsLitType (HsString _)     = stringTy
+hsLitType (HsStringPrim _) = addrPrimTy
+hsLitType (HsInt _)        = intTy
+hsLitType (HsIntPrim _)    = intPrimTy
+hsLitType (HsWordPrim _)   = wordPrimTy
+hsLitType (HsInteger _ ty) = ty
+hsLitType (HsRat _ ty)     = ty
+hsLitType (HsFloatPrim _)  = floatPrimTy
+hsLitType (HsDoublePrim _) = doublePrimTy
 \end{code}
 
+Overloaded literals. Here mainly becuase it uses isIntTy etc
+
+\begin{code}
+shortCutLit :: OverLitVal -> TcType -> Maybe (HsExpr TcId)
+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
+	-- 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
+	-- This can make a big difference for programs with a lot of
+	-- literals, compiled without -O
+
+shortCutLit (HsFractional f) ty
+  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim f))
+  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
+  | otherwise     = Nothing
+
+shortCutLit (HsIsString s) ty
+  | isStringTy ty = Just (HsLit (HsString s))
+  | otherwise     = Nothing
+
+mkLit :: DataCon -> HsLit -> HsExpr Id
+mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
+
+------------------------------
+hsOverLitName :: OverLitVal -> Name
+-- Get the canonical 'fromX' name for a particular OverLitVal
+hsOverLitName (HsIntegral {})   = fromIntegerName
+hsOverLitName (HsFractional {}) = fromRationalName
+hsOverLitName (HsIsString {})   = fromStringName
+\end{code}
 
 %************************************************************************
 %*									*
@@ -120,7 +170,7 @@ hsLitType (HsDoublePrim d) = doublePrimTy
 zonkId :: TcId -> TcM TcId
 zonkId id
   = zonkTcType (idType id) `thenM` \ ty' ->
-    returnM (setIdType id ty')
+    returnM (Id.setIdType id ty')
 \end{code}
 
 The rest of the zonking is done *after* typechecking.
@@ -146,6 +196,7 @@ data ZonkEnv = ZonkEnv	(TcType -> TcM Type) 	-- How to zonk a type
 	-- Maps an Id to its zonked version; both have the same Name
 	-- Is only consulted lazily; hence knot-tying
 
+emptyZonkEnv :: ZonkEnv
 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
 
 extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
@@ -178,10 +229,11 @@ zonkIdOcc :: ZonkEnv -> TcId -> Id
 --
 -- Even without template splices, in module Main, the checking of
 -- 'main' is done as a separate chunk.
-zonkIdOcc (ZonkEnv zonk_ty env) id 
+zonkIdOcc (ZonkEnv _zonk_ty env) id 
   | isLocalVar id = lookupVarEnv env id `orElse` id
   | otherwise	  = id
 
+zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
 zonkIdOccs env ids = map (zonkIdOcc env) ids
 
 -- zonkIdBndr is used *after* typechecking to get the Id's type
@@ -189,11 +241,19 @@ zonkIdOccs env ids = map (zonkIdOcc env) ids
 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
 zonkIdBndr env id
   = zonkTcTypeToType env (idType id)	`thenM` \ ty' ->
-    returnM (setIdType id ty')
+    returnM (Id.setIdType id ty')
 
 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
 
+zonkDictBndrs :: ZonkEnv -> [Var] -> TcM [Var]
+-- "Dictionary" binders can be coercion variables or dictionary variables
+zonkDictBndrs env ids = mappM (zonkDictBndr env) ids
+
+zonkDictBndr :: ZonkEnv -> Var -> TcM Var
+zonkDictBndr env var | isTyVar var = return var
+		     | otherwise   = zonkIdBndr env var
+
 zonkTopBndrs :: [TcId] -> TcM [Id]
 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
 \end{code}
@@ -243,8 +303,8 @@ zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
 
 ---------------------------------------------
 zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id)
-zonkValBinds env bs@(ValBindsIn _ _) 
-  = panic "zonkValBinds"	-- Not in typechecker output
+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) }
@@ -287,7 +347,7 @@ zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn
 zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts, 
 			  abs_exports = exports, abs_binds = val_binds })
   = ASSERT( all isImmutableTyVar tyvars )
-    zonkIdBndrs env dicts		`thenM` \ new_dicts ->
+    zonkDictBndrs env dicts			`thenM` \ new_dicts ->
     fixM (\ ~(new_val_binds, _) ->
 	let
 	  env1 = extendZonkEnv env new_dicts
@@ -301,14 +361,15 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts,
 			abs_exports = new_exports, abs_binds = new_val_bind })
   where
     zonkExport env (tyvars, global, local, prags)
+	-- The tyvars are already zonked
 	= zonkIdBndr env global			`thenM` \ new_global ->
 	  mapM zonk_prag prags			`thenM` \ new_prags -> 
 	  returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
-    zonk_prag prag@(InlinePrag {})  = return prag
-    zonk_prag (SpecPrag expr ty ds inl) = do { expr' <- zonkExpr env expr 
-					     ; ty'   <- zonkTcTypeToType env ty
-					     ; let ds' = zonkIdOccs env ds
-					     ; return (SpecPrag expr' ty' ds' inl) }
+    zonk_prag prag@(L _ (InlinePrag {}))  = return prag
+    zonk_prag (L loc (SpecPrag expr ty inl))
+	= do { expr' <- zonkExpr env expr 
+	     ; ty'   <- zonkTcTypeToType env ty
+	     ; return (L loc (SpecPrag expr' ty' inl)) }
 \end{code}
 
 %************************************************************************
@@ -369,7 +430,7 @@ zonkExpr env (HsLit (HsRat f ty))
   = zonkTcTypeToType env ty	   `thenM` \ new_ty  ->
     returnM (HsLit (HsRat f new_ty))
 
-zonkExpr env (HsLit lit)
+zonkExpr _ (HsLit lit)
   = returnM (HsLit lit)
 
 zonkExpr env (HsOverLit lit)
@@ -392,7 +453,7 @@ zonkExpr env (HsBracketOut body bs)
     zonk_b (n,e) = zonkLExpr env e	`thenM` \ e' ->
 		   returnM (n,e')
 
-zonkExpr env (HsSpliceE s) = WARN( True, ppr s )	-- Should not happen
+zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
 			     returnM (HsSpliceE s)
 
 zonkExpr env (OpApp e1 op fixity e2)
@@ -458,22 +519,22 @@ zonkExpr env (ExplicitTuple exprs boxed)
     returnM (ExplicitTuple new_exprs boxed)
 
 zonkExpr env (RecordCon data_con con_expr rbinds)
-  = zonkExpr env con_expr	`thenM` \ new_con_expr ->
-    zonkRbinds env rbinds	`thenM` \ new_rbinds ->
-    returnM (RecordCon data_con new_con_expr new_rbinds)
+  = do	{ new_con_expr <- zonkExpr env con_expr
+	; new_rbinds   <- zonkRecFields env rbinds
+	; return (RecordCon data_con new_con_expr new_rbinds) }
 
-zonkExpr env (RecordUpd expr rbinds in_ty out_ty)
-  = zonkLExpr env expr		`thenM` \ new_expr ->
-    zonkTcTypeToType env in_ty	`thenM` \ new_in_ty ->
-    zonkTcTypeToType env out_ty	`thenM` \ new_out_ty ->
-    zonkRbinds env rbinds	`thenM` \ new_rbinds ->
-    returnM (RecordUpd new_expr new_rbinds new_in_ty new_out_ty)
+zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
+  = do	{ new_expr    <- zonkLExpr env expr
+	; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys
+	; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
+	; new_rbinds  <- zonkRecFields env rbinds
+	; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) }
 
 zonkExpr env (ExprWithTySigOut e ty) 
   = do { e' <- zonkLExpr env e
        ; return (ExprWithTySigOut e' ty) }
 
-zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
+zonkExpr _ (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
 
 zonkExpr env (ArithSeq expr info)
   = zonkExpr env expr		`thenM` \ new_expr ->
@@ -489,33 +550,15 @@ zonkExpr env (HsSCC lbl expr)
   = zonkLExpr env expr	`thenM` \ new_expr ->
     returnM (HsSCC lbl new_expr)
 
+zonkExpr env (HsTickPragma info expr)
+  = zonkLExpr env expr	`thenM` \ new_expr ->
+    returnM (HsTickPragma info new_expr)
+
 -- hdaume: core annotations
 zonkExpr env (HsCoreAnn lbl expr)
   = zonkLExpr env expr   `thenM` \ new_expr ->
     returnM (HsCoreAnn lbl new_expr)
 
-zonkExpr env (TyLam tyvars expr)
-  = ASSERT( all isImmutableTyVar tyvars )
-    zonkLExpr env expr			`thenM` \ new_expr ->
-    returnM (TyLam tyvars new_expr)
-
-zonkExpr env (TyApp expr tys)
-  = zonkLExpr env expr    	`thenM` \ new_expr ->
-    zonkTcTypeToTypes env tys	`thenM` \ new_tys ->
-    returnM (TyApp new_expr new_tys)
-
-zonkExpr env (DictLam dicts expr)
-  = zonkIdBndrs env dicts	`thenM` \ new_dicts ->
-    let
-	env1 = extendZonkEnv env new_dicts
-    in
-    zonkLExpr env1 expr  	`thenM` \ new_expr ->
-    returnM (DictLam new_dicts new_expr)
-
-zonkExpr env (DictApp expr dicts)
-  = zonkLExpr env expr    	    	`thenM` \ new_expr ->
-    returnM (DictApp new_expr (zonkIdOccs env dicts))
-
 -- arrow notation extensions
 zonkExpr env (HsProc pat body)
   = do	{ (env1, new_pat) <- zonkPat env pat
@@ -533,16 +576,17 @@ zonkExpr env (HsArrForm op fixity args)
     mappM (zonkCmdTop env) args		`thenM` \ new_args ->
     returnM (HsArrForm new_op fixity new_args)
 
-zonkExpr env (HsCoerce co_fn expr)
+zonkExpr env (HsWrap co_fn expr)
   = zonkCoFn env co_fn	`thenM` \ (env1, new_co_fn) ->
     zonkExpr env1 expr	`thenM` \ new_expr ->
-    return (HsCoerce new_co_fn new_expr)
+    return (HsWrap new_co_fn new_expr)
 
-zonkExpr env other = pprPanic "zonkExpr" (ppr other)
+zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
 
 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
 
+zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
 zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
   = zonkLExpr env cmd	    		`thenM` \ new_cmd ->
     zonkTcTypeToTypes env stack_tys	`thenM` \ new_stack_tys ->
@@ -551,40 +595,38 @@ zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
     returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
 
 -------------------------------------------------------------------------
-zonkCoFn :: ZonkEnv -> ExprCoFn -> TcM (ZonkEnv, ExprCoFn)
-zonkCoFn env CoHole = return (env, CoHole)
-zonkCoFn env (CoCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
+zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
+zonkCoFn env WpHole   = return (env, WpHole)
+zonkCoFn env WpInline = return (env, WpInline)
+zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
 				    ; (env2, c2') <- zonkCoFn env1 c2
-				    ; return (env2, CoCompose c1' c2') }
-zonkCoFn env (CoLams ids c) = do { ids' <- zonkIdBndrs env ids
-				 ; let env1 = extendZonkEnv env ids'
-				 ; (env2, c') <- zonkCoFn env1 c
-				 ; return (env2, CoLams ids' c') }
-zonkCoFn env (CoTyLams tvs c) = ASSERT( all isImmutableTyVar tvs )
-				do { (env1, c') <- zonkCoFn env c
-				   ; return (env1, CoTyLams tvs c') }
-zonkCoFn env (CoApps c ids)   = do { (env1, c') <- zonkCoFn env c
-				   ; return (env1, CoApps c' (zonkIdOccs env ids)) }
-zonkCoFn env (CoTyApps c tys) = do { tys' <- zonkTcTypeToTypes env tys
-				   ; (env1, c') <- zonkCoFn env c
-				   ; return (env1, CoTyApps c' tys') }
-zonkCoFn env (CoLet bs c)     = do { (env1, bs') <- zonkRecMonoBinds env bs
-			 	   ; (env2, c')  <- zonkCoFn env1 c
-				   ; return (env2, CoLet bs' c') }
+				    ; return (env2, WpCompose c1' c2') }
+zonkCoFn env (WpCast co)    = do { co' <- zonkTcTypeToType env co
+				 ; return (env, WpCast co') }
+zonkCoFn env (WpLam id)     = do { id' <- zonkDictBndr env id
+				 ; let env1 = extendZonkEnv1 env id'
+				 ; return (env1, WpLam id') }
+zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )
+			      do { return (env, WpTyLam tv) }
+zonkCoFn env (WpApp id)     = do { return (env, WpApp (zonkIdOcc env id)) }
+zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToType env ty
+				 ; return (env, WpTyApp ty') }
+zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkRecMonoBinds env bs
+				 ; return (env1, WpLet bs') }
 
 
 -------------------------------------------------------------------------
 zonkDo :: ZonkEnv -> HsStmtContext Name -> HsStmtContext Name
 -- Only used for 'do', so the only Ids are in a MDoExpr table
 zonkDo env (MDoExpr tbl) = MDoExpr (mapSnd (zonkIdOcc env) tbl)
-zonkDo env do_or_lc      = do_or_lc
+zonkDo _   do_or_lc      = do_or_lc
 
 -------------------------------------------------------------------------
 zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
-zonkOverLit env (HsIntegral i e)
-  = do	{ e' <- zonkExpr env e; return (HsIntegral i e') }
-zonkOverLit env (HsFractional r e)
-  = do	{ e' <- zonkExpr env e; return (HsFractional r e') }
+zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
+  = do	{ ty' <- zonkTcTypeToType env ty
+	; e' <- zonkExpr env e
+ 	; return (lit { ol_witness = e', ol_type = ty' }) }
 
 -------------------------------------------------------------------------
 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
@@ -651,6 +693,37 @@ zonkStmt env (ExprStmt expr then_op ty)
     zonkTcTypeToType env ty	`thenM` \ new_ty ->
     returnM (env, ExprStmt new_expr new_then 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) groupByClause)
+  = do { (env', stmts') <- zonkStmts env stmts 
+    ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
+    ; groupByClause' <- 
+        case groupByClause of
+            GroupByNothing usingExpr -> (zonkLExpr env' usingExpr) >>= (return . GroupByNothing)
+            GroupBySomething eitherUsingExpr byExpr -> do
+                eitherUsingExpr' <- mapEitherM (zonkLExpr env') (zonkExpr env') eitherUsingExpr
+                byExpr' <- zonkLExpr env' byExpr
+                return $ GroupBySomething eitherUsingExpr' byExpr'
+                
+    ; let env'' = extendZonkEnv env' (map snd binderMap')
+    ; return (env'', GroupStmt (stmts', binderMap') groupByClause') }
+  where
+    mapEitherM f g x = do
+      case x of
+        Left a -> f a >>= (return . Left)
+        Right b -> g b >>= (return . Right)
+  
+    zonkBinderMapEntry env (oldBinder, newBinder) = do 
+        let oldBinder' = zonkIdOcc env oldBinder
+        newBinder' <- zonkIdBndr env newBinder
+        return (oldBinder', newBinder') 
+
 zonkStmt env (LetStmt binds)
   = zonkLocalBinds env binds	`thenM` \ (env1, new_binds) ->
     returnM (env1, LetStmt new_binds)
@@ -662,21 +735,25 @@ 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)
 
--------------------------------------------------------------------------
-zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
 
-zonkRbinds env rbinds
-  = mappM zonk_rbind rbinds
+-------------------------------------------------------------------------
+zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
+zonkRecFields env (HsRecFields flds dd)
+  = do	{ flds' <- mappM zonk_rbind flds
+	; return (HsRecFields flds' dd) }
   where
-    zonk_rbind (field, expr)
-      = zonkLExpr env expr	`thenM` \ new_expr ->
-	returnM (fmap (zonkIdOcc env) field, new_expr)
+    zonk_rbind fld
+      = do { new_expr <- zonkLExpr env (hsRecFieldArg fld)
+	   ; return (fld { hsRecFieldArg = new_expr }) }
+	-- Field selectors have declared types; hence no zonking
 
 -------------------------------------------------------------------------
 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
-mapIPNameTc f (Dupable n) = f n  `thenM` \ r -> returnM (Dupable r)
-mapIPNameTc f (Linear  n) = f n  `thenM` \ r -> returnM (Linear r)
+mapIPNameTc f (IPName n) = f n  `thenM` \ r -> returnM (IPName r)
 \end{code}
 
 
@@ -693,6 +770,7 @@ zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
 -- to the right)
 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
 
+zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id)
 zonk_pat env (ParPat p)
   = do	{ (env', p') <- zonkPat env p
   	; return (env', ParPat p') }
@@ -723,6 +801,11 @@ zonk_pat env (AsPat (L loc v) pat)
 	; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
  	; return (env', AsPat (L loc v') pat') }
 
+zonk_pat env (ViewPat expr pat ty)
+  = do	{ expr' <- zonkLExpr env expr
+	; (env', pat') <- zonkPat env pat
+ 	; return (env', ViewPat expr' pat' ty) }
+
 zonk_pat env (ListPat pats ty)
   = do	{ ty' <- zonkTcTypeToType env ty
 	; (env', pats') <- zonkPats env pats
@@ -738,14 +821,15 @@ zonk_pat env (TuplePat pats boxed ty)
 	; (env', pats') <- zonkPats env pats
 	; return (env', TuplePat pats' boxed ty') }
 
-zonk_pat env (ConPatOut n tvs dicts binds stuff ty)
-  = ASSERT( all isImmutableTyVar tvs )
+zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = dicts, pat_binds = binds, pat_args = args })
+  = ASSERT( all isImmutableTyVar (pat_tvs p) ) 
     do	{ new_ty <- zonkTcTypeToType env ty
-	; new_dicts <- zonkIdBndrs env dicts
+	; new_dicts <- zonkDictBndrs env dicts
 	; let env1 = extendZonkEnv env new_dicts
 	; (env2, new_binds) <- zonkRecMonoBinds env1 binds
-	; (env', new_stuff) <- zonkConStuff env2 stuff
-	; returnM (env', ConPatOut n tvs new_dicts new_binds new_stuff new_ty) }
+	; (env', new_args) <- zonkConStuff env2 args
+	; returnM (env', p { pat_ty = new_ty, pat_dicts = new_dicts, 
+			     pat_binds = new_binds, pat_args = new_args }) }
 
 zonk_pat env (LitPat lit) = return (env, LitPat lit)
 
@@ -754,15 +838,14 @@ zonk_pat env (SigPatOut pat ty)
 	; (env', pat') <- zonkPat env pat
 	; return (env', SigPatOut pat' ty') }
 
-zonk_pat env (NPat lit mb_neg eq_expr 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') }
  	; eq_expr' <- zonkExpr env eq_expr
-	; ty' <- zonkTcTypeToType env ty
-	; return (env, NPat lit' mb_neg' eq_expr' ty') }
+	; return (env, NPat lit' mb_neg' eq_expr') }
 
 zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
   = do	{ n' <- zonkIdBndr env n
@@ -771,12 +854,19 @@ zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
 	; e2' <- zonkExpr env e2
 	; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
 
-zonk_pat env (DictPat ds ms)
-  = do	{ ds' <- zonkIdBndrs env ds
-	; ms' <- zonkIdBndrs env ms
-	; return (extendZonkEnv env (ds' ++ ms'), DictPat ds' ms') }
+zonk_pat env (CoPat co_fn pat ty) 
+  = do { (env', co_fn') <- zonkCoFn env co_fn
+       ; (env'', pat') <- zonkPat env' (noLoc pat)
+       ; ty' <- zonkTcTypeToType env'' ty
+       ; return (env'', CoPat co_fn' (unLoc pat') ty') }
+
+zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
 
 ---------------------------
+zonkConStuff :: ZonkEnv
+             -> HsConDetails (OutPat TcId) (HsRecFields id (OutPat TcId))
+             -> TcM (ZonkEnv,
+                     HsConDetails (OutPat Id) (HsRecFields id (OutPat Id)))
 zonkConStuff env (PrefixCon pats)
   = do	{ (env', pats') <- zonkPats env pats
 	; return (env', PrefixCon pats') }
@@ -786,17 +876,18 @@ zonkConStuff env (InfixCon p1 p2)
 	; (env', p2') <- zonkPat env1 p2
 	; return (env', InfixCon p1' p2') }
 
-zonkConStuff env (RecCon rpats)
-  = do	{ (env', pats') <- zonkPats env pats
-	; returnM (env', RecCon (fields `zip` pats')) }
-  where
-    (fields, pats) = unzip rpats
+zonkConStuff env (RecCon (HsRecFields rpats dd))
+  = do	{ (env', pats') <- zonkPats env (map hsRecFieldArg rpats)
+	; let rpats' = zipWith (\rp p' -> rp { hsRecFieldArg = p' }) rpats pats'
+	; returnM (env', RecCon (HsRecFields rpats' dd)) }
+	-- Field selectors have declared types; hence no zonking
 
 ---------------------------
+zonkPats :: ZonkEnv -> [OutPat TcId] -> TcM (ZonkEnv, [OutPat Id])
 zonkPats env []		= return (env, [])
 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
-			     ; (env', pats') <- zonkPats env1 pats
-			     ; return (env', pat':pats') }
+		     ; (env', pats') <- zonkPats env1 pats
+		     ; return (env', pat':pats') }
 \end{code}
 
 %************************************************************************
@@ -811,9 +902,9 @@ zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
 
 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
-zonkForeignExport env (ForeignExport i hs_ty spec) =
+zonkForeignExport env (ForeignExport i _hs_ty spec) =
    returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec)
-zonkForeignExport env for_imp 
+zonkForeignExport _ for_imp 
   = returnM for_imp	-- Foreign imports don't need zonking
 \end{code}
 
@@ -822,7 +913,7 @@ zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
 
 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
-zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs fv_lhs rhs fv_rhs)
+zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
   = mappM zonk_bndr vars		`thenM` \ new_bndrs ->
     newMutVar emptyVarSet		`thenM` \ unbound_tv_set ->
     let
@@ -865,6 +956,7 @@ zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs fv_lhs rhs fv_rhs)
 	| isId (unLoc v) = wrapLocM (zonkIdBndr env)   v
 	| otherwise      = ASSERT( isImmutableTyVar (unLoc v) )
 			   return v
+   zonk_bndr (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig"
 \end{code}
 
 
@@ -904,58 +996,76 @@ zonkTypeZapping ty
 	-- mutable tyvar to a fresh immutable one.  So the mutable store
 	-- plays the role of an environment.  If we come across a mutable
 	-- type variable that isn't so bound, it must be completely free.
-    zonk_unbound_tyvar tv = do { writeMetaTyVar tv ty; return ty }
-			  where 
-			    ty = mkArbitraryType tv
-
-
--- When the type checker finds a type variable with no binding,
--- which means it can be instantiated with an arbitrary type, it
--- usually instantiates it to Void.  Eg.
--- 
--- 	length []
--- ===>
--- 	length Void (Nil Void)
--- 
--- But in really obscure programs, the type variable might have
--- a kind other than *, so we need to invent a suitably-kinded type.
--- 
--- This commit uses
--- 	Void for kind *
--- 	List for kind *->*
--- 	Tuple for kind *->...*->*
--- 
--- which deals with most cases.  (Previously, it only dealt with
--- kind *.)   
--- 
--- In the other cases, it just makes up a TyCon with a suitable
--- kind.  If this gets into an interface file, anyone reading that
--- file won't understand it.  This is fixable (by making the client
--- of the interface file make up a TyCon too) but it is tiresome and
--- never happens, so I am leaving it 
-
-mkArbitraryType :: TcTyVar -> Type
--- Make up an arbitrary type whose kind is the same as the tyvar.
--- We'll use this to instantiate the (unbound) tyvar.
-mkArbitraryType tv 
-  | liftedTypeKind `isSubKind` kind = voidTy		-- The vastly common case
-  | otherwise			    = mkTyConApp tycon []
-  where
-    kind       = tyVarKind tv
-    (args,res) = splitKindFunTys kind
+    zonk_unbound_tyvar tv = do { ty <- mkArbitraryType warn tv
+			       ; writeMetaTyVar tv ty
+			       ; return ty }
+	where
+	    warn span msg = setSrcSpan span (addWarnTc msg)
+
 
-    tycon | kind == tyConKind listTyCon 	--  *->*
-	  = listTyCon				-- No tuples this size
+{- 	Note [Strangely-kinded void TyCons]
+	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+	See Trac #959 for more examples
 
-	  | all isLiftedTypeKind args && isLiftedTypeKind res
-	  = tupleTyCon Boxed (length args)	--  *-> ... ->*->*
+When the type checker finds a type variable with no binding, which
+means it can be instantiated with an arbitrary type, it usually
+instantiates it to Void.  Eg.
 
-	  | otherwise
-	  = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
-	    mkPrimTyCon tc_name kind 0 [] VoidRep
+	length []
+===>
+	length Void (Nil Void)
+
+But in really obscure programs, the type variable might have a kind
+other than *, so we need to invent a suitably-kinded type.
+
+This commit uses
+	Void for kind *
+	List for kind *->*
+	Tuple for kind *->...*->*
+
+which deals with most cases.  (Previously, it only dealt with
+kind *.)   
+
+In the other cases, it just makes up a TyCon with a suitable kind.  If
+this gets into an interface file, anyone reading that file won't
+understand it.  This is fixable (by making the client of the interface
+file make up a TyCon too) but it is tiresome and never happens, so I
+am leaving it.
+
+Meanwhile I have now fixed GHC to emit a civilized warning.
+ -}
+
+mkArbitraryType :: (SrcSpan -> SDoc -> TcRnIf g l a)	-- How to complain
+		-> TcTyVar
+		-> TcRnIf g l Type		-- Used by desugarer too
+-- Make up an arbitrary type whose kind is the same as the tyvar.
+-- We'll use this to instantiate the (unbound) tyvar.
+--
+-- Also used by the desugarer; hence the (tiresome) parameter
+-- to use when generating a warning
+mkArbitraryType warn tv 
+  | liftedTypeKind `isSubKind` kind 		-- The vastly common case
+  = return anyPrimTy
+  | eqKind kind (tyConKind anyPrimTyCon1) 	-- @*->*@
+  = return (mkTyConApp anyPrimTyCon1 [])	--     No tuples this size
+  | all isLiftedTypeKind args 			-- @*-> ... ->*->*@
+  , isLiftedTypeKind res			--    Horrible hack to make less use 
+  = return (mkTyConApp tup_tc [])		--    of mkAnyPrimTyCon
+  | otherwise
+  = do	{ warn (getSrcSpan tv) msg
+	; return (mkTyConApp (mkAnyPrimTyCon (getUnique tv) kind) []) }
 		-- Same name as the tyvar, apart from making it start with a colon (sigh)
 		-- I dread to think what will happen if this gets out into an 
 		-- interface file.  Catastrophe likely.  Major sigh.
-
-    tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
+  where
+    kind       = tyVarKind tv
+    (args,res) = splitKindFunTys kind
+    tup_tc     = tupleTyCon Boxed (length args)
+		
+    msg = vcat [ hang (ptext (sLit "Inventing strangely-kinded Any TyCon"))
+		    2 (ptext (sLit "of kind") <+> quotes (ppr kind))
+	       , nest 2 (ptext (sLit "from an instantiation of type variable") <+> quotes (ppr tv))
+	       , ptext (sLit "This warning can be suppressed by a type signature fixing") <+> quotes (ppr tv)
+	       , nest 2 (ptext (sLit "but is harmless without -O (and usually harmless anyway)."))
+	       , ptext (sLit "See http://hackage.haskell.org/trac/ghc/ticket/959 for details")  ]
 \end{code}