TcHsSyn.lhs 31.4 KB
Newer Older
1
%
2
% (c) The AQUA Project, Glasgow University, 1996-1998
3 4 5 6 7 8 9 10
%
\section[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 (
11
	TcDictBinds,
12
	mkHsTyApp, mkHsDictApp, mkHsConApp,
13 14 15 16
	mkHsTyLam, mkHsDictLam, mkHsLet, mkHsApp,
	hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt,
	nlHsIntLit, glueBindsOnGRHSs,
	
17

18 19 20 21 22
	-- Coercions
	Coercion, ExprCoFn, PatCoFn, 
	(<$>), (<.>), mkCoercion, 
	idCoercion, isIdCoercion,

23 24
	-- re-exported from TcMonad
	TcId, TcIdSet,
25

26
	zonkTopDecls, zonkTopExpr, zonkTopLExpr,
27
	zonkId, zonkTopBndrs
28 29
  ) where

30
#include "HsVersions.h"
31 32 33 34 35

-- friends:
import HsSyn	-- oodles of it

-- others:
36
import Id	( idType, setIdType, Id )
37

38
import TcRnMonad
39
import Type	  ( Type )
40 41
import TcType	  ( TcType, TcTyVar, mkTyVarTy, tcGetTyVar, mkTyConApp )
import Kind	  ( isLiftedTypeKind, liftedTypeKind, isSubKind )
42 43 44
import qualified  Type
import TcMType	  ( zonkTcTyVarToTyVar, zonkType, zonkTcType, zonkTcTyVars,
		    putTcTyVar )
45 46 47
import TysPrim	  ( charPrimTy, intPrimTy, floatPrimTy,
		    doublePrimTy, addrPrimTy
		  )
48
import TysWiredIn ( charTy, stringTy, intTy, 
49 50
		    mkListTy, mkPArrTy, mkTupleTy, unitTy,
		    voidTy, listTyCon, tupleTyCon )
51
import TyCon	  ( mkPrimTyCon, tyConKind, PrimRep(..) )
52
import Kind	  ( splitKindFunTys )
53 54
import Name	  ( getOccName, mkInternalName, mkDerivedTyConOcc )
import Var	  ( Var, isId, isLocalVar, tyVarKind )
55
import VarSet
56
import VarEnv
57
import BasicTypes ( Boxity(..), IPName(..), ipNameName, mapIPName )
58
import Maybes	  ( orElse )
59
import Maybe  	  ( isNothing )
60
import Unique	  ( Uniquable(..) )
61
import SrcLoc	  ( noSrcLoc, noLoc, Located(..), unLoc )
sof's avatar
sof committed
62
import Bag
sof's avatar
sof committed
63
import Outputable
64 65 66 67
\end{code}


\begin{code}
68
type TcDictBinds = LHsBinds TcId	-- Bag of dictionary bindings
69
\end{code}
70

71 72 73 74 75 76 77

%************************************************************************
%*									*
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
%*									*
%************************************************************************

78
Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@,
79 80
then something is wrong.
\begin{code}
81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97
hsPatType :: OutPat Id -> Type
hsPatType pat = pat_type (unLoc pat)

pat_type (ParPat pat)		  = hsPatType pat
pat_type (WildPat ty)		  = ty
pat_type (VarPat var)		  = idType var
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)	  = mkTupleTy box (length pats) (map hsPatType pats)
pat_type (ConPatOut _ _ ty _ _)   = ty
pat_type (SigPatOut _ ty _)	  = ty
pat_type (NPatOut lit ty _)	  = ty
pat_type (NPlusKPatOut id _ _ _)  = idType (unLoc id)
pat_type (DictPat ds ms)          = case (ds ++ ms) of
98 99 100 101 102 103 104 105 106 107 108 109
				       []  -> unitTy
				       [d] -> idType d
				       ds  -> mkTupleTy Boxed (length ds) (map idType ds)


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
110
hsLitType (HsInteger i ty) = ty
111 112 113
hsLitType (HsRat _ ty)	   = ty
hsLitType (HsFloatPrim f)  = floatPrimTy
hsLitType (HsDoublePrim d) = doublePrimTy
114 115
\end{code}

116 117 118 119 120 121
%************************************************************************
%*									*
\subsection{Coercion functions}
%*									*
%************************************************************************

