TcHsSyn.lhs 36.2 KB
Newer Older
1 2
%
% (c) The University of Glasgow 2006
3
% (c) The AQUA Project, Glasgow University, 1996-1998
4
%
5 6

TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker
7 8 9 10 11

This module is an extension of @HsSyn@ syntax, for use in the type
checker.

\begin{code}
12
{-# OPTIONS -w #-}
13 14 15
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
16
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
17 18
-- for details

19
module TcHsSyn (
20 21 22
	mkHsConApp, mkHsDictLet, mkHsApp,
	hsLitType, hsLPatType, hsPatType, 
	mkHsAppTy, mkSimpleHsAlt,
23
	nlHsIntLit, mkVanillaTuplePat,
24
	
25
	mkArbitraryType,	-- Put this elsewhere?
26

27
	-- re-exported from TcMonad
28
	TcId, TcIdSet, TcDictBinds,
29

30
	zonkTopDecls, zonkTopExpr, zonkTopLExpr,
31
	zonkId, zonkTopBndrs
32 33
  ) where

34
#include "HsVersions.h"
35 36 37 38 39

-- friends:
import HsSyn	-- oodles of it

-- others:
40
import Id
41

42
import TcRnMonad
43 44 45 46 47 48 49 50
import Type
import TcType
import TcMType
import TysPrim
import TysWiredIn
import TyCon
import Name
import Var
51
import VarSet
52
import VarEnv
53 54 55 56 57
import BasicTypes
import Maybes
import Unique
import SrcLoc
import Util
sof's avatar
sof committed
58
import Bag
sof's avatar
sof committed
59
import Outputable
60 61
\end{code}

Ian Lynagh's avatar
Ian Lynagh committed
62 63 64 65 66 67 68 69 70 71 72 73 74 75 76
\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}

77

78 79 80 81 82 83
%************************************************************************
%*									*
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
%*									*
%************************************************************************

84
Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
85 86
then something is wrong.
\begin{code}
87 88 89
mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
-- A vanilla tuple pattern simply gets its type from its sub-patterns
mkVanillaTuplePat pats box 
90 91 92 93 94 95 96 97 98 99 100 101 102
  = TuplePat pats box (mkTupleTy box (length pats) (map hsLPatType pats))

hsLPatType :: OutPat Id -> Type
hsLPatType (L _ pat) = hsPatType pat

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 pat)	    = idType (unLoc var)
103
hsPatType (ViewPat expr pat ty)     = ty
104 105 106 107 108
hsPatType (ListPat _ ty)	    = mkListTy ty
hsPatType (PArrPat _ ty)	    = mkPArrTy ty
hsPatType (TuplePat pats box ty)    = ty
hsPatType (ConPatOut{ pat_ty = ty })= ty
hsPatType (SigPatOut pat ty)	    = ty
109
hsPatType (NPat lit _ _)	    = overLitType lit
110 111
hsPatType (NPlusKPat id _ _ _)      = idType (unLoc id)
hsPatType (CoPat _ _ ty)	    = ty
112 113 114 115 116 117 118 119

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
120
hsLitType (HsInteger i ty) = ty
121 122 123
hsLitType (HsRat _ ty)	   = ty
hsLitType (HsFloatPrim f)  = floatPrimTy
hsLitType (HsDoublePrim d) = doublePrimTy
124 125 126
\end{code}


127 128 129 130 131 132
%************************************************************************
%*									*
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
%*									*
%************************************************************************

133 134 135 136 137
\begin{code}
-- zonkId is used *during* typechecking just to zonk the Id's type
zonkId :: TcId -> TcM TcId
zonkId id
  = zonkTcType (idType id) `thenM` \ ty' ->
138
    returnM (Id.setIdType id ty')
139 140 141 142
\end{code}

The rest of the zonking is done *after* typechecking.
The main zonking pass runs over the bindings
143 144 145

 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
 b) convert unbound TcTyVar to Void
146
 c) convert each TcId to an Id by zonking its type
sof's avatar
sof committed
147

148 149
The type variables are converted by binding mutable tyvars to immutable ones
and then zonking as normal.
150

151 152 153
The Ids are converted by binding them in the normal Tc envt; that
way we maintain sharing; eg an Id is zonked at its binding site and they
all occurrences of that Id point to the common zonked copy
sof's avatar
sof committed
154

