module TcHsSyn (
hsLitType, hsLPatType, hsPatType,
mkHsDictLet, mkHsApp,
mkHsAppTy, mkHsCaseAlt,
shortCutLit, hsOverLitName,
conLikeResTy,
TcId, TcIdSet,
zonkTopDecls, zonkTopExpr, zonkTopLExpr,
zonkTopBndrs, zonkTyBndrsX,
zonkTyVarBindersX, zonkTyVarBinderX,
emptyZonkEnv, mkEmptyZonkEnv,
zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,
zonkCoToCo,
zonkEvBinds, zonkTcEvBinds,
zonkTcMethInfoToMethInfo
) where
#include "HsVersions.h"
import GhcPrelude
import HsSyn
import Id
import IdInfo
import TcRnMonad
import PrelNames
import BuildTyCl ( TcMethInfo, MethInfo )
import TcType
import TcMType
import TcEnv ( tcLookupGlobalOnly )
import TcEvidence
import TysPrim
import TyCon
import TysWiredIn
import TyCoRep( CoercionHole(..) )
import Type
import Coercion
import ConLike
import DataCon
import HscTypes
import Name
import NameEnv
import Var
import VarEnv
import DynFlags
import Literal
import BasicTypes
import Maybes
import SrcLoc
import Bag
import Outputable
import Util
import UniqFM
import CoreSyn
import Control.Monad
import Data.List ( partition )
import Control.Arrow ( second )
hsLPatType :: OutPat GhcTc -> Type
hsLPatType (L _ pat) = hsPatType pat
hsPatType :: Pat GhcTc -> Type
hsPatType (ParPat _ pat) = hsLPatType pat
hsPatType (WildPat ty) = ty
hsPatType (VarPat _ (L _ var)) = idType var
hsPatType (BangPat _ pat) = hsLPatType pat
hsPatType (LazyPat _ pat) = hsLPatType pat
hsPatType (LitPat _ lit) = hsLitType lit
hsPatType (AsPat _ var _) = idType (unLoc var)
hsPatType (ViewPat ty _ _) = ty
hsPatType (ListPat (ListPatTc ty Nothing) _) = mkListTy ty
hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty
hsPatType (TuplePat tys _ bx) = mkTupleTy bx tys
hsPatType (SumPat tys _ _ _ ) = mkSumTy tys
hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys })
= conLikeResTy con tys
hsPatType (SigPat ty _) = ty
hsPatType (NPat ty _ _ _) = ty
hsPatType (NPlusKPat ty _ _ _ _ _) = ty
hsPatType (CoPat _ _ _ ty) = ty
hsPatType p = pprPanic "hsPatType" (ppr p)
hsLitType :: HsLit (GhcPass p) -> TcType
hsLitType (HsChar _ _) = charTy
hsLitType (HsCharPrim _ _) = charPrimTy
hsLitType (HsString _ _) = stringTy
hsLitType (HsStringPrim _ _) = addrPrimTy
hsLitType (HsInt _ _) = intTy
hsLitType (HsIntPrim _ _) = intPrimTy
hsLitType (HsWordPrim _ _) = wordPrimTy
hsLitType (HsInt64Prim _ _) = int64PrimTy
hsLitType (HsWord64Prim _ _) = word64PrimTy
hsLitType (HsInteger _ _ ty) = ty
hsLitType (HsRat _ _ ty) = ty
hsLitType (HsFloatPrim _ _) = floatPrimTy
hsLitType (HsDoublePrim _ _) = doublePrimTy
hsLitType (XLit p) = pprPanic "hsLitType" (ppr p)
shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId)
shortCutLit dflags (HsIntegral int@(IL src neg i)) ty
| isIntTy ty && inIntRange dflags i = Just (HsLit noExt (HsInt noExt int))
| isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i))
| isIntegerTy ty = Just (HsLit noExt (HsInteger src i ty))
| otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty
shortCutLit _ (HsFractional f) ty
| isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim noExt f))
| isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExt f))
| otherwise = Nothing
shortCutLit _ (HsIsString src s) ty
| isStringTy ty = Just (HsLit noExt (HsString src s))
| otherwise = Nothing
mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc
mkLit con lit = HsApp noExt (nlHsDataCon con) (nlHsLit lit)
hsOverLitName :: OverLitVal -> Name
hsOverLitName (HsIntegral {}) = fromIntegerName
hsOverLitName (HsFractional {}) = fromRationalName
hsOverLitName (HsIsString {}) = fromStringName
type UnboundTyVarZonker = TcTyVar -> TcM Type
data ZonkEnv
= ZonkEnv
UnboundTyVarZonker
(TyCoVarEnv TyVar)
(IdEnv Var)
instance Outputable ZonkEnv where
ppr (ZonkEnv _ _ty_env var_env) = pprUFM var_env (vcat . map ppr)
emptyZonkEnv :: ZonkEnv
emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping
mkEmptyZonkEnv :: UnboundTyVarZonker -> ZonkEnv
mkEmptyZonkEnv zonker = ZonkEnv zonker emptyVarEnv emptyVarEnv
extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv
extendIdZonkEnvRec (ZonkEnv zonk_ty ty_env id_env) ids
= ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
extendZonkEnv (ZonkEnv zonk_ty tyco_env id_env) vars
= ZonkEnv zonk_ty (extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars])
(extendVarEnvList id_env [(id,id) | id <- ids])
where (tycovars, ids) = partition isTyCoVar vars
extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id
= ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) tv
= ZonkEnv zonk_ty (extendVarEnv ty_env tv tv) id_env
setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
setZonkType (ZonkEnv _ ty_env id_env) zonk_ty
= ZonkEnv zonk_ty ty_env id_env
zonkEnvIds :: ZonkEnv -> TypeEnv
zonkEnvIds (ZonkEnv _ _ id_env) =
mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env]
zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id
zonkLIdOcc env (L loc id) = L loc (zonkIdOcc env id)
zonkIdOcc :: ZonkEnv -> TcId -> Id
zonkIdOcc (ZonkEnv _zonk_ty _ty_env id_env) id
| isLocalVar id = lookupVarEnv id_env id `orElse`
id
| otherwise = id
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
zonkIdOccs env ids = map (zonkIdOcc env) ids
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
zonkIdBndr env v
= do ty' <- zonkTcTypeToType env (idType v)
ensureNotLevPoly ty'
(text "In the type of binder" <+> quotes (ppr v))
return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty'))
zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
zonkTopBndrs :: [TcId] -> TcM [Id]
zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc)
zonkFieldOcc env (FieldOcc sel lbl)
= fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel
zonkFieldOcc _ (XFieldOcc _) = panic "zonkFieldOcc"
zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
zonkEvBndrsX = mapAccumLM zonkEvBndrX
zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
zonkEvBndrX env var
= do { var' <- zonkEvBndr env var
; return (extendZonkEnv env [var'], var') }
zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
zonkEvBndr env var
= do { let var_ty = varType var
; ty <-
zonkTcTypeToType env var_ty
; return (setVarType var ty) }
zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var)
zonkCoreBndrX env v
| isId v = do { v' <- zonkIdBndr env v
; return (extendIdZonkEnv1 env v', v') }
| otherwise = zonkTyBndrX env v
zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var])
zonkCoreBndrsX = mapAccumLM zonkCoreBndrX
zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX = mapAccumLM zonkTyBndrX
zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)
zonkTyBndrX env tv
= ASSERT( isImmutableTyVar tv )
do { ki <- zonkTcTypeToType env (tyVarKind tv)
; let tv' = mkTyVar (tyVarName tv) ki
; return (extendTyZonkEnv1 env tv', tv') }
zonkTyVarBindersX :: ZonkEnv -> [TyVarBndr TcTyVar vis]
-> TcM (ZonkEnv, [TyVarBndr TyVar vis])
zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX
zonkTyVarBinderX :: ZonkEnv -> TyVarBndr TcTyVar vis
-> TcM (ZonkEnv, TyVarBndr TyVar vis)
zonkTyVarBinderX env (TvBndr tv vis)
= do { (env', tv') <- zonkTyBndrX env tv
; return (env', TvBndr tv' vis) }
zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc)
zonkTopExpr e = zonkExpr emptyZonkEnv e
zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e
zonkTopDecls :: Bag EvBind
-> LHsBinds GhcTcId
-> [LRuleDecl GhcTcId] -> [LTcSpecPrag]
-> [LForeignDecl GhcTcId]
-> TcM (TypeEnv,
Bag EvBind,
LHsBinds GhcTc,
[LForeignDecl GhcTc],
[LTcSpecPrag],
[LRuleDecl GhcTc])
zonkTopDecls ev_binds binds rules imp_specs fords
= do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
; (env2, binds') <- zonkRecMonoBinds env1 binds
; rules' <- zonkRules env2 rules
; specs' <- zonkLTcSpecPrags env2 imp_specs
; fords' <- zonkForeignExports env2 fords
; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') }
zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId
-> TcM (ZonkEnv, HsLocalBinds GhcTc)
zonkLocalBinds env (EmptyLocalBinds x)
= return (env, (EmptyLocalBinds x))
zonkLocalBinds _ (HsValBinds _ (ValBinds {}))
= panic "zonkLocalBinds"
zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs)))
= do { (env1, new_binds) <- go env binds
; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) }
where
go env []
= return (env, [])
go env ((r,b):bs)
= do { (env1, b') <- zonkRecMonoBinds env b
; (env2, bs') <- go env1 bs
; return (env2, (r,b'):bs') }
zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do
new_binds <- mapM (wrapLocM zonk_ip_bind) binds
let
env1 = extendIdZonkEnvRec env [ n
| L _ (IPBind _ (Right n) _) <- new_binds]
(env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds))
where
zonk_ip_bind (IPBind x n e)
= do n' <- mapIPNameTc (zonkIdBndr env) n
e' <- zonkLExpr env e
return (IPBind x n' e')
zonk_ip_bind (XIPBind _) = panic "zonkLocalBinds : XCIPBind"
zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds _))
= panic "zonkLocalBinds"
zonkLocalBinds _ (XHsLocalBindsLR _)
= panic "zonkLocalBinds"
zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc)
zonkRecMonoBinds env binds
= fixM (\ ~(_, new_binds) -> do
{ let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)
; binds' <- zonkMonoBinds env1 binds
; return (env1, binds') })
zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc)
zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc)
zonk_lbind env = wrapLocM (zonk_bind env)
zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc)
zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss
, pat_ext = NPatBindTc fvs ty})
= do { (_env, new_pat) <- zonkPat env pat
; new_grhss <- zonkGRHSs env zonkLExpr grhss
; new_ty <- zonkTcTypeToType env ty
; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss
, pat_ext = NPatBindTc fvs new_ty }) }
zonk_bind env (VarBind { var_ext = x
, var_id = var, var_rhs = expr, var_inline = inl })
= do { new_var <- zonkIdBndr env var
; new_expr <- zonkLExpr env expr
; return (VarBind { var_ext = x
, var_id = new_var
, var_rhs = new_expr
, var_inline = inl }) }
zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
, fun_co_fn = co_fn })
= do { new_var <- zonkIdBndr env var
; (env1, new_co_fn) <- zonkCoFn env co_fn
; new_ms <- zonkMatchGroup env1 zonkLExpr ms
; return (bind { fun_id = L loc new_var, fun_matches = new_ms
, fun_co_fn = new_co_fn }) }
zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
, abs_ev_binds = ev_binds
, abs_exports = exports
, abs_binds = val_binds
, abs_sig = has_sig })
= ASSERT( all isImmutableTyVar tyvars )
do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
; (env1, new_evs) <- zonkEvBndrsX env0 evs
; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
do { let env3 = extendIdZonkEnvRec env2 $
collectHsBindsBinders new_val_binds
; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds
; new_exports <- mapM (zonk_export env3) exports
; return (new_val_binds, new_exports) }
; return (AbsBinds { abs_ext = noExt
, abs_tvs = new_tyvars, abs_ev_vars = new_evs
, abs_ev_binds = new_ev_binds
, abs_exports = new_exports, abs_binds = new_val_bind
, abs_sig = has_sig }) }
where
zonk_val_bind env lbind
| has_sig
, L loc bind@(FunBind { fun_id = L mloc mono_id
, fun_matches = ms
, fun_co_fn = co_fn }) <- lbind
= do { new_mono_id <- updateVarTypeM (zonkTcTypeToType env) mono_id
; (env', new_co_fn) <- zonkCoFn env co_fn
; new_ms <- zonkMatchGroup env' zonkLExpr ms
; return $ L loc $
bind { fun_id = L mloc new_mono_id
, fun_matches = new_ms
, fun_co_fn = new_co_fn } }
| otherwise
= zonk_lbind env lbind
zonk_export env (ABE{ abe_ext = x
, abe_wrap = wrap
, abe_poly = poly_id
, abe_mono = mono_id
, abe_prags = prags })
= do new_poly_id <- zonkIdBndr env poly_id
(_, new_wrap) <- zonkCoFn env wrap
new_prags <- zonkSpecPrags env prags
return (ABE{ abe_ext = x
, abe_wrap = new_wrap
, abe_poly = new_poly_id
, abe_mono = zonkIdOcc env mono_id
, abe_prags = new_prags })
zonk_export _ (XABExport _) = panic "zonk_bind: XABExport"
zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id
, psb_args = details
, psb_def = lpat
, psb_dir = dir }))
= do { id' <- zonkIdBndr env id
; (env1, lpat') <- zonkPat env lpat
; let details' = zonkPatSynDetails env1 details
; (_env2, dir') <- zonkPatSynDir env1 dir
; return $ PatSynBind x $
bind { psb_id = L loc id'
, psb_args = details'
, psb_def = lpat'
, psb_dir = dir' } }
zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind"
zonk_bind _ (XHsBindsLR _) = panic "zonk_bind"
zonkPatSynDetails :: ZonkEnv
-> HsPatSynDetails (Located TcId)
-> HsPatSynDetails (Located Id)
zonkPatSynDetails env (PrefixCon as)
= PrefixCon (map (zonkLIdOcc env) as)
zonkPatSynDetails env (InfixCon a1 a2)
= InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2)
zonkPatSynDetails env (RecCon flds)
= RecCon (map (fmap (zonkLIdOcc env)) flds)
zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId
-> TcM (ZonkEnv, HsPatSynDir GhcTc)
zonkPatSynDir env Unidirectional = return (env, Unidirectional)
zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
zonkPatSynDir env (ExplicitBidirectional mg) = do
mg' <- zonkMatchGroup env zonkLExpr mg
return (env, ExplicitBidirectional mg')
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod
zonkSpecPrags env (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags env ps
; return (SpecPrags ps') }
zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
= mapM zonk_prag ps
where
zonk_prag (L loc (SpecPrag id co_fn inl))
= do { (_, co_fn') <- zonkCoFn env co_fn
; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
zonkMatchGroup :: ZonkEnv
-> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
-> MatchGroup GhcTcId (Located (body GhcTcId))
-> TcM (MatchGroup GhcTc (Located (body GhcTc)))
zonkMatchGroup env zBody (MG { mg_alts = L l ms
, mg_ext = MatchGroupTc arg_tys res_ty
, mg_origin = origin })
= do { ms' <- mapM (zonkMatch env zBody) ms
; arg_tys' <- zonkTcTypeToTypes env arg_tys
; res_ty' <- zonkTcTypeToType env res_ty
; return (MG { mg_alts = L l ms'
, mg_ext = MatchGroupTc arg_tys' res_ty'
, mg_origin = origin }) }
zonkMatchGroup _ _ (XMatchGroup {}) = panic "zonkMatchGroup"
zonkMatch :: ZonkEnv
-> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
-> LMatch GhcTcId (Located (body GhcTcId))
-> TcM (LMatch GhcTc (Located (body GhcTc)))
zonkMatch env zBody (L loc match@(Match { m_pats = pats, m_grhss = grhss }))
= do { (env1, new_pats) <- zonkPats env pats
; new_grhss <- zonkGRHSs env1 zBody grhss
; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
zonkMatch _ _ (L _ (XMatch _)) = panic "zonkMatch"
zonkGRHSs :: ZonkEnv
-> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
-> GRHSs GhcTcId (Located (body GhcTcId))
-> TcM (GRHSs GhcTc (Located (body GhcTc)))
zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do
(new_env, new_binds) <- zonkLocalBinds env binds
let
zonk_grhs (GRHS xx guarded rhs)
= do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
new_rhs <- zBody env2 rhs
return (GRHS xx new_guarded new_rhs)
zonk_grhs (XGRHS _) = panic "zonkGRHSs"
new_grhss <- mapM (wrapLocM zonk_grhs) grhss
return (GRHSs x new_grhss (L l new_binds))
zonkGRHSs _ _ (XGRHSs _) = panic "zonkGRHSs"
zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc]
zonkLExpr :: ZonkEnv -> LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)
zonkExpr :: ZonkEnv -> HsExpr GhcTcId -> TcM (HsExpr GhcTc)
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
zonkLExpr env expr = wrapLocM (zonkExpr env) expr
zonkExpr env (HsVar x (L l id))
= ASSERT2( isNothing (isDataConId_maybe id), ppr id )
return (HsVar x (L l (zonkIdOcc env id)))
zonkExpr _ e@(HsConLikeOut {}) = return e
zonkExpr _ (HsIPVar x id)
= return (HsIPVar x id)
zonkExpr _ e@HsOverLabel{} = return e
zonkExpr env (HsLit x (HsRat e f ty))
= do new_ty <- zonkTcTypeToType env ty
return (HsLit x (HsRat e f new_ty))
zonkExpr _ (HsLit x lit)
= return (HsLit x lit)
zonkExpr env (HsOverLit x lit)
= do { lit' <- zonkOverLit env lit
; return (HsOverLit x lit') }
zonkExpr env (HsLam x matches)
= do new_matches <- zonkMatchGroup env zonkLExpr matches
return (HsLam x new_matches)
zonkExpr env (HsLamCase x matches)
= do new_matches <- zonkMatchGroup env zonkLExpr matches
return (HsLamCase x new_matches)
zonkExpr env (HsApp x e1 e2)
= do new_e1 <- zonkLExpr env e1
new_e2 <- zonkLExpr env e2
return (HsApp x new_e1 new_e2)
zonkExpr env (HsAppType t e)
= do new_e <- zonkLExpr env e
return (HsAppType t new_e)
zonkExpr _ e@(HsRnBracketOut _ _ _)
= pprPanic "zonkExpr: HsRnBracketOut" (ppr e)
zonkExpr env (HsTcBracketOut x body bs)
= do bs' <- mapM zonk_b bs
return (HsTcBracketOut x body bs')
where
zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
return (PendingTcSplice n e')
zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s )
return (HsSpliceE x s)
zonkExpr env (OpApp fixity e1 op e2)
= do new_e1 <- zonkLExpr env e1
new_op <- zonkLExpr env op
new_e2 <- zonkLExpr env e2
return (OpApp fixity new_e1 new_op new_e2)
zonkExpr env (NegApp x expr op)
= do (env', new_op) <- zonkSyntaxExpr env op
new_expr <- zonkLExpr env' expr
return (NegApp x new_expr new_op)
zonkExpr env (HsPar x e)
= do new_e <- zonkLExpr env e
return (HsPar x new_e)
zonkExpr env (SectionL x expr op)
= do new_expr <- zonkLExpr env expr
new_op <- zonkLExpr env op
return (SectionL x new_expr new_op)
zonkExpr env (SectionR x op expr)
= do new_op <- zonkLExpr env op
new_expr <- zonkLExpr env expr
return (SectionR x new_op new_expr)
zonkExpr env (ExplicitTuple x tup_args boxed)
= do { new_tup_args <- mapM zonk_tup_arg tup_args
; return (ExplicitTuple x new_tup_args boxed) }
where
zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e
; return (L l (Present x e')) }
zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t
; return (L l (Missing t')) }
zonk_tup_arg (L _ (XTupArg{})) = panic "zonkExpr.XTupArg"
zonkExpr env (ExplicitSum args alt arity expr)
= do new_args <- mapM (zonkTcTypeToType env) args
new_expr <- zonkLExpr env expr
return (ExplicitSum new_args alt arity new_expr)
zonkExpr env (HsCase x expr ms)
= do new_expr <- zonkLExpr env expr
new_ms <- zonkMatchGroup env zonkLExpr ms
return (HsCase x new_expr new_ms)
zonkExpr env (HsIf x Nothing e1 e2 e3)
= do new_e1 <- zonkLExpr env e1
new_e2 <- zonkLExpr env e2
new_e3 <- zonkLExpr env e3
return (HsIf x Nothing new_e1 new_e2 new_e3)
zonkExpr env (HsIf x (Just fun) e1 e2 e3)
= do (env1, new_fun) <- zonkSyntaxExpr env fun
new_e1 <- zonkLExpr env1 e1
new_e2 <- zonkLExpr env1 e2
new_e3 <- zonkLExpr env1 e3
return (HsIf x (Just new_fun) new_e1 new_e2 new_e3)
zonkExpr env (HsMultiIf ty alts)
= do { alts' <- mapM (wrapLocM zonk_alt) alts
; ty' <- zonkTcTypeToType env ty
; return $ HsMultiIf ty' alts' }
where zonk_alt (GRHS x guard expr)
= do { (env', guard') <- zonkStmts env zonkLExpr guard
; expr' <- zonkLExpr env' expr
; return $ GRHS x guard' expr' }
zonk_alt (XGRHS _) = panic "zonkExpr.HsMultiIf"
zonkExpr env (HsLet x (L l binds) expr)
= do (new_env, new_binds) <- zonkLocalBinds env binds
new_expr <- zonkLExpr new_env expr
return (HsLet x (L l new_binds) new_expr)
zonkExpr env (HsDo ty do_or_lc (L l stmts))
= do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
new_ty <- zonkTcTypeToType env ty
return (HsDo new_ty do_or_lc (L l new_stmts))
zonkExpr env (ExplicitList ty wit exprs)
= do (env1, new_wit) <- zonkWit env wit
new_ty <- zonkTcTypeToType env1 ty
new_exprs <- zonkLExprs env1 exprs
return (ExplicitList new_ty new_wit new_exprs)
where zonkWit env Nothing = return (env, Nothing)
zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds })
= do { new_con_expr <- zonkExpr env (rcon_con_expr ext)
; new_rbinds <- zonkRecFields env rbinds
; return (expr { rcon_ext = ext { rcon_con_expr = new_con_expr }
, rcon_flds = new_rbinds }) }
zonkExpr env (RecordUpd { rupd_flds = rbinds
, rupd_expr = expr
, rupd_ext = RecordUpdTc
{ rupd_cons = cons, rupd_in_tys = in_tys
, rupd_out_tys = out_tys, rupd_wrap = req_wrap }})
= do { new_expr <- zonkLExpr env expr
; new_in_tys <- mapM (zonkTcTypeToType env) in_tys
; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
; new_rbinds <- zonkRecUpdFields env rbinds
; (_, new_recwrap) <- zonkCoFn env req_wrap
; return (RecordUpd { rupd_expr = new_expr, rupd_flds = new_rbinds
, rupd_ext = RecordUpdTc
{ rupd_cons = cons, rupd_in_tys = new_in_tys
, rupd_out_tys = new_out_tys
, rupd_wrap = new_recwrap }}) }
zonkExpr env (ExprWithTySig ty e)
= do { e' <- zonkLExpr env e
; return (ExprWithTySig ty e') }
zonkExpr env (ArithSeq expr wit info)
= do (env1, new_wit) <- zonkWit env wit
new_expr <- zonkExpr env expr
new_info <- zonkArithSeq env1 info
return (ArithSeq new_expr new_wit new_info)
where zonkWit env Nothing = return (env, Nothing)
zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
zonkExpr env (HsSCC x src lbl expr)
= do new_expr <- zonkLExpr env expr
return (HsSCC x src lbl new_expr)
zonkExpr env (HsTickPragma x src info srcInfo expr)
= do new_expr <- zonkLExpr env expr
return (HsTickPragma x src info srcInfo new_expr)
zonkExpr env (HsCoreAnn x src lbl expr)
= do new_expr <- zonkLExpr env expr
return (HsCoreAnn x src lbl new_expr)
zonkExpr env (HsProc x pat body)
= do { (env1, new_pat) <- zonkPat env pat
; new_body <- zonkCmdTop env1 body
; return (HsProc x new_pat new_body) }
zonkExpr env (HsStatic fvs expr)
= HsStatic fvs <$> zonkLExpr env expr
zonkExpr env (HsWrap x co_fn expr)
= do (env1, new_co_fn) <- zonkCoFn env co_fn
new_expr <- zonkExpr env1 expr
return (HsWrap x new_co_fn new_expr)
zonkExpr _ e@(HsUnboundVar {}) = return e
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTcId
-> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr env (SyntaxExpr { syn_expr = expr
, syn_arg_wraps = arg_wraps
, syn_res_wrap = res_wrap })
= do { (env0, res_wrap') <- zonkCoFn env res_wrap
; expr' <- zonkExpr env0 expr
; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps
; return (env1, SyntaxExpr { syn_expr = expr'
, syn_arg_wraps = arg_wraps'
, syn_res_wrap = res_wrap' }) }
zonkLCmd :: ZonkEnv -> LHsCmd GhcTcId -> TcM (LHsCmd GhcTc)
zonkCmd :: ZonkEnv -> HsCmd GhcTcId -> TcM (HsCmd GhcTc)
zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd
zonkCmd env (HsCmdWrap x w cmd)
= do { (env1, w') <- zonkCoFn env w
; cmd' <- zonkCmd env1 cmd
; return (HsCmdWrap x w' cmd') }
zonkCmd env (HsCmdArrApp ty e1 e2 ho rl)
= do new_e1 <- zonkLExpr env e1
new_e2 <- zonkLExpr env e2
new_ty <- zonkTcTypeToType env ty
return (HsCmdArrApp new_ty new_e1 new_e2 ho rl)
zonkCmd env (HsCmdArrForm x op f fixity args)
= do new_op <- zonkLExpr env op
new_args <- mapM (zonkCmdTop env) args
return (HsCmdArrForm x new_op f fixity new_args)
zonkCmd env (HsCmdApp x c e)
= do new_c <- zonkLCmd env c
new_e <- zonkLExpr env e
return (HsCmdApp x new_c new_e)
zonkCmd env (HsCmdLam x matches)
= do new_matches <- zonkMatchGroup env zonkLCmd matches
return (HsCmdLam x new_matches)
zonkCmd env (HsCmdPar x c)
= do new_c <- zonkLCmd env c
return (HsCmdPar x new_c)
zonkCmd env (HsCmdCase x expr ms)
= do new_expr <- zonkLExpr env expr
new_ms <- zonkMatchGroup env zonkLCmd ms
return (HsCmdCase x new_expr new_ms)
zonkCmd env (HsCmdIf x eCond ePred cThen cElse)
= do { (env1, new_eCond) <- zonkWit env eCond
; new_ePred <- zonkLExpr env1 ePred
; new_cThen <- zonkLCmd env1 cThen
; new_cElse <- zonkLCmd env1 cElse
; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) }
where
zonkWit env Nothing = return (env, Nothing)
zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w
zonkCmd env (HsCmdLet x (L l binds) cmd)
= do (new_env, new_binds) <- zonkLocalBinds env binds
new_cmd <- zonkLCmd new_env cmd
return (HsCmdLet x (L l new_binds) new_cmd)
zonkCmd env (HsCmdDo ty (L l stmts))
= do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
new_ty <- zonkTcTypeToType env ty
return (HsCmdDo new_ty (L l new_stmts))
zonkCmd _ (XCmd{}) = panic "zonkCmd"
zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTc)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTcId -> TcM (HsCmdTop GhcTc)
zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)
= do new_cmd <- zonkLCmd env cmd
new_stack_tys <- zonkTcTypeToType env stack_tys
new_ty <- zonkTcTypeToType env ty
new_ids <- mapSndM (zonkExpr env) ids
MASSERT( isLiftedTypeKind (typeKind new_stack_tys) )
return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd)
zonk_cmd_top _ (XCmdTop {}) = panic "zonk_cmd_top"
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn env WpHole = return (env, WpHole)
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
; (env2, c2') <- zonkCoFn env1 c2
; return (env2, WpCompose c1' c2') }
zonkCoFn env (WpFun c1 c2 t1 d) = do { (env1, c1') <- zonkCoFn env c1
; (env2, c2') <- zonkCoFn env1 c2
; t1' <- zonkTcTypeToType env2 t1
; return (env2, WpFun c1' c2' t1' d) }
zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co
; return (env, WpCast co') }
zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev
; return (env', WpEvLam ev') }
zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg
; return (env, WpEvApp arg') }
zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv )
do { (env', tv') <- zonkTyBndrX env tv
; return (env', WpTyLam tv') }
zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty
; return (env, WpTyApp ty') }
zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs
; return (env1, WpLet bs') }
zonkOverLit :: ZonkEnv -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc)
zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e })
= do { ty' <- zonkTcTypeToType env ty
; e' <- zonkExpr env e
; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) }
zonkOverLit _ XOverLit{} = panic "zonkOverLit"
zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> TcM (ArithSeqInfo GhcTc)
zonkArithSeq env (From e)
= do new_e <- zonkLExpr env e
return (From new_e)
zonkArithSeq env (FromThen e1 e2)
= do new_e1 <- zonkLExpr env e1
new_e2 <- zonkLExpr env e2
return (FromThen new_e1 new_e2)
zonkArithSeq env (FromTo e1 e2)
= do new_e1 <- zonkLExpr env e1
new_e2 <- zonkLExpr env e2
return (FromTo new_e1 new_e2)
zonkArithSeq env (FromThenTo e1 e2 e3)
= do new_e1 <- zonkLExpr env e1
new_e2 <- zonkLExpr env e2
new_e3 <- zonkLExpr env e3
return (FromThenTo new_e1 new_e2 new_e3)
zonkStmts :: ZonkEnv
-> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
-> [LStmt GhcTcId (Located (body GhcTcId))]
-> TcM (ZonkEnv, [LStmt GhcTc (Located (body GhcTc))])
zonkStmts env _ [] = return (env, [])
zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s
; (env2, ss') <- zonkStmts env1 zBody ss
; return (env2, s' : ss') }
zonkStmt :: ZonkEnv
-> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
-> Stmt GhcTcId (Located (body GhcTcId))
-> TcM (ZonkEnv, Stmt GhcTc (Located (body GhcTc)))
zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op)
= do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op
; new_bind_ty <- zonkTcTypeToType env1 bind_ty
; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs
; let new_binders = [b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs
, b <- bs]
env2 = extendIdZonkEnvRec env1 new_binders
; new_mzip <- zonkExpr env2 mzip_op
; return (env2
, ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)}
where
zonk_branch env1 (ParStmtBlock x stmts bndrs return_op)
= do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts
; (env3, new_return) <- zonkSyntaxExpr env2 return_op
; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs)
new_return) }
zonk_branch _ (XParStmtBlock{}) = panic "zonkStmt"
zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
, recS_ret_fn = ret_id, recS_mfix_fn = mfix_id
, recS_bind_fn = bind_id
, recS_ext =
RecStmtTc { recS_bind_ty = bind_ty
, recS_later_rets = later_rets
, recS_rec_rets = rec_rets
, recS_ret_ty = ret_ty} })
= do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id
; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id
; (env3, new_ret_id) <- zonkSyntaxExpr env2 ret_id
; new_bind_ty <- zonkTcTypeToType env3 bind_ty
; new_rvs <- zonkIdBndrs env3 rvs
; new_lvs <- zonkIdBndrs env3 lvs
; new_ret_ty <- zonkTcTypeToType env3 ret_ty
; let env4 = extendIdZonkEnvRec env3 new_rvs
; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts
; new_later_rets <- mapM (zonkExpr env5) later_rets
; new_rec_rets <- mapM (zonkExpr env5) rec_rets
; return (extendIdZonkEnvRec env3 new_lvs,
RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
, recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
, recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
, recS_ext = RecStmtTc
{ recS_bind_ty = new_bind_ty
, recS_later_rets = new_later_rets
, recS_rec_rets = new_rec_rets
, recS_ret_ty = new_ret_ty } }) }
zonkStmt env zBody (BodyStmt ty body then_op guard_op)
= do (env1, new_then_op) <- zonkSyntaxExpr env then_op
(env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op
new_body <- zBody env2 body
new_ty <- zonkTcTypeToType env2 ty
return (env2, BodyStmt new_ty new_body new_then_op new_guard_op)
zonkStmt env zBody (LastStmt x body noret ret_op)
= do (env1, new_ret) <- zonkSyntaxExpr env ret_op
new_body <- zBody env1 body
return (env, LastStmt x new_body noret new_ret)
zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
, trS_by = by, trS_form = form, trS_using = using
, trS_ret = return_op, trS_bind = bind_op
, trS_ext = bind_arg_ty
, trS_fmap = liftM_op })
= do {
; (env1, bind_op') <- zonkSyntaxExpr env bind_op
; bind_arg_ty' <- zonkTcTypeToType env1 bind_arg_ty
; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts
; by' <- fmapMaybeM (zonkLExpr env2) by
; using' <- zonkLExpr env2 using
; (env3, return_op') <- zonkSyntaxExpr env2 return_op
; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap
; liftM_op' <- zonkExpr env3 liftM_op
; let env3' = extendIdZonkEnvRec env3 (map snd binderMap')
; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
, trS_by = by', trS_form = form, trS_using = using'
, trS_ret = return_op', trS_bind = bind_op'
, trS_ext = bind_arg_ty'
, trS_fmap = liftM_op' }) }
where
zonkBinderMapEntry env (oldBinder, newBinder) = do
let oldBinder' = zonkIdOcc env oldBinder
newBinder' <- zonkIdBndr env newBinder
return (oldBinder', newBinder')
zonkStmt env _ (LetStmt x (L l binds))
= do (env1, new_binds) <- zonkLocalBinds env binds
return (env1, LetStmt x (L l new_binds))
zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op)
= do { (env1, new_bind) <- zonkSyntaxExpr env bind_op
; new_bind_ty <- zonkTcTypeToType env1 bind_ty
; new_body <- zBody env1 body
; (env2, new_pat) <- zonkPat env1 pat
; (_, new_fail) <- zonkSyntaxExpr env1 fail_op
; return ( env2
, BindStmt new_bind_ty new_pat new_body new_bind new_fail) }
zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
= do { (env1, new_mb_join) <- zonk_join env mb_join
; (env2, new_args) <- zonk_args env1 args
; new_body_ty <- zonkTcTypeToType env2 body_ty
; return (env2, ApplicativeStmt new_body_ty new_args new_mb_join) }
where
zonk_join env Nothing = return (env, Nothing)
zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j
get_pat (_, ApplicativeArgOne _ pat _ _) = pat
get_pat (_, ApplicativeArgMany _ _ _ pat) = pat
get_pat (_, XApplicativeArg _) = panic "zonkStmt"
replace_pat pat (op, ApplicativeArgOne x _ a isBody)
= (op, ApplicativeArgOne x pat a isBody)
replace_pat pat (op, ApplicativeArgMany x a b _)
= (op, ApplicativeArgMany x a b pat)
replace_pat _ (_, XApplicativeArg _) = panic "zonkStmt"
zonk_args env args
= do { (env1, new_args_rev) <- zonk_args_rev env (reverse args)
; (env2, new_pats) <- zonkPats env1 (map get_pat args)
; return (env2, zipWith replace_pat new_pats (reverse new_args_rev)) }
zonk_args_rev env ((op, arg) : args)
= do { (env1, new_op) <- zonkSyntaxExpr env op
; new_arg <- zonk_arg env1 arg
; (env2, new_args) <- zonk_args_rev env1 args
; return (env2, (new_op, new_arg) : new_args) }
zonk_args_rev env [] = return (env, [])
zonk_arg env (ApplicativeArgOne x pat expr isBody)
= do { new_expr <- zonkLExpr env expr
; return (ApplicativeArgOne x pat new_expr isBody) }
zonk_arg env (ApplicativeArgMany x stmts ret pat)
= do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
; new_ret <- zonkExpr env1 ret
; return (ApplicativeArgMany x new_stmts new_ret pat) }
zonk_arg _ (XApplicativeArg _) = panic "zonkStmt.XApplicativeArg"
zonkStmt _ _ (XStmtLR _) = panic "zonkStmt"
zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId)
zonkRecFields env (HsRecFields flds dd)
= do { flds' <- mapM zonk_rbind flds
; return (HsRecFields flds' dd) }
where
zonk_rbind (L l fld)
= do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld)
; new_expr <- zonkLExpr env (hsRecFieldArg fld)
; return (L l (fld { hsRecFieldLbl = new_id
, hsRecFieldArg = new_expr })) }
zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTcId]
-> TcM [LHsRecUpdField GhcTcId]
zonkRecUpdFields env = mapM zonk_rbind
where
zonk_rbind (L l fld)
= do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld)
; new_expr <- zonkLExpr env (hsRecFieldArg fld)
; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id
, hsRecFieldArg = new_expr })) }
mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a
-> TcM (Either (Located HsIPName) b)
mapIPNameTc _ (Left x) = return (Left x)
mapIPNameTc f (Right x) = do r <- f x
return (Right r)
zonkPat :: ZonkEnv -> OutPat GhcTcId -> TcM (ZonkEnv, OutPat GhcTc)
zonkPat env pat = wrapLocSndM (zonk_pat env) pat
zonk_pat :: ZonkEnv -> Pat GhcTcId -> TcM (ZonkEnv, Pat GhcTc)
zonk_pat env (ParPat x p)
= do { (env', p') <- zonkPat env p
; return (env', ParPat x p') }
zonk_pat env (WildPat ty)
= do { ty' <- zonkTcTypeToType env ty
; ensureNotLevPoly ty'
(text "In a wildcard pattern")
; return (env, WildPat ty') }
zonk_pat env (VarPat x (L l v))
= do { v' <- zonkIdBndr env v
; return (extendIdZonkEnv1 env v', VarPat x (L l v')) }
zonk_pat env (LazyPat x pat)
= do { (env', pat') <- zonkPat env pat
; return (env', LazyPat x pat') }
zonk_pat env (BangPat x pat)
= do { (env', pat') <- zonkPat env pat
; return (env', BangPat x pat') }
zonk_pat env (AsPat x (L loc v) pat)
= do { v' <- zonkIdBndr env v
; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat
; return (env', AsPat x (L loc v') pat') }
zonk_pat env (ViewPat ty expr pat)
= do { expr' <- zonkLExpr env expr
; (env', pat') <- zonkPat env pat
; ty' <- zonkTcTypeToType env ty
; return (env', ViewPat ty' expr' pat') }
zonk_pat env (ListPat (ListPatTc ty Nothing) pats)
= do { ty' <- zonkTcTypeToType env ty
; (env', pats') <- zonkPats env pats
; return (env', ListPat (ListPatTc ty' Nothing) pats') }
zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats)
= do { (env', wit') <- zonkSyntaxExpr env wit
; ty2' <- zonkTcTypeToType env' ty2
; ty' <- zonkTcTypeToType env' ty
; (env'', pats') <- zonkPats env' pats
; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) pats') }
zonk_pat env (TuplePat tys pats boxed)
= do { tys' <- mapM (zonkTcTypeToType env) tys
; (env', pats') <- zonkPats env pats
; return (env', TuplePat tys' pats' boxed) }
zonk_pat env (SumPat tys pat alt arity )
= do { tys' <- mapM (zonkTcTypeToType env) tys
; (env', pat') <- zonkPat env pat
; return (env', SumPat tys' pat' alt arity) }
zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars
, pat_dicts = evs, pat_binds = binds
, pat_args = args, pat_wrap = wrapper
, pat_con = L _ con })
= ASSERT( all isImmutableTyVar tyvars )
do { new_tys <- mapM (zonkTcTypeToType env) tys
; case con of
RealDataCon dc
| isUnboxedTupleTyCon (dataConTyCon dc)
-> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys)
_ -> return ()
; (env0, new_tyvars) <- zonkTyBndrsX env tyvars
; (env1, new_evs) <- zonkEvBndrsX env0 evs
; (env2, new_binds) <- zonkTcEvBinds env1 binds
; (env3, new_wrapper) <- zonkCoFn env2 wrapper
; (env', new_args) <- zonkConStuff env3 args
; return (env', p { pat_arg_tys = new_tys,
pat_tvs = new_tyvars,
pat_dicts = new_evs,
pat_binds = new_binds,
pat_args = new_args,
pat_wrap = new_wrapper}) }
where
doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p
zonk_pat env (LitPat x lit) = return (env, LitPat x lit)
zonk_pat env (SigPat ty pat)
= do { ty' <- zonkTcTypeToType env ty
; (env', pat') <- zonkPat env pat
; return (env', SigPat ty' pat') }
zonk_pat env (NPat ty (L l lit) mb_neg eq_expr)
= do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr
; (env2, mb_neg') <- case mb_neg of
Nothing -> return (env1, Nothing)
Just n -> second Just <$> zonkSyntaxExpr env1 n
; lit' <- zonkOverLit env2 lit
; ty' <- zonkTcTypeToType env2 ty
; return (env2, NPat ty' (L l lit') mb_neg' eq_expr') }
zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2)
= do { (env1, e1') <- zonkSyntaxExpr env e1
; (env2, e2') <- zonkSyntaxExpr env1 e2
; n' <- zonkIdBndr env2 n
; lit1' <- zonkOverLit env2 lit1
; lit2' <- zonkOverLit env2 lit2
; ty' <- zonkTcTypeToType env2 ty
; return (extendIdZonkEnv1 env2 n',
NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') }
zonk_pat env (CoPat x co_fn pat ty)
= do { (env', co_fn') <- zonkCoFn env co_fn
; (env'', pat') <- zonkPat env' (noLoc pat)
; ty' <- zonkTcTypeToType env'' ty
; return (env'', CoPat x co_fn' (unLoc pat') ty') }
zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
zonkConStuff :: ZonkEnv
-> HsConDetails (OutPat GhcTcId) (HsRecFields id (OutPat GhcTcId))
-> TcM (ZonkEnv,
HsConDetails (OutPat GhcTc) (HsRecFields id (OutPat GhcTc)))
zonkConStuff env (PrefixCon pats)
= do { (env', pats') <- zonkPats env pats
; return (env', PrefixCon pats') }
zonkConStuff env (InfixCon p1 p2)
= do { (env1, p1') <- zonkPat env p1
; (env', p2') <- zonkPat env1 p2
; return (env', InfixCon p1' p2') }
zonkConStuff env (RecCon (HsRecFields rpats dd))
= do { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats)
; let rpats' = zipWith (\(L l rp) p' -> L l (rp { hsRecFieldArg = p' }))
rpats pats'
; return (env', RecCon (HsRecFields rpats' dd)) }
zonkPats :: ZonkEnv -> [OutPat GhcTcId] -> TcM (ZonkEnv, [OutPat GhcTc])
zonkPats env [] = return (env, [])
zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
; (env', pats') <- zonkPats env1 pats
; return (env', pat':pats') }
zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTcId]
-> TcM [LForeignDecl GhcTc]
zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls
zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTcId -> TcM (ForeignDecl GhcTc)
zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co
, fd_fe = spec })
= return (ForeignExport { fd_name = zonkLIdOcc env i
, fd_sig_ty = undefined, fd_e_ext = co
, fd_fe = spec })
zonkForeignExport _ for_imp
= return for_imp
zonkRules :: ZonkEnv -> [LRuleDecl GhcTcId] -> TcM [LRuleDecl GhcTc]
zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs
zonkRule :: ZonkEnv -> RuleDecl GhcTcId -> TcM (RuleDecl GhcTc)
zonkRule env (HsRule fvs name act (vars) lhs rhs)
= do { (env_inside, new_bndrs) <- mapAccumLM zonk_bndr env vars
; let env_lhs = setZonkType env_inside zonkTvSkolemising
; new_lhs <- zonkLExpr env_lhs lhs
; new_rhs <- zonkLExpr env_inside rhs
; return (HsRule fvs name act new_bndrs new_lhs new_rhs ) }
where
zonk_bndr env (L l (RuleBndr x (L loc v)))
= do { (env', v') <- zonk_it env v
; return (env', L l (RuleBndr x (L loc v'))) }
zonk_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_bndr RuleBndrSig"
zonk_bndr _ (L _ (XRuleBndr {})) = panic "zonk_bndr XRuleBndr"
zonk_it env v
| isId v = do { v' <- zonkIdBndr env v
; return (extendIdZonkEnvRec env [v'], v') }
| otherwise = ASSERT( isImmutableTyVar v)
zonkTyBndrX env v
zonkRule _ (XRuleDecl _) = panic "zonkRule"
zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
zonkEvTerm env (EvExpr e)
= EvExpr <$> zonkCoreExpr env e
zonkEvTerm env (EvTypeable ty ev)
= EvTypeable <$> zonkTcTypeToType env ty <*> zonkEvTypeable env ev
zonkEvTerm env (EvFun { et_tvs = tvs, et_given = evs
, et_binds = ev_binds, et_body = body_id })
= do { (env0, new_tvs) <- zonkTyBndrsX env tvs
; (env1, new_evs) <- zonkEvBndrsX env0 evs
; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
; let new_body_id = zonkIdOcc env2 body_id
; return (EvFun { et_tvs = new_tvs, et_given = new_evs
, et_binds = new_ev_binds, et_body = new_body_id }) }
zonkCoreExpr :: ZonkEnv -> CoreExpr -> TcM CoreExpr
zonkCoreExpr env (Var v)
| isCoVar v
= Coercion <$> zonkCoVarOcc env v
| otherwise
= return (Var $ zonkIdOcc env v)
zonkCoreExpr _ (Lit l)
= return $ Lit l
zonkCoreExpr env (Coercion co)
= Coercion <$> zonkCoToCo env co
zonkCoreExpr env (Type ty)
= Type <$> zonkTcTypeToType env ty
zonkCoreExpr env (Cast e co)
= Cast <$> zonkCoreExpr env e <*> zonkCoToCo env co
zonkCoreExpr env (Tick t e)
= Tick t <$> zonkCoreExpr env e
zonkCoreExpr env (App e1 e2)
= App <$> zonkCoreExpr env e1 <*> zonkCoreExpr env e2
zonkCoreExpr env (Lam v e)
= do { (env1, v') <- zonkCoreBndrX env v
; Lam v' <$> zonkCoreExpr env1 e }
zonkCoreExpr env (Let bind e)
= do (env1, bind') <- zonkCoreBind env bind
Let bind'<$> zonkCoreExpr env1 e
zonkCoreExpr env (Case scrut b ty alts)
= do scrut' <- zonkCoreExpr env scrut
ty' <- zonkTcTypeToType env ty
b' <- zonkIdBndr env b
let env1 = extendIdZonkEnv1 env b'
alts' <- mapM (zonkCoreAlt env1) alts
return $ Case scrut' b' ty' alts'
zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt
zonkCoreAlt env (dc, bndrs, rhs)
= do (env1, bndrs') <- zonkCoreBndrsX env bndrs
rhs' <- zonkCoreExpr env1 rhs
return $ (dc, bndrs', rhs')
zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind)
zonkCoreBind env (NonRec v e)
= do v' <- zonkIdBndr env v
e' <- zonkCoreExpr env e
let env1 = extendIdZonkEnv1 env v'
return (env1, NonRec v' e')
zonkCoreBind env (Rec pairs)
= do (env1, pairs') <- fixM go
return (env1, Rec pairs')
where
go ~(_, new_pairs) = do
let env1 = extendIdZonkEnvRec env (map fst new_pairs)
pairs' <- mapM (zonkCorePair env1) pairs
return (env1, pairs')
zonkCorePair :: ZonkEnv -> (CoreBndr, CoreExpr) -> TcM (CoreBndr, CoreExpr)
zonkCorePair env (v,e) = (,) <$> zonkIdBndr env v <*> zonkCoreExpr env e
zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
zonkEvTypeable env (EvTypeableTyCon tycon e)
= do { e' <- mapM (zonkEvTerm env) e
; return $ EvTypeableTyCon tycon e' }
zonkEvTypeable env (EvTypeableTyApp t1 t2)
= do { t1' <- zonkEvTerm env t1
; t2' <- zonkEvTerm env t2
; return (EvTypeableTyApp t1' t2') }
zonkEvTypeable env (EvTypeableTrFun t1 t2)
= do { t1' <- zonkEvTerm env t1
; t2' <- zonkEvTerm env t2
; return (EvTypeableTrFun t1' t2') }
zonkEvTypeable env (EvTypeableTyLit t1)
= do { t1' <- zonkEvTerm env t1
; return (EvTypeableTyLit t1') }
zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs
; return (env, [EvBinds (unionManyBags bs')]) }
zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs
; return (env', EvBinds bs') }
zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind)
zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var
zonk_tc_ev_binds env (EvBinds bs) = zonkEvBinds env bs
zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
zonkEvBindsVar env (EvBindsVar { ebv_binds = ref })
= do { bs <- readMutVar ref
; zonkEvBinds env (evBindMapBinds bs) }
zonkEvBindsVar env (NoEvBindsVar {}) = return (env, emptyBag)
zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
zonkEvBinds env binds
=
fixM (\ ~( _, new_binds) -> do
{ let env1 = extendIdZonkEnvRec env (collect_ev_bndrs new_binds)
; binds' <- mapBagM (zonkEvBind env1) binds
; return (env1, binds') })
where
collect_ev_bndrs :: Bag EvBind -> [EvVar]
collect_ev_bndrs = foldrBag add []
add (EvBind { eb_lhs = var }) vars = var : vars
zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term })
= do { var' <- zonkEvBndr env var
; term' <- case getEqPredTys_maybe (idType var') of
Just (r, ty1, ty2) | ty1 `eqType` ty2
-> return (evCoercion (mkTcReflCo r ty1))
_other -> zonkEvTerm env term
; return (bind { eb_lhs = var', eb_rhs = term' }) }
zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType
zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv
| isTcTyVar tv
= case tcTyVarDetails tv of
SkolemTv {} -> lookup_in_env
RuntimeUnk {} -> lookup_in_env
MetaTv { mtv_ref = ref }
-> do { cts <- readMutVar ref
; case cts of
Flexi -> do { kind <-
zonkTcTypeToType env (tyVarKind tv)
; zonk_unbound_tyvar (setTyVarKind tv kind) }
Indirect ty -> do { zty <- zonkTcTypeToType env ty
; writeMutVar ref (Indirect zty)
; return zty } }
| otherwise
= lookup_in_env
where
lookup_in_env
= case lookupVarEnv tv_env tv of
Nothing -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToType env) tv
Just tv' -> return (mkTyVarTy tv')
zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion
zonkCoVarOcc (ZonkEnv _ tyco_env _) cv
| Just cv' <- lookupVarEnv tyco_env cv
= return $ mkCoVarCo cv'
| otherwise
= do { cv' <- zonkCoVar cv; return (mkCoVarCo cv') }
zonkCoHole :: ZonkEnv -> CoercionHole -> TcM Coercion
zonkCoHole env hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })
= do { contents <- readTcRef ref
; case contents of
Just co -> do { co' <- zonkCoToCo env co
; checkCoercionHole cv co' }
Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole)
; when debugIsOn $
whenNoErrs $
MASSERT2( False
, text "Type-correct unfilled coercion hole"
<+> ppr hole )
; cv' <- zonkCoVar cv
; return $ mkCoVarCo cv' } }
zonk_tycomapper :: TyCoMapper ZonkEnv TcM
zonk_tycomapper = TyCoMapper
{ tcm_smart = True
, tcm_tyvar = zonkTyVarOcc
, tcm_covar = zonkCoVarOcc
, tcm_hole = zonkCoHole
, tcm_tybinder = \env tv _vis -> zonkTyBndrX env tv
, tcm_tycon = zonkTcTyConToTyCon }
zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon
zonkTcTyConToTyCon tc
| isTcTyCon tc = do { thing <- tcLookupGlobalOnly (getName tc)
; case thing of
ATyCon real_tc -> return real_tc
_ -> pprPanic "zonkTcTyCon" (ppr tc $$ ppr thing) }
| otherwise = return tc
zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
zonkTcTypeToType = mapType zonk_tycomapper
zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion
zonkCoToCo = mapCoercion zonk_tycomapper
zonkTcMethInfoToMethInfo :: TcMethInfo -> TcM MethInfo
zonkTcMethInfoToMethInfo (name, ty, gdm_spec)
= do { ty' <- zonkTcTypeToType emptyZonkEnv ty
; gdm_spec' <- zonk_gdm gdm_spec
; return (name, ty', gdm_spec') }
where
zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType))
-> TcM (Maybe (DefMethSpec (SrcSpan, Type)))
zonk_gdm Nothing = return Nothing
zonk_gdm (Just VanillaDM) = return (Just VanillaDM)
zonk_gdm (Just (GenericDM (loc, ty)))
= do { ty' <- zonkTcTypeToType emptyZonkEnv ty
; return (Just (GenericDM (loc, ty'))) }
zonkTvSkolemising :: UnboundTyVarZonker
zonkTvSkolemising tv
= do { let tv' = mkTyVar (tyVarName tv) (tyVarKind tv)
ty = mkTyVarTy tv'
; writeMetaTyVar tv ty
; return ty }
zonkTypeZapping :: UnboundTyVarZonker
zonkTypeZapping tv
= do { let ty | isRuntimeRepVar tv = liftedRepTy
| otherwise = anyTypeOfKind (tyVarKind tv)
; writeMetaTyVar tv ty
; return ty }