2 % (c) The University of Glasgow 2006
3 % (c) The AQUA Project, Glasgow University, 1996-1998
6 TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker
8 This module is an extension of @HsSyn@ syntax, for use in the type
13 -- The above warning supression flag is a temporary kludge.
14 -- While working on this module you are encouraged to remove it and fix
15 -- any warnings in the module. See
16 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
20 mkHsConApp, mkHsDictLet, mkHsApp,
21 hsLitType, hsLPatType, hsPatType,
22 mkHsAppTy, mkSimpleHsAlt,
23 nlHsIntLit, mkVanillaTuplePat,
24 shortCutLit, hsOverLitName,
26 mkArbitraryType, -- Put this elsewhere?
28 -- re-exported from TcMonad
29 TcId, TcIdSet, TcDictBinds,
31 zonkTopDecls, zonkTopExpr, zonkTopLExpr,
35 #include "HsVersions.h"
38 import HsSyn -- oodles of it
69 thenM :: Monad a => a b -> (b -> a c) -> a c
72 thenM_ :: Monad a => a b -> a c -> a c
75 returnM :: Monad m => a -> m a
78 mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
83 %************************************************************************
85 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
87 %************************************************************************
89 Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
90 then something is wrong.
92 mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
93 -- A vanilla tuple pattern simply gets its type from its sub-patterns
94 mkVanillaTuplePat pats box
95 = TuplePat pats box (mkTupleTy box (length pats) (map hsLPatType pats))
97 hsLPatType :: OutPat Id -> Type
98 hsLPatType (L _ pat) = hsPatType pat
100 hsPatType (ParPat pat) = hsLPatType pat
101 hsPatType (WildPat ty) = ty
102 hsPatType (VarPat var) = idType var
103 hsPatType (VarPatOut var _) = idType var
104 hsPatType (BangPat pat) = hsLPatType pat
105 hsPatType (LazyPat pat) = hsLPatType pat
106 hsPatType (LitPat lit) = hsLitType lit
107 hsPatType (AsPat var pat) = idType (unLoc var)
108 hsPatType (ViewPat expr pat ty) = ty
109 hsPatType (ListPat _ ty) = mkListTy ty
110 hsPatType (PArrPat _ ty) = mkPArrTy ty
111 hsPatType (TuplePat pats box ty) = ty
112 hsPatType (ConPatOut{ pat_ty = ty })= ty
113 hsPatType (SigPatOut pat ty) = ty
114 hsPatType (NPat lit _ _) = overLitType lit
115 hsPatType (NPlusKPat id _ _ _) = idType (unLoc id)
116 hsPatType (CoPat _ _ ty) = ty
118 hsLitType :: HsLit -> TcType
119 hsLitType (HsChar c) = charTy
120 hsLitType (HsCharPrim c) = charPrimTy
121 hsLitType (HsString str) = stringTy
122 hsLitType (HsStringPrim s) = addrPrimTy
123 hsLitType (HsInt i) = intTy
124 hsLitType (HsIntPrim i) = intPrimTy
125 hsLitType (HsWordPrim w) = wordPrimTy
126 hsLitType (HsInteger i ty) = ty
127 hsLitType (HsRat _ ty) = ty
128 hsLitType (HsFloatPrim f) = floatPrimTy
129 hsLitType (HsDoublePrim d) = doublePrimTy
132 Overloaded literals. Here mainly becuase it uses isIntTy etc
135 shortCutLit :: OverLitVal -> TcType -> Maybe (HsExpr TcId)
136 shortCutLit (HsIntegral i) ty
137 | isIntTy ty && inIntRange i = Just (HsLit (HsInt i))
138 | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
139 | isIntegerTy ty = Just (HsLit (HsInteger i ty))
140 | otherwise = shortCutLit (HsFractional (fromInteger i)) ty
141 -- The 'otherwise' case is important
142 -- Consider (3 :: Float). Syntactically it looks like an IntLit,
143 -- so we'll call shortCutIntLit, but of course it's a float
144 -- This can make a big difference for programs with a lot of
145 -- literals, compiled without -O
147 shortCutLit (HsFractional f) ty
148 | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim f))
149 | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
150 | otherwise = Nothing
152 shortCutLit (HsIsString s) ty
153 | isStringTy ty = Just (HsLit (HsString s))
154 | otherwise = Nothing
156 mkLit :: DataCon -> HsLit -> HsExpr Id
157 mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
159 ------------------------------
160 hsOverLitName :: OverLitVal -> Name
161 -- Get the canonical 'fromX' name for a particular OverLitVal
162 hsOverLitName (HsIntegral {}) = fromIntegerName
163 hsOverLitName (HsFractional {}) = fromRationalName
164 hsOverLitName (HsIsString {}) = fromStringName
167 %************************************************************************
169 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
171 %************************************************************************
174 -- zonkId is used *during* typechecking just to zonk the Id's type
175 zonkId :: TcId -> TcM TcId
177 = zonkTcType (idType id) `thenM` \ ty' ->
178 returnM (Id.setIdType id ty')
181 The rest of the zonking is done *after* typechecking.
182 The main zonking pass runs over the bindings
184 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
185 b) convert unbound TcTyVar to Void
186 c) convert each TcId to an Id by zonking its type
188 The type variables are converted by binding mutable tyvars to immutable ones
189 and then zonking as normal.
191 The Ids are converted by binding them in the normal Tc envt; that
192 way we maintain sharing; eg an Id is zonked at its binding site and they
193 all occurrences of that Id point to the common zonked copy
195 It's all pretty boring stuff, because HsSyn is such a large type, and
196 the environment manipulation is tiresome.
199 data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type
200 (IdEnv Id) -- What variables are in scope
201 -- Maps an Id to its zonked version; both have the same Name
202 -- Is only consulted lazily; hence knot-tying
204 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
206 extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
207 extendZonkEnv (ZonkEnv zonk_ty env) ids
208 = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
210 extendZonkEnv1 :: ZonkEnv -> Id -> ZonkEnv
211 extendZonkEnv1 (ZonkEnv zonk_ty env) id
212 = ZonkEnv zonk_ty (extendVarEnv env id id)
214 setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
215 setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
217 zonkEnvIds :: ZonkEnv -> [Id]
218 zonkEnvIds (ZonkEnv _ env) = varEnvElts env
220 zonkIdOcc :: ZonkEnv -> TcId -> Id
221 -- Ids defined in this module should be in the envt;
222 -- ignore others. (Actually, data constructors are also
223 -- not LocalVars, even when locally defined, but that is fine.)
224 -- (Also foreign-imported things aren't currently in the ZonkEnv;
225 -- that's ok because they don't need zonking.)
227 -- Actually, Template Haskell works in 'chunks' of declarations, and
228 -- an earlier chunk won't be in the 'env' that the zonking phase
229 -- carries around. Instead it'll be in the tcg_gbl_env, already fully
230 -- zonked. There's no point in looking it up there (except for error
231 -- checking), and it's not conveniently to hand; hence the simple
232 -- 'orElse' case in the LocalVar branch.
234 -- Even without template splices, in module Main, the checking of
235 -- 'main' is done as a separate chunk.
236 zonkIdOcc (ZonkEnv zonk_ty env) id
237 | isLocalVar id = lookupVarEnv env id `orElse` id
240 zonkIdOccs env ids = map (zonkIdOcc env) ids
242 -- zonkIdBndr is used *after* typechecking to get the Id's type
243 -- to its final form. The TyVarEnv give
244 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
246 = zonkTcTypeToType env (idType id) `thenM` \ ty' ->
247 returnM (Id.setIdType id ty')
249 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
250 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
252 zonkDictBndrs :: ZonkEnv -> [Var] -> TcM [Var]
253 -- "Dictionary" binders can be coercion variables or dictionary variables
254 zonkDictBndrs env ids = mappM (zonkDictBndr env) ids
256 zonkDictBndr env var | isTyVar var = return var
257 | otherwise = zonkIdBndr env var
259 zonkTopBndrs :: [TcId] -> TcM [Id]
260 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
265 zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
266 zonkTopExpr e = zonkExpr emptyZonkEnv e
268 zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
269 zonkTopLExpr e = zonkLExpr emptyZonkEnv e
271 zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
276 zonkTopDecls binds rules fords
277 = do { (env, binds') <- zonkRecMonoBinds emptyZonkEnv binds
278 -- Top level is implicitly recursive
279 ; rules' <- zonkRules env rules
280 ; fords' <- zonkForeignExports env fords
281 ; return (zonkEnvIds env, binds', fords', rules') }
283 ---------------------------------------------
284 zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
285 zonkLocalBinds env EmptyLocalBinds
286 = return (env, EmptyLocalBinds)
288 zonkLocalBinds env (HsValBinds binds)
289 = do { (env1, new_binds) <- zonkValBinds env binds
290 ; return (env1, HsValBinds new_binds) }
292 zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
293 = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds ->
295 env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
297 zonkRecMonoBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) ->
298 returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
300 zonk_ip_bind (IPBind n e)
301 = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
302 zonkLExpr env e `thenM` \ e' ->
303 returnM (IPBind n' e')
306 ---------------------------------------------
307 zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id)
308 zonkValBinds env bs@(ValBindsIn _ _)
309 = panic "zonkValBinds" -- Not in typechecker output
310 zonkValBinds env (ValBindsOut binds sigs)
311 = do { (env1, new_binds) <- go env binds
312 ; return (env1, ValBindsOut new_binds sigs) }
314 go env [] = return (env, [])
315 go env ((r,b):bs) = do { (env1, b') <- zonkRecMonoBinds env b
316 ; (env2, bs') <- go env1 bs
317 ; return (env2, (r,b'):bs') }
319 ---------------------------------------------
320 zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
321 zonkRecMonoBinds env binds
322 = fixM (\ ~(_, new_binds) -> do
323 { let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
324 ; binds' <- zonkMonoBinds env1 binds
325 ; return (env1, binds') })
327 ---------------------------------------------
328 zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
329 zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
331 zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
332 zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
333 = do { (_env, new_pat) <- zonkPat env pat -- Env already extended
334 ; new_grhss <- zonkGRHSs env grhss
335 ; new_ty <- zonkTcTypeToType env ty
336 ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
338 zonk_bind env (VarBind { var_id = var, var_rhs = expr })
339 = zonkIdBndr env var `thenM` \ new_var ->
340 zonkLExpr env expr `thenM` \ new_expr ->
341 returnM (VarBind { var_id = new_var, var_rhs = new_expr })
343 zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn })
344 = wrapLocM (zonkIdBndr env) var `thenM` \ new_var ->
345 zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
346 zonkMatchGroup env1 ms `thenM` \ new_ms ->
347 returnM (bind { fun_id = new_var, fun_matches = new_ms, fun_co_fn = new_co_fn })
349 zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts,
350 abs_exports = exports, abs_binds = val_binds })
351 = ASSERT( all isImmutableTyVar tyvars )
352 zonkDictBndrs env dicts `thenM` \ new_dicts ->
353 fixM (\ ~(new_val_binds, _) ->
355 env1 = extendZonkEnv env new_dicts
356 env2 = extendZonkEnv env1 (collectHsBindBinders new_val_binds)
358 zonkMonoBinds env2 val_binds `thenM` \ new_val_binds ->
359 mappM (zonkExport env2) exports `thenM` \ new_exports ->
360 returnM (new_val_binds, new_exports)
361 ) `thenM` \ (new_val_bind, new_exports) ->
362 returnM (AbsBinds { abs_tvs = tyvars, abs_dicts = new_dicts,
363 abs_exports = new_exports, abs_binds = new_val_bind })
365 zonkExport env (tyvars, global, local, prags)
366 -- The tyvars are already zonked
367 = zonkIdBndr env global `thenM` \ new_global ->
368 mapM zonk_prag prags `thenM` \ new_prags ->
369 returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
370 zonk_prag prag@(L _ (InlinePrag {})) = return prag
371 zonk_prag (L loc (SpecPrag expr ty inl))
372 = do { expr' <- zonkExpr env expr
373 ; ty' <- zonkTcTypeToType env ty
374 ; return (L loc (SpecPrag expr' ty' inl)) }
377 %************************************************************************
379 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
381 %************************************************************************
384 zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id)
385 zonkMatchGroup env (MatchGroup ms ty)
386 = do { ms' <- mapM (zonkMatch env) ms
387 ; ty' <- zonkTcTypeToType env ty
388 ; return (MatchGroup ms' ty') }
390 zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
391 zonkMatch env (L loc (Match pats _ grhss))
392 = do { (env1, new_pats) <- zonkPats env pats
393 ; new_grhss <- zonkGRHSs env1 grhss
394 ; return (L loc (Match new_pats Nothing new_grhss)) }
396 -------------------------------------------------------------------------
397 zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
399 zonkGRHSs env (GRHSs grhss binds)
400 = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
402 zonk_grhs (GRHS guarded rhs)
403 = zonkStmts new_env guarded `thenM` \ (env2, new_guarded) ->
404 zonkLExpr env2 rhs `thenM` \ new_rhs ->
405 returnM (GRHS new_guarded new_rhs)
407 mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss ->
408 returnM (GRHSs new_grhss new_binds)
411 %************************************************************************
413 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
415 %************************************************************************
418 zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
419 zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id)
420 zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id)
422 zonkLExprs env exprs = mappM (zonkLExpr env) exprs
423 zonkLExpr env expr = wrapLocM (zonkExpr env) expr
425 zonkExpr env (HsVar id)
426 = returnM (HsVar (zonkIdOcc env id))
428 zonkExpr env (HsIPVar id)
429 = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
431 zonkExpr env (HsLit (HsRat f ty))
432 = zonkTcTypeToType env ty `thenM` \ new_ty ->
433 returnM (HsLit (HsRat f new_ty))
435 zonkExpr env (HsLit lit)
436 = returnM (HsLit lit)
438 zonkExpr env (HsOverLit lit)
439 = do { lit' <- zonkOverLit env lit
440 ; return (HsOverLit lit') }
442 zonkExpr env (HsLam matches)
443 = zonkMatchGroup env matches `thenM` \ new_matches ->
444 returnM (HsLam new_matches)
446 zonkExpr env (HsApp e1 e2)
447 = zonkLExpr env e1 `thenM` \ new_e1 ->
448 zonkLExpr env e2 `thenM` \ new_e2 ->
449 returnM (HsApp new_e1 new_e2)
451 zonkExpr env (HsBracketOut body bs)
452 = mappM zonk_b bs `thenM` \ bs' ->
453 returnM (HsBracketOut body bs')
455 zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
458 zonkExpr env (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
459 returnM (HsSpliceE s)
461 zonkExpr env (OpApp e1 op fixity e2)
462 = zonkLExpr env e1 `thenM` \ new_e1 ->
463 zonkLExpr env op `thenM` \ new_op ->
464 zonkLExpr env e2 `thenM` \ new_e2 ->
465 returnM (OpApp new_e1 new_op fixity new_e2)
467 zonkExpr env (NegApp expr op)
468 = zonkLExpr env expr `thenM` \ new_expr ->
469 zonkExpr env op `thenM` \ new_op ->
470 returnM (NegApp new_expr new_op)
472 zonkExpr env (HsPar e)
473 = zonkLExpr env e `thenM` \new_e ->
474 returnM (HsPar new_e)
476 zonkExpr env (SectionL expr op)
477 = zonkLExpr env expr `thenM` \ new_expr ->
478 zonkLExpr env op `thenM` \ new_op ->
479 returnM (SectionL new_expr new_op)
481 zonkExpr env (SectionR op expr)
482 = zonkLExpr env op `thenM` \ new_op ->
483 zonkLExpr env expr `thenM` \ new_expr ->
484 returnM (SectionR new_op new_expr)
486 zonkExpr env (HsCase expr ms)
487 = zonkLExpr env expr `thenM` \ new_expr ->
488 zonkMatchGroup env ms `thenM` \ new_ms ->
489 returnM (HsCase new_expr new_ms)
491 zonkExpr env (HsIf e1 e2 e3)
492 = zonkLExpr env e1 `thenM` \ new_e1 ->
493 zonkLExpr env e2 `thenM` \ new_e2 ->
494 zonkLExpr env e3 `thenM` \ new_e3 ->
495 returnM (HsIf new_e1 new_e2 new_e3)
497 zonkExpr env (HsLet binds expr)
498 = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
499 zonkLExpr new_env expr `thenM` \ new_expr ->
500 returnM (HsLet new_binds new_expr)
502 zonkExpr env (HsDo do_or_lc stmts body ty)
503 = zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
504 zonkLExpr new_env body `thenM` \ new_body ->
505 zonkTcTypeToType env ty `thenM` \ new_ty ->
506 returnM (HsDo (zonkDo env do_or_lc)
507 new_stmts new_body new_ty)
509 zonkExpr env (ExplicitList ty exprs)
510 = zonkTcTypeToType env ty `thenM` \ new_ty ->
511 zonkLExprs env exprs `thenM` \ new_exprs ->
512 returnM (ExplicitList new_ty new_exprs)
514 zonkExpr env (ExplicitPArr ty exprs)
515 = zonkTcTypeToType env ty `thenM` \ new_ty ->
516 zonkLExprs env exprs `thenM` \ new_exprs ->
517 returnM (ExplicitPArr new_ty new_exprs)
519 zonkExpr env (ExplicitTuple exprs boxed)
520 = zonkLExprs env exprs `thenM` \ new_exprs ->
521 returnM (ExplicitTuple new_exprs boxed)
523 zonkExpr env (RecordCon data_con con_expr rbinds)
524 = do { new_con_expr <- zonkExpr env con_expr
525 ; new_rbinds <- zonkRecFields env rbinds
526 ; return (RecordCon data_con new_con_expr new_rbinds) }
528 zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
529 = do { new_expr <- zonkLExpr env expr
530 ; new_in_tys <- mapM (zonkTcTypeToType env) in_tys
531 ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
532 ; new_rbinds <- zonkRecFields env rbinds
533 ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) }
535 zonkExpr env (ExprWithTySigOut e ty)
536 = do { e' <- zonkLExpr env e
537 ; return (ExprWithTySigOut e' ty) }
539 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
541 zonkExpr env (ArithSeq expr info)
542 = zonkExpr env expr `thenM` \ new_expr ->
543 zonkArithSeq env info `thenM` \ new_info ->
544 returnM (ArithSeq new_expr new_info)
546 zonkExpr env (PArrSeq expr info)
547 = zonkExpr env expr `thenM` \ new_expr ->
548 zonkArithSeq env info `thenM` \ new_info ->
549 returnM (PArrSeq new_expr new_info)
551 zonkExpr env (HsSCC lbl expr)
552 = zonkLExpr env expr `thenM` \ new_expr ->
553 returnM (HsSCC lbl new_expr)
555 zonkExpr env (HsTickPragma info expr)
556 = zonkLExpr env expr `thenM` \ new_expr ->
557 returnM (HsTickPragma info new_expr)
559 -- hdaume: core annotations
560 zonkExpr env (HsCoreAnn lbl expr)
561 = zonkLExpr env expr `thenM` \ new_expr ->
562 returnM (HsCoreAnn lbl new_expr)
564 -- arrow notation extensions
565 zonkExpr env (HsProc pat body)
566 = do { (env1, new_pat) <- zonkPat env pat
567 ; new_body <- zonkCmdTop env1 body
568 ; return (HsProc new_pat new_body) }
570 zonkExpr env (HsArrApp e1 e2 ty ho rl)
571 = zonkLExpr env e1 `thenM` \ new_e1 ->
572 zonkLExpr env e2 `thenM` \ new_e2 ->
573 zonkTcTypeToType env ty `thenM` \ new_ty ->
574 returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
576 zonkExpr env (HsArrForm op fixity args)
577 = zonkLExpr env op `thenM` \ new_op ->
578 mappM (zonkCmdTop env) args `thenM` \ new_args ->
579 returnM (HsArrForm new_op fixity new_args)
581 zonkExpr env (HsWrap co_fn expr)
582 = zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
583 zonkExpr env1 expr `thenM` \ new_expr ->
584 return (HsWrap new_co_fn new_expr)
586 zonkExpr env other = pprPanic "zonkExpr" (ppr other)
588 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
589 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
591 zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
592 = zonkLExpr env cmd `thenM` \ new_cmd ->
593 zonkTcTypeToTypes env stack_tys `thenM` \ new_stack_tys ->
594 zonkTcTypeToType env ty `thenM` \ new_ty ->
595 mapSndM (zonkExpr env) ids `thenM` \ new_ids ->
596 returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
598 -------------------------------------------------------------------------
599 zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
600 zonkCoFn env WpHole = return (env, WpHole)
601 zonkCoFn env WpInline = return (env, WpInline)
602 zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
603 ; (env2, c2') <- zonkCoFn env1 c2
604 ; return (env2, WpCompose c1' c2') }
605 zonkCoFn env (WpCast co) = do { co' <- zonkTcTypeToType env co
606 ; return (env, WpCast co') }
607 zonkCoFn env (WpLam id) = do { id' <- zonkDictBndr env id
608 ; let env1 = extendZonkEnv1 env id'
609 ; return (env1, WpLam id') }
610 zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv )
611 do { return (env, WpTyLam tv) }
612 zonkCoFn env (WpApp id) = do { return (env, WpApp (zonkIdOcc env id)) }
613 zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty
614 ; return (env, WpTyApp ty') }
615 zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkRecMonoBinds env bs
616 ; return (env1, WpLet bs') }
619 -------------------------------------------------------------------------
620 zonkDo :: ZonkEnv -> HsStmtContext Name -> HsStmtContext Name
621 -- Only used for 'do', so the only Ids are in a MDoExpr table
622 zonkDo env (MDoExpr tbl) = MDoExpr (mapSnd (zonkIdOcc env) tbl)
623 zonkDo env do_or_lc = do_or_lc
625 -------------------------------------------------------------------------
626 zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
627 zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
628 = do { ty' <- zonkTcTypeToType env ty
629 ; e' <- zonkExpr env e
630 ; return (lit { ol_witness = e', ol_type = ty' }) }
632 -------------------------------------------------------------------------
633 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
635 zonkArithSeq env (From e)
636 = zonkLExpr env e `thenM` \ new_e ->
639 zonkArithSeq env (FromThen e1 e2)
640 = zonkLExpr env e1 `thenM` \ new_e1 ->
641 zonkLExpr env e2 `thenM` \ new_e2 ->
642 returnM (FromThen new_e1 new_e2)
644 zonkArithSeq env (FromTo e1 e2)
645 = zonkLExpr env e1 `thenM` \ new_e1 ->
646 zonkLExpr env e2 `thenM` \ new_e2 ->
647 returnM (FromTo new_e1 new_e2)
649 zonkArithSeq env (FromThenTo e1 e2 e3)
650 = zonkLExpr env e1 `thenM` \ new_e1 ->
651 zonkLExpr env e2 `thenM` \ new_e2 ->
652 zonkLExpr env e3 `thenM` \ new_e3 ->
653 returnM (FromThenTo new_e1 new_e2 new_e3)
656 -------------------------------------------------------------------------
657 zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
658 zonkStmts env [] = return (env, [])
659 zonkStmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s
660 ; (env2, ss') <- zonkStmts env1 ss
661 ; return (env2, s' : ss') }
663 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
664 zonkStmt env (ParStmt stmts_w_bndrs)
665 = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
667 new_binders = concat (map snd new_stmts_w_bndrs)
668 env1 = extendZonkEnv env new_binders
670 return (env1, ParStmt new_stmts_w_bndrs)
672 zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) ->
673 returnM (new_stmts, zonkIdOccs env1 bndrs)
675 zonkStmt env (RecStmt segStmts lvs rvs rets binds)
676 = zonkIdBndrs env rvs `thenM` \ new_rvs ->
678 env1 = extendZonkEnv env new_rvs
680 zonkStmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
681 -- Zonk the ret-expressions in an envt that
682 -- has the polymorphic bindings in the envt
683 mapM (zonkExpr env2) rets `thenM` \ new_rets ->
685 new_lvs = zonkIdOccs env2 lvs
686 env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
688 zonkRecMonoBinds env3 binds `thenM` \ (env4, new_binds) ->
689 returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets new_binds)
691 zonkStmt env (ExprStmt expr then_op ty)
692 = zonkLExpr env expr `thenM` \ new_expr ->
693 zonkExpr env then_op `thenM` \ new_then ->
694 zonkTcTypeToType env ty `thenM` \ new_ty ->
695 returnM (env, ExprStmt new_expr new_then new_ty)
697 zonkStmt env (TransformStmt (stmts, binders) usingExpr maybeByExpr)
698 = do { (env', stmts') <- zonkStmts env stmts
699 ; let binders' = zonkIdOccs env' binders
700 ; usingExpr' <- zonkLExpr env' usingExpr
701 ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr
702 ; return (env', TransformStmt (stmts', binders') usingExpr' maybeByExpr') }
704 zonkStmt env (GroupStmt (stmts, binderMap) groupByClause)
705 = do { (env', stmts') <- zonkStmts env stmts
706 ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
708 case groupByClause of
709 GroupByNothing usingExpr -> (zonkLExpr env' usingExpr) >>= (return . GroupByNothing)
710 GroupBySomething eitherUsingExpr byExpr -> do
711 eitherUsingExpr' <- mapEitherM (zonkLExpr env') (zonkExpr env') eitherUsingExpr
712 byExpr' <- zonkLExpr env' byExpr
713 return $ GroupBySomething eitherUsingExpr' byExpr'
715 ; let env'' = extendZonkEnv env' (map snd binderMap')
716 ; return (env'', GroupStmt (stmts', binderMap') groupByClause') }
718 mapEitherM f g x = do
720 Left a -> f a >>= (return . Left)
721 Right b -> g b >>= (return . Right)
723 zonkBinderMapEntry env (oldBinder, newBinder) = do
724 let oldBinder' = zonkIdOcc env oldBinder
725 newBinder' <- zonkIdBndr env newBinder
726 return (oldBinder', newBinder')
728 zonkStmt env (LetStmt binds)
729 = zonkLocalBinds env binds `thenM` \ (env1, new_binds) ->
730 returnM (env1, LetStmt new_binds)
732 zonkStmt env (BindStmt pat expr bind_op fail_op)
733 = do { new_expr <- zonkLExpr env expr
734 ; (env1, new_pat) <- zonkPat env pat
735 ; new_bind <- zonkExpr env bind_op
736 ; new_fail <- zonkExpr env fail_op
737 ; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
739 zonkMaybeLExpr env Nothing = return Nothing
740 zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just)
743 -------------------------------------------------------------------------
744 zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
745 zonkRecFields env (HsRecFields flds dd)
746 = do { flds' <- mappM zonk_rbind flds
747 ; return (HsRecFields flds' dd) }
750 = do { new_expr <- zonkLExpr env (hsRecFieldArg fld)
751 ; return (fld { hsRecFieldArg = new_expr }) }
752 -- Field selectors have declared types; hence no zonking
754 -------------------------------------------------------------------------
755 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
756 mapIPNameTc f (IPName n) = f n `thenM` \ r -> returnM (IPName r)
760 %************************************************************************
762 \subsection[BackSubst-Pats]{Patterns}
764 %************************************************************************
767 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
768 -- Extend the environment as we go, because it's possible for one
769 -- pattern to bind something that is used in another (inside or
771 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
773 zonk_pat env (ParPat p)
774 = do { (env', p') <- zonkPat env p
775 ; return (env', ParPat p') }
777 zonk_pat env (WildPat ty)
778 = do { ty' <- zonkTcTypeToType env ty
779 ; return (env, WildPat ty') }
781 zonk_pat env (VarPat v)
782 = do { v' <- zonkIdBndr env v
783 ; return (extendZonkEnv1 env v', VarPat v') }
785 zonk_pat env (VarPatOut v binds)
786 = do { v' <- zonkIdBndr env v
787 ; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds
788 ; returnM (env', VarPatOut v' binds') }
790 zonk_pat env (LazyPat pat)
791 = do { (env', pat') <- zonkPat env pat
792 ; return (env', LazyPat pat') }
794 zonk_pat env (BangPat pat)
795 = do { (env', pat') <- zonkPat env pat
796 ; return (env', BangPat pat') }
798 zonk_pat env (AsPat (L loc v) pat)
799 = do { v' <- zonkIdBndr env v
800 ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
801 ; return (env', AsPat (L loc v') pat') }
803 zonk_pat env (ViewPat expr pat ty)
804 = do { expr' <- zonkLExpr env expr
805 ; (env', pat') <- zonkPat env pat
806 ; return (env', ViewPat expr' pat' ty) }
808 zonk_pat env (ListPat pats ty)
809 = do { ty' <- zonkTcTypeToType env ty
810 ; (env', pats') <- zonkPats env pats
811 ; return (env', ListPat pats' ty') }
813 zonk_pat env (PArrPat pats ty)
814 = do { ty' <- zonkTcTypeToType env ty
815 ; (env', pats') <- zonkPats env pats
816 ; return (env', PArrPat pats' ty') }
818 zonk_pat env (TuplePat pats boxed ty)
819 = do { ty' <- zonkTcTypeToType env ty
820 ; (env', pats') <- zonkPats env pats
821 ; return (env', TuplePat pats' boxed ty') }
823 zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = dicts, pat_binds = binds, pat_args = args })
824 = ASSERT( all isImmutableTyVar (pat_tvs p) )
825 do { new_ty <- zonkTcTypeToType env ty
826 ; new_dicts <- zonkDictBndrs env dicts
827 ; let env1 = extendZonkEnv env new_dicts
828 ; (env2, new_binds) <- zonkRecMonoBinds env1 binds
829 ; (env', new_args) <- zonkConStuff env2 args
830 ; returnM (env', p { pat_ty = new_ty, pat_dicts = new_dicts,
831 pat_binds = new_binds, pat_args = new_args }) }
833 zonk_pat env (LitPat lit) = return (env, LitPat lit)
835 zonk_pat env (SigPatOut pat ty)
836 = do { ty' <- zonkTcTypeToType env ty
837 ; (env', pat') <- zonkPat env pat
838 ; return (env', SigPatOut pat' ty') }
840 zonk_pat env (NPat lit mb_neg eq_expr)
841 = do { lit' <- zonkOverLit env lit
842 ; mb_neg' <- case mb_neg of
843 Nothing -> return Nothing
844 Just neg -> do { neg' <- zonkExpr env neg
845 ; return (Just neg') }
846 ; eq_expr' <- zonkExpr env eq_expr
847 ; return (env, NPat lit' mb_neg' eq_expr') }
849 zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
850 = do { n' <- zonkIdBndr env n
851 ; lit' <- zonkOverLit env lit
852 ; e1' <- zonkExpr env e1
853 ; e2' <- zonkExpr env e2
854 ; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
856 zonk_pat env (CoPat co_fn pat ty)
857 = do { (env', co_fn') <- zonkCoFn env co_fn
858 ; (env'', pat') <- zonkPat env' (noLoc pat)
859 ; ty' <- zonkTcTypeToType env'' ty
860 ; return (env'', CoPat co_fn' (unLoc pat') ty') }
862 zonk_pat env pat = pprPanic "zonk_pat" (ppr pat)
864 ---------------------------
865 zonkConStuff env (PrefixCon pats)
866 = do { (env', pats') <- zonkPats env pats
867 ; return (env', PrefixCon pats') }
869 zonkConStuff env (InfixCon p1 p2)
870 = do { (env1, p1') <- zonkPat env p1
871 ; (env', p2') <- zonkPat env1 p2
872 ; return (env', InfixCon p1' p2') }
874 zonkConStuff env (RecCon (HsRecFields rpats dd))
875 = do { (env', pats') <- zonkPats env (map hsRecFieldArg rpats)
876 ; let rpats' = zipWith (\rp p' -> rp { hsRecFieldArg = p' }) rpats pats'
877 ; returnM (env', RecCon (HsRecFields rpats' dd)) }
878 -- Field selectors have declared types; hence no zonking
880 ---------------------------
881 zonkPats env [] = return (env, [])
882 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
883 ; (env', pats') <- zonkPats env1 pats
884 ; return (env', pat':pats') }
887 %************************************************************************
889 \subsection[BackSubst-Foreign]{Foreign exports}
891 %************************************************************************
895 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
896 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
898 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
899 zonkForeignExport env (ForeignExport i hs_ty spec) =
900 returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec)
901 zonkForeignExport env for_imp
902 = returnM for_imp -- Foreign imports don't need zonking
906 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
907 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
909 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
910 zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
911 = mappM zonk_bndr vars `thenM` \ new_bndrs ->
912 newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
914 env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
915 -- Type variables don't need an envt
916 -- They are bound through the mutable mechanism
918 env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
919 -- We need to gather the type variables mentioned on the LHS so we can
920 -- quantify over them. Example:
926 -- {-# RULES "myrule" foo C = 1 #-}
928 -- After type checking the LHS becomes (foo a (C a))
929 -- and we do not want to zap the unbound tyvar 'a' to (), because
930 -- that limits the applicability of the rule. Instead, we
931 -- want to quantify over it!
933 -- It's easiest to find the free tyvars here. Attempts to do so earlier
934 -- are tiresome, because (a) the data type is big and (b) finding the
935 -- free type vars of an expression is necessarily monadic operation.
936 -- (consider /\a -> f @ b, where b is side-effected to a)
938 zonkLExpr env_lhs lhs `thenM` \ new_lhs ->
939 zonkLExpr env_rhs rhs `thenM` \ new_rhs ->
941 readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
943 final_bndrs :: [Located Var]
944 final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
946 returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs fv_lhs new_rhs fv_rhs)
947 -- I hate this map RuleBndr stuff
949 zonk_bndr (RuleBndr v)
950 | isId (unLoc v) = wrapLocM (zonkIdBndr env) v
951 | otherwise = ASSERT( isImmutableTyVar (unLoc v) )
956 %************************************************************************
958 \subsection[BackSubst-Foreign]{Foreign exports}
960 %************************************************************************
963 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
964 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
966 zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
967 zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
969 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
970 -- This variant collects unbound type variables in a mutable variable
971 zonkTypeCollecting unbound_tv_set
972 = zonkType zonk_unbound_tyvar
974 zonk_unbound_tyvar tv
975 = zonkQuantifiedTyVar tv `thenM` \ tv' ->
976 readMutVar unbound_tv_set `thenM` \ tv_set ->
977 writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
978 return (mkTyVarTy tv')
980 zonkTypeZapping :: TcType -> TcM Type
981 -- This variant is used for everything except the LHS of rules
982 -- It zaps unbound type variables to (), or some other arbitrary type
984 = zonkType zonk_unbound_tyvar ty
986 -- Zonk a mutable but unbound type variable to an arbitrary type
987 -- We know it's unbound even though we don't carry an environment,
988 -- because at the binding site for a type variable we bind the
989 -- mutable tyvar to a fresh immutable one. So the mutable store
990 -- plays the role of an environment. If we come across a mutable
991 -- type variable that isn't so bound, it must be completely free.
992 zonk_unbound_tyvar tv = do { ty <- mkArbitraryType warn tv
993 ; writeMetaTyVar tv ty
996 warn span msg = setSrcSpan span (addWarnTc msg)
999 {- Note [Strangely-kinded void TyCons]
1000 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1001 See Trac #959 for more examples
1003 When the type checker finds a type variable with no binding, which
1004 means it can be instantiated with an arbitrary type, it usually
1005 instantiates it to Void. Eg.
1009 length Void (Nil Void)
1011 But in really obscure programs, the type variable might have a kind
1012 other than *, so we need to invent a suitably-kinded type.
1017 Tuple for kind *->...*->*
1019 which deals with most cases. (Previously, it only dealt with
1022 In the other cases, it just makes up a TyCon with a suitable kind. If
1023 this gets into an interface file, anyone reading that file won't
1024 understand it. This is fixable (by making the client of the interface
1025 file make up a TyCon too) but it is tiresome and never happens, so I
1028 Meanwhile I have now fixed GHC to emit a civilized warning.
1031 mkArbitraryType :: (SrcSpan -> SDoc -> TcRnIf g l a) -- How to complain
1033 -> TcRnIf g l Type -- Used by desugarer too
1034 -- Make up an arbitrary type whose kind is the same as the tyvar.
1035 -- We'll use this to instantiate the (unbound) tyvar.
1037 -- Also used by the desugarer; hence the (tiresome) parameter
1038 -- to use when generating a warning
1039 mkArbitraryType warn tv
1040 | liftedTypeKind `isSubKind` kind -- The vastly common case
1042 | eqKind kind (tyConKind anyPrimTyCon1) -- *->*
1043 = return (mkTyConApp anyPrimTyCon1 []) -- No tuples this size
1044 | all isLiftedTypeKind args -- *-> ... ->*->*
1045 , isLiftedTypeKind res -- Horrible hack to make less use
1046 = return (mkTyConApp tup_tc []) -- of mkAnyPrimTyCon
1048 = do { warn (getSrcSpan tv) msg
1049 ; return (mkTyConApp (mkAnyPrimTyCon (getUnique tv) kind) []) }
1050 -- Same name as the tyvar, apart from making it start with a colon (sigh)
1051 -- I dread to think what will happen if this gets out into an
1052 -- interface file. Catastrophe likely. Major sigh.
1055 (args,res) = splitKindFunTys kind
1056 tup_tc = tupleTyCon Boxed (length args)
1058 msg = vcat [ hang (ptext (sLit "Inventing strangely-kinded Any TyCon"))
1059 2 (ptext (sLit "of kind") <+> quotes (ppr kind))
1060 , nest 2 (ptext (sLit "from an instantiation of type variable") <+> quotes (ppr tv))
1061 , ptext (sLit "This warning can be suppressed by a type signature fixing") <+> quotes (ppr tv)
1062 , nest 2 (ptext (sLit "but is harmless without -O (and usually harmless anyway)."))
1063 , ptext (sLit "See http://hackage.haskell.org/trac/ghc/ticket/959 for details") ]