155 156
It's all pretty boring stuff, because HsSyn is such a large type, and 
the environment manipulation is tiresome.
157

158
\begin{code}
159 160
data ZonkEnv = ZonkEnv	(TcType -> TcM Type) 	-- How to zonk a type
			(IdEnv Id)		-- What variables are in scope
161 162 163
	-- Maps an Id to its zonked version; both have the same Name
	-- Is only consulted lazily; hence knot-tying

164
emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
165 166

extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
167 168 169
extendZonkEnv (ZonkEnv zonk_ty env) ids 
  = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])

170 171 172 173
extendZonkEnv1 :: ZonkEnv -> Id -> ZonkEnv
extendZonkEnv1 (ZonkEnv zonk_ty env) id 
  = ZonkEnv zonk_ty (extendVarEnv env id id)

174 175
setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
176

177 178
zonkEnvIds :: ZonkEnv -> [Id]
zonkEnvIds (ZonkEnv _ env) = varEnvElts env
179 180 181 182 183

zonkIdOcc :: ZonkEnv -> TcId -> Id
-- Ids defined in this module should be in the envt; 
-- ignore others.  (Actually, data constructors are also
-- not LocalVars, even when locally defined, but that is fine.)
184 185
-- (Also foreign-imported things aren't currently in the ZonkEnv;
--  that's ok because they don't need zonking.)
186 187 188 189 190 191 192 193 194
--
-- Actually, Template Haskell works in 'chunks' of declarations, and
-- an earlier chunk won't be in the 'env' that the zonking phase 
-- carries around.  Instead it'll be in the tcg_gbl_env, already fully
-- zonked.  There's no point in looking it up there (except for error 
-- checking), and it's not conveniently to hand; hence the simple
-- 'orElse' case in the LocalVar branch.
--
-- Even without template splices, in module Main, the checking of
195
-- 'main' is done as a separate chunk.
196
zonkIdOcc (ZonkEnv zonk_ty env) id 
197 198 199 200
  | isLocalVar id = lookupVarEnv env id `orElse` id
  | otherwise	  = id

zonkIdOccs env ids = map (zonkIdOcc env) ids
201

202 203
-- zonkIdBndr is used *after* typechecking to get the Id's type
-- to its final form.  The TyVarEnv give 
204 205 206
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
zonkIdBndr env id
  = zonkTcTypeToType env (idType id)	`thenM` \ ty' ->