122
\begin{code}
123 124 125
type Coercion a = Maybe (a -> a)
	-- Nothing => identity fn

126 127
type ExprCoFn = Coercion (HsExpr TcId)
type PatCoFn  = Coercion (Pat    TcId)
128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146

(<.>) :: Coercion a -> Coercion a -> Coercion a	-- Composition
Nothing <.> Nothing = Nothing
Nothing <.> Just f  = Just f
Just f  <.> Nothing = Just f
Just f1 <.> Just f2 = Just (f1 . f2)

(<$>) :: Coercion a -> a -> a
Just f  <$> e = f e
Nothing <$> e = e

mkCoercion :: (a -> a) -> Coercion a
mkCoercion f = Just f

idCoercion :: Coercion a
idCoercion = Nothing

isIdCoercion :: Coercion a -> Bool
isIdCoercion = isNothing
147 148 149
\end{code}


150 151 152 153 154 155
%************************************************************************
%*									*
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
%*									*
%************************************************************************

156 157 158 159 160 161 162 163 164 165
\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' ->
    returnM (setIdType id ty')
\end{code}

The rest of the zonking is done *after* typechecking.
The main zonking pass runs over the bindings
166 167 168

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

171 172
The type variables are converted by binding mutable tyvars to immutable ones
and then zonking as normal.
173

174 175 176
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
177

178 179
It's all pretty boring stuff, because HsSyn is such a large type, and 
the environment manipulation is tiresome.
180

181
\begin{code}
182 183
data ZonkEnv = ZonkEnv	(TcType -> TcM Type) 	-- How to zonk a type
			(IdEnv Id)		-- What variables are in scope
184 185 186
	-- Maps an Id to its zonked version; both have the same Name
	-- Is only consulted lazily; hence knot-tying

187
emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
188 189

extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
190 191 192 193 194
extendZonkEnv (ZonkEnv zonk_ty env) ids 
  = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])

setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212

mkZonkEnv :: [Id] -> ZonkEnv
mkZonkEnv ids = extendZonkEnv emptyZonkEnv ids

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.)
--
-- 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
-- 'main' is done as a separte chunk.
213
zonkIdOcc (ZonkEnv zonk_ty env) id 
214 215 216 217
  | isLocalVar id = lookupVarEnv env id `orElse` id
  | otherwise	  = id

zonkIdOccs env ids = map (zonkIdOcc env) ids
218

219 220
-- zonkIdBndr is used *after* typechecking to get the Id's type
-- to its final form.  The TyVarEnv give 
221 222 223
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
zonkIdBndr env id
  = zonkTcTypeToType env (idType id)	`thenM` \ ty' ->
