1{- 2(c) The University of Glasgow 2006 3(c) The AQUA Project, Glasgow University, 1996-1998 4 5 6TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker 7 8This module is an extension of @HsSyn@ syntax, for use in the type 9checker. 10-} 11 12{-# LANGUAGE CPP, TupleSections #-} 13{-# LANGUAGE TypeFamilies #-} 14{-# LANGUAGE FlexibleContexts #-} 15{-# LANGUAGE ViewPatterns #-} 16 17module TcHsSyn ( 18 -- * Extracting types from HsSyn 19 hsLitType, hsPatType, hsLPatType, 20 21 -- * Other HsSyn functions 22 mkHsDictLet, mkHsApp, 23 mkHsAppTy, mkHsCaseAlt, 24 shortCutLit, hsOverLitName, 25 conLikeResTy, 26 27 -- * re-exported from TcMonad 28 TcId, TcIdSet, 29 30 -- * Zonking 31 -- | For a description of "zonking", see Note [What is zonking?] 32 -- in TcMType 33 zonkTopDecls, zonkTopExpr, zonkTopLExpr, 34 zonkTopBndrs, 35 ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv, 36 zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX, 37 zonkTyBndrs, zonkTyBndrsX, 38 zonkTcTypeToType, zonkTcTypeToTypeX, 39 zonkTcTypesToTypes, zonkTcTypesToTypesX, 40 zonkTyVarOcc, 41 zonkCoToCo, 42 zonkEvBinds, zonkTcEvBinds, 43 zonkTcMethInfoToMethInfoX, 44 lookupTyVarOcc 45 ) where 46 47#include "HsVersions.h" 48 49import GhcPrelude 50 51import GHC.Hs 52import Id 53import IdInfo 54import Predicate 55import TcRnMonad 56import PrelNames 57import BuildTyCl ( TcMethInfo, MethInfo ) 58import TcType 59import TcMType 60import TcEnv ( tcLookupGlobalOnly ) 61import TcEvidence 62import TyCoPpr ( pprTyVar ) 63import TysPrim 64import TyCon 65import TysWiredIn 66import Type 67import Coercion 68import ConLike 69import DataCon 70import HscTypes 71import Name 72import NameEnv 73import Var 74import VarEnv 75import DynFlags 76import Literal 77import BasicTypes 78import Maybes 79import SrcLoc 80import Bag 81import Outputable 82import Util 83import UniqFM 84import CoreSyn 85 86import {-# SOURCE #-} TcSplice (runTopSplice) 87 88import Control.Monad 89import Data.List ( partition ) 90import Control.Arrow ( second ) 91 92{- 93************************************************************************ 94* * 95 Extracting the type from HsSyn 96* * 97************************************************************************ 98 99-} 100 101hsLPatType :: LPat GhcTc -> Type 102hsLPatType (dL->L _ p) = hsPatType p 103 104hsPatType :: Pat GhcTc -> Type 105hsPatType (ParPat _ pat) = hsLPatType pat 106hsPatType (WildPat ty) = ty 107hsPatType (VarPat _ lvar) = idType (unLoc lvar) 108hsPatType (BangPat _ pat) = hsLPatType pat 109hsPatType (LazyPat _ pat) = hsLPatType pat 110hsPatType (LitPat _ lit) = hsLitType lit 111hsPatType (AsPat _ var _) = idType (unLoc var) 112hsPatType (ViewPat ty _ _) = ty 113hsPatType (ListPat (ListPatTc ty Nothing) _) = mkListTy ty 114hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty 115hsPatType (TuplePat tys _ bx) = mkTupleTy1 bx tys 116 -- See Note [Don't flatten tuples from HsSyn] in MkCore 117hsPatType (SumPat tys _ _ _ ) = mkSumTy tys 118hsPatType (ConPatOut { pat_con = lcon 119 , pat_arg_tys = tys }) 120 = conLikeResTy (unLoc lcon) tys 121hsPatType (SigPat ty _ _) = ty 122hsPatType (NPat ty _ _ _) = ty 123hsPatType (NPlusKPat ty _ _ _ _ _) = ty 124hsPatType (CoPat _ _ _ ty) = ty 125hsPatType (XPat n) = noExtCon n 126hsPatType ConPatIn{} = panic "hsPatType: ConPatIn" 127hsPatType SplicePat{} = panic "hsPatType: SplicePat" 128 129hsLitType :: HsLit (GhcPass p) -> TcType 130hsLitType (HsChar _ _) = charTy 131hsLitType (HsCharPrim _ _) = charPrimTy 132hsLitType (HsString _ _) = stringTy 133hsLitType (HsStringPrim _ _) = addrPrimTy 134hsLitType (HsInt _ _) = intTy 135hsLitType (HsIntPrim _ _) = intPrimTy 136hsLitType (HsWordPrim _ _) = wordPrimTy 137hsLitType (HsInt64Prim _ _) = int64PrimTy 138hsLitType (HsWord64Prim _ _) = word64PrimTy 139hsLitType (HsInteger _ _ ty) = ty 140hsLitType (HsRat _ _ ty) = ty 141hsLitType (HsFloatPrim _ _) = floatPrimTy 142hsLitType (HsDoublePrim _ _) = doublePrimTy 143hsLitType (XLit nec) = noExtCon nec 144 145-- Overloaded literals. Here mainly because it uses isIntTy etc 146 147shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId) 148shortCutLit dflags (HsIntegral int@(IL src neg i)) ty 149 | isIntTy ty && inIntRange dflags i = Just (HsLit noExtField (HsInt noExtField int)) 150 | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i)) 151 | isIntegerTy ty = Just (HsLit noExtField (HsInteger src i ty)) 152 | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty 153 -- The 'otherwise' case is important 154 -- Consider (3 :: Float). Syntactically it looks like an IntLit, 155 -- so we'll call shortCutIntLit, but of course it's a float 156 -- This can make a big difference for programs with a lot of 157 -- literals, compiled without -O 158 159shortCutLit _ (HsFractional f) ty 160 | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim noExtField f)) 161 | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f)) 162 | otherwise = Nothing 163 164shortCutLit _ (HsIsString src s) ty 165 | isStringTy ty = Just (HsLit noExtField (HsString src s)) 166 | otherwise = Nothing 167 168mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc 169mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit) 170 171------------------------------ 172hsOverLitName :: OverLitVal -> Name 173-- Get the canonical 'fromX' name for a particular OverLitVal 174hsOverLitName (HsIntegral {}) = fromIntegerName 175hsOverLitName (HsFractional {}) = fromRationalName 176hsOverLitName (HsIsString {}) = fromStringName 177 178{- 179************************************************************************ 180* * 181\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} 182* * 183************************************************************************ 184 185The rest of the zonking is done *after* typechecking. 186The main zonking pass runs over the bindings 187 188 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc 189 b) convert unbound TcTyVar to Void 190 c) convert each TcId to an Id by zonking its type 191 192The type variables are converted by binding mutable tyvars to immutable ones 193and then zonking as normal. 194 195The Ids are converted by binding them in the normal Tc envt; that 196way we maintain sharing; eg an Id is zonked at its binding site and they 197all occurrences of that Id point to the common zonked copy 198 199It's all pretty boring stuff, because HsSyn is such a large type, and 200the environment manipulation is tiresome. 201-} 202 203-- Confused by zonking? See Note [What is zonking?] in TcMType. 204 205-- | See Note [The ZonkEnv] 206-- Confused by zonking? See Note [What is zonking?] in TcMType. 207data ZonkEnv -- See Note [The ZonkEnv] 208 = ZonkEnv { ze_flexi :: ZonkFlexi 209 , ze_tv_env :: TyCoVarEnv TyCoVar 210 , ze_id_env :: IdEnv Id 211 , ze_meta_tv_env :: TcRef (TyVarEnv Type) } 212 213{- Note [The ZonkEnv] 214~~~~~~~~~~~~~~~~~~~~~ 215* ze_flexi :: ZonkFlexi says what to do with a 216 unification variable that is still un-unified. 217 See Note [Un-unified unification variables] 218 219* ze_tv_env :: TyCoVarEnv TyCoVar promotes sharing. At a binding site 220 of a tyvar or covar, we zonk the kind right away and add a mapping 221 to the env. This prevents re-zonking the kind at every 222 occurrence. But this is *just* an optimisation. 223 224* ze_id_env : IdEnv Id promotes sharing among Ids, by making all 225 occurrences of the Id point to a single zonked copy, built at the 226 binding site. 227 228 Unlike ze_tv_env, it is knot-tied: see extendIdZonkEnvRec. 229 In a mutually recusive group 230 rec { f = ...g...; g = ...f... } 231 we want the occurrence of g to point to the one zonked Id for g, 232 and the same for f. 233 234 Because it is knot-tied, we must be careful to consult it lazily. 235 Specifically, zonkIdOcc is not monadic. 236 237* ze_meta_tv_env: see Note [Sharing when zonking to Type] 238 239 240Notes: 241 * We must be careful never to put coercion variables (which are Ids, 242 after all) in the knot-tied ze_id_env, because coercions can 243 appear in types, and we sometimes inspect a zonked type in this 244 module. [Question: where, precisely?] 245 246 * In zonkTyVarOcc we consult ze_tv_env in a monadic context, 247 a second reason that ze_tv_env can't be monadic. 248 249 * An obvious suggestion would be to have one VarEnv Var to 250 replace both ze_id_env and ze_tv_env, but that doesn't work 251 because of the knot-tying stuff mentioned above. 252 253Note [Un-unified unification variables] 254~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 255What should we do if we find a Flexi unification variable? 256There are three possibilities: 257 258* DefaultFlexi: this is the common case, in situations like 259 length @alpha ([] @alpha) 260 It really doesn't matter what type we choose for alpha. But 261 we must choose a type! We can't leae mutable unification 262 variables floating around: after typecheck is complete, every 263 type variable occurrence must have a bindign site. 264 265 So we default it to 'Any' of the right kind. 266 267 All this works for both type and kind variables (indeed 268 the two are the same thign). 269 270* SkolemiseFlexi: is a special case for the LHS of RULES. 271 See Note [Zonking the LHS of a RULE] 272 273* RuntimeUnkFlexi: is a special case for the GHCi debugger. 274 It's a way to have a variable that is not a mutuable 275 unification variable, but doesn't have a binding site 276 either. 277-} 278 279data ZonkFlexi -- See Note [Un-unified unification variables] 280 = DefaultFlexi -- Default unbound unificaiton variables to Any 281 | SkolemiseFlexi -- Skolemise unbound unification variables 282 -- See Note [Zonking the LHS of a RULE] 283 | RuntimeUnkFlexi -- Used in the GHCi debugger 284 285instance Outputable ZonkEnv where 286 ppr (ZonkEnv { ze_tv_env = tv_env 287 , ze_id_env = id_env }) 288 = text "ZE" <+> braces (vcat 289 [ text "ze_tv_env =" <+> ppr tv_env 290 , text "ze_id_env =" <+> ppr id_env ]) 291 292-- The EvBinds have to already be zonked, but that's usually the case. 293emptyZonkEnv :: TcM ZonkEnv 294emptyZonkEnv = mkEmptyZonkEnv DefaultFlexi 295 296mkEmptyZonkEnv :: ZonkFlexi -> TcM ZonkEnv 297mkEmptyZonkEnv flexi 298 = do { mtv_env_ref <- newTcRef emptyVarEnv 299 ; return (ZonkEnv { ze_flexi = flexi 300 , ze_tv_env = emptyVarEnv 301 , ze_id_env = emptyVarEnv 302 , ze_meta_tv_env = mtv_env_ref }) } 303 304initZonkEnv :: (ZonkEnv -> TcM b) -> TcM b 305initZonkEnv thing_inside = do { ze <- mkEmptyZonkEnv DefaultFlexi 306 ; thing_inside ze } 307 308-- | Extend the knot-tied environment. 309extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv 310extendIdZonkEnvRec ze@(ZonkEnv { ze_id_env = id_env }) ids 311 -- NB: Don't look at the var to decide which env't to put it in. That 312 -- would end up knot-tying all the env'ts. 313 = ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] } 314 -- Given coercion variables will actually end up here. That's OK though: 315 -- coercion variables are never looked up in the knot-tied env't, so zonking 316 -- them simply doesn't get optimised. No one gets hurt. An improvement (?) 317 -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the 318 -- recursive groups. But perhaps the time it takes to do the analysis is 319 -- more than the savings. 320 321extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv 322extendZonkEnv ze@(ZonkEnv { ze_tv_env = tyco_env, ze_id_env = id_env }) vars 323 = ze { ze_tv_env = extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars] 324 , ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] } 325 where 326 (tycovars, ids) = partition isTyCoVar vars 327 328extendIdZonkEnv :: ZonkEnv -> Var -> ZonkEnv 329extendIdZonkEnv ze@(ZonkEnv { ze_id_env = id_env }) id 330 = ze { ze_id_env = extendVarEnv id_env id id } 331 332extendTyZonkEnv :: ZonkEnv -> TyVar -> ZonkEnv 333extendTyZonkEnv ze@(ZonkEnv { ze_tv_env = ty_env }) tv 334 = ze { ze_tv_env = extendVarEnv ty_env tv tv } 335 336setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv 337setZonkType ze flexi = ze { ze_flexi = flexi } 338 339zonkEnvIds :: ZonkEnv -> TypeEnv 340zonkEnvIds (ZonkEnv { ze_id_env = id_env}) 341 = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env] 342 -- It's OK to use nonDetEltsUFM here because we forget the ordering 343 -- immediately by creating a TypeEnv 344 345zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id 346zonkLIdOcc env = onHasSrcSpan (zonkIdOcc env) 347 348zonkIdOcc :: ZonkEnv -> TcId -> Id 349-- Ids defined in this module should be in the envt; 350-- ignore others. (Actually, data constructors are also 351-- not LocalVars, even when locally defined, but that is fine.) 352-- (Also foreign-imported things aren't currently in the ZonkEnv; 353-- that's ok because they don't need zonking.) 354-- 355-- Actually, Template Haskell works in 'chunks' of declarations, and 356-- an earlier chunk won't be in the 'env' that the zonking phase 357-- carries around. Instead it'll be in the tcg_gbl_env, already fully 358-- zonked. There's no point in looking it up there (except for error 359-- checking), and it's not conveniently to hand; hence the simple 360-- 'orElse' case in the LocalVar branch. 361-- 362-- Even without template splices, in module Main, the checking of 363-- 'main' is done as a separate chunk. 364zonkIdOcc (ZonkEnv { ze_id_env = id_env}) id 365 | isLocalVar id = lookupVarEnv id_env id `orElse` 366 id 367 | otherwise = id 368 369zonkIdOccs :: ZonkEnv -> [TcId] -> [Id] 370zonkIdOccs env ids = map (zonkIdOcc env) ids 371 372-- zonkIdBndr is used *after* typechecking to get the Id's type 373-- to its final form. The TyVarEnv give 374zonkIdBndr :: ZonkEnv -> TcId -> TcM Id 375zonkIdBndr env v 376 = do ty' <- zonkTcTypeToTypeX env (idType v) 377 ensureNotLevPoly ty' 378 (text "In the type of binder" <+> quotes (ppr v)) 379 380 return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty')) 381 382zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id] 383zonkIdBndrs env ids = mapM (zonkIdBndr env) ids 384 385zonkTopBndrs :: [TcId] -> TcM [Id] 386zonkTopBndrs ids = initZonkEnv $ \ ze -> zonkIdBndrs ze ids 387 388zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc) 389zonkFieldOcc env (FieldOcc sel lbl) 390 = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel 391zonkFieldOcc _ (XFieldOcc nec) = noExtCon nec 392 393zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var]) 394zonkEvBndrsX = mapAccumLM zonkEvBndrX 395 396zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar) 397-- Works for dictionaries and coercions 398zonkEvBndrX env var 399 = do { var' <- zonkEvBndr env var 400 ; return (extendZonkEnv env [var'], var') } 401 402zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar 403-- Works for dictionaries and coercions 404-- Does not extend the ZonkEnv 405zonkEvBndr env var 406 = do { let var_ty = varType var 407 ; ty <- 408 {-# SCC "zonkEvBndr_zonkTcTypeToType" #-} 409 zonkTcTypeToTypeX env var_ty 410 ; return (setVarType var ty) } 411 412{- 413zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm 414zonkEvVarOcc env v 415 | isCoVar v 416 = EvCoercion <$> zonkCoVarOcc env v 417 | otherwise 418 = return (EvId $ zonkIdOcc env v) 419-} 420 421zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var) 422zonkCoreBndrX env v 423 | isId v = do { v' <- zonkIdBndr env v 424 ; return (extendIdZonkEnv env v', v') } 425 | otherwise = zonkTyBndrX env v 426 427zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var]) 428zonkCoreBndrsX = mapAccumLM zonkCoreBndrX 429 430zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar]) 431zonkTyBndrs tvs = initZonkEnv $ \ze -> zonkTyBndrsX ze tvs 432 433zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar]) 434zonkTyBndrsX = mapAccumLM zonkTyBndrX 435 436zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar) 437-- This guarantees to return a TyVar (not a TcTyVar) 438-- then we add it to the envt, so all occurrences are replaced 439-- 440-- It does not clone: the new TyVar has the sane Name 441-- as the old one. This important when zonking the 442-- TyVarBndrs of a TyCon, whose Names may scope. 443zonkTyBndrX env tv 444 = ASSERT2( isImmutableTyVar tv, ppr tv <+> dcolon <+> ppr (tyVarKind tv) ) 445 do { ki <- zonkTcTypeToTypeX env (tyVarKind tv) 446 -- Internal names tidy up better, for iface files. 447 ; let tv' = mkTyVar (tyVarName tv) ki 448 ; return (extendTyZonkEnv env tv', tv') } 449 450zonkTyVarBinders :: [VarBndr TcTyVar vis] 451 -> TcM (ZonkEnv, [VarBndr TyVar vis]) 452zonkTyVarBinders tvbs = initZonkEnv $ \ ze -> zonkTyVarBindersX ze tvbs 453 454zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis] 455 -> TcM (ZonkEnv, [VarBndr TyVar vis]) 456zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX 457 458zonkTyVarBinderX :: ZonkEnv -> VarBndr TcTyVar vis 459 -> TcM (ZonkEnv, VarBndr TyVar vis) 460-- Takes a TcTyVar and guarantees to return a TyVar 461zonkTyVarBinderX env (Bndr tv vis) 462 = do { (env', tv') <- zonkTyBndrX env tv 463 ; return (env', Bndr tv' vis) } 464 465zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc) 466zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e 467 468zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc) 469zonkTopLExpr e = initZonkEnv $ \ ze -> zonkLExpr ze e 470 471zonkTopDecls :: Bag EvBind 472 -> LHsBinds GhcTcId 473 -> [LRuleDecl GhcTcId] -> [LTcSpecPrag] 474 -> [LForeignDecl GhcTcId] 475 -> TcM (TypeEnv, 476 Bag EvBind, 477 LHsBinds GhcTc, 478 [LForeignDecl GhcTc], 479 [LTcSpecPrag], 480 [LRuleDecl GhcTc]) 481zonkTopDecls ev_binds binds rules imp_specs fords 482 = do { (env1, ev_binds') <- initZonkEnv $ \ ze -> zonkEvBinds ze ev_binds 483 ; (env2, binds') <- zonkRecMonoBinds env1 binds 484 -- Top level is implicitly recursive 485 ; rules' <- zonkRules env2 rules 486 ; specs' <- zonkLTcSpecPrags env2 imp_specs 487 ; fords' <- zonkForeignExports env2 fords 488 ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') } 489 490--------------------------------------------- 491zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId 492 -> TcM (ZonkEnv, HsLocalBinds GhcTc) 493zonkLocalBinds env (EmptyLocalBinds x) 494 = return (env, (EmptyLocalBinds x)) 495 496zonkLocalBinds _ (HsValBinds _ (ValBinds {})) 497 = panic "zonkLocalBinds" -- Not in typechecker output 498 499zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs))) 500 = do { (env1, new_binds) <- go env binds 501 ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) } 502 where 503 go env [] 504 = return (env, []) 505 go env ((r,b):bs) 506 = do { (env1, b') <- zonkRecMonoBinds env b 507 ; (env2, bs') <- go env1 bs 508 ; return (env2, (r,b'):bs') } 509 510zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do 511 new_binds <- mapM (wrapLocM zonk_ip_bind) binds 512 let 513 env1 = extendIdZonkEnvRec env 514 [ n | (dL->L _ (IPBind _ (Right n) _)) <- new_binds] 515 (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds 516 return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds)) 517 where 518 zonk_ip_bind (IPBind x n e) 519 = do n' <- mapIPNameTc (zonkIdBndr env) n 520 e' <- zonkLExpr env e 521 return (IPBind x n' e') 522 zonk_ip_bind (XIPBind nec) = noExtCon nec 523 524zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds nec)) 525 = noExtCon nec 526zonkLocalBinds _ (XHsLocalBindsLR nec) 527 = noExtCon nec 528 529--------------------------------------------- 530zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc) 531zonkRecMonoBinds env binds 532 = fixM (\ ~(_, new_binds) -> do 533 { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds) 534 ; binds' <- zonkMonoBinds env1 binds 535 ; return (env1, binds') }) 536 537--------------------------------------------- 538zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc) 539zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds 540 541zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc) 542zonk_lbind env = wrapLocM (zonk_bind env) 543 544zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc) 545zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss 546 , pat_ext = NPatBindTc fvs ty}) 547 = do { (_env, new_pat) <- zonkPat env pat -- Env already extended 548 ; new_grhss <- zonkGRHSs env zonkLExpr grhss 549 ; new_ty <- zonkTcTypeToTypeX env ty 550 ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss 551 , pat_ext = NPatBindTc fvs new_ty }) } 552 553zonk_bind env (VarBind { var_ext = x 554 , var_id = var, var_rhs = expr, var_inline = inl }) 555 = do { new_var <- zonkIdBndr env var 556 ; new_expr <- zonkLExpr env expr 557 ; return (VarBind { var_ext = x 558 , var_id = new_var 559 , var_rhs = new_expr 560 , var_inline = inl }) } 561 562zonk_bind env bind@(FunBind { fun_id = (dL->L loc var) 563 , fun_matches = ms 564 , fun_co_fn = co_fn }) 565 = do { new_var <- zonkIdBndr env var 566 ; (env1, new_co_fn) <- zonkCoFn env co_fn 567 ; new_ms <- zonkMatchGroup env1 zonkLExpr ms 568 ; return (bind { fun_id = cL loc new_var 569 , fun_matches = new_ms 570 , fun_co_fn = new_co_fn }) } 571 572zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs 573 , abs_ev_binds = ev_binds 574 , abs_exports = exports 575 , abs_binds = val_binds 576 , abs_sig = has_sig }) 577 = ASSERT( all isImmutableTyVar tyvars ) 578 do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars 579 ; (env1, new_evs) <- zonkEvBndrsX env0 evs 580 ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds 581 ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) -> 582 do { let env3 = extendIdZonkEnvRec env2 $ 583 collectHsBindsBinders new_val_binds 584 ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds 585 ; new_exports <- mapM (zonk_export env3) exports 586 ; return (new_val_binds, new_exports) } 587 ; return (AbsBinds { abs_ext = noExtField 588 , abs_tvs = new_tyvars, abs_ev_vars = new_evs 589 , abs_ev_binds = new_ev_binds 590 , abs_exports = new_exports, abs_binds = new_val_bind 591 , abs_sig = has_sig }) } 592 where 593 zonk_val_bind env lbind 594 | has_sig 595 , (dL->L loc bind@(FunBind { fun_id = (dL->L mloc mono_id) 596 , fun_matches = ms 597 , fun_co_fn = co_fn })) <- lbind 598 = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id 599 -- Specifically /not/ zonkIdBndr; we do not 600 -- want to complain about a levity-polymorphic binder 601 ; (env', new_co_fn) <- zonkCoFn env co_fn 602 ; new_ms <- zonkMatchGroup env' zonkLExpr ms 603 ; return $ cL loc $ 604 bind { fun_id = cL mloc new_mono_id 605 , fun_matches = new_ms 606 , fun_co_fn = new_co_fn } } 607 | otherwise 608 = zonk_lbind env lbind -- The normal case 609 610 zonk_export env (ABE{ abe_ext = x 611 , abe_wrap = wrap 612 , abe_poly = poly_id 613 , abe_mono = mono_id 614 , abe_prags = prags }) 615 = do new_poly_id <- zonkIdBndr env poly_id 616 (_, new_wrap) <- zonkCoFn env wrap 617 new_prags <- zonkSpecPrags env prags 618 return (ABE{ abe_ext = x 619 , abe_wrap = new_wrap 620 , abe_poly = new_poly_id 621 , abe_mono = zonkIdOcc env mono_id 622 , abe_prags = new_prags }) 623 zonk_export _ (XABExport nec) = noExtCon nec 624 625zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id) 626 , psb_args = details 627 , psb_def = lpat 628 , psb_dir = dir })) 629 = do { id' <- zonkIdBndr env id 630 ; (env1, lpat') <- zonkPat env lpat 631 ; let details' = zonkPatSynDetails env1 details 632 ; (_env2, dir') <- zonkPatSynDir env1 dir 633 ; return $ PatSynBind x $ 634 bind { psb_id = cL loc id' 635 , psb_args = details' 636 , psb_def = lpat' 637 , psb_dir = dir' } } 638 639zonk_bind _ (PatSynBind _ (XPatSynBind nec)) = noExtCon nec 640zonk_bind _ (XHsBindsLR nec) = noExtCon nec 641 642zonkPatSynDetails :: ZonkEnv 643 -> HsPatSynDetails (Located TcId) 644 -> HsPatSynDetails (Located Id) 645zonkPatSynDetails env (PrefixCon as) 646 = PrefixCon (map (zonkLIdOcc env) as) 647zonkPatSynDetails env (InfixCon a1 a2) 648 = InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2) 649zonkPatSynDetails env (RecCon flds) 650 = RecCon (map (fmap (zonkLIdOcc env)) flds) 651 652zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId 653 -> TcM (ZonkEnv, HsPatSynDir GhcTc) 654zonkPatSynDir env Unidirectional = return (env, Unidirectional) 655zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional) 656zonkPatSynDir env (ExplicitBidirectional mg) = do 657 mg' <- zonkMatchGroup env zonkLExpr mg 658 return (env, ExplicitBidirectional mg') 659 660zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags 661zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod 662zonkSpecPrags env (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags env ps 663 ; return (SpecPrags ps') } 664 665zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag] 666zonkLTcSpecPrags env ps 667 = mapM zonk_prag ps 668 where 669 zonk_prag (dL->L loc (SpecPrag id co_fn inl)) 670 = do { (_, co_fn') <- zonkCoFn env co_fn 671 ; return (cL loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } 672 673{- 674************************************************************************ 675* * 676\subsection[BackSubst-Match-GRHSs]{Match and GRHSs} 677* * 678************************************************************************ 679-} 680 681zonkMatchGroup :: ZonkEnv 682 -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) 683 -> MatchGroup GhcTcId (Located (body GhcTcId)) 684 -> TcM (MatchGroup GhcTc (Located (body GhcTc))) 685zonkMatchGroup env zBody (MG { mg_alts = (dL->L l ms) 686 , mg_ext = MatchGroupTc arg_tys res_ty 687 , mg_origin = origin }) 688 = do { ms' <- mapM (zonkMatch env zBody) ms 689 ; arg_tys' <- zonkTcTypesToTypesX env arg_tys 690 ; res_ty' <- zonkTcTypeToTypeX env res_ty 691 ; return (MG { mg_alts = cL l ms' 692 , mg_ext = MatchGroupTc arg_tys' res_ty' 693 , mg_origin = origin }) } 694zonkMatchGroup _ _ (XMatchGroup nec) = noExtCon nec 695 696zonkMatch :: ZonkEnv 697 -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) 698 -> LMatch GhcTcId (Located (body GhcTcId)) 699 -> TcM (LMatch GhcTc (Located (body GhcTc))) 700zonkMatch env zBody (dL->L loc match@(Match { m_pats = pats 701 , m_grhss = grhss })) 702 = do { (env1, new_pats) <- zonkPats env pats 703 ; new_grhss <- zonkGRHSs env1 zBody grhss 704 ; return (cL loc (match { m_pats = new_pats, m_grhss = new_grhss })) } 705zonkMatch _ _ (dL->L _ (XMatch nec)) = noExtCon nec 706zonkMatch _ _ _ = panic "zonkMatch: Impossible Match" 707 -- due to #15884 708 709------------------------------------------------------------------------- 710zonkGRHSs :: ZonkEnv 711 -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) 712 -> GRHSs GhcTcId (Located (body GhcTcId)) 713 -> TcM (GRHSs GhcTc (Located (body GhcTc))) 714 715zonkGRHSs env zBody (GRHSs x grhss (dL->L l binds)) = do 716 (new_env, new_binds) <- zonkLocalBinds env binds 717 let 718 zonk_grhs (GRHS xx guarded rhs) 719 = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded 720 new_rhs <- zBody env2 rhs 721 return (GRHS xx new_guarded new_rhs) 722 zonk_grhs (XGRHS nec) = noExtCon nec 723 new_grhss <- mapM (wrapLocM zonk_grhs) grhss 724 return (GRHSs x new_grhss (cL l new_binds)) 725zonkGRHSs _ _ (XGRHSs nec) = noExtCon nec 726 727{- 728************************************************************************ 729* * 730\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr} 731* * 732************************************************************************ 733-} 734 735zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc] 736zonkLExpr :: ZonkEnv -> LHsExpr GhcTcId -> TcM (LHsExpr GhcTc) 737zonkExpr :: ZonkEnv -> HsExpr GhcTcId -> TcM (HsExpr GhcTc) 738 739zonkLExprs env exprs = mapM (zonkLExpr env) exprs 740zonkLExpr env expr = wrapLocM (zonkExpr env) expr 741 742zonkExpr env (HsVar x (dL->L l id)) 743 = ASSERT2( isNothing (isDataConId_maybe id), ppr id ) 744 return (HsVar x (cL l (zonkIdOcc env id))) 745 746zonkExpr _ e@(HsConLikeOut {}) = return e 747 748zonkExpr _ (HsIPVar x id) 749 = return (HsIPVar x id) 750 751zonkExpr _ e@HsOverLabel{} = return e 752 753zonkExpr env (HsLit x (HsRat e f ty)) 754 = do new_ty <- zonkTcTypeToTypeX env ty 755 return (HsLit x (HsRat e f new_ty)) 756 757zonkExpr _ (HsLit x lit) 758 = return (HsLit x lit) 759 760zonkExpr env (HsOverLit x lit) 761 = do { lit' <- zonkOverLit env lit 762 ; return (HsOverLit x lit') } 763 764zonkExpr env (HsLam x matches) 765 = do new_matches <- zonkMatchGroup env zonkLExpr matches 766 return (HsLam x new_matches) 767 768zonkExpr env (HsLamCase x matches) 769 = do new_matches <- zonkMatchGroup env zonkLExpr matches 770 return (HsLamCase x new_matches) 771 772zonkExpr env (HsApp x e1 e2) 773 = do new_e1 <- zonkLExpr env e1 774 new_e2 <- zonkLExpr env e2 775 return (HsApp x new_e1 new_e2) 776 777zonkExpr env (HsAppType x e t) 778 = do new_e <- zonkLExpr env e 779 return (HsAppType x new_e t) 780 -- NB: the type is an HsType; can't zonk that! 781 782zonkExpr _ e@(HsRnBracketOut _ _ _) 783 = pprPanic "zonkExpr: HsRnBracketOut" (ppr e) 784 785zonkExpr env (HsTcBracketOut x body bs) 786 = do bs' <- mapM zonk_b bs 787 return (HsTcBracketOut x body bs') 788 where 789 zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e 790 return (PendingTcSplice n e') 791 792zonkExpr env (HsSpliceE _ (HsSplicedT s)) = 793 runTopSplice s >>= zonkExpr env 794 795zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen 796 return (HsSpliceE x s) 797 798zonkExpr env (OpApp fixity e1 op e2) 799 = do new_e1 <- zonkLExpr env e1 800 new_op <- zonkLExpr env op 801 new_e2 <- zonkLExpr env e2 802 return (OpApp fixity new_e1 new_op new_e2) 803 804zonkExpr env (NegApp x expr op) 805 = do (env', new_op) <- zonkSyntaxExpr env op 806 new_expr <- zonkLExpr env' expr 807 return (NegApp x new_expr new_op) 808 809zonkExpr env (HsPar x e) 810 = do new_e <- zonkLExpr env e 811 return (HsPar x new_e) 812 813zonkExpr env (SectionL x expr op) 814 = do new_expr <- zonkLExpr env expr 815 new_op <- zonkLExpr env op 816 return (SectionL x new_expr new_op) 817 818zonkExpr env (SectionR x op expr) 819 = do new_op <- zonkLExpr env op 820 new_expr <- zonkLExpr env expr 821 return (SectionR x new_op new_expr) 822 823zonkExpr env (ExplicitTuple x tup_args boxed) 824 = do { new_tup_args <- mapM zonk_tup_arg tup_args 825 ; return (ExplicitTuple x new_tup_args boxed) } 826 where 827 zonk_tup_arg (dL->L l (Present x e)) = do { e' <- zonkLExpr env e 828 ; return (cL l (Present x e')) } 829 zonk_tup_arg (dL->L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t 830 ; return (cL l (Missing t')) } 831 zonk_tup_arg (dL->L _ (XTupArg nec)) = noExtCon nec 832 zonk_tup_arg _ = panic "zonk_tup_arg: Impossible Match" 833 -- due to #15884 834 835 836zonkExpr env (ExplicitSum args alt arity expr) 837 = do new_args <- mapM (zonkTcTypeToTypeX env) args 838 new_expr <- zonkLExpr env expr 839 return (ExplicitSum new_args alt arity new_expr) 840 841zonkExpr env (HsCase x expr ms) 842 = do new_expr <- zonkLExpr env expr 843 new_ms <- zonkMatchGroup env zonkLExpr ms 844 return (HsCase x new_expr new_ms) 845 846zonkExpr env (HsIf x Nothing e1 e2 e3) 847 = do new_e1 <- zonkLExpr env e1 848 new_e2 <- zonkLExpr env e2 849 new_e3 <- zonkLExpr env e3 850 return (HsIf x Nothing new_e1 new_e2 new_e3) 851 852zonkExpr env (HsIf x (Just fun) e1 e2 e3) 853 = do (env1, new_fun) <- zonkSyntaxExpr env fun 854 new_e1 <- zonkLExpr env1 e1 855 new_e2 <- zonkLExpr env1 e2 856 new_e3 <- zonkLExpr env1 e3 857 return (HsIf x (Just new_fun) new_e1 new_e2 new_e3) 858 859zonkExpr env (HsMultiIf ty alts) 860 = do { alts' <- mapM (wrapLocM zonk_alt) alts 861 ; ty' <- zonkTcTypeToTypeX env ty 862 ; return $ HsMultiIf ty' alts' } 863 where zonk_alt (GRHS x guard expr) 864 = do { (env', guard') <- zonkStmts env zonkLExpr guard 865 ; expr' <- zonkLExpr env' expr 866 ; return $ GRHS x guard' expr' } 867 zonk_alt (XGRHS nec) = noExtCon nec 868 869zonkExpr env (HsLet x (dL->L l binds) expr) 870 = do (new_env, new_binds) <- zonkLocalBinds env binds 871 new_expr <- zonkLExpr new_env expr 872 return (HsLet x (cL l new_binds) new_expr) 873 874zonkExpr env (HsDo ty do_or_lc (dL->L l stmts)) 875 = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts 876 new_ty <- zonkTcTypeToTypeX env ty 877 return (HsDo new_ty do_or_lc (cL l new_stmts)) 878 879zonkExpr env (ExplicitList ty wit exprs) 880 = do (env1, new_wit) <- zonkWit env wit 881 new_ty <- zonkTcTypeToTypeX env1 ty 882 new_exprs <- zonkLExprs env1 exprs 883 return (ExplicitList new_ty new_wit new_exprs) 884 where zonkWit env Nothing = return (env, Nothing) 885 zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln 886 887zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds }) 888 = do { new_con_expr <- zonkExpr env (rcon_con_expr ext) 889 ; new_rbinds <- zonkRecFields env rbinds 890 ; return (expr { rcon_ext = ext { rcon_con_expr = new_con_expr } 891 , rcon_flds = new_rbinds }) } 892 893zonkExpr env (RecordUpd { rupd_flds = rbinds 894 , rupd_expr = expr 895 , rupd_ext = RecordUpdTc 896 { rupd_cons = cons, rupd_in_tys = in_tys 897 , rupd_out_tys = out_tys, rupd_wrap = req_wrap }}) 898 = do { new_expr <- zonkLExpr env expr 899 ; new_in_tys <- mapM (zonkTcTypeToTypeX env) in_tys 900 ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys 901 ; new_rbinds <- zonkRecUpdFields env rbinds 902 ; (_, new_recwrap) <- zonkCoFn env req_wrap 903 ; return (RecordUpd { rupd_expr = new_expr, rupd_flds = new_rbinds 904 , rupd_ext = RecordUpdTc 905 { rupd_cons = cons, rupd_in_tys = new_in_tys 906 , rupd_out_tys = new_out_tys 907 , rupd_wrap = new_recwrap }}) } 908 909zonkExpr env (ExprWithTySig _ e ty) 910 = do { e' <- zonkLExpr env e 911 ; return (ExprWithTySig noExtField e' ty) } 912 913zonkExpr env (ArithSeq expr wit info) 914 = do (env1, new_wit) <- zonkWit env wit 915 new_expr <- zonkExpr env expr 916 new_info <- zonkArithSeq env1 info 917 return (ArithSeq new_expr new_wit new_info) 918 where zonkWit env Nothing = return (env, Nothing) 919 zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln 920 921zonkExpr env (HsSCC x src lbl expr) 922 = do new_expr <- zonkLExpr env expr 923 return (HsSCC x src lbl new_expr) 924 925zonkExpr env (HsTickPragma x src info srcInfo expr) 926 = do new_expr <- zonkLExpr env expr 927 return (HsTickPragma x src info srcInfo new_expr) 928 929-- hdaume: core annotations 930zonkExpr env (HsCoreAnn x src lbl expr) 931 = do new_expr <- zonkLExpr env expr 932 return (HsCoreAnn x src lbl new_expr) 933 934-- arrow notation extensions 935zonkExpr env (HsProc x pat body) 936 = do { (env1, new_pat) <- zonkPat env pat 937 ; new_body <- zonkCmdTop env1 body 938 ; return (HsProc x new_pat new_body) } 939 940-- StaticPointers extension 941zonkExpr env (HsStatic fvs expr) 942 = HsStatic fvs <$> zonkLExpr env expr 943 944zonkExpr env (HsWrap x co_fn expr) 945 = do (env1, new_co_fn) <- zonkCoFn env co_fn 946 new_expr <- zonkExpr env1 expr 947 return (HsWrap x new_co_fn new_expr) 948 949zonkExpr _ e@(HsUnboundVar {}) = return e 950 951zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr) 952 953------------------------------------------------------------------------- 954{- 955Note [Skolems in zonkSyntaxExpr] 956~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 957Consider rebindable syntax with something like 958 959 (>>=) :: (forall x. blah) -> (forall y. blah') -> blah'' 960 961The x and y become skolems that are in scope when type-checking the 962arguments to the bind. This means that we must extend the ZonkEnv with 963these skolems when zonking the arguments to the bind. But the skolems 964are different between the two arguments, and so we should theoretically 965carry around different environments to use for the different arguments. 966 967However, this becomes a logistical nightmare, especially in dealing with 968the more exotic Stmt forms. So, we simplify by making the critical 969assumption that the uniques of the skolems are different. (This assumption 970is justified by the use of newUnique in TcMType.instSkolTyCoVarX.) 971Now, we can safely just extend one environment. 972-} 973 974-- See Note [Skolems in zonkSyntaxExpr] 975zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTcId 976 -> TcM (ZonkEnv, SyntaxExpr GhcTc) 977zonkSyntaxExpr env (SyntaxExpr { syn_expr = expr 978 , syn_arg_wraps = arg_wraps 979 , syn_res_wrap = res_wrap }) 980 = do { (env0, res_wrap') <- zonkCoFn env res_wrap 981 ; expr' <- zonkExpr env0 expr 982 ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps 983 ; return (env1, SyntaxExpr { syn_expr = expr' 984 , syn_arg_wraps = arg_wraps' 985 , syn_res_wrap = res_wrap' }) } 986 987------------------------------------------------------------------------- 988 989zonkLCmd :: ZonkEnv -> LHsCmd GhcTcId -> TcM (LHsCmd GhcTc) 990zonkCmd :: ZonkEnv -> HsCmd GhcTcId -> TcM (HsCmd GhcTc) 991 992zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd 993 994zonkCmd env (HsCmdWrap x w cmd) 995 = do { (env1, w') <- zonkCoFn env w 996 ; cmd' <- zonkCmd env1 cmd 997 ; return (HsCmdWrap x w' cmd') } 998zonkCmd env (HsCmdArrApp ty e1 e2 ho rl) 999 = do new_e1 <- zonkLExpr env e1 1000 new_e2 <- zonkLExpr env e2 1001 new_ty <- zonkTcTypeToTypeX env ty 1002 return (HsCmdArrApp new_ty new_e1 new_e2 ho rl) 1003 1004zonkCmd env (HsCmdArrForm x op f fixity args) 1005 = do new_op <- zonkLExpr env op 1006 new_args <- mapM (zonkCmdTop env) args 1007 return (HsCmdArrForm x new_op f fixity new_args) 1008 1009zonkCmd env (HsCmdApp x c e) 1010 = do new_c <- zonkLCmd env c 1011 new_e <- zonkLExpr env e 1012 return (HsCmdApp x new_c new_e) 1013 1014zonkCmd env (HsCmdLam x matches) 1015 = do new_matches <- zonkMatchGroup env zonkLCmd matches 1016 return (HsCmdLam x new_matches) 1017 1018zonkCmd env (HsCmdPar x c) 1019 = do new_c <- zonkLCmd env c 1020 return (HsCmdPar x new_c) 1021 1022zonkCmd env (HsCmdCase x expr ms) 1023 = do new_expr <- zonkLExpr env expr 1024 new_ms <- zonkMatchGroup env zonkLCmd ms 1025 return (HsCmdCase x new_expr new_ms) 1026 1027zonkCmd env (HsCmdIf x eCond ePred cThen cElse) 1028 = do { (env1, new_eCond) <- zonkWit env eCond 1029 ; new_ePred <- zonkLExpr env1 ePred 1030 ; new_cThen <- zonkLCmd env1 cThen 1031 ; new_cElse <- zonkLCmd env1 cElse 1032 ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } 1033 where 1034 zonkWit env Nothing = return (env, Nothing) 1035 zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w 1036 1037zonkCmd env (HsCmdLet x (dL->L l binds) cmd) 1038 = do (new_env, new_binds) <- zonkLocalBinds env binds 1039 new_cmd <- zonkLCmd new_env cmd 1040 return (HsCmdLet x (cL l new_binds) new_cmd) 1041 1042zonkCmd env (HsCmdDo ty (dL->L l stmts)) 1043 = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts 1044 new_ty <- zonkTcTypeToTypeX env ty 1045 return (HsCmdDo new_ty (cL l new_stmts)) 1046 1047zonkCmd _ (XCmd nec) = noExtCon nec 1048 1049 1050 1051zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTc) 1052zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd 1053 1054zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTcId -> TcM (HsCmdTop GhcTc) 1055zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) 1056 = do new_cmd <- zonkLCmd env cmd 1057 new_stack_tys <- zonkTcTypeToTypeX env stack_tys 1058 new_ty <- zonkTcTypeToTypeX env ty 1059 new_ids <- mapSndM (zonkExpr env) ids 1060 1061 MASSERT( isLiftedTypeKind (tcTypeKind new_stack_tys) ) 1062 -- desugarer assumes that this is not levity polymorphic... 1063 -- but indeed it should always be lifted due to the typing 1064 -- rules for arrows 1065 1066 return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd) 1067zonk_cmd_top _ (XCmdTop nec) = noExtCon nec 1068 1069------------------------------------------------------------------------- 1070zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) 1071zonkCoFn env WpHole = return (env, WpHole) 1072zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 1073 ; (env2, c2') <- zonkCoFn env1 c2 1074 ; return (env2, WpCompose c1' c2') } 1075zonkCoFn env (WpFun c1 c2 t1 d) = do { (env1, c1') <- zonkCoFn env c1 1076 ; (env2, c2') <- zonkCoFn env1 c2 1077 ; t1' <- zonkTcTypeToTypeX env2 t1 1078 ; return (env2, WpFun c1' c2' t1' d) } 1079zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co 1080 ; return (env, WpCast co') } 1081zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev 1082 ; return (env', WpEvLam ev') } 1083zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg 1084 ; return (env, WpEvApp arg') } 1085zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv ) 1086 do { (env', tv') <- zonkTyBndrX env tv 1087 ; return (env', WpTyLam tv') } 1088zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToTypeX env ty 1089 ; return (env, WpTyApp ty') } 1090zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs 1091 ; return (env1, WpLet bs') } 1092 1093------------------------------------------------------------------------- 1094zonkOverLit :: ZonkEnv -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc) 1095zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e }) 1096 = do { ty' <- zonkTcTypeToTypeX env ty 1097 ; e' <- zonkExpr env e 1098 ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) } 1099 1100zonkOverLit _ (XOverLit nec) = noExtCon nec 1101 1102------------------------------------------------------------------------- 1103zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> TcM (ArithSeqInfo GhcTc) 1104 1105zonkArithSeq env (From e) 1106 = do new_e <- zonkLExpr env e 1107 return (From new_e) 1108 1109zonkArithSeq env (FromThen e1 e2) 1110 = do new_e1 <- zonkLExpr env e1 1111 new_e2 <- zonkLExpr env e2 1112 return (FromThen new_e1 new_e2) 1113 1114zonkArithSeq env (FromTo e1 e2) 1115 = do new_e1 <- zonkLExpr env e1 1116 new_e2 <- zonkLExpr env e2 1117 return (FromTo new_e1 new_e2) 1118 1119zonkArithSeq env (FromThenTo e1 e2 e3) 1120 = do new_e1 <- zonkLExpr env e1 1121 new_e2 <- zonkLExpr env e2 1122 new_e3 <- zonkLExpr env e3 1123 return (FromThenTo new_e1 new_e2 new_e3) 1124 1125 1126------------------------------------------------------------------------- 1127zonkStmts :: ZonkEnv 1128 -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) 1129 -> [LStmt GhcTcId (Located (body GhcTcId))] 1130 -> TcM (ZonkEnv, [LStmt GhcTc (Located (body GhcTc))]) 1131zonkStmts env _ [] = return (env, []) 1132zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s 1133 ; (env2, ss') <- zonkStmts env1 zBody ss 1134 ; return (env2, s' : ss') } 1135 1136zonkStmt :: ZonkEnv 1137 -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) 1138 -> Stmt GhcTcId (Located (body GhcTcId)) 1139 -> TcM (ZonkEnv, Stmt GhcTc (Located (body GhcTc))) 1140zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op) 1141 = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op 1142 ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty 1143 ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs 1144 ; let new_binders = [b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs 1145 , b <- bs] 1146 env2 = extendIdZonkEnvRec env1 new_binders 1147 ; new_mzip <- zonkExpr env2 mzip_op 1148 ; return (env2 1149 , ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)} 1150 where 1151 zonk_branch env1 (ParStmtBlock x stmts bndrs return_op) 1152 = do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts 1153 ; (env3, new_return) <- zonkSyntaxExpr env2 return_op 1154 ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs) 1155 new_return) } 1156 zonk_branch _ (XParStmtBlock nec) = noExtCon nec 1157 1158zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs 1159 , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id 1160 , recS_bind_fn = bind_id 1161 , recS_ext = 1162 RecStmtTc { recS_bind_ty = bind_ty 1163 , recS_later_rets = later_rets 1164 , recS_rec_rets = rec_rets 1165 , recS_ret_ty = ret_ty} }) 1166 = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id 1167 ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id 1168 ; (env3, new_ret_id) <- zonkSyntaxExpr env2 ret_id 1169 ; new_bind_ty <- zonkTcTypeToTypeX env3 bind_ty 1170 ; new_rvs <- zonkIdBndrs env3 rvs 1171 ; new_lvs <- zonkIdBndrs env3 lvs 1172 ; new_ret_ty <- zonkTcTypeToTypeX env3 ret_ty 1173 ; let env4 = extendIdZonkEnvRec env3 new_rvs 1174 ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts 1175 -- Zonk the ret-expressions in an envt that 1176 -- has the polymorphic bindings in the envt 1177 ; new_later_rets <- mapM (zonkExpr env5) later_rets 1178 ; new_rec_rets <- mapM (zonkExpr env5) rec_rets 1179 ; return (extendIdZonkEnvRec env3 new_lvs, -- Only the lvs are needed 1180 RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs 1181 , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id 1182 , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id 1183 , recS_ext = RecStmtTc 1184 { recS_bind_ty = new_bind_ty 1185 , recS_later_rets = new_later_rets 1186 , recS_rec_rets = new_rec_rets 1187 , recS_ret_ty = new_ret_ty } }) } 1188 1189zonkStmt env zBody (BodyStmt ty body then_op guard_op) 1190 = do (env1, new_then_op) <- zonkSyntaxExpr env then_op 1191 (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op 1192 new_body <- zBody env2 body 1193 new_ty <- zonkTcTypeToTypeX env2 ty 1194 return (env2, BodyStmt new_ty new_body new_then_op new_guard_op) 1195 1196zonkStmt env zBody (LastStmt x body noret ret_op) 1197 = do (env1, new_ret) <- zonkSyntaxExpr env ret_op 1198 new_body <- zBody env1 body 1199 return (env, LastStmt x new_body noret new_ret) 1200 1201zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap 1202 , trS_by = by, trS_form = form, trS_using = using 1203 , trS_ret = return_op, trS_bind = bind_op 1204 , trS_ext = bind_arg_ty 1205 , trS_fmap = liftM_op }) 1206 = do { 1207 ; (env1, bind_op') <- zonkSyntaxExpr env bind_op 1208 ; bind_arg_ty' <- zonkTcTypeToTypeX env1 bind_arg_ty 1209 ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts 1210 ; by' <- fmapMaybeM (zonkLExpr env2) by 1211 ; using' <- zonkLExpr env2 using 1212 1213 ; (env3, return_op') <- zonkSyntaxExpr env2 return_op 1214 ; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap 1215 ; liftM_op' <- zonkExpr env3 liftM_op 1216 ; let env3' = extendIdZonkEnvRec env3 (map snd binderMap') 1217 ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' 1218 , trS_by = by', trS_form = form, trS_using = using' 1219 , trS_ret = return_op', trS_bind = bind_op' 1220 , trS_ext = bind_arg_ty' 1221 , trS_fmap = liftM_op' }) } 1222 where 1223 zonkBinderMapEntry env (oldBinder, newBinder) = do 1224 let oldBinder' = zonkIdOcc env oldBinder 1225 newBinder' <- zonkIdBndr env newBinder 1226 return (oldBinder', newBinder') 1227 1228zonkStmt env _ (LetStmt x (dL->L l binds)) 1229 = do (env1, new_binds) <- zonkLocalBinds env binds 1230 return (env1, LetStmt x (cL l new_binds)) 1231 1232zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op) 1233 = do { (env1, new_bind) <- zonkSyntaxExpr env bind_op 1234 ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty 1235 ; new_body <- zBody env1 body 1236 ; (env2, new_pat) <- zonkPat env1 pat 1237 ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op 1238 ; return ( env2 1239 , BindStmt new_bind_ty new_pat new_body new_bind new_fail) } 1240 1241-- Scopes: join > ops (in reverse order) > pats (in forward order) 1242-- > rest of stmts 1243zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join) 1244 = do { (env1, new_mb_join) <- zonk_join env mb_join 1245 ; (env2, new_args) <- zonk_args env1 args 1246 ; new_body_ty <- zonkTcTypeToTypeX env2 body_ty 1247 ; return ( env2 1248 , ApplicativeStmt new_body_ty new_args new_mb_join) } 1249 where 1250 zonk_join env Nothing = return (env, Nothing) 1251 zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j 1252 1253 get_pat (_, ApplicativeArgOne _ pat _ _ _) = pat 1254 get_pat (_, ApplicativeArgMany _ _ _ pat) = pat 1255 get_pat (_, XApplicativeArg nec) = noExtCon nec 1256 1257 replace_pat pat (op, ApplicativeArgOne x _ a isBody fail_op) 1258 = (op, ApplicativeArgOne x pat a isBody fail_op) 1259 replace_pat pat (op, ApplicativeArgMany x a b _) 1260 = (op, ApplicativeArgMany x a b pat) 1261 replace_pat _ (_, XApplicativeArg nec) = noExtCon nec 1262 1263 zonk_args env args 1264 = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args) 1265 ; (env2, new_pats) <- zonkPats env1 (map get_pat args) 1266 ; return (env2, zipWith replace_pat new_pats (reverse new_args_rev)) } 1267 1268 -- these need to go backward, because if any operators are higher-rank, 1269 -- later operators may introduce skolems that are in scope for earlier 1270 -- arguments 1271 zonk_args_rev env ((op, arg) : args) 1272 = do { (env1, new_op) <- zonkSyntaxExpr env op 1273 ; new_arg <- zonk_arg env1 arg 1274 ; (env2, new_args) <- zonk_args_rev env1 args 1275 ; return (env2, (new_op, new_arg) : new_args) } 1276 zonk_args_rev env [] = return (env, []) 1277 1278 zonk_arg env (ApplicativeArgOne x pat expr isBody fail_op) 1279 = do { new_expr <- zonkLExpr env expr 1280 ; (_, new_fail) <- zonkSyntaxExpr env fail_op 1281 ; return (ApplicativeArgOne x pat new_expr isBody new_fail) } 1282 zonk_arg env (ApplicativeArgMany x stmts ret pat) 1283 = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts 1284 ; new_ret <- zonkExpr env1 ret 1285 ; return (ApplicativeArgMany x new_stmts new_ret pat) } 1286 zonk_arg _ (XApplicativeArg nec) = noExtCon nec 1287 1288zonkStmt _ _ (XStmtLR nec) = noExtCon nec 1289 1290------------------------------------------------------------------------- 1291zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId) 1292zonkRecFields env (HsRecFields flds dd) 1293 = do { flds' <- mapM zonk_rbind flds 1294 ; return (HsRecFields flds' dd) } 1295 where 1296 zonk_rbind (dL->L l fld) 1297 = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld) 1298 ; new_expr <- zonkLExpr env (hsRecFieldArg fld) 1299 ; return (cL l (fld { hsRecFieldLbl = new_id 1300 , hsRecFieldArg = new_expr })) } 1301 1302zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTcId] 1303 -> TcM [LHsRecUpdField GhcTcId] 1304zonkRecUpdFields env = mapM zonk_rbind 1305 where 1306 zonk_rbind (dL->L l fld) 1307 = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld) 1308 ; new_expr <- zonkLExpr env (hsRecFieldArg fld) 1309 ; return (cL l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id 1310 , hsRecFieldArg = new_expr })) } 1311 1312------------------------------------------------------------------------- 1313mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a 1314 -> TcM (Either (Located HsIPName) b) 1315mapIPNameTc _ (Left x) = return (Left x) 1316mapIPNameTc f (Right x) = do r <- f x 1317 return (Right r) 1318 1319{- 1320************************************************************************ 1321* * 1322\subsection[BackSubst-Pats]{Patterns} 1323* * 1324************************************************************************ 1325-} 1326 1327zonkPat :: ZonkEnv -> OutPat GhcTcId -> TcM (ZonkEnv, OutPat GhcTc) 1328-- Extend the environment as we go, because it's possible for one 1329-- pattern to bind something that is used in another (inside or 1330-- to the right) 1331zonkPat env pat = wrapLocSndM (zonk_pat env) pat 1332 1333zonk_pat :: ZonkEnv -> Pat GhcTcId -> TcM (ZonkEnv, Pat GhcTc) 1334zonk_pat env (ParPat x p) 1335 = do { (env', p') <- zonkPat env p 1336 ; return (env', ParPat x p') } 1337 1338zonk_pat env (WildPat ty) 1339 = do { ty' <- zonkTcTypeToTypeX env ty 1340 ; ensureNotLevPoly ty' 1341 (text "In a wildcard pattern") 1342 ; return (env, WildPat ty') } 1343 1344zonk_pat env (VarPat x (dL->L l v)) 1345 = do { v' <- zonkIdBndr env v 1346 ; return (extendIdZonkEnv env v', VarPat x (cL l v')) } 1347 1348zonk_pat env (LazyPat x pat) 1349 = do { (env', pat') <- zonkPat env pat 1350 ; return (env', LazyPat x pat') } 1351 1352zonk_pat env (BangPat x pat) 1353 = do { (env', pat') <- zonkPat env pat 1354 ; return (env', BangPat x pat') } 1355 1356zonk_pat env (AsPat x (dL->L loc v) pat) 1357 = do { v' <- zonkIdBndr env v 1358 ; (env', pat') <- zonkPat (extendIdZonkEnv env v') pat 1359 ; return (env', AsPat x (cL loc v') pat') } 1360 1361zonk_pat env (ViewPat ty expr pat) 1362 = do { expr' <- zonkLExpr env expr 1363 ; (env', pat') <- zonkPat env pat 1364 ; ty' <- zonkTcTypeToTypeX env ty 1365 ; return (env', ViewPat ty' expr' pat') } 1366 1367zonk_pat env (ListPat (ListPatTc ty Nothing) pats) 1368 = do { ty' <- zonkTcTypeToTypeX env ty 1369 ; (env', pats') <- zonkPats env pats 1370 ; return (env', ListPat (ListPatTc ty' Nothing) pats') } 1371 1372zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats) 1373 = do { (env', wit') <- zonkSyntaxExpr env wit 1374 ; ty2' <- zonkTcTypeToTypeX env' ty2 1375 ; ty' <- zonkTcTypeToTypeX env' ty 1376 ; (env'', pats') <- zonkPats env' pats 1377 ; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) pats') } 1378 1379zonk_pat env (TuplePat tys pats boxed) 1380 = do { tys' <- mapM (zonkTcTypeToTypeX env) tys 1381 ; (env', pats') <- zonkPats env pats 1382 ; return (env', TuplePat tys' pats' boxed) } 1383 1384zonk_pat env (SumPat tys pat alt arity ) 1385 = do { tys' <- mapM (zonkTcTypeToTypeX env) tys 1386 ; (env', pat') <- zonkPat env pat 1387 ; return (env', SumPat tys' pat' alt arity) } 1388 1389zonk_pat env p@(ConPatOut { pat_arg_tys = tys 1390 , pat_tvs = tyvars 1391 , pat_dicts = evs 1392 , pat_binds = binds 1393 , pat_args = args 1394 , pat_wrap = wrapper 1395 , pat_con = (dL->L _ con) }) 1396 = ASSERT( all isImmutableTyVar tyvars ) 1397 do { new_tys <- mapM (zonkTcTypeToTypeX env) tys 1398 1399 -- an unboxed tuple pattern (but only an unboxed tuple pattern) 1400 -- might have levity-polymorphic arguments. Check for this badness. 1401 ; case con of 1402 RealDataCon dc 1403 | isUnboxedTupleTyCon (dataConTyCon dc) 1404 -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys) 1405 _ -> return () 1406 1407 ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars 1408 -- Must zonk the existential variables, because their 1409 -- /kind/ need potential zonking. 1410 -- cf typecheck/should_compile/tc221.hs 1411 ; (env1, new_evs) <- zonkEvBndrsX env0 evs 1412 ; (env2, new_binds) <- zonkTcEvBinds env1 binds 1413 ; (env3, new_wrapper) <- zonkCoFn env2 wrapper 1414 ; (env', new_args) <- zonkConStuff env3 args 1415 ; return (env', p { pat_arg_tys = new_tys, 1416 pat_tvs = new_tyvars, 1417 pat_dicts = new_evs, 1418 pat_binds = new_binds, 1419 pat_args = new_args, 1420 pat_wrap = new_wrapper}) } 1421 where 1422 doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p 1423 1424zonk_pat env (LitPat x lit) = return (env, LitPat x lit) 1425 1426zonk_pat env (SigPat ty pat hs_ty) 1427 = do { ty' <- zonkTcTypeToTypeX env ty 1428 ; (env', pat') <- zonkPat env pat 1429 ; return (env', SigPat ty' pat' hs_ty) } 1430 1431zonk_pat env (NPat ty (dL->L l lit) mb_neg eq_expr) 1432 = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr 1433 ; (env2, mb_neg') <- case mb_neg of 1434 Nothing -> return (env1, Nothing) 1435 Just n -> second Just <$> zonkSyntaxExpr env1 n 1436 1437 ; lit' <- zonkOverLit env2 lit 1438 ; ty' <- zonkTcTypeToTypeX env2 ty 1439 ; return (env2, NPat ty' (cL l lit') mb_neg' eq_expr') } 1440 1441zonk_pat env (NPlusKPat ty (dL->L loc n) (dL->L l lit1) lit2 e1 e2) 1442 = do { (env1, e1') <- zonkSyntaxExpr env e1 1443 ; (env2, e2') <- zonkSyntaxExpr env1 e2 1444 ; n' <- zonkIdBndr env2 n 1445 ; lit1' <- zonkOverLit env2 lit1 1446 ; lit2' <- zonkOverLit env2 lit2 1447 ; ty' <- zonkTcTypeToTypeX env2 ty 1448 ; return (extendIdZonkEnv env2 n', 1449 NPlusKPat ty' (cL loc n') (cL l lit1') lit2' e1' e2') } 1450 1451zonk_pat env (CoPat x co_fn pat ty) 1452 = do { (env', co_fn') <- zonkCoFn env co_fn 1453 ; (env'', pat') <- zonkPat env' (noLoc pat) 1454 ; ty' <- zonkTcTypeToTypeX env'' ty 1455 ; return (env'', CoPat x co_fn' (unLoc pat') ty') } 1456 1457zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat) 1458 1459--------------------------- 1460zonkConStuff :: ZonkEnv 1461 -> HsConDetails (OutPat GhcTcId) (HsRecFields id (OutPat GhcTcId)) 1462 -> TcM (ZonkEnv, 1463 HsConDetails (OutPat GhcTc) (HsRecFields id (OutPat GhcTc))) 1464zonkConStuff env (PrefixCon pats) 1465 = do { (env', pats') <- zonkPats env pats 1466 ; return (env', PrefixCon pats') } 1467 1468zonkConStuff env (InfixCon p1 p2) 1469 = do { (env1, p1') <- zonkPat env p1 1470 ; (env', p2') <- zonkPat env1 p2 1471 ; return (env', InfixCon p1' p2') } 1472 1473zonkConStuff env (RecCon (HsRecFields rpats dd)) 1474 = do { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats) 1475 ; let rpats' = zipWith (\(dL->L l rp) p' -> 1476 cL l (rp { hsRecFieldArg = p' })) 1477 rpats pats' 1478 ; return (env', RecCon (HsRecFields rpats' dd)) } 1479 -- Field selectors have declared types; hence no zonking 1480 1481--------------------------- 1482zonkPats :: ZonkEnv -> [OutPat GhcTcId] -> TcM (ZonkEnv, [OutPat GhcTc]) 1483zonkPats env [] = return (env, []) 1484zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat 1485 ; (env', pats') <- zonkPats env1 pats 1486 ; return (env', pat':pats') } 1487 1488{- 1489************************************************************************ 1490* * 1491\subsection[BackSubst-Foreign]{Foreign exports} 1492* * 1493************************************************************************ 1494-} 1495 1496zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTcId] 1497 -> TcM [LForeignDecl GhcTc] 1498zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls 1499 1500zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTcId -> TcM (ForeignDecl GhcTc) 1501zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co 1502 , fd_fe = spec }) 1503 = return (ForeignExport { fd_name = zonkLIdOcc env i 1504 , fd_sig_ty = undefined, fd_e_ext = co 1505 , fd_fe = spec }) 1506zonkForeignExport _ for_imp 1507 = return for_imp -- Foreign imports don't need zonking 1508 1509zonkRules :: ZonkEnv -> [LRuleDecl GhcTcId] -> TcM [LRuleDecl GhcTc] 1510zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs 1511 1512zonkRule :: ZonkEnv -> RuleDecl GhcTcId -> TcM (RuleDecl GhcTc) 1513zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-} 1514 , rd_lhs = lhs 1515 , rd_rhs = rhs }) 1516 = do { (env_inside, new_tm_bndrs) <- mapAccumLM zonk_tm_bndr env tm_bndrs 1517 1518 ; let env_lhs = setZonkType env_inside SkolemiseFlexi 1519 -- See Note [Zonking the LHS of a RULE] 1520 1521 ; new_lhs <- zonkLExpr env_lhs lhs 1522 ; new_rhs <- zonkLExpr env_inside rhs 1523 1524 ; return $ rule { rd_tmvs = new_tm_bndrs 1525 , rd_lhs = new_lhs 1526 , rd_rhs = new_rhs } } 1527 where 1528 zonk_tm_bndr env (dL->L l (RuleBndr x (dL->L loc v))) 1529 = do { (env', v') <- zonk_it env v 1530 ; return (env', cL l (RuleBndr x (cL loc v'))) } 1531 zonk_tm_bndr _ (dL->L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig" 1532 zonk_tm_bndr _ (dL->L _ (XRuleBndr nec)) = noExtCon nec 1533 zonk_tm_bndr _ _ = panic "zonk_tm_bndr: Impossible Match" 1534 -- due to #15884 1535 1536 zonk_it env v 1537 | isId v = do { v' <- zonkIdBndr env v 1538 ; return (extendIdZonkEnvRec env [v'], v') } 1539 | otherwise = ASSERT( isImmutableTyVar v) 1540 zonkTyBndrX env v 1541 -- DV: used to be return (env,v) but that is plain 1542 -- wrong because we may need to go inside the kind 1543 -- of v and zonk there! 1544zonkRule _ (XRuleDecl nec) = noExtCon nec 1545 1546{- 1547************************************************************************ 1548* * 1549 Constraints and evidence 1550* * 1551************************************************************************ 1552-} 1553 1554zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm 1555zonkEvTerm env (EvExpr e) 1556 = EvExpr <$> zonkCoreExpr env e 1557zonkEvTerm env (EvTypeable ty ev) 1558 = EvTypeable <$> zonkTcTypeToTypeX env ty <*> zonkEvTypeable env ev 1559zonkEvTerm env (EvFun { et_tvs = tvs, et_given = evs 1560 , et_binds = ev_binds, et_body = body_id }) 1561 = do { (env0, new_tvs) <- zonkTyBndrsX env tvs 1562 ; (env1, new_evs) <- zonkEvBndrsX env0 evs 1563 ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds 1564 ; let new_body_id = zonkIdOcc env2 body_id 1565 ; return (EvFun { et_tvs = new_tvs, et_given = new_evs 1566 , et_binds = new_ev_binds, et_body = new_body_id }) } 1567 1568zonkCoreExpr :: ZonkEnv -> CoreExpr -> TcM CoreExpr 1569zonkCoreExpr env (Var v) 1570 | isCoVar v 1571 = Coercion <$> zonkCoVarOcc env v 1572 | otherwise 1573 = return (Var $ zonkIdOcc env v) 1574zonkCoreExpr _ (Lit l) 1575 = return $ Lit l 1576zonkCoreExpr env (Coercion co) 1577 = Coercion <$> zonkCoToCo env co 1578zonkCoreExpr env (Type ty) 1579 = Type <$> zonkTcTypeToTypeX env ty 1580 1581zonkCoreExpr env (Cast e co) 1582 = Cast <$> zonkCoreExpr env e <*> zonkCoToCo env co 1583zonkCoreExpr env (Tick t e) 1584 = Tick t <$> zonkCoreExpr env e -- Do we need to zonk in ticks? 1585 1586zonkCoreExpr env (App e1 e2) 1587 = App <$> zonkCoreExpr env e1 <*> zonkCoreExpr env e2 1588zonkCoreExpr env (Lam v e) 1589 = do { (env1, v') <- zonkCoreBndrX env v 1590 ; Lam v' <$> zonkCoreExpr env1 e } 1591zonkCoreExpr env (Let bind e) 1592 = do (env1, bind') <- zonkCoreBind env bind 1593 Let bind'<$> zonkCoreExpr env1 e 1594zonkCoreExpr env (Case scrut b ty alts) 1595 = do scrut' <- zonkCoreExpr env scrut 1596 ty' <- zonkTcTypeToTypeX env ty 1597 b' <- zonkIdBndr env b 1598 let env1 = extendIdZonkEnv env b' 1599 alts' <- mapM (zonkCoreAlt env1) alts 1600 return $ Case scrut' b' ty' alts' 1601 1602zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt 1603zonkCoreAlt env (dc, bndrs, rhs) 1604 = do (env1, bndrs') <- zonkCoreBndrsX env bndrs 1605 rhs' <- zonkCoreExpr env1 rhs 1606 return $ (dc, bndrs', rhs') 1607 1608zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind) 1609zonkCoreBind env (NonRec v e) 1610 = do v' <- zonkIdBndr env v 1611 e' <- zonkCoreExpr env e 1612 let env1 = extendIdZonkEnv env v' 1613 return (env1, NonRec v' e') 1614zonkCoreBind env (Rec pairs) 1615 = do (env1, pairs') <- fixM go 1616 return (env1, Rec pairs') 1617 where 1618 go ~(_, new_pairs) = do 1619 let env1 = extendIdZonkEnvRec env (map fst new_pairs) 1620 pairs' <- mapM (zonkCorePair env1) pairs 1621 return (env1, pairs') 1622 1623zonkCorePair :: ZonkEnv -> (CoreBndr, CoreExpr) -> TcM (CoreBndr, CoreExpr) 1624zonkCorePair env (v,e) = (,) <$> zonkIdBndr env v <*> zonkCoreExpr env e 1625 1626zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable 1627zonkEvTypeable env (EvTypeableTyCon tycon e) 1628 = do { e' <- mapM (zonkEvTerm env) e 1629 ; return $ EvTypeableTyCon tycon e' } 1630zonkEvTypeable env (EvTypeableTyApp t1 t2) 1631 = do { t1' <- zonkEvTerm env t1 1632 ; t2' <- zonkEvTerm env t2 1633 ; return (EvTypeableTyApp t1' t2') } 1634zonkEvTypeable env (EvTypeableTrFun t1 t2) 1635 = do { t1' <- zonkEvTerm env t1 1636 ; t2' <- zonkEvTerm env t2 1637 ; return (EvTypeableTrFun t1' t2') } 1638zonkEvTypeable env (EvTypeableTyLit t1) 1639 = do { t1' <- zonkEvTerm env t1 1640 ; return (EvTypeableTyLit t1') } 1641 1642zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds]) 1643zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs 1644 ; return (env, [EvBinds (unionManyBags bs')]) } 1645 1646zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds) 1647zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs 1648 ; return (env', EvBinds bs') } 1649 1650zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind) 1651zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var 1652zonk_tc_ev_binds env (EvBinds bs) = zonkEvBinds env bs 1653 1654zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind) 1655zonkEvBindsVar env (EvBindsVar { ebv_binds = ref }) 1656 = do { bs <- readMutVar ref 1657 ; zonkEvBinds env (evBindMapBinds bs) } 1658zonkEvBindsVar env (CoEvBindsVar {}) = return (env, emptyBag) 1659 1660zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind) 1661zonkEvBinds env binds 1662 = {-# SCC "zonkEvBinds" #-} 1663 fixM (\ ~( _, new_binds) -> do 1664 { let env1 = extendIdZonkEnvRec env (collect_ev_bndrs new_binds) 1665 ; binds' <- mapBagM (zonkEvBind env1) binds 1666 ; return (env1, binds') }) 1667 where 1668 collect_ev_bndrs :: Bag EvBind -> [EvVar] 1669 collect_ev_bndrs = foldr add [] 1670 add (EvBind { eb_lhs = var }) vars = var : vars 1671 1672zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind 1673zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term }) 1674 = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var 1675 1676 -- Optimise the common case of Refl coercions 1677 -- See Note [Optimise coercion zonking] 1678 -- This has a very big effect on some programs (eg #5030) 1679 1680 ; term' <- case getEqPredTys_maybe (idType var') of 1681 Just (r, ty1, ty2) | ty1 `eqType` ty2 1682 -> return (evCoercion (mkTcReflCo r ty1)) 1683 _other -> zonkEvTerm env term 1684 1685 ; return (bind { eb_lhs = var', eb_rhs = term' }) } 1686 1687{- Note [Optimise coercion zonking] 1688~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1689When optimising evidence binds we may come across situations where 1690a coercion looks like 1691 cv = ReflCo ty 1692or cv1 = cv2 1693where the type 'ty' is big. In such cases it is a waste of time to zonk both 1694 * The variable on the LHS 1695 * The coercion on the RHS 1696Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just 1697use Refl on the right, ignoring the actual coercion on the RHS. 1698 1699This can have a very big effect, because the constraint solver sometimes does go 1700to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf #5030) 1701 1702 1703************************************************************************ 1704* * 1705 Zonking types 1706* * 1707************************************************************************ 1708-} 1709 1710{- Note [Sharing when zonking to Type] 1711~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1712Problem: 1713 1714 In TcMType.zonkTcTyVar, we short-circuit (Indirect ty) to 1715 (Indirect zty), see Note [Sharing in zonking] in TcMType. But we 1716 /can't/ do this when zonking a TcType to a Type (#15552, esp 1717 comment:3). Suppose we have 1718 1719 alpha -> alpha 1720 where 1721 alpha is already unified: 1722 alpha := T{tc-tycon} Int -> Int 1723 and T is knot-tied 1724 1725 By "knot-tied" I mean that the occurrence of T is currently a TcTyCon, 1726 but the global env contains a mapping "T" :-> T{knot-tied-tc}. See 1727 Note [Type checking recursive type and class declarations] in 1728 TcTyClsDecls. 1729 1730 Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow 1731 the same path as Note [Sharing in zonking] in TcMType, we'll 1732 update alpha to 1733 alpha := T{knot-tied-tc} Int -> Int 1734 1735 But alas, if we encounter alpha for a /second/ time, we end up 1736 looking at T{knot-tied-tc} and fall into a black hole. The whole 1737 point of zonkTcTypeToType is that it produces a type full of 1738 knot-tied tycons, and you must not look at the result!! 1739 1740 To put it another way (zonkTcTypeToType . zonkTcTypeToType) is not 1741 the same as zonkTcTypeToType. (If we distinguished TcType from 1742 Type, this issue would have been a type error!) 1743 1744Solution: (see #15552 for other variants) 1745 1746 One possible solution is simply not to do the short-circuiting. 1747 That has less sharing, but maybe sharing is rare. And indeed, 1748 that turns out to be viable from a perf point of view 1749 1750 But the code implements something a bit better 1751 1752 * ZonkEnv contains ze_meta_tv_env, which maps 1753 from a MetaTyVar (unificaion variable) 1754 to a Type (not a TcType) 1755 1756 * In zonkTyVarOcc, we check this map to see if we have zonked 1757 this variable before. If so, use the previous answer; if not 1758 zonk it, and extend the map. 1759 1760 * The map is of course stateful, held in a TcRef. (That is unlike 1761 the treatment of lexically-scoped variables in ze_tv_env and 1762 ze_id_env.) 1763 1764 Is the extra work worth it? Some non-sytematic perf measurements 1765 suggest that compiler allocation is reduced overall (by 0.5% or so) 1766 but compile time really doesn't change. 1767-} 1768 1769zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType 1770zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi 1771 , ze_tv_env = tv_env 1772 , ze_meta_tv_env = mtv_env_ref }) tv 1773 | isTcTyVar tv 1774 = case tcTyVarDetails tv of 1775 SkolemTv {} -> lookup_in_tv_env 1776 RuntimeUnk {} -> lookup_in_tv_env 1777 MetaTv { mtv_ref = ref } 1778 -> do { mtv_env <- readTcRef mtv_env_ref 1779 -- See Note [Sharing when zonking to Type] 1780 ; case lookupVarEnv mtv_env tv of 1781 Just ty -> return ty 1782 Nothing -> do { mtv_details <- readTcRef ref 1783 ; zonk_meta mtv_env ref mtv_details } } 1784 | otherwise 1785 = lookup_in_tv_env 1786 1787 where 1788 lookup_in_tv_env -- Look up in the env just as we do for Ids 1789 = case lookupVarEnv tv_env tv of 1790 Nothing -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv 1791 Just tv' -> return (mkTyVarTy tv') 1792 1793 zonk_meta mtv_env ref Flexi 1794 = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv) 1795 ; ty <- commitFlexi flexi tv kind 1796 ; writeMetaTyVarRef tv ref ty -- Belt and braces 1797 ; finish_meta mtv_env ty } 1798 1799 zonk_meta mtv_env _ (Indirect ty) 1800 = do { zty <- zonkTcTypeToTypeX env ty 1801 ; finish_meta mtv_env zty } 1802 1803 finish_meta mtv_env ty 1804 = do { let mtv_env' = extendVarEnv mtv_env tv ty 1805 ; writeTcRef mtv_env_ref mtv_env' 1806 ; return ty } 1807 1808lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar 1809lookupTyVarOcc (ZonkEnv { ze_tv_env = tv_env }) tv 1810 = lookupVarEnv tv_env tv 1811 1812commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type 1813-- Only monadic so we can do tc-tracing 1814commitFlexi flexi tv zonked_kind 1815 = case flexi of 1816 SkolemiseFlexi -> return (mkTyVarTy (mkTyVar name zonked_kind)) 1817 1818 DefaultFlexi 1819 | isRuntimeRepTy zonked_kind 1820 -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv) 1821 ; return liftedRepTy } 1822 | otherwise 1823 -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv) 1824 ; return (anyTypeOfKind zonked_kind) } 1825 1826 RuntimeUnkFlexi 1827 -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv) 1828 ; return (mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)) } 1829 -- This is where RuntimeUnks are born: 1830 -- otherwise-unconstrained unification variables are 1831 -- turned into RuntimeUnks as they leave the 1832 -- typechecker's monad 1833 where 1834 name = tyVarName tv 1835 1836zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion 1837zonkCoVarOcc (ZonkEnv { ze_tv_env = tyco_env }) cv 1838 | Just cv' <- lookupVarEnv tyco_env cv -- don't look in the knot-tied env 1839 = return $ mkCoVarCo cv' 1840 | otherwise 1841 = do { cv' <- zonkCoVar cv; return (mkCoVarCo cv') } 1842 1843zonkCoHole :: ZonkEnv -> CoercionHole -> TcM Coercion 1844zonkCoHole env hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) 1845 = do { contents <- readTcRef ref 1846 ; case contents of 1847 Just co -> do { co' <- zonkCoToCo env co 1848 ; checkCoercionHole cv co' } 1849 1850 -- This next case should happen only in the presence of 1851 -- (undeferred) type errors. Originally, I put in a panic 1852 -- here, but that caused too many uses of `failIfErrsM`. 1853 Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole) 1854 ; when debugIsOn $ 1855 whenNoErrs $ 1856 MASSERT2( False 1857 , text "Type-correct unfilled coercion hole" 1858 <+> ppr hole ) 1859 ; cv' <- zonkCoVar cv 1860 ; return $ mkCoVarCo cv' } } 1861 -- This will be an out-of-scope variable, but keeping 1862 -- this as a coercion hole led to #15787 1863 1864zonk_tycomapper :: TyCoMapper ZonkEnv TcM 1865zonk_tycomapper = TyCoMapper 1866 { tcm_tyvar = zonkTyVarOcc 1867 , tcm_covar = zonkCoVarOcc 1868 , tcm_hole = zonkCoHole 1869 , tcm_tycobinder = \env tv _vis -> zonkTyBndrX env tv 1870 , tcm_tycon = zonkTcTyConToTyCon } 1871 1872-- Zonk a TyCon by changing a TcTyCon to a regular TyCon 1873zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon 1874zonkTcTyConToTyCon tc 1875 | isTcTyCon tc = do { thing <- tcLookupGlobalOnly (getName tc) 1876 ; case thing of 1877 ATyCon real_tc -> return real_tc 1878 _ -> pprPanic "zonkTcTyCon" (ppr tc $$ ppr thing) } 1879 | otherwise = return tc -- it's already zonked 1880 1881-- Confused by zonking? See Note [What is zonking?] in TcMType. 1882zonkTcTypeToType :: TcType -> TcM Type 1883zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty 1884 1885zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type 1886zonkTcTypeToTypeX = mapType zonk_tycomapper 1887 1888zonkTcTypesToTypes :: [TcType] -> TcM [Type] 1889zonkTcTypesToTypes tys = initZonkEnv $ \ ze -> zonkTcTypesToTypesX ze tys 1890 1891zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type] 1892zonkTcTypesToTypesX env tys = mapM (zonkTcTypeToTypeX env) tys 1893 1894zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion 1895zonkCoToCo = mapCoercion zonk_tycomapper 1896 1897zonkTcMethInfoToMethInfoX :: ZonkEnv -> TcMethInfo -> TcM MethInfo 1898zonkTcMethInfoToMethInfoX ze (name, ty, gdm_spec) 1899 = do { ty' <- zonkTcTypeToTypeX ze ty 1900 ; gdm_spec' <- zonk_gdm gdm_spec 1901 ; return (name, ty', gdm_spec') } 1902 where 1903 zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType)) 1904 -> TcM (Maybe (DefMethSpec (SrcSpan, Type))) 1905 zonk_gdm Nothing = return Nothing 1906 zonk_gdm (Just VanillaDM) = return (Just VanillaDM) 1907 zonk_gdm (Just (GenericDM (loc, ty))) 1908 = do { ty' <- zonkTcTypeToTypeX ze ty 1909 ; return (Just (GenericDM (loc, ty'))) } 1910 1911--------------------------------------- 1912{- Note [Zonking the LHS of a RULE] 1913~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1914See also DsBinds Note [Free tyvars on rule LHS] 1915 1916We need to gather the type variables mentioned on the LHS so we can 1917quantify over them. Example: 1918 data T a = C 1919 1920 foo :: T a -> Int 1921 foo C = 1 1922 1923 {-# RULES "myrule" foo C = 1 #-} 1924 1925After type checking the LHS becomes (foo alpha (C alpha)) and we do 1926not want to zap the unbound meta-tyvar 'alpha' to Any, because that 1927limits the applicability of the rule. Instead, we want to quantify 1928over it! 1929 1930We do this in two stages. 1931 1932* During zonking, we skolemise the TcTyVar 'alpha' to TyVar 'a'. We 1933 do this by using zonkTvSkolemising as the UnboundTyVarZonker in the 1934 ZonkEnv. (This is in fact the whole reason that the ZonkEnv has a 1935 UnboundTyVarZonker.) 1936 1937* In DsBinds, we quantify over it. See DsBinds 1938 Note [Free tyvars on rule LHS] 1939 1940Quantifying here is awkward because (a) the data type is big and (b) 1941finding the free type vars of an expression is necessarily monadic 1942operation. (consider /\a -> f @ b, where b is side-effected to a) 1943-} 1944