207
    returnM (Id.setIdType id ty')
208 209 210 211

zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
zonkIdBndrs env ids = mappM (zonkIdBndr env) ids

212 213 214 215 216 217 218
zonkDictBndrs :: ZonkEnv -> [Var] -> TcM [Var]
-- "Dictionary" binders can be coercion variables or dictionary variables
zonkDictBndrs env ids = mappM (zonkDictBndr env) ids

zonkDictBndr env var | isTyVar var = return var
		     | otherwise   = zonkIdBndr env var

219 220
zonkTopBndrs :: [TcId] -> TcM [Id]
zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
221 222 223 224
\end{code}


\begin{code}
225
zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
226 227
zonkTopExpr e = zonkExpr emptyZonkEnv e

228 229 230
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

231
zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
232
	     -> TcM ([Id], 
233 234 235
		     Bag (LHsBind  Id),
		     [LForeignDecl Id],
		     [LRuleDecl    Id])
236 237 238 239 240 241
zonkTopDecls binds rules fords
  = do	{ (env, binds') <- zonkRecMonoBinds emptyZonkEnv binds
			-- Top level is implicitly recursive
	; rules' <- zonkRules env rules
	; fords' <- zonkForeignExports env fords
	; return (zonkEnvIds env, binds', fords', rules') }
242 243

---------------------------------------------
244 245 246 247 248 249 250 251 252
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 env (HsIPBinds (IPBinds binds dict_binds))
253
  = mappM (wrapLocM zonk_ip_bind) binds	`thenM` \ new_binds ->
254
    let
255
	env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
256
    in
257 258
    zonkRecMonoBinds env1 dict_binds 	`thenM` \ (env2, new_dict_binds) -> 
    returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
259
  where
260
    zonk_ip_bind (IPBind n e)
261
	= mapIPNameTc (zonkIdBndr env) n	`thenM` \ n' ->
262 263
	  zonkLExpr env e			`thenM` \ e' ->
	  returnM (IPBind n' e')
264

265

266
---------------------------------------------
267 268 269
zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id)
zonkValBinds env bs@(ValBindsIn _ _) 
  = panic "zonkValBinds"	-- Not in typechecker output
270
zonkValBinds env (ValBindsOut binds sigs) 
271
  = do 	{ (env1, new_binds) <- go env binds
272
	; return (env1, ValBindsOut new_binds sigs) }
273 274 275 276 277
  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') }
278

279
---------------------------------------------
280 281 282 283 284 285 286
zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
zonkRecMonoBinds env binds 
 = fixM (\ ~(_, new_binds) -> do 
	{ let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
        ; binds' <- zonkMonoBinds env1 binds
        ; return (env1, binds') })

287
---------------------------------------------
288
zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
289
zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
290

291
zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
292
zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
293 294 295
  = do	{ (_env, new_pat) <- zonkPat env pat		-- Env already extended
	; new_grhss <- zonkGRHSs env grhss
	; new_ty    <- zonkTcTypeToType env ty
296
	; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
297

298
zonk_bind env (VarBind { var_id = var, var_rhs = expr })
299 300
  = zonkIdBndr env var 			`thenM` \ new_var ->
    zonkLExpr env expr			`thenM` \ new_expr ->
301
    returnM (VarBind { var_id = new_var, var_rhs = new_expr })
302

303
zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn })
304
  = wrapLocM (zonkIdBndr env) var	`thenM` \ new_var ->
305 306 307
    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 })
sof's avatar
sof committed
308

309 310
zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts, 
			  abs_exports = exports, abs_binds = val_binds })
311
  = ASSERT( all isImmutableTyVar tyvars )
312
    zonkDictBndrs env dicts			`thenM` \ new_dicts ->
313
    fixM (\ ~(new_val_binds, _) ->
314
	let
315 316
	  env1 = extendZonkEnv env new_dicts
	  env2 = extendZonkEnv env1 (collectHsBindBinders new_val_binds)
317
	in
318 319
	zonkMonoBinds env2 val_binds 		`thenM` \ new_val_binds ->
        mappM (zonkExport env2) exports		`thenM` \ new_exports ->
320 321
	returnM (new_val_binds, new_exports)
    )						`thenM` \ (new_val_bind, new_exports) ->
322 323
    returnM (AbsBinds { abs_tvs = tyvars, abs_dicts = new_dicts, 
			abs_exports = new_exports, abs_binds = new_val_bind })
sof's avatar
sof committed
324
  where
325
    zonkExport env (tyvars, global, local, prags)
326
	-- The tyvars are already zonked
327 328 329
	= zonkIdBndr env global			`thenM` \ new_global ->
	  mapM zonk_prag prags			`thenM` \ new_prags -> 
	  returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
330
    zonk_prag prag@(L _ (InlinePrag {}))  = return prag
331
    zonk_prag (L loc (SpecPrag expr ty inl))
332 333
	= do { expr' <- zonkExpr env expr 
	     ; ty'   <- zonkTcTypeToType env ty
334
	     ; return (L loc (SpecPrag expr' ty' inl)) }
335 336 337 338
\end{code}

%************************************************************************
%*									*
339
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
340 341 342 343
%*									*
%************************************************************************

\begin{code}
344 345 346 347 348
zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id)
zonkMatchGroup env (MatchGroup ms ty) 
  = do	{ ms' <- mapM (zonkMatch env) ms
	; ty' <- zonkTcTypeToType env ty
	; return (MatchGroup ms' ty') }
349

350
zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
351
zonkMatch env (L loc (Match pats _ grhss))
352 353 354
  = do	{ (env1, new_pats) <- zonkPats env pats
	; new_grhss <- zonkGRHSs env1 grhss
	; return (L loc (Match new_pats Nothing new_grhss)) }
355

356
-------------------------------------------------------------------------
357
zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
358

359
zonkGRHSs env (GRHSs grhss binds)
360
  = zonkLocalBinds env binds   	`thenM` \ (new_env, new_binds) ->
361
    let