224
    returnM (setIdType id ty')
225 226 227 228 229 230

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

zonkTopBndrs :: [TcId] -> TcM [Id]
zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
231 232 233 234
\end{code}


\begin{code}
235
zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
236 237
zonkTopExpr e = zonkExpr emptyZonkEnv e

238 239 240 241
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

zonkTopDecls :: Bag (LHsBind TcId) -> [LRuleDecl TcId] -> [LForeignDecl TcId]
242
	     -> TcM ([Id], 
243 244 245
		     Bag (LHsBind  Id),
		     [LForeignDecl Id],
		     [LRuleDecl    Id])
246 247 248 249 250
zonkTopDecls binds rules fords	-- Top level is implicitly recursive
  = fixM (\ ~(new_ids, _, _, _) ->
	let
	   zonk_env = mkZonkEnv new_ids
	in
251
	zonkMonoBinds zonk_env binds		`thenM` \ binds' ->
252 253 254
	zonkRules zonk_env rules		`thenM` \ rules' ->
	zonkForeignExports zonk_env fords	`thenM` \ fords' ->
	
255
	returnM (collectHsBindBinders binds', binds', fords', rules')
256 257 258
    )

---------------------------------------------
259 260
zonkGroup :: ZonkEnv -> HsBindGroup TcId -> TcM (ZonkEnv, HsBindGroup Id)
zonkGroup env (HsBindGroup bs sigs is_rec)
261
  = ASSERT( null sigs )
262 263 264 265 266 267 268 269 270
    do  { (env1, bs') <- fixM (\ ~(_, new_binds) -> do 
                   { let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
                   ; bs' <- zonkMonoBinds env1 bs
                   ; return (env1, bs') })
          ; return (env1, HsBindGroup bs' [] is_rec) }
 

zonkGroup env (HsIPBinds binds)
  = mappM (wrapLocM zonk_ip_bind) binds	`thenM` \ new_binds ->
271
    let
272
	env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
273
    in
274
    returnM (env1, HsIPBinds new_binds)
275
  where
276
    zonk_ip_bind (IPBind n e)
277
	= mapIPNameTc (zonkIdBndr env) n	`thenM` \ n' ->
278 279
	  zonkLExpr env e			`thenM` \ e' ->
	  returnM (IPBind n' e')
280 281

---------------------------------------------
282 283 284 285 286
zonkNestedBinds :: ZonkEnv -> [HsBindGroup TcId] -> TcM (ZonkEnv, [HsBindGroup Id])
zonkNestedBinds env []     = return (env, [])
zonkNestedBinds env (b:bs) = do	{ (env1, b') <- zonkGroup env b
				; (env2, bs') <- zonkNestedBinds env1 bs
				; return (env2, b':bs') }
287

288 289 290
---------------------------------------------
zonkMonoBinds :: ZonkEnv -> Bag (LHsBind TcId) -> TcM (Bag (LHsBind Id))
zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
291

292 293 294
zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
zonk_bind env (PatBind pat grhss)
  = zonkPat env pat	`thenM` \ (new_pat, _) ->
295
    zonkGRHSs env grhss	`thenM` \ new_grhss ->
296
    returnM (PatBind new_pat new_grhss)
297

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

303 304
zonk_bind env (FunBind var inf ms)
  = wrapLocM (zonkIdBndr env) var	`thenM` \ new_var ->
305
    mappM (zonkMatch env) ms		`thenM` \ new_ms ->
306
    returnM (FunBind new_var inf new_ms)
sof's avatar
sof committed
307

308
zonk_bind env (AbsBinds tyvars dicts exports inlines val_binds)
309
  = mappM zonkTcTyVarToTyVar tyvars	`thenM` \ new_tyvars ->
310 311
	-- No need to extend tyvar env: the effects are
	-- propagated through binding the tyvars themselves
sof's avatar
sof committed
312

313
    zonkIdBndrs env dicts		`thenM` \ new_dicts ->
314
    fixM (\ ~(new_val_binds, _) ->
315 316
	let
	  env1 = extendZonkEnv (extendZonkEnv env new_dicts)
317
			       (collectHsBindBinders new_val_binds)
318
	in
319 320 321 322 323
	zonkMonoBinds env1 val_binds 		`thenM` \ new_val_binds ->
        mappM (zonkExport env1) exports		`thenM` \ new_exports ->
	returnM (new_val_binds, new_exports)
    )						`thenM` \ (new_val_bind, new_exports) ->
    returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind)
sof's avatar
sof committed
324
  where
325 326
    zonkExport env (tyvars, global, local)
	= zonkTcTyVars tyvars		`thenM` \ tys ->
327 328
	  let
		new_tyvars = map (tcGetTyVar "zonkExport") tys
329
		-- This isn't the binding occurrence of these tyvars
330 331
		-- but they should *be* tyvars.  Hence tcGetTyVar.
	  in
332
	  zonkIdBndr env global		`thenM` \ new_global ->
333
	  returnM (new_tyvars, new_global, zonkIdOcc env local)
334 335 336 337
\end{code}

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

\begin{code}
343
zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
344

345
zonkMatch env (L loc (Match pats _ grhss))
346 347
  = zonkPats env pats						`thenM` \ (new_pats, new_ids) ->
    zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss 	`thenM` \ new_grhss ->
348
    returnM (L loc (Match new_pats Nothing new_grhss))
349

350
-------------------------------------------------------------------------
351
zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
352

353
zonkGRHSs env (GRHSs grhss binds ty)
354
  = zonkNestedBinds env binds   	`thenM` \ (new_env, new_binds) ->
355
    let
356 357 358
	zonk_grhs (GRHS guarded)
	  = zonkStmts new_env guarded	`thenM` \ new_guarded ->
	    returnM (GRHS new_guarded)
359
    in
360 361
    mappM (wrapLocM zonk_grhs) grhss 	`thenM` \ new_grhss ->
    zonkTcTypeToType env ty 		`thenM` \ new_ty ->
362
    returnM (GRHSs new_grhss new_binds new_ty)
363 364 365 366 367 368 369 370 371
\end{code}

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

\begin{code}
372 373 374
zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
375

376 377
zonkLExprs env exprs = mappM (zonkLExpr env) exprs
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
378

379 380
zonkExpr env (HsVar id)
  = returnM (HsVar (zonkIdOcc env id))
381

382 383
zonkExpr env (HsIPVar id)
  = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
384

385
zonkExpr env (HsLit (HsRat f ty))
386
  = zonkTcTypeToType env ty	   `thenM` \ new_ty  ->
387
    returnM (HsLit (HsRat f new_ty))
sof's avatar
sof committed
388

389 390
zonkExpr env (HsLit lit)
  = returnM (HsLit lit)
391 392

-- HsOverLit doesn't appear in typechecker output
393

394 395 396 397 398
zonkExpr env (HsLam match)
  = zonkMatch env match	`thenM` \ new_match ->
    returnM (HsLam new_match)

zonkExpr env (HsApp e1 e2)
399 400
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
401 402 403 404 405 406
    returnM (HsApp new_e1 new_e2)

zonkExpr env (HsBracketOut body bs) 
  = mappM zonk_b bs	`thenM` \ bs' ->
    returnM (HsBracketOut body bs')
  where
407
    zonk_b (n,e) = zonkLExpr env e	`thenM` \ e' ->
408 409
		   returnM (n,e')

410 411
zonkExpr env (HsSpliceE s) = WARN( True, ppr s )	-- Should not happen
			     returnM (HsSpliceE s)
412 413

zonkExpr env (OpApp e1 op fixity e2)
414 415 416
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env op	`thenM` \ new_op ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
417 418 419 420 421
    returnM (OpApp new_e1 new_op fixity new_e2)

zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"

zonkExpr env (HsPar e)    
422
  = zonkLExpr env e	`thenM` \new_e ->
423 424 425
    returnM (HsPar new_e)

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

zonkExpr env (SectionR op expr)
431 432
  = zonkLExpr env op		`thenM` \ new_op ->
    zonkLExpr env expr		`thenM` \ new_expr ->
433 434
    returnM (SectionR new_op new_expr)

435 436
zonkExpr env (HsCase expr ms)
  = zonkLExpr env expr    	`thenM` \ new_expr ->
437
    mappM (zonkMatch env) ms	`thenM` \ new_ms ->
438
    returnM (HsCase new_expr new_ms)
439

440 441 442 443 444
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)
445 446

zonkExpr env (HsLet binds expr)
447 448
  = zonkNestedBinds env binds	`thenM` \ (new_env, new_binds) ->
    zonkLExpr new_env expr	`thenM` \ new_expr ->
449 450
    returnM (HsLet new_binds new_expr)

451
zonkExpr env (HsDo do_or_lc stmts ids ty)
452
  = zonkStmts env stmts 	`thenM` \ new_stmts ->
453
    zonkTcTypeToType env ty	`thenM` \ new_ty   ->
454
    zonkReboundNames env ids	`thenM` \ new_ids ->
455
    returnM (HsDo do_or_lc new_stmts new_ids new_ty)
456 457

zonkExpr env (ExplicitList ty exprs)
458
  = zonkTcTypeToType env ty	`thenM` \ new_ty ->
459
    zonkLExprs env exprs	`thenM` \ new_exprs ->
460 461 462
    returnM (ExplicitList new_ty new_exprs)

zonkExpr env (ExplicitPArr ty exprs)
463
  = zonkTcTypeToType env ty	`thenM` \ new_ty ->
464
    zonkLExprs env exprs	`thenM` \ new_exprs ->
465 466 467
    returnM (ExplicitPArr new_ty new_exprs)

zonkExpr env (ExplicitTuple exprs boxed)
468
  = zonkLExprs env exprs  	`thenM` \ new_exprs ->
469 470 471
    returnM (ExplicitTuple new_exprs boxed)

zonkExpr env (RecordConOut data_con con_expr rbinds)
472
  = zonkLExpr env con_expr	`thenM` \ new_con_expr ->
473 474 475 476 477 478
    zonkRbinds env rbinds	`thenM` \ new_rbinds ->
    returnM (RecordConOut data_con new_con_expr new_rbinds)

zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"

zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
479
  = zonkLExpr env expr		`thenM` \ new_expr ->
480 481
    zonkTcTypeToType env in_ty	`thenM` \ new_in_ty ->
    zonkTcTypeToType env out_ty	`thenM` \ new_out_ty ->
482 483 484 485 486 487 488 489
    zonkRbinds env rbinds	`thenM` \ new_rbinds ->
    returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)

zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
zonkExpr env (ArithSeqIn _)      = panic "zonkExpr env:ArithSeqIn"
zonkExpr env (PArrSeqIn _)       = panic "zonkExpr env:PArrSeqIn"

zonkExpr env (ArithSeqOut expr info)
490
  = zonkLExpr env expr		`thenM` \ new_expr ->
491 492 493 494
    zonkArithSeq env info	`thenM` \ new_info ->
    returnM (ArithSeqOut new_expr new_info)

zonkExpr env (PArrSeqOut expr info)
495
  = zonkLExpr env expr		`thenM` \ new_expr ->
496 497 498 499
    zonkArithSeq env info	`thenM` \ new_info ->
    returnM (PArrSeqOut new_expr new_info)

zonkExpr env (HsSCC lbl expr)
500
  = zonkLExpr env expr	`thenM` \ new_expr ->
501 502
    returnM (HsSCC lbl new_expr)

503 504
-- hdaume: core annotations
zonkExpr env (HsCoreAnn lbl expr)
505
  = zonkLExpr env expr   `thenM` \ new_expr ->
506 507
    returnM (HsCoreAnn lbl new_expr)

508 509
zonkExpr env (TyLam tyvars expr)
  = mappM zonkTcTyVarToTyVar tyvars	`thenM` \ new_tyvars ->
510 511
	-- No need to extend tyvar env; see AbsBinds

512
    zonkLExpr env expr			`thenM` \ new_expr ->
513
    returnM (TyLam new_tyvars new_expr)
514

515
zonkExpr env (TyApp expr tys)
516
  = zonkLExpr env expr    	 	`thenM` \ new_expr ->
517
    mappM (zonkTcTypeToType env) tys	`thenM` \ new_tys ->
518
    returnM (TyApp new_expr new_tys)
519

520
zonkExpr env (DictLam dicts expr)
521
  = zonkIdBndrs env dicts	`thenM` \ new_dicts ->
522 523 524
    let
	env1 = extendZonkEnv env new_dicts
    in
525
    zonkLExpr env1 expr  	`thenM` \ new_expr ->
526
    returnM (DictLam new_dicts new_expr)
527

528
zonkExpr env (DictApp expr dicts)
529
  = zonkLExpr env expr    	    	`thenM` \ new_expr ->
530
    returnM (DictApp new_expr (zonkIdOccs env dicts))
531

532
-- arrow notation extensions
533
zonkExpr env (HsProc pat body)
534 535 536 537 538
  = zonkPat env pat	    	    	`thenM` \ (new_pat, new_ids) ->
    let
	env1 = extendZonkEnv env (bagToList new_ids)
    in
    zonkCmdTop env1 body    	    	`thenM` \ new_body ->
539
    returnM (HsProc new_pat new_body)
540

541 542 543
zonkExpr env (HsArrApp e1 e2 ty ho rl)
  = zonkLExpr env e1	    	    	`thenM` \ new_e1 ->
    zonkLExpr env e2	    	    	`thenM` \ new_e2 ->
544
    zonkTcTypeToType env ty 		`thenM` \ new_ty ->
545
    returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
546

547 548
zonkExpr env (HsArrForm op fixity args)
  = zonkLExpr env op	    	    	`thenM` \ new_op ->
549
    mappM (zonkCmdTop env) args		`thenM` \ new_args ->
550
    returnM (HsArrForm new_op fixity new_args)
551

552 553 554 555 556
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)
  = zonkLExpr env cmd	    	    	`thenM` \ new_cmd ->
557 558 559 560 561 562 563 564 565 566 567
    mappM (zonkTcTypeToType env) stack_tys
			 		`thenM` \ new_stack_tys ->
    zonkTcTypeToType env ty 		`thenM` \ new_ty ->
    zonkReboundNames env ids		`thenM` \ new_ids ->
    returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)

-------------------------------------------------------------------------
zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id)
zonkReboundNames env prs 
  = mapM zonk prs
  where
568
    zonk (n, e) = zonkExpr env e `thenM` \ new_e ->
569
		  returnM (n, new_e)
570

571

572
-------------------------------------------------------------------------
573
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
574

575
zonkArithSeq env (From e)
576
  = zonkLExpr env e		`thenM` \ new_e ->
577
    returnM (From new_e)
578

579
zonkArithSeq env (FromThen e1 e2)
580 581
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
582
    returnM (FromThen new_e1 new_e2)
583

584
zonkArithSeq env (FromTo e1 e2)
585 586
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
587
    returnM (FromTo new_e1 new_e2)
588

589
zonkArithSeq env (FromThenTo e1 e2 e3)
590 591 592
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
    zonkLExpr env e3	`thenM` \ new_e3 ->
593
    returnM (FromThenTo new_e1 new_e2 new_e3)
594

595

596
-------------------------------------------------------------------------
597
zonkStmts  :: ZonkEnv -> [LStmt TcId] -> TcM [LStmt Id]
598

599 600
zonkStmts env stmts = zonk_stmts env stmts	`thenM` \ (_, stmts) ->
		      returnM stmts
601

602 603 604 605 606
zonk_stmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
zonk_stmts env []     = return (env, [])
zonk_stmts env (s:ss) = do { (env1, s')  <- wrapLocSndM (zonkStmt env) s
			   ; (env2, ss') <- zonk_stmts env1 ss
			   ; return (env2, s' : ss') }
607

608 609
zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
zonkStmt env (ParStmt stmts_w_bndrs)
610
  = mappM zonk_branch stmts_w_bndrs	`thenM` \ new_stmts_w_bndrs ->
611
    let 
612
	new_binders = concat (map snd new_stmts_w_bndrs)
613 614
	env1 = extendZonkEnv env new_binders
    in
615
    return (env1, ParStmt new_stmts_w_bndrs)
616
  where
617 618
    zonk_branch (stmts, bndrs) = zonk_stmts env stmts	`thenM` \ (env1, new_stmts) ->
				 returnM (new_stmts, zonkIdOccs env1 bndrs)
619

620
zonkStmt env (RecStmt segStmts lvs rvs rets)
621
  = zonkIdBndrs env rvs		`thenM` \ new_rvs ->
622
    let
623
	env1 = extendZonkEnv env new_rvs
624
    in
625 626 627
    zonk_stmts env1 segStmts	`thenM` \ (env2, new_segStmts) ->
	-- Zonk the ret-expressions in an envt that 
	-- has the polymorphic bindings in the envt
628
    zonkLExprs env2 rets	`thenM` \ new_rets ->
629 630 631 632
    let
	new_lvs = zonkIdOccs env2 lvs
	env3 = extendZonkEnv env new_lvs	-- Only the lvs are needed
    in
633
    returnM (env3, RecStmt new_segStmts new_lvs new_rvs new_rets)
634

635 636 637
zonkStmt env (ResultStmt expr)
  = zonkLExpr env expr	`thenM` \ new_expr ->
    returnM (env, ResultStmt new_expr)
638

639 640
zonkStmt env (ExprStmt expr ty)
  = zonkLExpr env expr		`thenM` \ new_expr ->
641
    zonkTcTypeToType env ty	`thenM` \ new_ty ->
642
    returnM (env, ExprStmt new_expr new_ty)
643

644 645 646
zonkStmt env (LetStmt binds)
  = zonkNestedBinds env binds	`thenM` \ (env1, new_binds) ->
    returnM (env1, LetStmt new_binds)
647

648 649
zonkStmt env (BindStmt pat expr)
  = zonkLExpr env expr			`thenM` \ new_expr ->
650 651 652 653
    zonkPat env pat			`thenM` \ (new_pat, new_ids) ->
    let
	env1 = extendZonkEnv env (bagToList new_ids)
    in
654
    returnM (env1, BindStmt new_pat new_expr)
655 656


657 658

-------------------------------------------------------------------------
659
zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
660

661 662
zonkRbinds env rbinds
  = mappM zonk_rbind rbinds
663
  where
664
    zonk_rbind (field, expr)
665 666
      = zonkLExpr env expr	`thenM` \ new_expr ->
	returnM (fmap (zonkIdOcc env) field, new_expr)
667 668

-------------------------------------------------------------------------
669 670 671
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)
672 673
\end{code}

674

675 676 677 678 679 680 681
%************************************************************************
%*									*
\subsection[BackSubst-Pats]{Patterns}
%*									*
%************************************************************************

\begin{code}
682 683
zonkPat :: ZonkEnv -> OutPat TcId -> TcM (OutPat Id, Bag Id)
zonkPat env pat = wrapLocFstM (zonk_pat env) pat
684

685
zonk_pat env (ParPat p)
686 687 688
  = zonkPat env p	`thenM` \ (new_p, ids) ->
    returnM (ParPat new_p, ids)

689
zonk_pat env (WildPat ty)
690
  = zonkTcTypeToType env ty   `thenM` \ new_ty ->
691 692
    returnM (WildPat new_ty, emptyBag)

693
zonk_pat env (VarPat v)
694
  = zonkIdBndr env v	    `thenM` \ new_v ->
695 696
    returnM (VarPat new_v, unitBag new_v)

697
zonk_pat env (LazyPat pat)
698 699 700
  = zonkPat env pat	    `thenM` \ (new_pat, ids) ->
    returnM (LazyPat new_pat, ids)

701 702 703 704
zonk_pat env (AsPat n pat)
  = wrapLocM (zonkIdBndr env) n	`thenM` \ new_n ->
    zonkPat env pat	    	`thenM` \ (new_pat, ids) ->
    returnM (AsPat new_n new_pat, unLoc new_n `consBag` ids)
705

706
zonk_pat env (ListPat pats ty)
707
  = zonkTcTypeToType env ty	`thenM` \ new_ty ->
708 709 710
    zonkPats env pats		`thenM` \ (new_pats, ids) ->
    returnM (ListPat new_pats new_ty, ids)

711
zonk_pat env (PArrPat pats ty)
712
  = zonkTcTypeToType env ty	`thenM` \ new_ty ->
713 714 715
    zonkPats env pats		`thenM` \ (new_pats, ids) ->
    returnM (PArrPat new_pats new_ty, ids)

716
zonk_pat env (TuplePat pats boxed)
717 718 719
  = zonkPats env pats   		`thenM` \ (new_pats, ids) ->
    returnM (TuplePat new_pats boxed, ids)

720
zonk_pat env (ConPatOut n stuff ty tvs dicts)
721
  = zonkTcTypeToType env ty		`thenM` \ new_ty ->
722
    mappM zonkTcTyVarToTyVar tvs	`thenM` \ new_tvs ->
723
    zonkIdBndrs env dicts		`thenM` \ new_dicts ->
724 725 726
    let
	env1 = extendZonkEnv env new_dicts
    in
727
    zonkConStuff env1 stuff		`thenM` \ (new_stuff, ids) ->
728
    returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts, 
729
		 listToBag new_dicts `unionBags` ids)
730

731
zonk_pat env (LitPat lit) = returnM (LitPat lit, emptyBag)
732

733
zonk_pat env (SigPatOut pat ty expr)
734 735
  = zonkPat env pat		`thenM` \ (new_pat, ids) ->
    zonkTcTypeToType env ty	`thenM` \ new_ty  ->
736 737 738
    zonkExpr env expr		`thenM` \ new_expr ->
    returnM (SigPatOut new_pat new_ty new_expr, ids)

739
zonk_pat env (NPatOut lit ty expr)
740
  = zonkTcTypeToType env ty	`thenM` \ new_ty   ->
741 742 743
    zonkExpr env expr		`thenM` \ new_expr ->
    returnM (NPatOut lit new_ty new_expr, emptyBag)

744 745
zonk_pat env (NPlusKPatOut n k e1 e2)
  = wrapLocM (zonkIdBndr env) n	        `thenM` \ new_n ->
746 747
    zonkExpr env e1		        `thenM` \ new_e1 ->
    zonkExpr env e2		        `thenM` \ new_e2 ->
748
    returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag (unLoc new_n))
749

750
zonk_pat env (DictPat ds ms)
751 752
  = zonkIdBndrs env ds      `thenM` \ new_ds ->
    zonkIdBndrs env ms     `thenM` \ new_ms ->
753
    returnM (DictPat new_ds new_ms,
sof's avatar
sof committed
754
		 listToBag new_ds `unionBags` listToBag new_ms)
755

756 757 758 759
---------------------------
zonkConStuff env (PrefixCon pats)
  = zonkPats env pats		`thenM` \ (new_pats, ids) ->
    returnM (PrefixCon new_pats, ids)
760

761 762 763 764
zonkConStuff env (InfixCon p1 p2)
  = zonkPat env p1		`thenM` \ (new_p1, ids1) ->
    zonkPat env p2		`thenM` \ (new_p2, ids2) ->
    returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
765

766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781
zonkConStuff env (RecCon rpats)
  = mapAndUnzipM zonk_rpat rpats	`thenM` \ (new_rpats, ids_s) ->
    returnM (RecCon new_rpats, unionManyBags ids_s)
  where
    zonk_rpat (f, pat)
      = zonkPat env pat		`thenM` \ (new_pat, ids) ->
	returnM ((f, new_pat), ids)

---------------------------
zonkPats env []
  = returnM ([], emptyBag)

zonkPats env (pat:pats) 
  = zonkPat env pat	`thenM` \ (pat',  ids1) ->
    zonkPats env pats	`thenM` \ (pats', ids2) ->
    returnM (pat':pats', ids1 `unionBags` ids2)
782 783
\end{code}

sof's avatar
sof committed
784 785 786 787 788 789
%************************************************************************
%*									*
\subsection[BackSubst-Foreign]{Foreign exports}
%*									*
%************************************************************************

790

sof's avatar
sof committed
791
\begin{code}
792 793
zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
sof's avatar
sof committed
794

795 796 797
zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
zonkForeignExport env (ForeignExport i hs_ty spec isDeprec) =
   returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec isDeprec)
798 799
zonkForeignExport env for_imp 
  = returnM for_imp	-- Foreign imports don't need zonking
sof's avatar
sof committed
800
\end{code}
801 802

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

806 807
zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs)
808 809
  = mappM zonk_bndr vars		`thenM` \ new_bndrs ->
    newMutVar emptyVarSet		`thenM` \ unbound_tv_set ->
810
    let
811
	env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
812 813
	-- Type variables don't need an envt
	-- They are bound through the mutable mechanism
814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833

	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)
834
    in
835 836
    zonkLExpr env_lhs lhs		`thenM` \ new_lhs ->
    zonkLExpr env_rhs rhs		`thenM` \ new_rhs ->
837 838 839

    readMutVar unbound_tv_set		`thenM` \ unbound_tvs ->
    let
840 841
	final_bndrs :: [Located Var]
	final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
842
    in
843 844
    returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs new_rhs)
		-- I hate this map RuleBndr stuff
845 846
  where
   zonk_bndr (RuleBndr v) 
847 848
	| isId (unLoc v) = wrapLocM (zonkIdBndr env)   v
	| otherwise      = wrapLocM zonkTcTyVarToTyVar v
849
\end{code}
sof's avatar
sof committed
850

851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916

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

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

zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
-- This variant collects unbound type variables in a mutable variable
zonkTypeCollecting unbound_tv_set
  = zonkType zonk_unbound_tyvar
  where
    zonk_unbound_tyvar tv 
	= zonkTcTyVarToTyVar tv					`thenM` \ tv' ->
	  readMutVar unbound_tv_set				`thenM` \ tv_set ->
	  writeMutVar unbound_tv_set (extendVarSet tv_set tv')	`thenM_`
	  return (mkTyVarTy tv')

zonkTypeZapping :: TcType -> TcM Type
-- This variant is used for everything except the LHS of rules
-- It zaps unbound type variables to (), or some other arbitrary type
zonkTypeZapping ty 
  = zonkType zonk_unbound_tyvar ty
  where
	-- Zonk a mutable but unbound type variable to an arbitrary type
	-- We know it's unbound even though we don't carry an environment,
	-- because at the binding site for a type variable we bind the
	-- 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 = putTcTyVar tv (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 
917 918
  | liftedTypeKind `isSubKind` kind = voidTy		-- The vastly common case
  | otherwise			    = mkTyConApp tycon []
919 920
  where
    kind       = tyVarKind tv
921
    (args,res) = splitKindFunTys kind
922

923
    tycon | kind == tyConKind listTyCon 	-- *->*
924 925
	  = listTyCon				-- No tuples this size

926
	  | all isLiftedTypeKind args && isLiftedTypeKind res
927 928 929 930 931 932 933 934 935 936 937
	  = tupleTyCon Boxed (length args)	-- *-> ... ->*->*

	  | otherwise
	  = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
	    mkPrimTyCon tc_name kind 0 [] VoidRep
		-- 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
\end{code}