362 363 364 365
	zonk_grhs (GRHS guarded rhs)
	  = zonkStmts new_env guarded	`thenM` \ (env2, new_guarded) ->
	    zonkLExpr env2 rhs		`thenM` \ new_rhs ->
	    returnM (GRHS new_guarded new_rhs)
366
    in
367
    mappM (wrapLocM zonk_grhs) grhss 	`thenM` \ new_grhss ->
368
    returnM (GRHSs new_grhss new_binds)
369 370 371 372 373 374 375 376 377
\end{code}

%************************************************************************
%*									*
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
%*									*
%************************************************************************

\begin{code}
378 379 380
zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
381

382 383
zonkLExprs env exprs = mappM (zonkLExpr env) exprs
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
384

385 386
zonkExpr env (HsVar id)
  = returnM (HsVar (zonkIdOcc env id))
387

388 389
zonkExpr env (HsIPVar id)
  = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
390

391
zonkExpr env (HsLit (HsRat f ty))
392
  = zonkTcTypeToType env ty	   `thenM` \ new_ty  ->
393
    returnM (HsLit (HsRat f new_ty))
sof's avatar
sof committed
394

395 396
zonkExpr env (HsLit lit)
  = returnM (HsLit lit)
397 398 399 400

zonkExpr env (HsOverLit lit)
  = do	{ lit' <- zonkOverLit env lit
	; return (HsOverLit lit') }
401

402 403 404
zonkExpr env (HsLam matches)
  = zonkMatchGroup env matches	`thenM` \ new_matches ->
    returnM (HsLam new_matches)
405 406

zonkExpr env (HsApp e1 e2)
407 408
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
409 410 411 412 413 414
    returnM (HsApp new_e1 new_e2)

zonkExpr env (HsBracketOut body bs) 
  = mappM zonk_b bs	`thenM` \ bs' ->
    returnM (HsBracketOut body bs')
  where
415
    zonk_b (n,e) = zonkLExpr env e	`thenM` \ e' ->
416 417
		   returnM (n,e')

418 419
zonkExpr env (HsSpliceE s) = WARN( True, ppr s )	-- Should not happen
			     returnM (HsSpliceE s)
420 421

zonkExpr env (OpApp e1 op fixity e2)
422 423 424
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env op	`thenM` \ new_op ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
425 426
    returnM (OpApp new_e1 new_op fixity new_e2)

427 428 429 430
zonkExpr env (NegApp expr op)
  = zonkLExpr env expr	`thenM` \ new_expr ->
    zonkExpr env op	`thenM` \ new_op ->
    returnM (NegApp new_expr new_op)
431 432

zonkExpr env (HsPar e)    
433
  = zonkLExpr env e	`thenM` \new_e ->
434 435 436
    returnM (HsPar new_e)

zonkExpr env (SectionL expr op)
437 438
  = zonkLExpr env expr	`thenM` \ new_expr ->
    zonkLExpr env op		`thenM` \ new_op ->
439 440 441
    returnM (SectionL new_expr new_op)

zonkExpr env (SectionR op expr)
442 443
  = zonkLExpr env op		`thenM` \ new_op ->
    zonkLExpr env expr		`thenM` \ new_expr ->
444 445
    returnM (SectionR new_op new_expr)

446 447
zonkExpr env (HsCase expr ms)
  = zonkLExpr env expr    	`thenM` \ new_expr ->
448
    zonkMatchGroup env ms	`thenM` \ new_ms ->
449
    returnM (HsCase new_expr new_ms)
450

451 452 453 454 455
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)
456 457

zonkExpr env (HsLet binds expr)
458
  = zonkLocalBinds env binds	`thenM` \ (new_env, new_binds) ->
459
    zonkLExpr new_env expr	`thenM` \ new_expr ->
460 461
    returnM (HsLet new_binds new_expr)

462 463 464
zonkExpr env (HsDo do_or_lc stmts body ty)
  = zonkStmts env stmts 	`thenM` \ (new_env, new_stmts) ->
    zonkLExpr new_env body	`thenM` \ new_body ->
465
    zonkTcTypeToType env ty	`thenM` \ new_ty   ->
466 467
    returnM (HsDo (zonkDo env do_or_lc) 
		  new_stmts new_body new_ty)
468 469

zonkExpr env (ExplicitList ty exprs)
470
  = zonkTcTypeToType env ty	`thenM` \ new_ty ->
471
    zonkLExprs env exprs	`thenM` \ new_exprs ->
472 473 474
    returnM (ExplicitList new_ty new_exprs)

zonkExpr env (ExplicitPArr ty exprs)
475
  = zonkTcTypeToType env ty	`thenM` \ new_ty ->
476
    zonkLExprs env exprs	`thenM` \ new_exprs ->
477 478 479
    returnM (ExplicitPArr new_ty new_exprs)

zonkExpr env (ExplicitTuple exprs boxed)
480
  = zonkLExprs env exprs  	`thenM` \ new_exprs ->
481 482
    returnM (ExplicitTuple new_exprs boxed)

483
zonkExpr env (RecordCon data_con con_expr rbinds)
484 485 486
  = do	{ new_con_expr <- zonkExpr env con_expr
	; new_rbinds   <- zonkRecFields env rbinds
	; return (RecordCon data_con new_con_expr new_rbinds) }
487

488
zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
489 490 491 492 493
  = 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) }
494

495 496 497 498
zonkExpr env (ExprWithTySigOut e ty) 
  = do { e' <- zonkLExpr env e
       ; return (ExprWithTySigOut e' ty) }

499 500
zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"

501 502
zonkExpr env (ArithSeq expr info)
  = zonkExpr env expr		`thenM` \ new_expr ->
503
    zonkArithSeq env info	`thenM` \ new_info ->
504
    returnM (ArithSeq new_expr new_info)
505

506 507
zonkExpr env (PArrSeq expr info)
  = zonkExpr env expr		`thenM` \ new_expr ->
508
    zonkArithSeq env info	`thenM` \ new_info ->
509
    returnM (PArrSeq new_expr new_info)
510 511

zonkExpr env (HsSCC lbl expr)
512
  = zonkLExpr env expr	`thenM` \ new_expr ->
513 514
    returnM (HsSCC lbl new_expr)

andy@galois.com's avatar
andy@galois.com committed
515 516 517 518
zonkExpr env (HsTickPragma info expr)
  = zonkLExpr env expr	`thenM` \ new_expr ->
    returnM (HsTickPragma info new_expr)

519 520
-- hdaume: core annotations
zonkExpr env (HsCoreAnn lbl expr)
521
  = zonkLExpr env expr   `thenM` \ new_expr ->
522 523
    returnM (HsCoreAnn lbl new_expr)

524
-- arrow notation extensions
525
zonkExpr env (HsProc pat body)
526 527 528
  = do	{ (env1, new_pat) <- zonkPat env pat
	; new_body <- zonkCmdTop env1 body
	; return (HsProc new_pat new_body) }
529

530 531 532
zonkExpr env (HsArrApp e1 e2 ty ho rl)
  = zonkLExpr env e1	    	    	`thenM` \ new_e1 ->
    zonkLExpr env e2	    	    	`thenM` \ new_e2 ->
533
    zonkTcTypeToType env ty 		`thenM` \ new_ty ->
534
    returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
535

536 537
zonkExpr env (HsArrForm op fixity args)
  = zonkLExpr env op	    	    	`thenM` \ new_op ->
538
    mappM (zonkCmdTop env) args		`thenM` \ new_args ->
539
    returnM (HsArrForm new_op fixity new_args)
540

541
zonkExpr env (HsWrap co_fn expr)
542 543
  = zonkCoFn env co_fn	`thenM` \ (env1, new_co_fn) ->
    zonkExpr env1 expr	`thenM` \ new_expr ->
544
    return (HsWrap new_co_fn new_expr)
545

546 547
zonkExpr env other = pprPanic "zonkExpr" (ppr other)

548 549 550 551
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd

zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
552 553
  = zonkLExpr env cmd	    		`thenM` \ new_cmd ->
    zonkTcTypeToTypes env stack_tys	`thenM` \ new_stack_tys ->
554
    zonkTcTypeToType env ty 		`thenM` \ new_ty ->
555
    mapSndM (zonkExpr env) ids		`thenM` \ new_ids ->
556 557
    returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)

558
-------------------------------------------------------------------------
559
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
560 561
zonkCoFn env WpHole   = return (env, WpHole)
zonkCoFn env WpInline = return (env, WpInline)
562
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
563
				    ; (env2, c2') <- zonkCoFn env1 c2
564 565 566
				    ; return (env2, WpCompose c1' c2') }
zonkCoFn env (WpCo co)      = do { co' <- zonkTcTypeToType env co
				 ; return (env, WpCo co') }
567
zonkCoFn env (WpLam id)     = do { id' <- zonkDictBndr env id
568
				 ; let env1 = extendZonkEnv1 env id'
569 570 571 572 573 574 575 576
				 ; 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') }
577 578


579
-------------------------------------------------------------------------
580 581 582 583
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
584

585 586
-------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
587 588 589 590 591 592 593 594 595 596 597
zonkOverLit env ol = 
    let 
        zonkedStuff = do ty' <- zonkTcTypeToType env (overLitType ol)
                         e' <- zonkExpr env (overLitExpr ol)
                         return (e', ty')
        ru f (x, y) = return (f x y)
    in
      case ol of 
        (HsIntegral i _ _)   -> ru (HsIntegral i) =<< zonkedStuff
        (HsFractional r _ _) -> ru (HsFractional r) =<< zonkedStuff
        (HsIsString s _ _)   -> ru (HsIsString s) =<< zonkedStuff
598

599
-------------------------------------------------------------------------
600
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
601

602
zonkArithSeq env (From e)
603
  = zonkLExpr env e		`thenM` \ new_e ->
604
    returnM (From new_e)
605

606
zonkArithSeq env (FromThen e1 e2)
607 608
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
609
    returnM (FromThen new_e1 new_e2)
610

611
zonkArithSeq env (FromTo e1 e2)
612 613
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
614
    returnM (FromTo new_e1 new_e2)
615

616
zonkArithSeq env (FromThenTo e1 e2 e3)
617 618 619
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
    zonkLExpr env e3	`thenM` \ new_e3 ->
620
    returnM (FromThenTo new_e1 new_e2 new_e3)
621

622

623
-------------------------------------------------------------------------
624 625 626 627 628
zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
zonkStmts env []     = return (env, [])
zonkStmts env (s:ss) = do { (env1, s')  <- wrapLocSndM (zonkStmt env) s
			  ; (env2, ss') <- zonkStmts env1 ss
			  ; return (env2, s' : ss') }
629

630 631
zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
zonkStmt env (ParStmt stmts_w_bndrs)
632
  = mappM zonk_branch stmts_w_bndrs	`thenM` \ new_stmts_w_bndrs ->
633
    let 
634
	new_binders = concat (map snd new_stmts_w_bndrs)
635 636
	env1 = extendZonkEnv env new_binders
    in
637
    return (env1, ParStmt new_stmts_w_bndrs)
638
  where
639
    zonk_branch (stmts, bndrs) = zonkStmts env stmts	`thenM` \ (env1, new_stmts) ->
640
				 returnM (new_stmts, zonkIdOccs env1 bndrs)
641

642
zonkStmt env (RecStmt segStmts lvs rvs rets binds)
643
  = zonkIdBndrs env rvs		`thenM` \ new_rvs ->
644
    let
645
	env1 = extendZonkEnv env new_rvs
646
    in
647
    zonkStmts env1 segStmts	`thenM` \ (env2, new_segStmts) ->
648 649
	-- Zonk the ret-expressions in an envt that 
	-- has the polymorphic bindings in the envt
650
    mapM (zonkExpr env2) rets	`thenM` \ new_rets ->
651 652 653 654
    let
	new_lvs = zonkIdOccs env2 lvs
	env3 = extendZonkEnv env new_lvs	-- Only the lvs are needed
    in
655 656
    zonkRecMonoBinds env3 binds	`thenM` \ (env4, new_binds) ->
    returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets new_binds)
657

658
zonkStmt env (ExprStmt expr then_op ty)
659
  = zonkLExpr env expr		`thenM` \ new_expr ->
660
    zonkExpr env then_op	`thenM` \ new_then ->
661
    zonkTcTypeToType env ty	`thenM` \ new_ty ->
662
    returnM (env, ExprStmt new_expr new_then new_ty)
663

664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694
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') 

695
zonkStmt env (LetStmt binds)
696
  = zonkLocalBinds env binds	`thenM` \ (env1, new_binds) ->
697
    returnM (env1, LetStmt new_binds)
698

699
zonkStmt env (BindStmt pat expr bind_op fail_op)
700 701
  = do	{ new_expr <- zonkLExpr env expr
	; (env1, new_pat) <- zonkPat env pat
702 703 704
	; new_bind <- zonkExpr env bind_op
	; new_fail <- zonkExpr env fail_op
	; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
705

706 707 708
zonkMaybeLExpr env Nothing = return Nothing
zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just)

709 710

-------------------------------------------------------------------------
711 712 713
zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
zonkRecFields env (HsRecFields flds dd)
  = do	{ flds' <- mappM zonk_rbind flds
714
	; return (HsRecFields flds' dd) }
715
  where
716 717 718 719
    zonk_rbind fld
      = do { new_expr <- zonkLExpr env (hsRecFieldArg fld)
	   ; return (fld { hsRecFieldArg = new_expr }) }
	-- Field selectors have declared types; hence no zonking
720 721

-------------------------------------------------------------------------
722
mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
723
mapIPNameTc f (IPName n) = f n  `thenM` \ r -> returnM (IPName r)
724 725
\end{code}

726

727 728 729 730 731 732 733
%************************************************************************
%*									*
\subsection[BackSubst-Pats]{Patterns}
%*									*
%************************************************************************

\begin{code}
734 735 736 737 738
zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
-- Extend the environment as we go, because it's possible for one
-- pattern to bind something that is used in another (inside or
-- to the right)
zonkPat env pat = wrapLocSndM (zonk_pat env) pat
739

740
zonk_pat env (ParPat p)
741 742
  = do	{ (env', p') <- zonkPat env p
  	; return (env', ParPat p') }
743

744
zonk_pat env (WildPat ty)
745 746
  = do	{ ty' <- zonkTcTypeToType env ty
	; return (env, WildPat ty') }
747

748
zonk_pat env (VarPat v)
749 750 751 752 753 754 755
  = do	{ v' <- zonkIdBndr env v
	; return (extendZonkEnv1 env v', VarPat v') }

zonk_pat env (VarPatOut v binds)
  = do	{ v' <- zonkIdBndr env v
	; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds
  	; returnM (env', VarPatOut v' binds') }
756

757
zonk_pat env (LazyPat pat)
758 759
  = do	{ (env', pat') <- zonkPat env pat
	; return (env',  LazyPat pat') }
760

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
761 762 763 764
zonk_pat env (BangPat pat)
  = do	{ (env', pat') <- zonkPat env pat
	; return (env',  BangPat pat') }

765 766 767 768
zonk_pat env (AsPat (L loc v) pat)
  = do	{ v' <- zonkIdBndr env v
	; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
 	; return (env', AsPat (L loc v') pat') }
769

770 771 772 773 774
zonk_pat env (ViewPat expr pat ty)
  = do	{ expr' <- zonkLExpr env expr
	; (env', pat') <- zonkPat env pat
 	; return (env', ViewPat expr' pat' ty) }

775
zonk_pat env (ListPat pats ty)
776 777 778
  = do	{ ty' <- zonkTcTypeToType env ty
	; (env', pats') <- zonkPats env pats
	; return (env', ListPat pats' ty') }
779

780
zonk_pat env (PArrPat pats ty)
781 782 783
  = do	{ ty' <- zonkTcTypeToType env ty
	; (env', pats') <- zonkPats env pats
	; return (env', PArrPat pats' ty') }
784

785 786 787 788
zonk_pat env (TuplePat pats boxed ty)
  = do	{ ty' <- zonkTcTypeToType env ty
	; (env', pats') <- zonkPats env pats
	; return (env', TuplePat pats' boxed ty') }
789

790 791
zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = dicts, pat_binds = binds, pat_args = args })
  = ASSERT( all isImmutableTyVar (pat_tvs p) ) 
792
    do	{ new_ty <- zonkTcTypeToType env ty
793
	; new_dicts <- zonkDictBndrs env dicts
794 795
	; let env1 = extendZonkEnv env new_dicts
	; (env2, new_binds) <- zonkRecMonoBinds env1 binds
796 797 798
	; (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 }) }
799

800
zonk_pat env (LitPat lit) = return (env, LitPat lit)
801

802 803 804 805
zonk_pat env (SigPatOut pat ty)
  = do	{ ty' <- zonkTcTypeToType env ty
	; (env', pat') <- zonkPat env pat
	; return (env', SigPatOut pat' ty') }
806

807
zonk_pat env (NPat lit mb_neg eq_expr)
808 809 810 811 812 813
  = 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
814
	; return (env, NPat lit' mb_neg' eq_expr') }
815

816
zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
817
  = do	{ n' <- zonkIdBndr env n
818 819
	; lit' <- zonkOverLit env lit
 	; e1' <- zonkExpr env e1
820
	; e2' <- zonkExpr env e2
821
	; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
822

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
823 824 825 826 827 828 829 830
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 env pat = pprPanic "zonk_pat" (ppr pat)

831 832
---------------------------
zonkConStuff env (PrefixCon pats)
833 834
  = do	{ (env', pats') <- zonkPats env pats
	; return (env', PrefixCon pats') }
835

836
zonkConStuff env (InfixCon p1 p2)
837 838 839
  = do	{ (env1, p1') <- zonkPat env  p1
	; (env', p2') <- zonkPat env1 p2
	; return (env', InfixCon p1' p2') }
840

841 842 843 844 845
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
846 847

---------------------------
848 849
zonkPats env []		= return (env, [])
zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
850 851
		     ; (env', pats') <- zonkPats env1 pats
		     ; return (env', pat':pats') }
852 853
\end{code}

sof's avatar
sof committed
854 855 856 857 858 859
%************************************************************************
%*									*
\subsection[BackSubst-Foreign]{Foreign exports}
%*									*
%************************************************************************

860

sof's avatar
sof committed
861
\begin{code}
862 863
zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
sof's avatar
sof committed
864

865
zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
Simon Marlow's avatar
Simon Marlow committed
866 867
zonkForeignExport env (ForeignExport i hs_ty spec) =
   returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec)
868 869
zonkForeignExport env for_imp 
  = returnM for_imp	-- Foreign imports don't need zonking
sof's avatar
sof committed
870
\end{code}
871 872

\begin{code}
873 874
zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
875

876
zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
877
zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
878 879
  = mappM zonk_bndr vars		`thenM` \ new_bndrs ->
    newMutVar emptyVarSet		`thenM` \ unbound_tv_set ->
880
    let
881
	env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
882 883
	-- Type variables don't need an envt
	-- They are bound through the mutable mechanism
884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903

	env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
	-- We need to gather the type variables mentioned on the LHS so we can 
	-- quantify over them.  Example:
	--   data T a = C
	-- 
	--   foo :: T a -> Int
	--   foo C = 1
	--
	--   {-# RULES "myrule"  foo C = 1 #-}
	-- 
	-- After type checking the LHS becomes (foo a (C a))
	-- and we do not want to zap the unbound tyvar 'a' to (), because
	-- that limits the applicability of the rule.  Instead, we
	-- want to quantify over it!  
	--
	-- It's easiest to find the free tyvars here. Attempts to do so earlier
	-- are tiresome, because (a) the data type is big and (b) finding the 
	-- free type vars of an expression is necessarily monadic operation.
	--	(consider /\a -> f @ b, where b is side-effected to a)
904
    in
905 906
    zonkLExpr env_lhs lhs		`thenM` \ new_lhs ->
    zonkLExpr env_rhs rhs		`thenM` \ new_rhs ->
907 908 909

    readMutVar unbound_tv_set		`thenM` \ unbound_tvs ->
    let
910 911
	final_bndrs :: [Located Var]
	final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
912
    in
913
    returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs fv_lhs new_rhs fv_rhs)
914
		-- I hate this map RuleBndr stuff
915 916
  where
   zonk_bndr (RuleBndr v) 
917
	| isId (unLoc v) = wrapLocM (zonkIdBndr env)   v
918 919
	| otherwise      = ASSERT( isImmutableTyVar (unLoc v) )
			   return v
920
\end{code}
sof's avatar
sof committed
921

922 923 924 925 926 927 928 929 930 931 932

%************************************************************************
%*									*
\subsection[BackSubst-Foreign]{Foreign exports}
%*									*
%************************************************************************

\begin{code}
zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty

933 934 935
zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys

936 937 938
zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
-- This variant collects unbound type variables in a mutable variable
zonkTypeCollecting unbound_tv_set
939
  = zonkType zonk_unbound_tyvar