{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Tc.Utils.Zonk (
hsLitType, hsPatType, hsLPatType,
mkHsDictLet, mkHsApp,
mkHsAppTy, mkHsCaseAlt,
tcShortCutLit, shortCutLit, hsOverLitName,
conLikeResTy,
TcId, TcIdSet,
zonkTopDecls, zonkTopExpr, zonkTopLExpr,
zonkTopBndrs,
ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv,
zonkTyVarBindersX, zonkTyVarBinderX,
zonkTyBndrs, zonkTyBndrsX,
zonkTcTypeToType, zonkTcTypeToTypeX,
zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX,
zonkTyVarOcc,
zonkCoToCo,
zonkEvBinds, zonkTcEvBinds,
zonkTcMethInfoToMethInfoX,
lookupTyVarOcc
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Platform
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Builtin.Names
import GHC.Hs
import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice)
import GHC.Tc.Utils.Monad
import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo )
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.Env ( tcLookupGlobalOnly )
import GHC.Tc.Types.Evidence
import GHC.Core.TyCo.Ppr ( pprTyVar )
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Core.Multiplicity
import GHC.Core
import GHC.Core.Predicate
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.TypeEnv
import GHC.Types.SourceText
import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Types.Unique.FM
import GHC.Types.TyThing
import GHC.Driver.Session( getDynFlags, targetPlatform )
import GHC.Data.Maybe
import GHC.Data.Bag
import Control.Monad
import Data.List ( partition )
import Control.Arrow ( second )
hsLPatType :: LPat GhcTc -> Type
hsLPatType :: LPat GhcTc -> Kind
hsLPatType (L SrcSpanAnnA
_ Pat GhcTc
p) = Pat GhcTc -> Kind
hsPatType Pat GhcTc
p
hsPatType :: Pat GhcTc -> Type
hsPatType :: Pat GhcTc -> Kind
hsPatType (ParPat XParPat GhcTc
_ LPat GhcTc
pat) = LPat GhcTc -> Kind
hsLPatType LPat GhcTc
pat
hsPatType (WildPat XWildPat GhcTc
ty) = XWildPat GhcTc
ty
hsPatType (VarPat XVarPat GhcTc
_ LIdP GhcTc
lvar) = TcTyVar -> Kind
idType (forall l e. GenLocated l e -> e
unLoc LIdP GhcTc
lvar)
hsPatType (BangPat XBangPat GhcTc
_ LPat GhcTc
pat) = LPat GhcTc -> Kind
hsLPatType LPat GhcTc
pat
hsPatType (LazyPat XLazyPat GhcTc
_ LPat GhcTc
pat) = LPat GhcTc -> Kind
hsLPatType LPat GhcTc
pat
hsPatType (LitPat XLitPat GhcTc
_ HsLit GhcTc
lit) = forall (p :: Pass). HsLit (GhcPass p) -> Kind
hsLitType HsLit GhcTc
lit
hsPatType (AsPat XAsPat GhcTc
_ LIdP GhcTc
var LPat GhcTc
_) = TcTyVar -> Kind
idType (forall l e. GenLocated l e -> e
unLoc LIdP GhcTc
var)
hsPatType (ViewPat XViewPat GhcTc
ty LHsExpr GhcTc
_ LPat GhcTc
_) = XViewPat GhcTc
ty
hsPatType (ListPat (ListPatTc Kind
ty Maybe (Kind, SyntaxExpr GhcTc)
Nothing) [LPat GhcTc]
_) = Kind -> Kind
mkListTy Kind
ty
hsPatType (ListPat (ListPatTc Kind
_ (Just (Kind
ty,SyntaxExpr GhcTc
_))) [LPat GhcTc]
_) = Kind
ty
hsPatType (TuplePat XTuplePat GhcTc
tys [LPat GhcTc]
_ Boxity
bx) = Boxity -> [Kind] -> Kind
mkTupleTy1 Boxity
bx XTuplePat GhcTc
tys
hsPatType (SumPat XSumPat GhcTc
tys LPat GhcTc
_ ConTag
_ ConTag
_ ) = [Kind] -> Kind
mkSumTy XSumPat GhcTc
tys
hsPatType (ConPat { pat_con :: forall p. Pat p -> XRec p (ConLikeP p)
pat_con = XRec GhcTc (ConLikeP GhcTc)
lcon
, pat_con_ext :: forall p. Pat p -> XConPat p
pat_con_ext = ConPatTc
{ cpt_arg_tys :: ConPatTc -> [Kind]
cpt_arg_tys = [Kind]
tys
}
})
= ConLike -> [Kind] -> Kind
conLikeResTy (forall l e. GenLocated l e -> e
unLoc XRec GhcTc (ConLikeP GhcTc)
lcon) [Kind]
tys
hsPatType (SigPat XSigPat GhcTc
ty LPat GhcTc
_ HsPatSigType (NoGhcTc GhcTc)
_) = XSigPat GhcTc
ty
hsPatType (NPat XNPat GhcTc
ty XRec GhcTc (HsOverLit GhcTc)
_ Maybe (SyntaxExpr GhcTc)
_ SyntaxExpr GhcTc
_) = XNPat GhcTc
ty
hsPatType (NPlusKPat XNPlusKPat GhcTc
ty LIdP GhcTc
_ XRec GhcTc (HsOverLit GhcTc)
_ HsOverLit GhcTc
_ SyntaxExpr GhcTc
_ SyntaxExpr GhcTc
_) = XNPlusKPat GhcTc
ty
hsPatType (XPat (CoPat HsWrapper
_ Pat GhcTc
_ Kind
ty)) = Kind
ty
hsPatType SplicePat{} = forall a. String -> a
panic String
"hsPatType: SplicePat"
hsLitType :: HsLit (GhcPass p) -> TcType
hsLitType :: forall (p :: Pass). HsLit (GhcPass p) -> Kind
hsLitType (HsChar XHsChar (GhcPass p)
_ Char
_) = Kind
charTy
hsLitType (HsCharPrim XHsCharPrim (GhcPass p)
_ Char
_) = Kind
charPrimTy
hsLitType (HsString XHsString (GhcPass p)
_ FastString
_) = Kind
stringTy
hsLitType (HsStringPrim XHsStringPrim (GhcPass p)
_ ByteString
_) = Kind
addrPrimTy
hsLitType (HsInt XHsInt (GhcPass p)
_ IntegralLit
_) = Kind
intTy
hsLitType (HsIntPrim XHsIntPrim (GhcPass p)
_ Integer
_) = Kind
intPrimTy
hsLitType (HsWordPrim XHsWordPrim (GhcPass p)
_ Integer
_) = Kind
wordPrimTy
hsLitType (HsInt64Prim XHsInt64Prim (GhcPass p)
_ Integer
_) = Kind
int64PrimTy
hsLitType (HsWord64Prim XHsWord64Prim (GhcPass p)
_ Integer
_) = Kind
word64PrimTy
hsLitType (HsInteger XHsInteger (GhcPass p)
_ Integer
_ Kind
ty) = Kind
ty
hsLitType (HsRat XHsRat (GhcPass p)
_ FractionalLit
_ Kind
ty) = Kind
ty
hsLitType (HsFloatPrim XHsFloatPrim (GhcPass p)
_ FractionalLit
_) = Kind
floatPrimTy
hsLitType (HsDoublePrim XHsDoublePrim (GhcPass p)
_ FractionalLit
_) = Kind
doublePrimTy
tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc))
tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc))
tcShortCutLit lit :: HsOverLit GhcRn
lit@(OverLit { ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val = OverLitVal
val, ol_ext :: forall p. HsOverLit p -> XOverLit p
ol_ext = XOverLit GhcRn
rebindable }) ExpRhoType
exp_res_ty
| Bool -> Bool
not XOverLit GhcRn
rebindable
, Just Kind
res_ty <- ExpRhoType -> Maybe Kind
checkingExpType_maybe ExpRhoType
exp_res_ty
= do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
; case Platform -> OverLitVal -> Kind -> Maybe (HsExpr GhcTc)
shortCutLit Platform
platform OverLitVal
val Kind
res_ty of
Just HsExpr GhcTc
expr -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
HsOverLit GhcRn
lit { ol_witness :: HsExpr GhcTc
ol_witness = HsExpr GhcTc
expr
, ol_ext :: XOverLit GhcTc
ol_ext = Bool -> Kind -> OverLitTc
OverLitTc Bool
False Kind
res_ty }
Maybe (HsExpr GhcTc)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing }
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTc)
shortCutLit :: Platform -> OverLitVal -> Kind -> Maybe (HsExpr GhcTc)
shortCutLit Platform
platform OverLitVal
val Kind
res_ty
= case OverLitVal
val of
HsIntegral IntegralLit
int_lit -> IntegralLit -> Maybe (HsExpr GhcTc)
go_integral IntegralLit
int_lit
HsFractional FractionalLit
frac_lit -> FractionalLit -> Maybe (HsExpr GhcTc)
go_fractional FractionalLit
frac_lit
HsIsString SourceText
s FastString
src -> SourceText -> FastString -> Maybe (HsExpr GhcTc)
go_string SourceText
s FastString
src
where
go_integral :: IntegralLit -> Maybe (HsExpr GhcTc)
go_integral int :: IntegralLit
int@(IL SourceText
src Bool
neg Integer
i)
| Kind -> Bool
isIntTy Kind
res_ty Bool -> Bool -> Bool
&& Platform -> Integer -> Bool
platformInIntRange Platform
platform Integer
i
= forall a. a -> Maybe a
Just (forall p. XLitE p -> HsLit p -> HsExpr p
HsLit forall a. EpAnn a
noAnn (forall x. XHsInt x -> IntegralLit -> HsLit x
HsInt NoExtField
noExtField IntegralLit
int))
| Kind -> Bool
isWordTy Kind
res_ty Bool -> Bool -> Bool
&& Platform -> Integer -> Bool
platformInWordRange Platform
platform Integer
i
= forall a. a -> Maybe a
Just (DataCon -> HsLit GhcTc -> HsExpr GhcTc
mkLit DataCon
wordDataCon (forall x. XHsWordPrim x -> Integer -> HsLit x
HsWordPrim SourceText
src Integer
i))
| Kind -> Bool
isIntegerTy Kind
res_ty
= forall a. a -> Maybe a
Just (forall p. XLitE p -> HsLit p -> HsExpr p
HsLit forall a. EpAnn a
noAnn (forall x. XHsInteger x -> Integer -> Kind -> HsLit x
HsInteger SourceText
src Integer
i Kind
res_ty))
| Bool
otherwise
= FractionalLit -> Maybe (HsExpr GhcTc)
go_fractional (Bool -> Integer -> FractionalLit
integralFractionalLit Bool
neg Integer
i)
go_fractional :: FractionalLit -> Maybe (HsExpr GhcTc)
go_fractional FractionalLit
f
| Kind -> Bool
isFloatTy Kind
res_ty Bool -> Bool -> Bool
&& Bool
valueInRange = forall a. a -> Maybe a
Just (DataCon -> HsLit GhcTc -> HsExpr GhcTc
mkLit DataCon
floatDataCon (forall x. XHsFloatPrim x -> FractionalLit -> HsLit x
HsFloatPrim NoExtField
noExtField FractionalLit
f))
| Kind -> Bool
isDoubleTy Kind
res_ty Bool -> Bool -> Bool
&& Bool
valueInRange = forall a. a -> Maybe a
Just (DataCon -> HsLit GhcTc -> HsExpr GhcTc
mkLit DataCon
doubleDataCon (forall x. XHsDoublePrim x -> FractionalLit -> HsLit x
HsDoublePrim NoExtField
noExtField FractionalLit
f))
| Bool
otherwise = forall a. Maybe a
Nothing
where
valueInRange :: Bool
valueInRange =
case FractionalLit
f of
FL { fl_exp :: FractionalLit -> Integer
fl_exp = Integer
e } -> (-Integer
100) forall a. Ord a => a -> a -> Bool
<= Integer
e Bool -> Bool -> Bool
&& Integer
e forall a. Ord a => a -> a -> Bool
<= Integer
100
go_string :: SourceText -> FastString -> Maybe (HsExpr GhcTc)
go_string SourceText
src FastString
s
| Kind -> Bool
isStringTy Kind
res_ty = forall a. a -> Maybe a
Just (forall p. XLitE p -> HsLit p -> HsExpr p
HsLit forall a. EpAnn a
noAnn (forall x. XHsString x -> FastString -> HsLit x
HsString SourceText
src FastString
s))
| Bool
otherwise = forall a. Maybe a
Nothing
mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc
mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc
mkLit DataCon
con HsLit GhcTc
lit = forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp EpAnnCO
noComments (DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
con) (forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit HsLit GhcTc
lit)
hsOverLitName :: OverLitVal -> Name
hsOverLitName :: OverLitVal -> Name
hsOverLitName (HsIntegral {}) = Name
fromIntegerName
hsOverLitName (HsFractional {}) = Name
fromRationalName
hsOverLitName (HsIsString {}) = Name
fromStringName
data ZonkEnv
= ZonkEnv { ZonkEnv -> ZonkFlexi
ze_flexi :: ZonkFlexi
, ZonkEnv -> TyCoVarEnv TcTyVar
ze_tv_env :: TyCoVarEnv TyCoVar
, ZonkEnv -> TyCoVarEnv TcTyVar
ze_id_env :: IdEnv Id
, ZonkEnv -> TcRef (TyVarEnv Kind)
ze_meta_tv_env :: TcRef (TyVarEnv Type) }
data ZonkFlexi
= DefaultFlexi
| SkolemiseFlexi
| RuntimeUnkFlexi
| NoFlexi
instance Outputable ZonkEnv where
ppr :: ZonkEnv -> SDoc
ppr (ZonkEnv { ze_tv_env :: ZonkEnv -> TyCoVarEnv TcTyVar
ze_tv_env = TyCoVarEnv TcTyVar
tv_env
, ze_id_env :: ZonkEnv -> TyCoVarEnv TcTyVar
ze_id_env = TyCoVarEnv TcTyVar
id_env })
= String -> SDoc
text String
"ZE" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"ze_tv_env =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyCoVarEnv TcTyVar
tv_env
, String -> SDoc
text String
"ze_id_env =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyCoVarEnv TcTyVar
id_env ])
emptyZonkEnv :: TcM ZonkEnv
emptyZonkEnv :: TcM ZonkEnv
emptyZonkEnv = ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
DefaultFlexi
mkEmptyZonkEnv :: ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv :: ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
flexi
= do { TcRef (TyVarEnv Kind)
mtv_env_ref <- forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef forall a. VarEnv a
emptyVarEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv { ze_flexi :: ZonkFlexi
ze_flexi = ZonkFlexi
flexi
, ze_tv_env :: TyCoVarEnv TcTyVar
ze_tv_env = forall a. VarEnv a
emptyVarEnv
, ze_id_env :: TyCoVarEnv TcTyVar
ze_id_env = forall a. VarEnv a
emptyVarEnv
, ze_meta_tv_env :: TcRef (TyVarEnv Kind)
ze_meta_tv_env = TcRef (TyVarEnv Kind)
mtv_env_ref }) }
initZonkEnv :: (ZonkEnv -> TcM b) -> TcM b
initZonkEnv :: forall b. (ZonkEnv -> TcM b) -> TcM b
initZonkEnv ZonkEnv -> TcM b
thing_inside = do { ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
DefaultFlexi
; ZonkEnv -> TcM b
thing_inside ZonkEnv
ze }
extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv
extendIdZonkEnvRec :: ZonkEnv -> [TcTyVar] -> ZonkEnv
extendIdZonkEnvRec ze :: ZonkEnv
ze@(ZonkEnv { ze_id_env :: ZonkEnv -> TyCoVarEnv TcTyVar
ze_id_env = TyCoVarEnv TcTyVar
id_env }) [TcTyVar]
ids
= ZonkEnv
ze { ze_id_env :: TyCoVarEnv TcTyVar
ze_id_env = forall a. VarEnv a -> [(TcTyVar, a)] -> VarEnv a
extendVarEnvList TyCoVarEnv TcTyVar
id_env [(TcTyVar
id,TcTyVar
id) | TcTyVar
id <- [TcTyVar]
ids] }
extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
extendZonkEnv :: ZonkEnv -> [TcTyVar] -> ZonkEnv
extendZonkEnv ze :: ZonkEnv
ze@(ZonkEnv { ze_tv_env :: ZonkEnv -> TyCoVarEnv TcTyVar
ze_tv_env = TyCoVarEnv TcTyVar
tyco_env, ze_id_env :: ZonkEnv -> TyCoVarEnv TcTyVar
ze_id_env = TyCoVarEnv TcTyVar
id_env }) [TcTyVar]
vars
= ZonkEnv
ze { ze_tv_env :: TyCoVarEnv TcTyVar
ze_tv_env = forall a. VarEnv a -> [(TcTyVar, a)] -> VarEnv a
extendVarEnvList TyCoVarEnv TcTyVar
tyco_env [(TcTyVar
tv,TcTyVar
tv) | TcTyVar
tv <- [TcTyVar]
tycovars]
, ze_id_env :: TyCoVarEnv TcTyVar
ze_id_env = forall a. VarEnv a -> [(TcTyVar, a)] -> VarEnv a
extendVarEnvList TyCoVarEnv TcTyVar
id_env [(TcTyVar
id,TcTyVar
id) | TcTyVar
id <- [TcTyVar]
ids] }
where
([TcTyVar]
tycovars, [TcTyVar]
ids) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition TcTyVar -> Bool
isTyCoVar [TcTyVar]
vars
extendIdZonkEnv :: ZonkEnv -> Var -> ZonkEnv
extendIdZonkEnv :: ZonkEnv -> TcTyVar -> ZonkEnv
extendIdZonkEnv ze :: ZonkEnv
ze@(ZonkEnv { ze_id_env :: ZonkEnv -> TyCoVarEnv TcTyVar
ze_id_env = TyCoVarEnv TcTyVar
id_env }) TcTyVar
id
= ZonkEnv
ze { ze_id_env :: TyCoVarEnv TcTyVar
ze_id_env = forall a. VarEnv a -> TcTyVar -> a -> VarEnv a
extendVarEnv TyCoVarEnv TcTyVar
id_env TcTyVar
id TcTyVar
id }
extendTyZonkEnv :: ZonkEnv -> TyVar -> ZonkEnv
extendTyZonkEnv :: ZonkEnv -> TcTyVar -> ZonkEnv
extendTyZonkEnv ze :: ZonkEnv
ze@(ZonkEnv { ze_tv_env :: ZonkEnv -> TyCoVarEnv TcTyVar
ze_tv_env = TyCoVarEnv TcTyVar
ty_env }) TcTyVar
tv
= ZonkEnv
ze { ze_tv_env :: TyCoVarEnv TcTyVar
ze_tv_env = forall a. VarEnv a -> TcTyVar -> a -> VarEnv a
extendVarEnv TyCoVarEnv TcTyVar
ty_env TcTyVar
tv TcTyVar
tv }
setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv
setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv
setZonkType ZonkEnv
ze ZonkFlexi
flexi = ZonkEnv
ze { ze_flexi :: ZonkFlexi
ze_flexi = ZonkFlexi
flexi }
zonkEnvIds :: ZonkEnv -> TypeEnv
zonkEnvIds :: ZonkEnv -> TypeEnv
zonkEnvIds (ZonkEnv { ze_id_env :: ZonkEnv -> TyCoVarEnv TcTyVar
ze_id_env = TyCoVarEnv TcTyVar
id_env})
= forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(forall a. NamedThing a => a -> Name
getName TcTyVar
id, TcTyVar -> TyThing
AnId TcTyVar
id) | TcTyVar
id <- forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM TyCoVarEnv TcTyVar
id_env]
zonkLIdOcc :: ZonkEnv -> LocatedN TcId -> LocatedN Id
zonkLIdOcc :: ZonkEnv
-> GenLocated SrcSpanAnnN TcTyVar -> GenLocated SrcSpanAnnN TcTyVar
zonkLIdOcc ZonkEnv
env = forall a b l. (a -> b) -> GenLocated l a -> GenLocated l b
mapLoc (ZonkEnv -> TcTyVar -> TcTyVar
zonkIdOcc ZonkEnv
env)
zonkIdOcc :: ZonkEnv -> TcId -> Id
zonkIdOcc :: ZonkEnv -> TcTyVar -> TcTyVar
zonkIdOcc (ZonkEnv { ze_id_env :: ZonkEnv -> TyCoVarEnv TcTyVar
ze_id_env = TyCoVarEnv TcTyVar
id_env}) TcTyVar
id
| TcTyVar -> Bool
isLocalVar TcTyVar
id = forall a. VarEnv a -> TcTyVar -> Maybe a
lookupVarEnv TyCoVarEnv TcTyVar
id_env TcTyVar
id forall a. Maybe a -> a -> a
`orElse`
TcTyVar
id
| Bool
otherwise = TcTyVar
id
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
zonkIdOccs :: ZonkEnv -> [TcTyVar] -> [TcTyVar]
zonkIdOccs ZonkEnv
env [TcTyVar]
ids = forall a b. (a -> b) -> [a] -> [b]
map (ZonkEnv -> TcTyVar -> TcTyVar
zonkIdOcc ZonkEnv
env) [TcTyVar]
ids
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
zonkIdBndr :: ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkIdBndr ZonkEnv
env TcTyVar
v
= do Scaled Kind
w' Kind
ty' <- ZonkEnv -> Scaled Kind -> TcM (Scaled Kind)
zonkScaledTcTypeToTypeX ZonkEnv
env (TcTyVar -> Scaled Kind
idScaledType TcTyVar
v)
Kind -> SDoc -> TcM ()
ensureNotLevPoly Kind
ty'
(String -> SDoc
text String
"In the type of binder" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr TcTyVar
v))
forall (m :: * -> *) a. Monad m => a -> m a
return (HasDebugCallStack => (IdInfo -> IdInfo) -> TcTyVar -> TcTyVar
modifyIdInfo (IdInfo -> Kind -> IdInfo
`setLevityInfoWithType` Kind
ty') (TcTyVar -> Kind -> TcTyVar
setIdMult (TcTyVar -> Kind -> TcTyVar
setIdType TcTyVar
v Kind
ty') Kind
w'))
zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
zonkIdBndrs :: ZonkEnv -> [TcTyVar] -> TcM [TcTyVar]
zonkIdBndrs ZonkEnv
env [TcTyVar]
ids = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkIdBndr ZonkEnv
env) [TcTyVar]
ids
zonkTopBndrs :: [TcId] -> TcM [Id]
zonkTopBndrs :: [TcTyVar] -> TcM [TcTyVar]
zonkTopBndrs [TcTyVar]
ids = forall b. (ZonkEnv -> TcM b) -> TcM b
initZonkEnv forall a b. (a -> b) -> a -> b
$ \ ZonkEnv
ze -> ZonkEnv -> [TcTyVar] -> TcM [TcTyVar]
zonkIdBndrs ZonkEnv
ze [TcTyVar]
ids
zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTc -> TcM (FieldOcc GhcTc)
zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTc -> TcM (FieldOcc GhcTc)
zonkFieldOcc ZonkEnv
env (FieldOcc XCFieldOcc GhcTc
sel LocatedN RdrName
lbl)
= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall a b c. (a -> b -> c) -> b -> a -> c
flip forall pass. XCFieldOcc pass -> LocatedN RdrName -> FieldOcc pass
FieldOcc) LocatedN RdrName
lbl) forall a b. (a -> b) -> a -> b
$ ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkIdBndr ZonkEnv
env XCFieldOcc GhcTc
sel
zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
zonkEvBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TcTyVar])
zonkEvBndrsX = forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TcTyVar)
zonkEvBndrX
zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
zonkEvBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TcTyVar)
zonkEvBndrX ZonkEnv
env TcTyVar
var
= do { TcTyVar
var' <- ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkEvBndr ZonkEnv
env TcTyVar
var
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv -> [TcTyVar] -> ZonkEnv
extendZonkEnv ZonkEnv
env [TcTyVar
var'], TcTyVar
var') }
zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
zonkEvBndr :: ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkEvBndr ZonkEnv
env TcTyVar
var
= forall (m :: * -> *).
Monad m =>
(Kind -> m Kind) -> TcTyVar -> m TcTyVar
updateIdTypeAndMultM ({-# SCC "zonkEvBndr_zonkTcTypeToType" #-} ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env) TcTyVar
var
zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var)
zonkCoreBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TcTyVar)
zonkCoreBndrX ZonkEnv
env TcTyVar
v
| TcTyVar -> Bool
isId TcTyVar
v = do { TcTyVar
v' <- ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkIdBndr ZonkEnv
env TcTyVar
v
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv -> TcTyVar -> ZonkEnv
extendIdZonkEnv ZonkEnv
env TcTyVar
v', TcTyVar
v') }
| Bool
otherwise = ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TcTyVar)
zonkTyBndrX ZonkEnv
env TcTyVar
v
zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var])
zonkCoreBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TcTyVar])
zonkCoreBndrsX = forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TcTyVar)
zonkCoreBndrX
zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TcTyVar])
zonkTyBndrs [TcTyVar]
tvs = forall b. (ZonkEnv -> TcM b) -> TcM b
initZonkEnv forall a b. (a -> b) -> a -> b
$ \ZonkEnv
ze -> ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TcTyVar])
zonkTyBndrsX ZonkEnv
ze [TcTyVar]
tvs
zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TcTyVar])
zonkTyBndrsX = forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TcTyVar)
zonkTyBndrX
zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)
zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TcTyVar)
zonkTyBndrX ZonkEnv
env TcTyVar
tv
= ASSERT2( isImmutableTyVar tv, ppr tv <+> dcolon <+> ppr (tyVarKind tv) )
do { Kind
ki <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env (TcTyVar -> Kind
tyVarKind TcTyVar
tv)
; let tv' :: TcTyVar
tv' = Name -> Kind -> TcTyVar
mkTyVar (TcTyVar -> Name
tyVarName TcTyVar
tv) Kind
ki
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv -> TcTyVar -> ZonkEnv
extendTyZonkEnv ZonkEnv
env TcTyVar
tv', TcTyVar
tv') }
zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis]
-> TcM (ZonkEnv, [VarBndr TyVar vis])
zonkTyVarBindersX :: forall vis.
ZonkEnv
-> [VarBndr TcTyVar vis] -> TcM (ZonkEnv, [VarBndr TcTyVar vis])
zonkTyVarBindersX = forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM forall vis.
ZonkEnv
-> VarBndr TcTyVar vis -> TcM (ZonkEnv, VarBndr TcTyVar vis)
zonkTyVarBinderX
zonkTyVarBinderX :: ZonkEnv -> VarBndr TcTyVar vis
-> TcM (ZonkEnv, VarBndr TyVar vis)
zonkTyVarBinderX :: forall vis.
ZonkEnv
-> VarBndr TcTyVar vis -> TcM (ZonkEnv, VarBndr TcTyVar vis)
zonkTyVarBinderX ZonkEnv
env (Bndr TcTyVar
tv vis
vis)
= do { (ZonkEnv
env', TcTyVar
tv') <- ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TcTyVar)
zonkTyBndrX ZonkEnv
env TcTyVar
tv
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env', forall var argf. var -> argf -> VarBndr var argf
Bndr TcTyVar
tv' vis
vis) }
zonkTopExpr :: HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkTopExpr :: HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkTopExpr HsExpr GhcTc
e = forall b. (ZonkEnv -> TcM b) -> TcM b
initZonkEnv forall a b. (a -> b) -> a -> b
$ \ ZonkEnv
ze -> ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkExpr ZonkEnv
ze HsExpr GhcTc
e
zonkTopLExpr :: LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkTopLExpr :: LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkTopLExpr LHsExpr GhcTc
e = forall b. (ZonkEnv -> TcM b) -> TcM b
initZonkEnv forall a b. (a -> b) -> a -> b
$ \ ZonkEnv
ze -> ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
ze LHsExpr GhcTc
e
zonkTopDecls :: Bag EvBind
-> LHsBinds GhcTc
-> [LRuleDecl GhcTc] -> [LTcSpecPrag]
-> [LForeignDecl GhcTc]
-> TcM (TypeEnv,
Bag EvBind,
LHsBinds GhcTc,
[LForeignDecl GhcTc],
[LTcSpecPrag],
[LRuleDecl GhcTc])
zonkTopDecls :: Bag EvBind
-> LHsBinds GhcTc
-> [LRuleDecl GhcTc]
-> [LTcSpecPrag]
-> [LForeignDecl GhcTc]
-> TcM
(TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
[LTcSpecPrag], [LRuleDecl GhcTc])
zonkTopDecls Bag EvBind
ev_binds LHsBinds GhcTc
binds [LRuleDecl GhcTc]
rules [LTcSpecPrag]
imp_specs [LForeignDecl GhcTc]
fords
= do { (ZonkEnv
env1, Bag EvBind
ev_binds') <- forall b. (ZonkEnv -> TcM b) -> TcM b
initZonkEnv forall a b. (a -> b) -> a -> b
$ \ ZonkEnv
ze -> ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
zonkEvBinds ZonkEnv
ze Bag EvBind
ev_binds
; (ZonkEnv
env2, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds') <- ZonkEnv -> LHsBinds GhcTc -> TcM (ZonkEnv, LHsBinds GhcTc)
zonkRecMonoBinds ZonkEnv
env1 LHsBinds GhcTc
binds
; [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
rules' <- ZonkEnv -> [LRuleDecl GhcTc] -> TcM [LRuleDecl GhcTc]
zonkRules ZonkEnv
env2 [LRuleDecl GhcTc]
rules
; [LTcSpecPrag]
specs' <- ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags ZonkEnv
env2 [LTcSpecPrag]
imp_specs
; [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
fords' <- ZonkEnv -> [LForeignDecl GhcTc] -> TcM [LForeignDecl GhcTc]
zonkForeignExports ZonkEnv
env2 [LForeignDecl GhcTc]
fords
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv -> TypeEnv
zonkEnvIds ZonkEnv
env2, Bag EvBind
ev_binds', Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds', [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
fords', [LTcSpecPrag]
specs', [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
rules') }
zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTc
-> TcM (ZonkEnv, HsLocalBinds GhcTc)
zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTc -> TcM (ZonkEnv, HsLocalBinds GhcTc)
zonkLocalBinds ZonkEnv
env (EmptyLocalBinds XEmptyLocalBinds GhcTc GhcTc
x)
= forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, (forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcTc GhcTc
x))
zonkLocalBinds ZonkEnv
_ (HsValBinds XHsValBinds GhcTc GhcTc
_ (ValBinds {}))
= forall a. String -> a
panic String
"zonkLocalBinds"
zonkLocalBinds ZonkEnv
env (HsValBinds XHsValBinds GhcTc GhcTc
x (XValBindsLR (NValBinds [(RecFlag, LHsBinds GhcTc)]
binds [LSig GhcRn]
sigs)))
= do { (ZonkEnv
env1, [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
new_binds) <- forall {a}.
ZonkEnv
-> [(a, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(ZonkEnv,
[(a, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))])
go ZonkEnv
env [(RecFlag, LHsBinds GhcTc)]
binds
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env1, forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcTc GhcTc
x (forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
XValBindsLR (forall idL.
[(RecFlag, LHsBinds idL)] -> [LSig GhcRn] -> NHsValBindsLR idL
NValBinds [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
new_binds [LSig GhcRn]
sigs))) }
where
go :: ZonkEnv
-> [(a, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(ZonkEnv,
[(a, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))])
go ZonkEnv
env []
= forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, [])
go ZonkEnv
env ((a
r,Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
b):[(a, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
bs)
= do { (ZonkEnv
env1, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
b') <- ZonkEnv -> LHsBinds GhcTc -> TcM (ZonkEnv, LHsBinds GhcTc)
zonkRecMonoBinds ZonkEnv
env Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
b
; (ZonkEnv
env2, [(a, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
bs') <- ZonkEnv
-> [(a, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(ZonkEnv,
[(a, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))])
go ZonkEnv
env1 [(a, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
bs
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env2, (a
r,Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
b')forall a. a -> [a] -> [a]
:[(a, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
bs') }
zonkLocalBinds ZonkEnv
env (HsIPBinds XHsIPBinds GhcTc GhcTc
x (IPBinds XIPBinds GhcTc
dict_binds [LIPBind GhcTc]
binds )) = do
[GenLocated SrcSpanAnnA (IPBind GhcTc)]
new_binds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA IPBind GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (IPBind GhcTc)
zonk_ip_bind) [LIPBind GhcTc]
binds
let
env1 :: ZonkEnv
env1 = ZonkEnv -> [TcTyVar] -> ZonkEnv
extendIdZonkEnvRec ZonkEnv
env
[ IdP GhcTc
n | (L SrcSpanAnnA
_ (IPBind XCIPBind GhcTc
_ (Right IdP GhcTc
n) LHsExpr GhcTc
_)) <- [GenLocated SrcSpanAnnA (IPBind GhcTc)]
new_binds]
(ZonkEnv
env2, TcEvBinds
new_dict_binds) <- ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
zonkTcEvBinds ZonkEnv
env1 XIPBinds GhcTc
dict_binds
forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env2, forall idL idR.
XHsIPBinds idL idR -> HsIPBinds idR -> HsLocalBindsLR idL idR
HsIPBinds XHsIPBinds GhcTc GhcTc
x (forall id. XIPBinds id -> [LIPBind id] -> HsIPBinds id
IPBinds TcEvBinds
new_dict_binds [GenLocated SrcSpanAnnA (IPBind GhcTc)]
new_binds))
where
zonk_ip_bind :: IPBind GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (IPBind GhcTc)
zonk_ip_bind (IPBind XCIPBind GhcTc
x Either (XRec GhcTc HsIPName) (IdP GhcTc)
n LHsExpr GhcTc
e)
= do Either (Located HsIPName) TcTyVar
n' <- forall a b.
(a -> TcM b)
-> Either (Located HsIPName) a -> TcM (Either (Located HsIPName) b)
mapIPNameTc (ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkIdBndr ZonkEnv
env) Either (XRec GhcTc HsIPName) (IdP GhcTc)
n
LocatedA (HsExpr GhcTc)
e' <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e
forall (m :: * -> *) a. Monad m => a -> m a
return (forall id.
XCIPBind id
-> Either (XRec id HsIPName) (IdP id) -> LHsExpr id -> IPBind id
IPBind XCIPBind GhcTc
x Either (Located HsIPName) TcTyVar
n' LocatedA (HsExpr GhcTc)
e')
zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (ZonkEnv, LHsBinds GhcTc)
zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (ZonkEnv, LHsBinds GhcTc)
zonkRecMonoBinds ZonkEnv
env LHsBinds GhcTc
binds
= forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM (\ ~(ZonkEnv
_, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
new_binds) -> do
{ let env1 :: ZonkEnv
env1 = ZonkEnv -> [TcTyVar] -> ZonkEnv
extendIdZonkEnvRec ZonkEnv
env (forall p idR.
CollectPass p =>
CollectFlag p -> LHsBindsLR p idR -> [IdP p]
collectHsBindsBinders forall p. CollectFlag p
CollNoDictBinders Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
new_binds)
; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds' <- ZonkEnv -> LHsBinds GhcTc -> TcM (LHsBinds GhcTc)
zonkMonoBinds ZonkEnv
env1 LHsBinds GhcTc
binds
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env1, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds') })
zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (LHsBinds GhcTc)
zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (LHsBinds GhcTc)
zonkMonoBinds ZonkEnv
env LHsBinds GhcTc
binds = forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM (ZonkEnv -> LHsBind GhcTc -> TcM (LHsBind GhcTc)
zonk_lbind ZonkEnv
env) LHsBinds GhcTc
binds
zonk_lbind :: ZonkEnv -> LHsBind GhcTc -> TcM (LHsBind GhcTc)
zonk_lbind :: ZonkEnv -> LHsBind GhcTc -> TcM (LHsBind GhcTc)
zonk_lbind ZonkEnv
env = forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA (ZonkEnv -> HsBindLR GhcTc GhcTc -> TcM (HsBindLR GhcTc GhcTc)
zonk_bind ZonkEnv
env)
zonk_bind :: ZonkEnv -> HsBind GhcTc -> TcM (HsBind GhcTc)
zonk_bind :: ZonkEnv -> HsBindLR GhcTc GhcTc -> TcM (HsBindLR GhcTc GhcTc)
zonk_bind ZonkEnv
env bind :: HsBindLR GhcTc GhcTc
bind@(PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = LPat GhcTc
pat, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs = GRHSs GhcTc (LHsExpr GhcTc)
grhss
, pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_ext = XPatBind GhcTc GhcTc
ty})
= do { (ZonkEnv
_env, GenLocated SrcSpanAnnA (Pat GhcTc)
new_pat) <- ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
zonkPat ZonkEnv
env LPat GhcTc
pat
; GRHSs GhcTc (LocatedA (HsExpr GhcTc))
new_grhss <- forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> GRHSs GhcTc (LocatedA (body GhcTc))
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
zonkGRHSs ZonkEnv
env ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr GRHSs GhcTc (LHsExpr GhcTc)
grhss
; Kind
new_ty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env XPatBind GhcTc GhcTc
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsBindLR GhcTc GhcTc
bind { pat_lhs :: LPat GhcTc
pat_lhs = GenLocated SrcSpanAnnA (Pat GhcTc)
new_pat, pat_rhs :: GRHSs GhcTc (LHsExpr GhcTc)
pat_rhs = GRHSs GhcTc (LocatedA (HsExpr GhcTc))
new_grhss
, pat_ext :: XPatBind GhcTc GhcTc
pat_ext = Kind
new_ty }) }
zonk_bind ZonkEnv
env (VarBind { var_ext :: forall idL idR. HsBindLR idL idR -> XVarBind idL idR
var_ext = XVarBind GhcTc GhcTc
x
, var_id :: forall idL idR. HsBindLR idL idR -> IdP idL
var_id = IdP GhcTc
var, var_rhs :: forall idL idR. HsBindLR idL idR -> LHsExpr idR
var_rhs = LHsExpr GhcTc
expr })
= do { TcTyVar
new_var <- ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkIdBndr ZonkEnv
env IdP GhcTc
var
; LocatedA (HsExpr GhcTc)
new_expr <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
expr
; forall (m :: * -> *) a. Monad m => a -> m a
return (VarBind { var_ext :: XVarBind GhcTc GhcTc
var_ext = XVarBind GhcTc GhcTc
x
, var_id :: IdP GhcTc
var_id = TcTyVar
new_var
, var_rhs :: LHsExpr GhcTc
var_rhs = LocatedA (HsExpr GhcTc)
new_expr }) }
zonk_bind ZonkEnv
env bind :: HsBindLR GhcTc GhcTc
bind@(FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
loc TcTyVar
var
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
ms
, fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_ext = XFunBind GhcTc GhcTc
co_fn })
= do { TcTyVar
new_var <- ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkIdBndr ZonkEnv
env TcTyVar
var
; (ZonkEnv
env1, HsWrapper
new_co_fn) <- ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn ZonkEnv
env XFunBind GhcTc GhcTc
co_fn
; MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
new_ms <- forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
zonkMatchGroup ZonkEnv
env1 ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr MatchGroup GhcTc (LHsExpr GhcTc)
ms
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsBindLR GhcTc GhcTc
bind { fun_id :: LIdP GhcTc
fun_id = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc TcTyVar
new_var
, fun_matches :: MatchGroup GhcTc (LHsExpr GhcTc)
fun_matches = MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
new_ms
, fun_ext :: XFunBind GhcTc GhcTc
fun_ext = HsWrapper
new_co_fn }) }
zonk_bind ZonkEnv
env (AbsBinds { abs_tvs :: forall idL idR. HsBindLR idL idR -> [TcTyVar]
abs_tvs = [TcTyVar]
tyvars, abs_ev_vars :: forall idL idR. HsBindLR idL idR -> [TcTyVar]
abs_ev_vars = [TcTyVar]
evs
, abs_ev_binds :: forall idL idR. HsBindLR idL idR -> [TcEvBinds]
abs_ev_binds = [TcEvBinds]
ev_binds
, abs_exports :: forall idL idR. HsBindLR idL idR -> [ABExport idL]
abs_exports = [ABExport GhcTc]
exports
, abs_binds :: forall idL idR. HsBindLR idL idR -> LHsBinds idL
abs_binds = LHsBinds GhcTc
val_binds
, abs_sig :: forall idL idR. HsBindLR idL idR -> Bool
abs_sig = Bool
has_sig })
= ASSERT( all isImmutableTyVar tyvars )
do { (ZonkEnv
env0, [TcTyVar]
new_tyvars) <- ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TcTyVar])
zonkTyBndrsX ZonkEnv
env [TcTyVar]
tyvars
; (ZonkEnv
env1, [TcTyVar]
new_evs) <- ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TcTyVar])
zonkEvBndrsX ZonkEnv
env0 [TcTyVar]
evs
; (ZonkEnv
env2, [TcEvBinds]
new_ev_binds) <- ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
zonkTcEvBinds_s ZonkEnv
env1 [TcEvBinds]
ev_binds
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
new_val_bind, [ABExport GhcTc]
new_exports) <- forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM forall a b. (a -> b) -> a -> b
$ \ ~(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
new_val_binds, [ABExport GhcTc]
_) ->
do { let env3 :: ZonkEnv
env3 = ZonkEnv -> [TcTyVar] -> ZonkEnv
extendIdZonkEnvRec ZonkEnv
env2 forall a b. (a -> b) -> a -> b
$
forall p idR.
CollectPass p =>
CollectFlag p -> LHsBindsLR p idR -> [IdP p]
collectHsBindsBinders forall p. CollectFlag p
CollNoDictBinders Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
new_val_binds
; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
new_val_binds <- forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM (ZonkEnv
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
zonk_val_bind ZonkEnv
env3) LHsBinds GhcTc
val_binds
; [ABExport GhcTc]
new_exports <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> ABExport GhcTc -> TcM (ABExport GhcTc)
zonk_export ZonkEnv
env3) [ABExport GhcTc]
exports
; forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
new_val_binds, [ABExport GhcTc]
new_exports) }
; forall (m :: * -> *) a. Monad m => a -> m a
return (AbsBinds { abs_ext :: XAbsBinds GhcTc GhcTc
abs_ext = NoExtField
noExtField
, abs_tvs :: [TcTyVar]
abs_tvs = [TcTyVar]
new_tyvars, abs_ev_vars :: [TcTyVar]
abs_ev_vars = [TcTyVar]
new_evs
, abs_ev_binds :: [TcEvBinds]
abs_ev_binds = [TcEvBinds]
new_ev_binds
, abs_exports :: [ABExport GhcTc]
abs_exports = [ABExport GhcTc]
new_exports, abs_binds :: LHsBinds GhcTc
abs_binds = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
new_val_bind
, abs_sig :: Bool
abs_sig = Bool
has_sig }) }
where
zonk_val_bind :: ZonkEnv
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
zonk_val_bind ZonkEnv
env GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
lbind
| Bool
has_sig
, (L SrcSpanAnnA
loc bind :: HsBindLR GhcTc GhcTc
bind@(FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = (L SrcSpanAnnN
mloc TcTyVar
mono_id)
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
ms
, fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_ext = XFunBind GhcTc GhcTc
co_fn })) <- GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
lbind
= do { TcTyVar
new_mono_id <- forall (m :: * -> *).
Monad m =>
(Kind -> m Kind) -> TcTyVar -> m TcTyVar
updateIdTypeAndMultM (ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env) TcTyVar
mono_id
; (ZonkEnv
env', HsWrapper
new_co_fn) <- ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn ZonkEnv
env XFunBind GhcTc GhcTc
co_fn
; MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
new_ms <- forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
zonkMatchGroup ZonkEnv
env' ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr MatchGroup GhcTc (LHsExpr GhcTc)
ms
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
HsBindLR GhcTc GhcTc
bind { fun_id :: LIdP GhcTc
fun_id = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
mloc TcTyVar
new_mono_id
, fun_matches :: MatchGroup GhcTc (LHsExpr GhcTc)
fun_matches = MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
new_ms
, fun_ext :: XFunBind GhcTc GhcTc
fun_ext = HsWrapper
new_co_fn } }
| Bool
otherwise
= ZonkEnv -> LHsBind GhcTc -> TcM (LHsBind GhcTc)
zonk_lbind ZonkEnv
env GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
lbind
zonk_export :: ZonkEnv -> ABExport GhcTc -> TcM (ABExport GhcTc)
zonk_export :: ZonkEnv -> ABExport GhcTc -> TcM (ABExport GhcTc)
zonk_export ZonkEnv
env (ABE{ abe_ext :: forall p. ABExport p -> XABE p
abe_ext = XABE GhcTc
x
, abe_wrap :: forall p. ABExport p -> HsWrapper
abe_wrap = HsWrapper
wrap
, abe_poly :: forall p. ABExport p -> IdP p
abe_poly = IdP GhcTc
poly_id
, abe_mono :: forall p. ABExport p -> IdP p
abe_mono = IdP GhcTc
mono_id
, abe_prags :: forall p. ABExport p -> TcSpecPrags
abe_prags = TcSpecPrags
prags })
= do TcTyVar
new_poly_id <- ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkIdBndr ZonkEnv
env IdP GhcTc
poly_id
(ZonkEnv
_, HsWrapper
new_wrap) <- ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn ZonkEnv
env HsWrapper
wrap
TcSpecPrags
new_prags <- ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags ZonkEnv
env TcSpecPrags
prags
forall (m :: * -> *) a. Monad m => a -> m a
return (ABE{ abe_ext :: XABE GhcTc
abe_ext = XABE GhcTc
x
, abe_wrap :: HsWrapper
abe_wrap = HsWrapper
new_wrap
, abe_poly :: IdP GhcTc
abe_poly = TcTyVar
new_poly_id
, abe_mono :: IdP GhcTc
abe_mono = ZonkEnv -> TcTyVar -> TcTyVar
zonkIdOcc ZonkEnv
env IdP GhcTc
mono_id
, abe_prags :: TcSpecPrags
abe_prags = TcSpecPrags
new_prags })
zonk_bind ZonkEnv
env (PatSynBind XPatSynBind GhcTc GhcTc
x bind :: PatSynBind GhcTc GhcTc
bind@(PSB { psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = L SrcSpanAnnN
loc TcTyVar
id
, psb_args :: forall idL idR. PatSynBind idL idR -> HsPatSynDetails idR
psb_args = HsPatSynDetails GhcTc
details
, psb_def :: forall idL idR. PatSynBind idL idR -> LPat idR
psb_def = LPat GhcTc
lpat
, psb_dir :: forall idL idR. PatSynBind idL idR -> HsPatSynDir idR
psb_dir = HsPatSynDir GhcTc
dir }))
= do { TcTyVar
id' <- ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkIdBndr ZonkEnv
env TcTyVar
id
; (ZonkEnv
env1, GenLocated SrcSpanAnnA (Pat GhcTc)
lpat') <- ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
zonkPat ZonkEnv
env LPat GhcTc
lpat
; HsConDetails
Void (GenLocated SrcSpanAnnN TcTyVar) [RecordPatSynField GhcTc]
details' <- ZonkEnv -> HsPatSynDetails GhcTc -> TcM (HsPatSynDetails GhcTc)
zonkPatSynDetails ZonkEnv
env1 HsPatSynDetails GhcTc
details
; (ZonkEnv
_env2, HsPatSynDir GhcTc
dir') <- ZonkEnv -> HsPatSynDir GhcTc -> TcM (ZonkEnv, HsPatSynDir GhcTc)
zonkPatSynDir ZonkEnv
env1 HsPatSynDir GhcTc
dir
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall idL idR.
XPatSynBind idL idR -> PatSynBind idL idR -> HsBindLR idL idR
PatSynBind XPatSynBind GhcTc GhcTc
x forall a b. (a -> b) -> a -> b
$
PatSynBind GhcTc GhcTc
bind { psb_id :: LIdP GhcTc
psb_id = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc TcTyVar
id'
, psb_args :: HsPatSynDetails GhcTc
psb_args = HsConDetails
Void (GenLocated SrcSpanAnnN TcTyVar) [RecordPatSynField GhcTc]
details'
, psb_def :: LPat GhcTc
psb_def = GenLocated SrcSpanAnnA (Pat GhcTc)
lpat'
, psb_dir :: HsPatSynDir GhcTc
psb_dir = HsPatSynDir GhcTc
dir' } }
zonkPatSynDetails :: ZonkEnv
-> HsPatSynDetails GhcTc
-> TcM (HsPatSynDetails GhcTc)
zonkPatSynDetails :: ZonkEnv -> HsPatSynDetails GhcTc -> TcM (HsPatSynDetails GhcTc)
zonkPatSynDetails ZonkEnv
env (PrefixCon [Void]
_ [LIdP GhcTc]
as)
= forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [Void]
noTypeArgs (forall a b. (a -> b) -> [a] -> [b]
map (ZonkEnv
-> GenLocated SrcSpanAnnN TcTyVar -> GenLocated SrcSpanAnnN TcTyVar
zonkLIdOcc ZonkEnv
env) [LIdP GhcTc]
as)
zonkPatSynDetails ZonkEnv
env (InfixCon LIdP GhcTc
a1 LIdP GhcTc
a2)
= forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon (ZonkEnv
-> GenLocated SrcSpanAnnN TcTyVar -> GenLocated SrcSpanAnnN TcTyVar
zonkLIdOcc ZonkEnv
env LIdP GhcTc
a1) (ZonkEnv
-> GenLocated SrcSpanAnnN TcTyVar -> GenLocated SrcSpanAnnN TcTyVar
zonkLIdOcc ZonkEnv
env LIdP GhcTc
a2)
zonkPatSynDetails ZonkEnv
env (RecCon [RecordPatSynField GhcTc]
flds)
= forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> RecordPatSynField GhcTc -> TcM (RecordPatSynField GhcTc)
zonkPatSynField ZonkEnv
env) [RecordPatSynField GhcTc]
flds
zonkPatSynField :: ZonkEnv -> RecordPatSynField GhcTc -> TcM (RecordPatSynField GhcTc)
zonkPatSynField :: ZonkEnv -> RecordPatSynField GhcTc -> TcM (RecordPatSynField GhcTc)
zonkPatSynField ZonkEnv
env (RecordPatSynField FieldOcc GhcTc
x LIdP GhcTc
y) =
forall pass. FieldOcc pass -> LIdP pass -> RecordPatSynField pass
RecordPatSynField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkEnv -> FieldOcc GhcTc -> TcM (FieldOcc GhcTc)
zonkFieldOcc ZonkEnv
env FieldOcc GhcTc
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ZonkEnv
-> GenLocated SrcSpanAnnN TcTyVar -> GenLocated SrcSpanAnnN TcTyVar
zonkLIdOcc ZonkEnv
env LIdP GhcTc
y)
zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTc
-> TcM (ZonkEnv, HsPatSynDir GhcTc)
zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTc -> TcM (ZonkEnv, HsPatSynDir GhcTc)
zonkPatSynDir ZonkEnv
env HsPatSynDir GhcTc
Unidirectional = forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, forall id. HsPatSynDir id
Unidirectional)
zonkPatSynDir ZonkEnv
env HsPatSynDir GhcTc
ImplicitBidirectional = forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, forall id. HsPatSynDir id
ImplicitBidirectional)
zonkPatSynDir ZonkEnv
env (ExplicitBidirectional MatchGroup GhcTc (LHsExpr GhcTc)
mg) = do
MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
mg' <- forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
zonkMatchGroup ZonkEnv
env ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr MatchGroup GhcTc (LHsExpr GhcTc)
mg
forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, forall id. MatchGroup id (LHsExpr id) -> HsPatSynDir id
ExplicitBidirectional MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
mg')
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags ZonkEnv
_ TcSpecPrags
IsDefaultMethod = forall (m :: * -> *) a. Monad m => a -> m a
return TcSpecPrags
IsDefaultMethod
zonkSpecPrags ZonkEnv
env (SpecPrags [LTcSpecPrag]
ps) = do { [LTcSpecPrag]
ps' <- ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags ZonkEnv
env [LTcSpecPrag]
ps
; forall (m :: * -> *) a. Monad m => a -> m a
return ([LTcSpecPrag] -> TcSpecPrags
SpecPrags [LTcSpecPrag]
ps') }
zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags ZonkEnv
env [LTcSpecPrag]
ps
= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LTcSpecPrag -> IOEnv (Env TcGblEnv TcLclEnv) LTcSpecPrag
zonk_prag [LTcSpecPrag]
ps
where
zonk_prag :: LTcSpecPrag -> IOEnv (Env TcGblEnv TcLclEnv) LTcSpecPrag
zonk_prag (L SrcSpan
loc (SpecPrag TcTyVar
id HsWrapper
co_fn InlinePragma
inl))
= do { (ZonkEnv
_, HsWrapper
co_fn') <- ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn ZonkEnv
env HsWrapper
co_fn
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (TcTyVar -> HsWrapper -> InlinePragma -> TcSpecPrag
SpecPrag (ZonkEnv -> TcTyVar -> TcTyVar
zonkIdOcc ZonkEnv
env TcTyVar
id) HsWrapper
co_fn' InlinePragma
inl)) }
zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan
=> ZonkEnv
-> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
zonkMatchGroup :: forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
zonkMatchGroup ZonkEnv
env ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
zBody (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L Anno
[GenLocated
(Anno (Match GhcTc (LocatedA (body GhcTc))))
(Match GhcTc (LocatedA (body GhcTc)))]
l [GenLocated
(Anno (Match GhcTc (LocatedA (body GhcTc))))
(Match GhcTc (LocatedA (body GhcTc)))]
ms
, mg_ext :: forall p body. MatchGroup p body -> XMG p body
mg_ext = MatchGroupTc [Scaled Kind]
arg_tys Kind
res_ty
, mg_origin :: forall p body. MatchGroup p body -> Origin
mg_origin = Origin
origin })
= do { [GenLocated
(Anno (Match GhcTc (LocatedA (body GhcTc))))
(Match GhcTc (LocatedA (body GhcTc)))]
ms' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> LMatch GhcTc (LocatedA (body GhcTc))
-> TcM (LMatch GhcTc (LocatedA (body GhcTc)))
zonkMatch ZonkEnv
env ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
zBody) [GenLocated
(Anno (Match GhcTc (LocatedA (body GhcTc))))
(Match GhcTc (LocatedA (body GhcTc)))]
ms
; [Scaled Kind]
arg_tys' <- ZonkEnv -> [Scaled Kind] -> TcM [Scaled Kind]
zonkScaledTcTypesToTypesX ZonkEnv
env [Scaled Kind]
arg_tys
; Kind
res_ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env Kind
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (MG { mg_alts :: XRec GhcTc [LMatch GhcTc (LocatedA (body GhcTc))]
mg_alts = forall l e. l -> e -> GenLocated l e
L Anno
[GenLocated
(Anno (Match GhcTc (LocatedA (body GhcTc))))
(Match GhcTc (LocatedA (body GhcTc)))]
l [GenLocated
(Anno (Match GhcTc (LocatedA (body GhcTc))))
(Match GhcTc (LocatedA (body GhcTc)))]
ms'
, mg_ext :: XMG GhcTc (LocatedA (body GhcTc))
mg_ext = [Scaled Kind] -> Kind -> MatchGroupTc
MatchGroupTc [Scaled Kind]
arg_tys' Kind
res_ty'
, mg_origin :: Origin
mg_origin = Origin
origin }) }
zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan
=> ZonkEnv
-> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> LMatch GhcTc (LocatedA (body GhcTc))
-> TcM (LMatch GhcTc (LocatedA (body GhcTc)))
zonkMatch :: forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> LMatch GhcTc (LocatedA (body GhcTc))
-> TcM (LMatch GhcTc (LocatedA (body GhcTc)))
zonkMatch ZonkEnv
env ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
zBody (L Anno (Match GhcTc (LocatedA (body GhcTc)))
loc match :: Match GhcTc (LocatedA (body GhcTc))
match@(Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcTc]
pats
, m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcTc (LocatedA (body GhcTc))
grhss }))
= do { (ZonkEnv
env1, [GenLocated SrcSpanAnnA (Pat GhcTc)]
new_pats) <- ZonkEnv -> [LPat GhcTc] -> TcM (ZonkEnv, [LPat GhcTc])
zonkPats ZonkEnv
env [LPat GhcTc]
pats
; GRHSs GhcTc (LocatedA (body GhcTc))
new_grhss <- forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> GRHSs GhcTc (LocatedA (body GhcTc))
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
zonkGRHSs ZonkEnv
env1 ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
zBody GRHSs GhcTc (LocatedA (body GhcTc))
grhss
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L Anno (Match GhcTc (LocatedA (body GhcTc)))
loc (Match GhcTc (LocatedA (body GhcTc))
match { m_pats :: [LPat GhcTc]
m_pats = [GenLocated SrcSpanAnnA (Pat GhcTc)]
new_pats, m_grhss :: GRHSs GhcTc (LocatedA (body GhcTc))
m_grhss = GRHSs GhcTc (LocatedA (body GhcTc))
new_grhss })) }
zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan
=> ZonkEnv
-> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> GRHSs GhcTc (LocatedA (body GhcTc))
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
zonkGRHSs :: forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> GRHSs GhcTc (LocatedA (body GhcTc))
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
zonkGRHSs ZonkEnv
env ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
zBody (GRHSs XCGRHSs GhcTc (LocatedA (body GhcTc))
x [LGRHS GhcTc (LocatedA (body GhcTc))]
grhss HsLocalBinds GhcTc
binds) = do
(ZonkEnv
new_env, HsLocalBinds GhcTc
new_binds) <- ZonkEnv -> HsLocalBinds GhcTc -> TcM (ZonkEnv, HsLocalBinds GhcTc)
zonkLocalBinds ZonkEnv
env HsLocalBinds GhcTc
binds
let
zonk_grhs :: GRHS GhcTc (LocatedA (body GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv) (GRHS GhcTc (LocatedA (body GhcTc)))
zonk_grhs (GRHS XCGRHS GhcTc (LocatedA (body GhcTc))
xx [GuardLStmt GhcTc]
guarded LocatedA (body GhcTc)
rhs)
= do (ZonkEnv
env2, [GenLocated
(Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
new_guarded) <- forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
~ SrcSpanAnnA) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))])
zonkStmts ZonkEnv
new_env ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr [GuardLStmt GhcTc]
guarded
LocatedA (body GhcTc)
new_rhs <- ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
zBody ZonkEnv
env2 LocatedA (body GhcTc)
rhs
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcTc (LocatedA (body GhcTc))
xx [GenLocated
(Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
new_guarded LocatedA (body GhcTc)
new_rhs)
[Located (GRHS GhcTc (LocatedA (body GhcTc)))]
new_grhss <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM GRHS GhcTc (LocatedA (body GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv) (GRHS GhcTc (LocatedA (body GhcTc)))
zonk_grhs) [LGRHS GhcTc (LocatedA (body GhcTc))]
grhss
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcTc (LocatedA (body GhcTc))
x [Located (GRHS GhcTc (LocatedA (body GhcTc)))]
new_grhss HsLocalBinds GhcTc
new_binds)
zonkLExprs :: ZonkEnv -> [LHsExpr GhcTc] -> TcM [LHsExpr GhcTc]
zonkLExpr :: ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkExpr :: ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkLExprs :: ZonkEnv -> [LHsExpr GhcTc] -> TcM [LHsExpr GhcTc]
zonkLExprs ZonkEnv
env [LHsExpr GhcTc]
exprs = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env) [LHsExpr GhcTc]
exprs
zonkLExpr :: ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
expr = forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA (ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkExpr ZonkEnv
env) LHsExpr GhcTc
expr
zonkExpr :: ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkExpr ZonkEnv
env (HsVar XVar GhcTc
x (L SrcSpanAnnN
l TcTyVar
id))
= ASSERT2( isNothing (isDataConId_maybe id), ppr id )
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcTc
x (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l (ZonkEnv -> TcTyVar -> TcTyVar
zonkIdOcc ZonkEnv
env TcTyVar
id)))
zonkExpr ZonkEnv
env (HsUnboundVar XUnboundVar GhcTc
her OccName
occ)
= do HoleExprRef
her' <- HoleExprRef -> TcM HoleExprRef
zonk_her XUnboundVar GhcTc
her
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XUnboundVar p -> OccName -> HsExpr p
HsUnboundVar HoleExprRef
her' OccName
occ)
where
zonk_her :: HoleExprRef -> TcM HoleExprRef
zonk_her :: HoleExprRef -> TcM HoleExprRef
zonk_her (HER IORef EvTerm
ref Kind
ty Unique
u)
= do forall a env. IORef a -> (a -> IOEnv env a) -> IOEnv env ()
updMutVarM IORef EvTerm
ref (ZonkEnv -> EvTerm -> TcM EvTerm
zonkEvTerm ZonkEnv
env)
Kind
ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env Kind
ty
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef EvTerm -> Kind -> Unique -> HoleExprRef
HER IORef EvTerm
ref Kind
ty' Unique
u)
zonkExpr ZonkEnv
env (HsRecFld XRecFld GhcTc
_ (Ambiguous XAmbiguous GhcTc
v LocatedN RdrName
occ))
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XRecFld p -> AmbiguousFieldOcc p -> HsExpr p
HsRecFld NoExtField
noExtField (forall pass.
XAmbiguous pass -> LocatedN RdrName -> AmbiguousFieldOcc pass
Ambiguous (ZonkEnv -> TcTyVar -> TcTyVar
zonkIdOcc ZonkEnv
env XAmbiguous GhcTc
v) LocatedN RdrName
occ))
zonkExpr ZonkEnv
env (HsRecFld XRecFld GhcTc
_ (Unambiguous XUnambiguous GhcTc
v LocatedN RdrName
occ))
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XRecFld p -> AmbiguousFieldOcc p -> HsExpr p
HsRecFld NoExtField
noExtField (forall pass.
XUnambiguous pass -> LocatedN RdrName -> AmbiguousFieldOcc pass
Unambiguous (ZonkEnv -> TcTyVar -> TcTyVar
zonkIdOcc ZonkEnv
env XUnambiguous GhcTc
v) LocatedN RdrName
occ))
zonkExpr ZonkEnv
_ e :: HsExpr GhcTc
e@(HsConLikeOut {}) = forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
zonkExpr ZonkEnv
_ (HsIPVar XIPVar GhcTc
x HsIPName
id)
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XIPVar p -> HsIPName -> HsExpr p
HsIPVar XIPVar GhcTc
x HsIPName
id)
zonkExpr ZonkEnv
_ e :: HsExpr GhcTc
e@HsOverLabel{} = forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
e
zonkExpr ZonkEnv
env (HsLit XLitE GhcTc
x (HsRat XHsRat GhcTc
e FractionalLit
f Kind
ty))
= do Kind
new_ty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env Kind
ty
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcTc
x (forall x. XHsRat x -> FractionalLit -> Kind -> HsLit x
HsRat XHsRat GhcTc
e FractionalLit
f Kind
new_ty))
zonkExpr ZonkEnv
_ (HsLit XLitE GhcTc
x HsLit GhcTc
lit)
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcTc
x HsLit GhcTc
lit)
zonkExpr ZonkEnv
env (HsOverLit XOverLitE GhcTc
x HsOverLit GhcTc
lit)
= do { HsOverLit GhcTc
lit' <- ZonkEnv -> HsOverLit GhcTc -> TcM (HsOverLit GhcTc)
zonkOverLit ZonkEnv
env HsOverLit GhcTc
lit
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcTc
x HsOverLit GhcTc
lit') }
zonkExpr ZonkEnv
env (HsLam XLam GhcTc
x MatchGroup GhcTc (LHsExpr GhcTc)
matches)
= do MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
new_matches <- forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
zonkMatchGroup ZonkEnv
env ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr MatchGroup GhcTc (LHsExpr GhcTc)
matches
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcTc
x MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
new_matches)
zonkExpr ZonkEnv
env (HsLamCase XLamCase GhcTc
x MatchGroup GhcTc (LHsExpr GhcTc)
matches)
= do MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
new_matches <- forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
zonkMatchGroup ZonkEnv
env ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr MatchGroup GhcTc (LHsExpr GhcTc)
matches
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XLamCase p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase XLamCase GhcTc
x MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
new_matches)
zonkExpr ZonkEnv
env (HsApp XApp GhcTc
x LHsExpr GhcTc
e1 LHsExpr GhcTc
e2)
= do LocatedA (HsExpr GhcTc)
new_e1 <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e1
LocatedA (HsExpr GhcTc)
new_e2 <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e2
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTc
x LocatedA (HsExpr GhcTc)
new_e1 LocatedA (HsExpr GhcTc)
new_e2)
zonkExpr ZonkEnv
env (HsAppType XAppTypeE GhcTc
ty LHsExpr GhcTc
e LHsWcType (NoGhcTc GhcTc)
t)
= do LocatedA (HsExpr GhcTc)
new_e <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e
Kind
new_ty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env XAppTypeE GhcTc
ty
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType Kind
new_ty LocatedA (HsExpr GhcTc)
new_e LHsWcType (NoGhcTc GhcTc)
t)
zonkExpr ZonkEnv
_ e :: HsExpr GhcTc
e@(HsRnBracketOut XRnBracketOut GhcTc
_ HsBracket (HsBracketRn GhcTc)
_ [PendingRnSplice' GhcTc]
_)
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"zonkExpr: HsRnBracketOut" (forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
e)
zonkExpr ZonkEnv
env (HsTcBracketOut XTcBracketOut GhcTc
x Maybe QuoteWrapper
wrap HsBracket (HsBracketRn GhcTc)
body [PendingTcSplice' GhcTc]
bs)
= do Maybe QuoteWrapper
wrap' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse QuoteWrapper -> IOEnv (Env TcGblEnv TcLclEnv) QuoteWrapper
zonkQuoteWrap Maybe QuoteWrapper
wrap
[PendingTcSplice]
bs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv
-> PendingTcSplice -> IOEnv (Env TcGblEnv TcLclEnv) PendingTcSplice
zonk_b ZonkEnv
env) [PendingTcSplice' GhcTc]
bs
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XTcBracketOut p
-> Maybe QuoteWrapper
-> HsBracket (HsBracketRn p)
-> [PendingTcSplice' p]
-> HsExpr p
HsTcBracketOut XTcBracketOut GhcTc
x Maybe QuoteWrapper
wrap' HsBracket (HsBracketRn GhcTc)
body [PendingTcSplice]
bs')
where
zonkQuoteWrap :: QuoteWrapper -> IOEnv (Env TcGblEnv TcLclEnv) QuoteWrapper
zonkQuoteWrap (QuoteWrapper TcTyVar
ev Kind
ty) = do
let ev' :: TcTyVar
ev' = ZonkEnv -> TcTyVar -> TcTyVar
zonkIdOcc ZonkEnv
env TcTyVar
ev
Kind
ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env Kind
ty
forall (m :: * -> *) a. Monad m => a -> m a
return (TcTyVar -> Kind -> QuoteWrapper
QuoteWrapper TcTyVar
ev' Kind
ty')
zonk_b :: ZonkEnv
-> PendingTcSplice -> IOEnv (Env TcGblEnv TcLclEnv) PendingTcSplice
zonk_b ZonkEnv
env' (PendingTcSplice Name
n LHsExpr GhcTc
e) = do LocatedA (HsExpr GhcTc)
e' <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env' LHsExpr GhcTc
e
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> LHsExpr GhcTc -> PendingTcSplice
PendingTcSplice Name
n LocatedA (HsExpr GhcTc)
e')
zonkExpr ZonkEnv
env (HsSpliceE XSpliceE GhcTc
_ (XSplice (HsSplicedT DelayedSplice
s))) =
DelayedSplice -> TcM (HsExpr GhcTc)
runTopSplice DelayedSplice
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkExpr ZonkEnv
env
zonkExpr ZonkEnv
_ e :: HsExpr GhcTc
e@(HsSpliceE XSpliceE GhcTc
_ HsSplice GhcTc
_) = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"zonkExpr: HsSpliceE" (forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
e)
zonkExpr ZonkEnv
env (OpApp XOpApp GhcTc
fixity LHsExpr GhcTc
e1 LHsExpr GhcTc
op LHsExpr GhcTc
e2)
= do LocatedA (HsExpr GhcTc)
new_e1 <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e1
LocatedA (HsExpr GhcTc)
new_op <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
op
LocatedA (HsExpr GhcTc)
new_e2 <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e2
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcTc
fixity LocatedA (HsExpr GhcTc)
new_e1 LocatedA (HsExpr GhcTc)
new_op LocatedA (HsExpr GhcTc)
new_e2)
zonkExpr ZonkEnv
env (NegApp XNegApp GhcTc
x LHsExpr GhcTc
expr SyntaxExpr GhcTc
op)
= do (ZonkEnv
env', SyntaxExprTc
new_op) <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env SyntaxExpr GhcTc
op
LocatedA (HsExpr GhcTc)
new_expr <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env' LHsExpr GhcTc
expr
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p
NegApp XNegApp GhcTc
x LocatedA (HsExpr GhcTc)
new_expr SyntaxExprTc
new_op)
zonkExpr ZonkEnv
env (HsPar XPar GhcTc
x LHsExpr GhcTc
e)
= do LocatedA (HsExpr GhcTc)
new_e <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcTc
x LocatedA (HsExpr GhcTc)
new_e)
zonkExpr ZonkEnv
env (SectionL XSectionL GhcTc
x LHsExpr GhcTc
expr LHsExpr GhcTc
op)
= do LocatedA (HsExpr GhcTc)
new_expr <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
expr
LocatedA (HsExpr GhcTc)
new_op <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
op
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL XSectionL GhcTc
x LocatedA (HsExpr GhcTc)
new_expr LocatedA (HsExpr GhcTc)
new_op)
zonkExpr ZonkEnv
env (SectionR XSectionR GhcTc
x LHsExpr GhcTc
op LHsExpr GhcTc
expr)
= do LocatedA (HsExpr GhcTc)
new_op <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
op
LocatedA (HsExpr GhcTc)
new_expr <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
expr
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR XSectionR GhcTc
x LocatedA (HsExpr GhcTc)
new_op LocatedA (HsExpr GhcTc)
new_expr)
zonkExpr ZonkEnv
env (ExplicitTuple XExplicitTuple GhcTc
x [HsTupArg GhcTc]
tup_args Boxity
boxed)
= do { [HsTupArg GhcTc]
new_tup_args <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsTupArg GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
zonk_tup_arg [HsTupArg GhcTc]
tup_args
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcTc
x [HsTupArg GhcTc]
new_tup_args Boxity
boxed) }
where
zonk_tup_arg :: HsTupArg GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
zonk_tup_arg (Present XPresent GhcTc
x LHsExpr GhcTc
e) = do { LocatedA (HsExpr GhcTc)
e' <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcTc
x LocatedA (HsExpr GhcTc)
e') }
zonk_tup_arg (Missing XMissing GhcTc
t) = do { Scaled Kind
t' <- ZonkEnv -> Scaled Kind -> TcM (Scaled Kind)
zonkScaledTcTypeToTypeX ZonkEnv
env XMissing GhcTc
t
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XMissing id -> HsTupArg id
Missing Scaled Kind
t') }
zonkExpr ZonkEnv
env (ExplicitSum XExplicitSum GhcTc
args ConTag
alt ConTag
arity LHsExpr GhcTc
expr)
= do [Kind]
new_args <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env) XExplicitSum GhcTc
args
LocatedA (HsExpr GhcTc)
new_expr <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
expr
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XExplicitSum p -> ConTag -> ConTag -> LHsExpr p -> HsExpr p
ExplicitSum [Kind]
new_args ConTag
alt ConTag
arity LocatedA (HsExpr GhcTc)
new_expr)
zonkExpr ZonkEnv
env (HsCase XCase GhcTc
x LHsExpr GhcTc
expr MatchGroup GhcTc (LHsExpr GhcTc)
ms)
= do LocatedA (HsExpr GhcTc)
new_expr <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
expr
MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
new_ms <- forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
zonkMatchGroup ZonkEnv
env ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr MatchGroup GhcTc (LHsExpr GhcTc)
ms
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase XCase GhcTc
x LocatedA (HsExpr GhcTc)
new_expr MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
new_ms)
zonkExpr ZonkEnv
env (HsIf XIf GhcTc
x LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3)
= do LocatedA (HsExpr GhcTc)
new_e1 <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e1
LocatedA (HsExpr GhcTc)
new_e2 <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e2
LocatedA (HsExpr GhcTc)
new_e3 <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e3
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XIf p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsIf XIf GhcTc
x LocatedA (HsExpr GhcTc)
new_e1 LocatedA (HsExpr GhcTc)
new_e2 LocatedA (HsExpr GhcTc)
new_e3)
zonkExpr ZonkEnv
env (HsMultiIf XMultiIf GhcTc
ty [LGRHS GhcTc (LHsExpr GhcTc)]
alts)
= do { [Located (GRHS GhcTc (LocatedA (HsExpr GhcTc)))]
alts' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM GRHS GhcTc (LocatedA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv) (GRHS GhcTc (LocatedA (HsExpr GhcTc)))
zonk_alt) [LGRHS GhcTc (LHsExpr GhcTc)]
alts
; Kind
ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env XMultiIf GhcTc
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p
HsMultiIf Kind
ty' [Located (GRHS GhcTc (LocatedA (HsExpr GhcTc)))]
alts' }
where zonk_alt :: GRHS GhcTc (LocatedA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv) (GRHS GhcTc (LocatedA (HsExpr GhcTc)))
zonk_alt (GRHS XCGRHS GhcTc (LocatedA (HsExpr GhcTc))
x [GuardLStmt GhcTc]
guard LocatedA (HsExpr GhcTc)
expr)
= do { (ZonkEnv
env', [GenLocated
(Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
guard') <- forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
~ SrcSpanAnnA) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))])
zonkStmts ZonkEnv
env ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr [GuardLStmt GhcTc]
guard
; LocatedA (HsExpr GhcTc)
expr' <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env' LocatedA (HsExpr GhcTc)
expr
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcTc (LocatedA (HsExpr GhcTc))
x [GenLocated
(Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
guard' LocatedA (HsExpr GhcTc)
expr' }
zonkExpr ZonkEnv
env (HsLet XLet GhcTc
x HsLocalBinds GhcTc
binds LHsExpr GhcTc
expr)
= do (ZonkEnv
new_env, HsLocalBinds GhcTc
new_binds) <- ZonkEnv -> HsLocalBinds GhcTc -> TcM (ZonkEnv, HsLocalBinds GhcTc)
zonkLocalBinds ZonkEnv
env HsLocalBinds GhcTc
binds
LocatedA (HsExpr GhcTc)
new_expr <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
new_env LHsExpr GhcTc
expr
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XLet p -> HsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet XLet GhcTc
x HsLocalBinds GhcTc
new_binds LocatedA (HsExpr GhcTc)
new_expr)
zonkExpr ZonkEnv
env (HsDo XDo GhcTc
ty HsStmtContext (HsDoRn GhcTc)
do_or_lc (L SrcSpanAnnL
l [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts))
= do (ZonkEnv
_, [GenLocated
(Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
new_stmts) <- forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
~ SrcSpanAnnA) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))])
zonkStmts ZonkEnv
env ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
Kind
new_ty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env XDo GhcTc
ty
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XDo p
-> HsStmtContext (HsDoRn p) -> XRec p [ExprLStmt p] -> HsExpr p
HsDo Kind
new_ty HsStmtContext (HsDoRn GhcTc)
do_or_lc (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
(Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
new_stmts))
zonkExpr ZonkEnv
env (ExplicitList XExplicitList GhcTc
ty [LHsExpr GhcTc]
exprs)
= do Kind
new_ty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env XExplicitList GhcTc
ty
[LocatedA (HsExpr GhcTc)]
new_exprs <- ZonkEnv -> [LHsExpr GhcTc] -> TcM [LHsExpr GhcTc]
zonkLExprs ZonkEnv
env [LHsExpr GhcTc]
exprs
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList Kind
new_ty [LocatedA (HsExpr GhcTc)]
new_exprs)
zonkExpr ZonkEnv
env expr :: HsExpr GhcTc
expr@(RecordCon { rcon_ext :: forall p. HsExpr p -> XRecordCon p
rcon_ext = XRecordCon GhcTc
con_expr, rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcTc
rbinds })
= do { HsExpr GhcTc
new_con_expr <- ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkExpr ZonkEnv
env XRecordCon GhcTc
con_expr
; HsRecFields GhcTc (LocatedA (HsExpr GhcTc))
new_rbinds <- ZonkEnv -> HsRecordBinds GhcTc -> TcM (HsRecordBinds GhcTc)
zonkRecFields ZonkEnv
env HsRecordBinds GhcTc
rbinds
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr { rcon_ext :: XRecordCon GhcTc
rcon_ext = HsExpr GhcTc
new_con_expr
, rcon_flds :: HsRecordBinds GhcTc
rcon_flds = HsRecFields GhcTc (LocatedA (HsExpr GhcTc))
new_rbinds }) }
zonkExpr ZonkEnv
env (RecordUpd { rupd_flds :: forall p. HsExpr p -> Either [LHsRecUpdField p] [LHsRecUpdProj p]
rupd_flds = Left [LHsRecUpdField GhcTc]
rbinds
, rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr = LHsExpr GhcTc
expr
, rupd_ext :: forall p. HsExpr p -> XRecordUpd p
rupd_ext = RecordUpdTc {
rupd_cons :: RecordUpdTc -> [ConLike]
rupd_cons = [ConLike]
cons
, rupd_in_tys :: RecordUpdTc -> [Kind]
rupd_in_tys = [Kind]
in_tys
, rupd_out_tys :: RecordUpdTc -> [Kind]
rupd_out_tys = [Kind]
out_tys
, rupd_wrap :: RecordUpdTc -> HsWrapper
rupd_wrap = HsWrapper
req_wrap }})
= do { LocatedA (HsExpr GhcTc)
new_expr <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
expr
; [Kind]
new_in_tys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env) [Kind]
in_tys
; [Kind]
new_out_tys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env) [Kind]
out_tys
; [GenLocated
SrcSpanAnnA
(HsRecField' (AmbiguousFieldOcc GhcTc) (LocatedA (HsExpr GhcTc)))]
new_rbinds <- ZonkEnv -> [LHsRecUpdField GhcTc] -> TcM [LHsRecUpdField GhcTc]
zonkRecUpdFields ZonkEnv
env [LHsRecUpdField GhcTc]
rbinds
; (ZonkEnv
_, HsWrapper
new_recwrap) <- ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn ZonkEnv
env HsWrapper
req_wrap
; forall (m :: * -> *) a. Monad m => a -> m a
return (
RecordUpd {
rupd_expr :: LHsExpr GhcTc
rupd_expr = LocatedA (HsExpr GhcTc)
new_expr
, rupd_flds :: Either [LHsRecUpdField GhcTc] [LHsRecUpdProj GhcTc]
rupd_flds = forall a b. a -> Either a b
Left [GenLocated
SrcSpanAnnA
(HsRecField' (AmbiguousFieldOcc GhcTc) (LocatedA (HsExpr GhcTc)))]
new_rbinds
, rupd_ext :: XRecordUpd GhcTc
rupd_ext = RecordUpdTc {
rupd_cons :: [ConLike]
rupd_cons = [ConLike]
cons
, rupd_in_tys :: [Kind]
rupd_in_tys = [Kind]
new_in_tys
, rupd_out_tys :: [Kind]
rupd_out_tys = [Kind]
new_out_tys
, rupd_wrap :: HsWrapper
rupd_wrap = HsWrapper
new_recwrap }}) }
zonkExpr ZonkEnv
_ (RecordUpd {}) = forall a. String -> a
panic String
"GHC.Tc.Utils.Zonk: zonkExpr: The impossible happened!"
zonkExpr ZonkEnv
env (ExprWithTySig XExprWithTySig GhcTc
_ LHsExpr GhcTc
e LHsSigWcType (NoGhcTc GhcTc)
ty)
= do { LocatedA (HsExpr GhcTc)
e' <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig NoExtField
noExtField LocatedA (HsExpr GhcTc)
e' LHsSigWcType (NoGhcTc GhcTc)
ty) }
zonkExpr ZonkEnv
env (ArithSeq XArithSeq GhcTc
expr Maybe (SyntaxExpr GhcTc)
wit ArithSeqInfo GhcTc
info)
= do (ZonkEnv
env1, Maybe SyntaxExprTc
new_wit) <- ZonkEnv
-> Maybe SyntaxExprTc
-> IOEnv (Env TcGblEnv TcLclEnv) (ZonkEnv, Maybe SyntaxExprTc)
zonkWit ZonkEnv
env Maybe (SyntaxExpr GhcTc)
wit
HsExpr GhcTc
new_expr <- ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkExpr ZonkEnv
env XArithSeq GhcTc
expr
ArithSeqInfo GhcTc
new_info <- ZonkEnv -> ArithSeqInfo GhcTc -> TcM (ArithSeqInfo GhcTc)
zonkArithSeq ZonkEnv
env1 ArithSeqInfo GhcTc
info
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq HsExpr GhcTc
new_expr Maybe SyntaxExprTc
new_wit ArithSeqInfo GhcTc
new_info)
where zonkWit :: ZonkEnv
-> Maybe SyntaxExprTc
-> IOEnv (Env TcGblEnv TcLclEnv) (ZonkEnv, Maybe SyntaxExprTc)
zonkWit ZonkEnv
env Maybe SyntaxExprTc
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, forall a. Maybe a
Nothing)
zonkWit ZonkEnv
env (Just SyntaxExprTc
fln) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env SyntaxExprTc
fln
zonkExpr ZonkEnv
env (HsPragE XPragE GhcTc
x HsPragE GhcTc
prag LHsExpr GhcTc
expr)
= do LocatedA (HsExpr GhcTc)
new_expr <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
expr
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p
HsPragE XPragE GhcTc
x HsPragE GhcTc
prag LocatedA (HsExpr GhcTc)
new_expr)
zonkExpr ZonkEnv
env (HsProc XProc GhcTc
x LPat GhcTc
pat LHsCmdTop GhcTc
body)
= do { (ZonkEnv
env1, GenLocated SrcSpanAnnA (Pat GhcTc)
new_pat) <- ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
zonkPat ZonkEnv
env LPat GhcTc
pat
; GenLocated SrcSpan (HsCmdTop GhcTc)
new_body <- ZonkEnv -> LHsCmdTop GhcTc -> TcM (LHsCmdTop GhcTc)
zonkCmdTop ZonkEnv
env1 LHsCmdTop GhcTc
body
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XProc p -> LPat p -> LHsCmdTop p -> HsExpr p
HsProc XProc GhcTc
x GenLocated SrcSpanAnnA (Pat GhcTc)
new_pat GenLocated SrcSpan (HsCmdTop GhcTc)
new_body) }
zonkExpr ZonkEnv
env (HsStatic XStatic GhcTc
fvs LHsExpr GhcTc
expr)
= forall p. XStatic p -> LHsExpr p -> HsExpr p
HsStatic XStatic GhcTc
fvs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
expr
zonkExpr ZonkEnv
env (XExpr (WrapExpr (HsWrap HsWrapper
co_fn HsExpr GhcTc
expr)))
= do (ZonkEnv
env1, HsWrapper
new_co_fn) <- ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn ZonkEnv
env HsWrapper
co_fn
HsExpr GhcTc
new_expr <- ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkExpr ZonkEnv
env1 HsExpr GhcTc
expr
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XXExpr p -> HsExpr p
XExpr (HsWrap HsExpr -> XXExprGhcTc
WrapExpr (forall (hs_syn :: * -> *).
HsWrapper -> hs_syn GhcTc -> HsWrap hs_syn
HsWrap HsWrapper
new_co_fn HsExpr GhcTc
new_expr)))
zonkExpr ZonkEnv
env (XExpr (ExpansionExpr (HsExpanded HsExpr GhcRn
a HsExpr GhcTc
b)))
= forall p. XXExpr p -> HsExpr p
XExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpansion (HsExpr GhcRn) (HsExpr GhcTc) -> XXExprGhcTc
ExpansionExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> HsExpansion a b
HsExpanded HsExpr GhcRn
a forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkExpr ZonkEnv
env HsExpr GhcTc
b
zonkExpr ZonkEnv
_ HsExpr GhcTc
expr = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"zonkExpr" (forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr)
zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTc
-> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env (SyntaxExprTc { syn_expr :: SyntaxExprTc -> HsExpr GhcTc
syn_expr = HsExpr GhcTc
expr
, syn_arg_wraps :: SyntaxExprTc -> [HsWrapper]
syn_arg_wraps = [HsWrapper]
arg_wraps
, syn_res_wrap :: SyntaxExprTc -> HsWrapper
syn_res_wrap = HsWrapper
res_wrap })
= do { (ZonkEnv
env0, HsWrapper
res_wrap') <- ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn ZonkEnv
env HsWrapper
res_wrap
; HsExpr GhcTc
expr' <- ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkExpr ZonkEnv
env0 HsExpr GhcTc
expr
; (ZonkEnv
env1, [HsWrapper]
arg_wraps') <- forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn ZonkEnv
env0 [HsWrapper]
arg_wraps
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env1, SyntaxExprTc { syn_expr :: HsExpr GhcTc
syn_expr = HsExpr GhcTc
expr'
, syn_arg_wraps :: [HsWrapper]
syn_arg_wraps = [HsWrapper]
arg_wraps'
, syn_res_wrap :: HsWrapper
syn_res_wrap = HsWrapper
res_wrap' }) }
zonkSyntaxExpr ZonkEnv
env SyntaxExpr GhcTc
SyntaxExprTc
NoSyntaxExprTc = forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, SyntaxExprTc
NoSyntaxExprTc)
zonkLCmd :: ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc)
zonkCmd :: ZonkEnv -> HsCmd GhcTc -> TcM (HsCmd GhcTc)
zonkLCmd :: ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc)
zonkLCmd ZonkEnv
env LHsCmd GhcTc
cmd = forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA (ZonkEnv -> HsCmd GhcTc -> TcM (HsCmd GhcTc)
zonkCmd ZonkEnv
env) LHsCmd GhcTc
cmd
zonkCmd :: ZonkEnv -> HsCmd GhcTc -> TcM (HsCmd GhcTc)
zonkCmd ZonkEnv
env (XCmd (HsWrap HsWrapper
w HsCmd GhcTc
cmd))
= do { (ZonkEnv
env1, HsWrapper
w') <- ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn ZonkEnv
env HsWrapper
w
; HsCmd GhcTc
cmd' <- ZonkEnv -> HsCmd GhcTc -> TcM (HsCmd GhcTc)
zonkCmd ZonkEnv
env1 HsCmd GhcTc
cmd
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XXCmd id -> HsCmd id
XCmd (forall (hs_syn :: * -> *).
HsWrapper -> hs_syn GhcTc -> HsWrap hs_syn
HsWrap HsWrapper
w' HsCmd GhcTc
cmd')) }
zonkCmd ZonkEnv
env (HsCmdArrApp XCmdArrApp GhcTc
ty LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 HsArrAppType
ho Bool
rl)
= do LocatedA (HsExpr GhcTc)
new_e1 <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e1
LocatedA (HsExpr GhcTc)
new_e2 <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e2
Kind
new_ty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env XCmdArrApp GhcTc
ty
forall (m :: * -> *) a. Monad m => a -> m a
return (forall id.
XCmdArrApp id
-> LHsExpr id -> LHsExpr id -> HsArrAppType -> Bool -> HsCmd id
HsCmdArrApp Kind
new_ty LocatedA (HsExpr GhcTc)
new_e1 LocatedA (HsExpr GhcTc)
new_e2 HsArrAppType
ho Bool
rl)
zonkCmd ZonkEnv
env (HsCmdArrForm XCmdArrForm GhcTc
x LHsExpr GhcTc
op LexicalFixity
f Maybe Fixity
fixity [LHsCmdTop GhcTc]
args)
= do LocatedA (HsExpr GhcTc)
new_op <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
op
[GenLocated SrcSpan (HsCmdTop GhcTc)]
new_args <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> LHsCmdTop GhcTc -> TcM (LHsCmdTop GhcTc)
zonkCmdTop ZonkEnv
env) [LHsCmdTop GhcTc]
args
forall (m :: * -> *) a. Monad m => a -> m a
return (forall id.
XCmdArrForm id
-> LHsExpr id
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop id]
-> HsCmd id
HsCmdArrForm XCmdArrForm GhcTc
x LocatedA (HsExpr GhcTc)
new_op LexicalFixity
f Maybe Fixity
fixity [GenLocated SrcSpan (HsCmdTop GhcTc)]
new_args)
zonkCmd ZonkEnv
env (HsCmdApp XCmdApp GhcTc
x LHsCmd GhcTc
c LHsExpr GhcTc
e)
= do LocatedA (HsCmd GhcTc)
new_c <- ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc)
zonkLCmd ZonkEnv
env LHsCmd GhcTc
c
LocatedA (HsExpr GhcTc)
new_e <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e
forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XCmdApp id -> LHsCmd id -> LHsExpr id -> HsCmd id
HsCmdApp XCmdApp GhcTc
x LocatedA (HsCmd GhcTc)
new_c LocatedA (HsExpr GhcTc)
new_e)
zonkCmd ZonkEnv
env (HsCmdLam XCmdLam GhcTc
x MatchGroup GhcTc (LHsCmd GhcTc)
matches)
= do MatchGroup GhcTc (LocatedA (HsCmd GhcTc))
new_matches <- forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
zonkMatchGroup ZonkEnv
env ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc)
zonkLCmd MatchGroup GhcTc (LHsCmd GhcTc)
matches
forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XCmdLam id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdLam XCmdLam GhcTc
x MatchGroup GhcTc (LocatedA (HsCmd GhcTc))
new_matches)
zonkCmd ZonkEnv
env (HsCmdPar XCmdPar GhcTc
x LHsCmd GhcTc
c)
= do LocatedA (HsCmd GhcTc)
new_c <- ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc)
zonkLCmd ZonkEnv
env LHsCmd GhcTc
c
forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XCmdPar id -> LHsCmd id -> HsCmd id
HsCmdPar XCmdPar GhcTc
x LocatedA (HsCmd GhcTc)
new_c)
zonkCmd ZonkEnv
env (HsCmdCase XCmdCase GhcTc
x LHsExpr GhcTc
expr MatchGroup GhcTc (LHsCmd GhcTc)
ms)
= do LocatedA (HsExpr GhcTc)
new_expr <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
expr
MatchGroup GhcTc (LocatedA (HsCmd GhcTc))
new_ms <- forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
zonkMatchGroup ZonkEnv
env ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc)
zonkLCmd MatchGroup GhcTc (LHsCmd GhcTc)
ms
forall (m :: * -> *) a. Monad m => a -> m a
return (forall id.
XCmdCase id -> LHsExpr id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdCase XCmdCase GhcTc
x LocatedA (HsExpr GhcTc)
new_expr MatchGroup GhcTc (LocatedA (HsCmd GhcTc))
new_ms)
zonkCmd ZonkEnv
env (HsCmdLamCase XCmdLamCase GhcTc
x MatchGroup GhcTc (LHsCmd GhcTc)
ms)
= do MatchGroup GhcTc (LocatedA (HsCmd GhcTc))
new_ms <- forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
zonkMatchGroup ZonkEnv
env ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc)
zonkLCmd MatchGroup GhcTc (LHsCmd GhcTc)
ms
forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XCmdLamCase id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdLamCase XCmdLamCase GhcTc
x MatchGroup GhcTc (LocatedA (HsCmd GhcTc))
new_ms)
zonkCmd ZonkEnv
env (HsCmdIf XCmdIf GhcTc
x SyntaxExpr GhcTc
eCond LHsExpr GhcTc
ePred LHsCmd GhcTc
cThen LHsCmd GhcTc
cElse)
= do { (ZonkEnv
env1, SyntaxExprTc
new_eCond) <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env SyntaxExpr GhcTc
eCond
; LocatedA (HsExpr GhcTc)
new_ePred <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env1 LHsExpr GhcTc
ePred
; LocatedA (HsCmd GhcTc)
new_cThen <- ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc)
zonkLCmd ZonkEnv
env1 LHsCmd GhcTc
cThen
; LocatedA (HsCmd GhcTc)
new_cElse <- ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc)
zonkLCmd ZonkEnv
env1 LHsCmd GhcTc
cElse
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id.
XCmdIf id
-> SyntaxExpr id
-> LHsExpr id
-> LHsCmd id
-> LHsCmd id
-> HsCmd id
HsCmdIf XCmdIf GhcTc
x SyntaxExprTc
new_eCond LocatedA (HsExpr GhcTc)
new_ePred LocatedA (HsCmd GhcTc)
new_cThen LocatedA (HsCmd GhcTc)
new_cElse) }
zonkCmd ZonkEnv
env (HsCmdLet XCmdLet GhcTc
x HsLocalBinds GhcTc
binds LHsCmd GhcTc
cmd)
= do (ZonkEnv
new_env, HsLocalBinds GhcTc
new_binds) <- ZonkEnv -> HsLocalBinds GhcTc -> TcM (ZonkEnv, HsLocalBinds GhcTc)
zonkLocalBinds ZonkEnv
env HsLocalBinds GhcTc
binds
LocatedA (HsCmd GhcTc)
new_cmd <- ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc)
zonkLCmd ZonkEnv
new_env LHsCmd GhcTc
cmd
forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XCmdLet id -> HsLocalBinds id -> LHsCmd id -> HsCmd id
HsCmdLet XCmdLet GhcTc
x HsLocalBinds GhcTc
new_binds LocatedA (HsCmd GhcTc)
new_cmd)
zonkCmd ZonkEnv
env (HsCmdDo XCmdDo GhcTc
ty (L SrcSpanAnnL
l [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsCmd GhcTc)))]
stmts))
= do (ZonkEnv
_, [GenLocated
(Anno (StmtLR GhcTc GhcTc (LocatedA (HsCmd GhcTc))))
(StmtLR GhcTc GhcTc (LocatedA (HsCmd GhcTc)))]
new_stmts) <- forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
~ SrcSpanAnnA) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))])
zonkStmts ZonkEnv
env ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc)
zonkLCmd [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsCmd GhcTc)))]
stmts
Kind
new_ty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env XCmdDo GhcTc
ty
forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XCmdDo id -> XRec id [CmdLStmt id] -> HsCmd id
HsCmdDo Kind
new_ty (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
(Anno (StmtLR GhcTc GhcTc (LocatedA (HsCmd GhcTc))))
(StmtLR GhcTc GhcTc (LocatedA (HsCmd GhcTc)))]
new_stmts))
zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTc -> TcM (LHsCmdTop GhcTc)
zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTc -> TcM (LHsCmdTop GhcTc)
zonkCmdTop ZonkEnv
env LHsCmdTop GhcTc
cmd = forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM (ZonkEnv -> HsCmdTop GhcTc -> TcM (HsCmdTop GhcTc)
zonk_cmd_top ZonkEnv
env) LHsCmdTop GhcTc
cmd
zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTc -> TcM (HsCmdTop GhcTc)
zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTc -> TcM (HsCmdTop GhcTc)
zonk_cmd_top ZonkEnv
env (HsCmdTop (CmdTopTc Kind
stack_tys Kind
ty CmdSyntaxTable GhcTc
ids) LHsCmd GhcTc
cmd)
= do LocatedA (HsCmd GhcTc)
new_cmd <- ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc)
zonkLCmd ZonkEnv
env LHsCmd GhcTc
cmd
Kind
new_stack_tys <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env Kind
stack_tys
Kind
new_ty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env Kind
ty
CmdSyntaxTable GhcTc
new_ids <- forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> [(a, b)] -> m [(a, c)]
mapSndM (ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkExpr ZonkEnv
env) CmdSyntaxTable GhcTc
ids
MASSERT( isLiftedTypeKind (tcTypeKind new_stack_tys) )
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XCmdTop p -> LHsCmd p -> HsCmdTop p
HsCmdTop (Kind -> Kind -> CmdSyntaxTable GhcTc -> CmdTopTc
CmdTopTc Kind
new_stack_tys Kind
new_ty CmdSyntaxTable GhcTc
new_ids) LocatedA (HsCmd GhcTc)
new_cmd)
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn ZonkEnv
env HsWrapper
WpHole = forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, HsWrapper
WpHole)
zonkCoFn ZonkEnv
env (WpCompose HsWrapper
c1 HsWrapper
c2) = do { (ZonkEnv
env1, HsWrapper
c1') <- ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn ZonkEnv
env HsWrapper
c1
; (ZonkEnv
env2, HsWrapper
c2') <- ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn ZonkEnv
env1 HsWrapper
c2
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env2, HsWrapper -> HsWrapper -> HsWrapper
WpCompose HsWrapper
c1' HsWrapper
c2') }
zonkCoFn ZonkEnv
env (WpFun HsWrapper
c1 HsWrapper
c2 Scaled Kind
t1 SDoc
d) = do { (ZonkEnv
env1, HsWrapper
c1') <- ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn ZonkEnv
env HsWrapper
c1
; (ZonkEnv
env2, HsWrapper
c2') <- ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn ZonkEnv
env1 HsWrapper
c2
; Scaled Kind
t1' <- ZonkEnv -> Scaled Kind -> TcM (Scaled Kind)
zonkScaledTcTypeToTypeX ZonkEnv
env2 Scaled Kind
t1
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env2, HsWrapper -> HsWrapper -> Scaled Kind -> SDoc -> HsWrapper
WpFun HsWrapper
c1' HsWrapper
c2' Scaled Kind
t1' SDoc
d) }
zonkCoFn ZonkEnv
env (WpCast TcCoercionR
co) = do { TcCoercionR
co' <- ZonkEnv -> TcCoercionR -> TcM TcCoercionR
zonkCoToCo ZonkEnv
env TcCoercionR
co
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, TcCoercionR -> HsWrapper
WpCast TcCoercionR
co') }
zonkCoFn ZonkEnv
env (WpEvLam TcTyVar
ev) = do { (ZonkEnv
env', TcTyVar
ev') <- ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TcTyVar)
zonkEvBndrX ZonkEnv
env TcTyVar
ev
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env', TcTyVar -> HsWrapper
WpEvLam TcTyVar
ev') }
zonkCoFn ZonkEnv
env (WpEvApp EvTerm
arg) = do { EvTerm
arg' <- ZonkEnv -> EvTerm -> TcM EvTerm
zonkEvTerm ZonkEnv
env EvTerm
arg
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, EvTerm -> HsWrapper
WpEvApp EvTerm
arg') }
zonkCoFn ZonkEnv
env (WpTyLam TcTyVar
tv) = ASSERT( isImmutableTyVar tv )
do { (ZonkEnv
env', TcTyVar
tv') <- ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TcTyVar)
zonkTyBndrX ZonkEnv
env TcTyVar
tv
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env', TcTyVar -> HsWrapper
WpTyLam TcTyVar
tv') }
zonkCoFn ZonkEnv
env (WpTyApp Kind
ty) = do { Kind
ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env Kind
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, Kind -> HsWrapper
WpTyApp Kind
ty') }
zonkCoFn ZonkEnv
env (WpLet TcEvBinds
bs) = do { (ZonkEnv
env1, TcEvBinds
bs') <- ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
zonkTcEvBinds ZonkEnv
env TcEvBinds
bs
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env1, TcEvBinds -> HsWrapper
WpLet TcEvBinds
bs') }
zonkCoFn ZonkEnv
env (WpMultCoercion TcCoercionR
co) = do { TcCoercionR
co' <- ZonkEnv -> TcCoercionR -> TcM TcCoercionR
zonkCoToCo ZonkEnv
env TcCoercionR
co
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, TcCoercionR -> HsWrapper
WpMultCoercion TcCoercionR
co') }
zonkOverLit :: ZonkEnv -> HsOverLit GhcTc -> TcM (HsOverLit GhcTc)
zonkOverLit :: ZonkEnv -> HsOverLit GhcTc -> TcM (HsOverLit GhcTc)
zonkOverLit ZonkEnv
env lit :: HsOverLit GhcTc
lit@(OverLit {ol_ext :: forall p. HsOverLit p -> XOverLit p
ol_ext = OverLitTc Bool
r Kind
ty, ol_witness :: forall p. HsOverLit p -> HsExpr p
ol_witness = HsExpr GhcTc
e })
= do { Kind
ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env Kind
ty
; HsExpr GhcTc
e' <- ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkExpr ZonkEnv
env HsExpr GhcTc
e
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsOverLit GhcTc
lit { ol_witness :: HsExpr GhcTc
ol_witness = HsExpr GhcTc
e', ol_ext :: XOverLit GhcTc
ol_ext = Bool -> Kind -> OverLitTc
OverLitTc Bool
r Kind
ty' }) }
zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTc -> TcM (ArithSeqInfo GhcTc)
zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTc -> TcM (ArithSeqInfo GhcTc)
zonkArithSeq ZonkEnv
env (From LHsExpr GhcTc
e)
= do LocatedA (HsExpr GhcTc)
new_e <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e
forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. LHsExpr id -> ArithSeqInfo id
From LocatedA (HsExpr GhcTc)
new_e)
zonkArithSeq ZonkEnv
env (FromThen LHsExpr GhcTc
e1 LHsExpr GhcTc
e2)
= do LocatedA (HsExpr GhcTc)
new_e1 <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e1
LocatedA (HsExpr GhcTc)
new_e2 <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e2
forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThen LocatedA (HsExpr GhcTc)
new_e1 LocatedA (HsExpr GhcTc)
new_e2)
zonkArithSeq ZonkEnv
env (FromTo LHsExpr GhcTc
e1 LHsExpr GhcTc
e2)
= do LocatedA (HsExpr GhcTc)
new_e1 <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e1
LocatedA (HsExpr GhcTc)
new_e2 <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e2
forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromTo LocatedA (HsExpr GhcTc)
new_e1 LocatedA (HsExpr GhcTc)
new_e2)
zonkArithSeq ZonkEnv
env (FromThenTo LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3)
= do LocatedA (HsExpr GhcTc)
new_e1 <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e1
LocatedA (HsExpr GhcTc)
new_e2 <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e2
LocatedA (HsExpr GhcTc)
new_e3 <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
e3
forall (m :: * -> *) a. Monad m => a -> m a
return (forall id.
LHsExpr id -> LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThenTo LocatedA (HsExpr GhcTc)
new_e1 LocatedA (HsExpr GhcTc)
new_e2 LocatedA (HsExpr GhcTc)
new_e3)
zonkStmts :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
=> ZonkEnv
-> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))])
zonkStmts :: forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
~ SrcSpanAnnA) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))])
zonkStmts ZonkEnv
env ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, [])
zonkStmts ZonkEnv
env ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
zBody (LStmt GhcTc (LocatedA (body GhcTc))
s:[LStmt GhcTc (LocatedA (body GhcTc))]
ss) = do { (ZonkEnv
env1, LocatedA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
s') <- forall a b c.
(a -> TcM (b, c)) -> LocatedA a -> TcM (b, LocatedA c)
wrapLocSndMA (forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
~ SrcSpanAnnA) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
-> TcM (ZonkEnv, StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
zonkStmt ZonkEnv
env ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
zBody) LStmt GhcTc (LocatedA (body GhcTc))
s
; (ZonkEnv
env2, [LocatedA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
ss') <- forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
~ SrcSpanAnnA) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))])
zonkStmts ZonkEnv
env1 ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
zBody [LStmt GhcTc (LocatedA (body GhcTc))]
ss
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env2, LocatedA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
s' forall a. a -> [a] -> [a]
: [LocatedA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
ss') }
zonkStmt :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
=> ZonkEnv
-> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> Stmt GhcTc (LocatedA (body GhcTc))
-> TcM (ZonkEnv, Stmt GhcTc (LocatedA (body GhcTc)))
zonkStmt :: forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
~ SrcSpanAnnA) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
-> TcM (ZonkEnv, StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
zonkStmt ZonkEnv
env ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
_ (ParStmt XParStmt GhcTc GhcTc (LocatedA (body GhcTc))
bind_ty [ParStmtBlock GhcTc GhcTc]
stmts_w_bndrs HsExpr GhcTc
mzip_op SyntaxExpr GhcTc
bind_op)
= do { (ZonkEnv
env1, SyntaxExprTc
new_bind_op) <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env SyntaxExpr GhcTc
bind_op
; Kind
new_bind_ty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env1 XParStmt GhcTc GhcTc (LocatedA (body GhcTc))
bind_ty
; [ParStmtBlock GhcTc GhcTc]
new_stmts_w_bndrs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv
-> ParStmtBlock GhcTc GhcTc -> TcM (ParStmtBlock GhcTc GhcTc)
zonk_branch ZonkEnv
env1) [ParStmtBlock GhcTc GhcTc]
stmts_w_bndrs
; let new_binders :: [TcTyVar]
new_binders = [TcTyVar
b | ParStmtBlock XParStmtBlock GhcTc GhcTc
_ [GuardLStmt GhcTc]
_ [IdP GhcTc]
bs SyntaxExpr GhcTc
_ <- [ParStmtBlock GhcTc GhcTc]
new_stmts_w_bndrs
, TcTyVar
b <- [IdP GhcTc]
bs]
env2 :: ZonkEnv
env2 = ZonkEnv -> [TcTyVar] -> ZonkEnv
extendIdZonkEnvRec ZonkEnv
env1 [TcTyVar]
new_binders
; HsExpr GhcTc
new_mzip <- ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkExpr ZonkEnv
env2 HsExpr GhcTc
mzip_op
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env2
, forall idL idR body.
XParStmt idL idR body
-> [ParStmtBlock idL idR]
-> HsExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
ParStmt Kind
new_bind_ty [ParStmtBlock GhcTc GhcTc]
new_stmts_w_bndrs HsExpr GhcTc
new_mzip SyntaxExprTc
new_bind_op)}
where
zonk_branch :: ZonkEnv -> ParStmtBlock GhcTc GhcTc
-> TcM (ParStmtBlock GhcTc GhcTc)
zonk_branch :: ZonkEnv
-> ParStmtBlock GhcTc GhcTc -> TcM (ParStmtBlock GhcTc GhcTc)
zonk_branch ZonkEnv
env1 (ParStmtBlock XParStmtBlock GhcTc GhcTc
x [GuardLStmt GhcTc]
stmts [IdP GhcTc]
bndrs SyntaxExpr GhcTc
return_op)
= do { (ZonkEnv
env2, [GenLocated
(Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
new_stmts) <- forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
~ SrcSpanAnnA) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))])
zonkStmts ZonkEnv
env1 ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr [GuardLStmt GhcTc]
stmts
; (ZonkEnv
env3, SyntaxExprTc
new_return) <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env2 SyntaxExpr GhcTc
return_op
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL idR.
XParStmtBlock idL idR
-> [ExprLStmt idL]
-> [IdP idR]
-> SyntaxExpr idR
-> ParStmtBlock idL idR
ParStmtBlock XParStmtBlock GhcTc GhcTc
x [GenLocated
(Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
new_stmts (ZonkEnv -> [TcTyVar] -> [TcTyVar]
zonkIdOccs ZonkEnv
env3 [IdP GhcTc]
bndrs)
SyntaxExprTc
new_return) }
zonkStmt ZonkEnv
env ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
zBody (RecStmt { recS_stmts :: forall idL idR body.
StmtLR idL idR body -> XRec idR [LStmtLR idL idR body]
recS_stmts = L SrcSpanAnnL
_ [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
segStmts, recS_later_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
recS_later_ids = [IdP GhcTc]
lvs
, recS_rec_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
recS_rec_ids = [IdP GhcTc]
rvs
, recS_ret_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_ret_fn = SyntaxExpr GhcTc
ret_id, recS_mfix_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_mfix_fn = SyntaxExpr GhcTc
mfix_id
, recS_bind_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_bind_fn = SyntaxExpr GhcTc
bind_id
, recS_ext :: forall idL idR body. StmtLR idL idR body -> XRecStmt idL idR body
recS_ext =
RecStmtTc { recS_bind_ty :: RecStmtTc -> Kind
recS_bind_ty = Kind
bind_ty
, recS_later_rets :: RecStmtTc -> [HsExpr GhcTc]
recS_later_rets = [HsExpr GhcTc]
later_rets
, recS_rec_rets :: RecStmtTc -> [HsExpr GhcTc]
recS_rec_rets = [HsExpr GhcTc]
rec_rets
, recS_ret_ty :: RecStmtTc -> Kind
recS_ret_ty = Kind
ret_ty} })
= do { (ZonkEnv
env1, SyntaxExprTc
new_bind_id) <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env SyntaxExpr GhcTc
bind_id
; (ZonkEnv
env2, SyntaxExprTc
new_mfix_id) <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env1 SyntaxExpr GhcTc
mfix_id
; (ZonkEnv
env3, SyntaxExprTc
new_ret_id) <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env2 SyntaxExpr GhcTc
ret_id
; Kind
new_bind_ty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env3 Kind
bind_ty
; [TcTyVar]
new_rvs <- ZonkEnv -> [TcTyVar] -> TcM [TcTyVar]
zonkIdBndrs ZonkEnv
env3 [IdP GhcTc]
rvs
; [TcTyVar]
new_lvs <- ZonkEnv -> [TcTyVar] -> TcM [TcTyVar]
zonkIdBndrs ZonkEnv
env3 [IdP GhcTc]
lvs
; Kind
new_ret_ty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env3 Kind
ret_ty
; let env4 :: ZonkEnv
env4 = ZonkEnv -> [TcTyVar] -> ZonkEnv
extendIdZonkEnvRec ZonkEnv
env3 [TcTyVar]
new_rvs
; (ZonkEnv
env5, [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
new_segStmts) <- forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
~ SrcSpanAnnA) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))])
zonkStmts ZonkEnv
env4 ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
zBody [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
segStmts
; [HsExpr GhcTc]
new_later_rets <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkExpr ZonkEnv
env5) [HsExpr GhcTc]
later_rets
; [HsExpr GhcTc]
new_rec_rets <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkExpr ZonkEnv
env5) [HsExpr GhcTc]
rec_rets
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv -> [TcTyVar] -> ZonkEnv
extendIdZonkEnvRec ZonkEnv
env3 [TcTyVar]
new_lvs,
RecStmt { recS_stmts :: XRec GhcTc [LStmtLR GhcTc GhcTc (LocatedA (body GhcTc))]
recS_stmts = forall a an. a -> LocatedAn an a
noLocA [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
new_segStmts
, recS_later_ids :: [IdP GhcTc]
recS_later_ids = [TcTyVar]
new_lvs
, recS_rec_ids :: [IdP GhcTc]
recS_rec_ids = [TcTyVar]
new_rvs, recS_ret_fn :: SyntaxExpr GhcTc
recS_ret_fn = SyntaxExprTc
new_ret_id
, recS_mfix_fn :: SyntaxExpr GhcTc
recS_mfix_fn = SyntaxExprTc
new_mfix_id, recS_bind_fn :: SyntaxExpr GhcTc
recS_bind_fn = SyntaxExprTc
new_bind_id
, recS_ext :: XRecStmt GhcTc GhcTc (LocatedA (body GhcTc))
recS_ext = RecStmtTc
{ recS_bind_ty :: Kind
recS_bind_ty = Kind
new_bind_ty
, recS_later_rets :: [HsExpr GhcTc]
recS_later_rets = [HsExpr GhcTc]
new_later_rets
, recS_rec_rets :: [HsExpr GhcTc]
recS_rec_rets = [HsExpr GhcTc]
new_rec_rets
, recS_ret_ty :: Kind
recS_ret_ty = Kind
new_ret_ty } }) }
zonkStmt ZonkEnv
env ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
zBody (BodyStmt XBodyStmt GhcTc GhcTc (LocatedA (body GhcTc))
ty LocatedA (body GhcTc)
body SyntaxExpr GhcTc
then_op SyntaxExpr GhcTc
guard_op)
= do (ZonkEnv
env1, SyntaxExprTc
new_then_op) <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env SyntaxExpr GhcTc
then_op
(ZonkEnv
env2, SyntaxExprTc
new_guard_op) <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env1 SyntaxExpr GhcTc
guard_op
LocatedA (body GhcTc)
new_body <- ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
zBody ZonkEnv
env2 LocatedA (body GhcTc)
body
Kind
new_ty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env2 XBodyStmt GhcTc GhcTc (LocatedA (body GhcTc))
ty
forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env2, forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt Kind
new_ty LocatedA (body GhcTc)
new_body SyntaxExprTc
new_then_op SyntaxExprTc
new_guard_op)
zonkStmt ZonkEnv
env ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
zBody (LastStmt XLastStmt GhcTc GhcTc (LocatedA (body GhcTc))
x LocatedA (body GhcTc)
body Maybe Bool
noret SyntaxExpr GhcTc
ret_op)
= do (ZonkEnv
env1, SyntaxExprTc
new_ret) <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env SyntaxExpr GhcTc
ret_op
LocatedA (body GhcTc)
new_body <- ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
zBody ZonkEnv
env1 LocatedA (body GhcTc)
body
forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcTc GhcTc (LocatedA (body GhcTc))
x LocatedA (body GhcTc)
new_body Maybe Bool
noret SyntaxExprTc
new_ret)
zonkStmt ZonkEnv
env ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
_ (TransStmt { trS_stmts :: forall idL idR body. StmtLR idL idR body -> [ExprLStmt idL]
trS_stmts = [GuardLStmt GhcTc]
stmts, trS_bndrs :: forall idL idR body. StmtLR idL idR body -> [(IdP idR, IdP idR)]
trS_bndrs = [(IdP GhcTc, IdP GhcTc)]
binderMap
, trS_by :: forall idL idR body. StmtLR idL idR body -> Maybe (LHsExpr idR)
trS_by = Maybe (LHsExpr GhcTc)
by, trS_form :: forall idL idR body. StmtLR idL idR body -> TransForm
trS_form = TransForm
form, trS_using :: forall idL idR body. StmtLR idL idR body -> LHsExpr idR
trS_using = LHsExpr GhcTc
using
, trS_ret :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
trS_ret = SyntaxExpr GhcTc
return_op, trS_bind :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
trS_bind = SyntaxExpr GhcTc
bind_op
, trS_ext :: forall idL idR body. StmtLR idL idR body -> XTransStmt idL idR body
trS_ext = XTransStmt GhcTc GhcTc (LocatedA (body GhcTc))
bind_arg_ty
, trS_fmap :: forall idL idR body. StmtLR idL idR body -> HsExpr idR
trS_fmap = HsExpr GhcTc
liftM_op })
= do {
; (ZonkEnv
env1, SyntaxExprTc
bind_op') <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env SyntaxExpr GhcTc
bind_op
; Kind
bind_arg_ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env1 XTransStmt GhcTc GhcTc (LocatedA (body GhcTc))
bind_arg_ty
; (ZonkEnv
env2, [GenLocated
(Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts') <- forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
~ SrcSpanAnnA) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))])
zonkStmts ZonkEnv
env1 ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr [GuardLStmt GhcTc]
stmts
; Maybe (LocatedA (HsExpr GhcTc))
by' <- forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
fmapMaybeM (ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env2) Maybe (LHsExpr GhcTc)
by
; LocatedA (HsExpr GhcTc)
using' <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env2 LHsExpr GhcTc
using
; (ZonkEnv
env3, SyntaxExprTc
return_op') <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env2 SyntaxExpr GhcTc
return_op
; [(TcTyVar, TcTyVar)]
binderMap' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv
-> (TcTyVar, TcTyVar)
-> IOEnv (Env TcGblEnv TcLclEnv) (TcTyVar, TcTyVar)
zonkBinderMapEntry ZonkEnv
env3) [(IdP GhcTc, IdP GhcTc)]
binderMap
; HsExpr GhcTc
liftM_op' <- ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkExpr ZonkEnv
env3 HsExpr GhcTc
liftM_op
; let env3' :: ZonkEnv
env3' = ZonkEnv -> [TcTyVar] -> ZonkEnv
extendIdZonkEnvRec ZonkEnv
env3 (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(TcTyVar, TcTyVar)]
binderMap')
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env3', TransStmt { trS_stmts :: [GuardLStmt GhcTc]
trS_stmts = [GenLocated
(Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts', trS_bndrs :: [(IdP GhcTc, IdP GhcTc)]
trS_bndrs = [(TcTyVar, TcTyVar)]
binderMap'
, trS_by :: Maybe (LHsExpr GhcTc)
trS_by = Maybe (LocatedA (HsExpr GhcTc))
by', trS_form :: TransForm
trS_form = TransForm
form, trS_using :: LHsExpr GhcTc
trS_using = LocatedA (HsExpr GhcTc)
using'
, trS_ret :: SyntaxExpr GhcTc
trS_ret = SyntaxExprTc
return_op', trS_bind :: SyntaxExpr GhcTc
trS_bind = SyntaxExprTc
bind_op'
, trS_ext :: XTransStmt GhcTc GhcTc (LocatedA (body GhcTc))
trS_ext = Kind
bind_arg_ty'
, trS_fmap :: HsExpr GhcTc
trS_fmap = HsExpr GhcTc
liftM_op' }) }
where
zonkBinderMapEntry :: ZonkEnv
-> (TcTyVar, TcTyVar)
-> IOEnv (Env TcGblEnv TcLclEnv) (TcTyVar, TcTyVar)
zonkBinderMapEntry ZonkEnv
env (TcTyVar
oldBinder, TcTyVar
newBinder) = do
let oldBinder' :: TcTyVar
oldBinder' = ZonkEnv -> TcTyVar -> TcTyVar
zonkIdOcc ZonkEnv
env TcTyVar
oldBinder
TcTyVar
newBinder' <- ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkIdBndr ZonkEnv
env TcTyVar
newBinder
forall (m :: * -> *) a. Monad m => a -> m a
return (TcTyVar
oldBinder', TcTyVar
newBinder')
zonkStmt ZonkEnv
env ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
_ (LetStmt XLetStmt GhcTc GhcTc (LocatedA (body GhcTc))
x HsLocalBinds GhcTc
binds)
= do (ZonkEnv
env1, HsLocalBinds GhcTc
new_binds) <- ZonkEnv -> HsLocalBinds GhcTc -> TcM (ZonkEnv, HsLocalBinds GhcTc)
zonkLocalBinds ZonkEnv
env HsLocalBinds GhcTc
binds
forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env1, forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcTc GhcTc (LocatedA (body GhcTc))
x HsLocalBinds GhcTc
new_binds)
zonkStmt ZonkEnv
env ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
zBody (BindStmt XBindStmt GhcTc GhcTc (LocatedA (body GhcTc))
xbs LPat GhcTc
pat LocatedA (body GhcTc)
body)
= do { (ZonkEnv
env1, SyntaxExprTc
new_bind) <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env (XBindStmtTc -> SyntaxExpr GhcTc
xbstc_bindOp XBindStmt GhcTc GhcTc (LocatedA (body GhcTc))
xbs)
; Kind
new_w <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env1 (XBindStmtTc -> Kind
xbstc_boundResultMult XBindStmt GhcTc GhcTc (LocatedA (body GhcTc))
xbs)
; Kind
new_bind_ty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env1 (XBindStmtTc -> Kind
xbstc_boundResultType XBindStmt GhcTc GhcTc (LocatedA (body GhcTc))
xbs)
; LocatedA (body GhcTc)
new_body <- ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
zBody ZonkEnv
env1 LocatedA (body GhcTc)
body
; (ZonkEnv
env2, GenLocated SrcSpanAnnA (Pat GhcTc)
new_pat) <- ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
zonkPat ZonkEnv
env1 LPat GhcTc
pat
; Maybe SyntaxExprTc
new_fail <- case XBindStmtTc -> Maybe (SyntaxExpr GhcTc)
xbstc_failOp XBindStmt GhcTc GhcTc (LocatedA (body GhcTc))
xbs of
Maybe (SyntaxExpr GhcTc)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just SyntaxExpr GhcTc
f -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env1 SyntaxExpr GhcTc
f)
; forall (m :: * -> *) a. Monad m => a -> m a
return ( ZonkEnv
env2
, forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt (XBindStmtTc
{ xbstc_bindOp :: SyntaxExpr GhcTc
xbstc_bindOp = SyntaxExprTc
new_bind
, xbstc_boundResultType :: Kind
xbstc_boundResultType = Kind
new_bind_ty
, xbstc_boundResultMult :: Kind
xbstc_boundResultMult = Kind
new_w
, xbstc_failOp :: Maybe (SyntaxExpr GhcTc)
xbstc_failOp = Maybe SyntaxExprTc
new_fail
})
GenLocated SrcSpanAnnA (Pat GhcTc)
new_pat LocatedA (body GhcTc)
new_body) }
zonkStmt ZonkEnv
env ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))
_zBody (ApplicativeStmt XApplicativeStmt GhcTc GhcTc (LocatedA (body GhcTc))
body_ty [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
args Maybe (SyntaxExpr GhcTc)
mb_join)
= do { (ZonkEnv
env1, Maybe SyntaxExprTc
new_mb_join) <- ZonkEnv
-> Maybe SyntaxExprTc
-> IOEnv (Env TcGblEnv TcLclEnv) (ZonkEnv, Maybe SyntaxExprTc)
zonk_join ZonkEnv
env Maybe (SyntaxExpr GhcTc)
mb_join
; (ZonkEnv
env2, [(SyntaxExprTc, ApplicativeArg GhcTc)]
new_args) <- ZonkEnv
-> [(SyntaxExprTc, ApplicativeArg GhcTc)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(ZonkEnv, [(SyntaxExprTc, ApplicativeArg GhcTc)])
zonk_args ZonkEnv
env1 [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
args
; Kind
new_body_ty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env2 XApplicativeStmt GhcTc GhcTc (LocatedA (body GhcTc))
body_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return ( ZonkEnv
env2
, forall idL idR body.
XApplicativeStmt idL idR body
-> [(SyntaxExpr idR, ApplicativeArg idL)]
-> Maybe (SyntaxExpr idR)
-> StmtLR idL idR body
ApplicativeStmt Kind
new_body_ty [(SyntaxExprTc, ApplicativeArg GhcTc)]
new_args Maybe SyntaxExprTc
new_mb_join) }
where
zonk_join :: ZonkEnv
-> Maybe SyntaxExprTc
-> IOEnv (Env TcGblEnv TcLclEnv) (ZonkEnv, Maybe SyntaxExprTc)
zonk_join ZonkEnv
env Maybe SyntaxExprTc
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, forall a. Maybe a
Nothing)
zonk_join ZonkEnv
env (Just SyntaxExprTc
j) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env SyntaxExprTc
j
get_pat :: (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> LPat GhcTc
get_pat :: (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> LPat GhcTc
get_pat (SyntaxExpr GhcTc
_, ApplicativeArgOne XApplicativeArgOne GhcTc
_ LPat GhcTc
pat LHsExpr GhcTc
_ Bool
_) = LPat GhcTc
pat
get_pat (SyntaxExpr GhcTc
_, ApplicativeArgMany XApplicativeArgMany GhcTc
_ [GuardLStmt GhcTc]
_ HsExpr GhcTc
_ LPat GhcTc
pat HsStmtContext (ApplicativeArgStmCtxPass GhcTc)
_) = LPat GhcTc
pat
replace_pat :: LPat GhcTc
-> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
replace_pat :: LPat GhcTc
-> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
replace_pat LPat GhcTc
pat (SyntaxExpr GhcTc
op, ApplicativeArgOne XApplicativeArgOne GhcTc
fail_op LPat GhcTc
_ LHsExpr GhcTc
a Bool
isBody)
= (SyntaxExpr GhcTc
op, forall idL.
XApplicativeArgOne idL
-> LPat idL -> LHsExpr idL -> Bool -> ApplicativeArg idL
ApplicativeArgOne XApplicativeArgOne GhcTc
fail_op LPat GhcTc
pat LHsExpr GhcTc
a Bool
isBody)
replace_pat LPat GhcTc
pat (SyntaxExpr GhcTc
op, ApplicativeArgMany XApplicativeArgMany GhcTc
x [GuardLStmt GhcTc]
a HsExpr GhcTc
b LPat GhcTc
_ HsStmtContext (ApplicativeArgStmCtxPass GhcTc)
c)
= (SyntaxExpr GhcTc
op, forall idL.
XApplicativeArgMany idL
-> [ExprLStmt idL]
-> HsExpr idL
-> LPat idL
-> HsStmtContext (ApplicativeArgStmCtxPass idL)
-> ApplicativeArg idL
ApplicativeArgMany XApplicativeArgMany GhcTc
x [GuardLStmt GhcTc]
a HsExpr GhcTc
b LPat GhcTc
pat HsStmtContext (ApplicativeArgStmCtxPass GhcTc)
c)
zonk_args :: ZonkEnv
-> [(SyntaxExprTc, ApplicativeArg GhcTc)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(ZonkEnv, [(SyntaxExprTc, ApplicativeArg GhcTc)])
zonk_args ZonkEnv
env [(SyntaxExprTc, ApplicativeArg GhcTc)]
args
= do { (ZonkEnv
env1, [(SyntaxExprTc, ApplicativeArg GhcTc)]
new_args_rev) <- ZonkEnv
-> [(SyntaxExprTc, ApplicativeArg GhcTc)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(ZonkEnv, [(SyntaxExprTc, ApplicativeArg GhcTc)])
zonk_args_rev ZonkEnv
env (forall a. [a] -> [a]
reverse [(SyntaxExprTc, ApplicativeArg GhcTc)]
args)
; (ZonkEnv
env2, [GenLocated SrcSpanAnnA (Pat GhcTc)]
new_pats) <- ZonkEnv -> [LPat GhcTc] -> TcM (ZonkEnv, [LPat GhcTc])
zonkPats ZonkEnv
env1 (forall a b. (a -> b) -> [a] -> [b]
map (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> LPat GhcTc
get_pat [(SyntaxExprTc, ApplicativeArg GhcTc)]
args)
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env2, forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"zonkStmt" LPat GhcTc
-> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
replace_pat
[GenLocated SrcSpanAnnA (Pat GhcTc)]
new_pats (forall a. [a] -> [a]
reverse [(SyntaxExprTc, ApplicativeArg GhcTc)]
new_args_rev)) }
zonk_args_rev :: ZonkEnv
-> [(SyntaxExprTc, ApplicativeArg GhcTc)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(ZonkEnv, [(SyntaxExprTc, ApplicativeArg GhcTc)])
zonk_args_rev ZonkEnv
env ((SyntaxExprTc
op, ApplicativeArg GhcTc
arg) : [(SyntaxExprTc, ApplicativeArg GhcTc)]
args)
= do { (ZonkEnv
env1, SyntaxExprTc
new_op) <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env SyntaxExprTc
op
; ApplicativeArg GhcTc
new_arg <- ZonkEnv
-> ApplicativeArg GhcTc
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
zonk_arg ZonkEnv
env1 ApplicativeArg GhcTc
arg
; (ZonkEnv
env2, [(SyntaxExprTc, ApplicativeArg GhcTc)]
new_args) <- ZonkEnv
-> [(SyntaxExprTc, ApplicativeArg GhcTc)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(ZonkEnv, [(SyntaxExprTc, ApplicativeArg GhcTc)])
zonk_args_rev ZonkEnv
env1 [(SyntaxExprTc, ApplicativeArg GhcTc)]
args
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env2, (SyntaxExprTc
new_op, ApplicativeArg GhcTc
new_arg) forall a. a -> [a] -> [a]
: [(SyntaxExprTc, ApplicativeArg GhcTc)]
new_args) }
zonk_args_rev ZonkEnv
env [] = forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, [])
zonk_arg :: ZonkEnv
-> ApplicativeArg GhcTc
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcTc)
zonk_arg ZonkEnv
env (ApplicativeArgOne XApplicativeArgOne GhcTc
fail_op LPat GhcTc
pat LHsExpr GhcTc
expr Bool
isBody)
= do { LocatedA (HsExpr GhcTc)
new_expr <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
expr
; Maybe SyntaxExprTc
new_fail <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM XApplicativeArgOne GhcTc
fail_op forall a b. (a -> b) -> a -> b
$ \SyntaxExprTc
old_fail ->
do { (ZonkEnv
_, SyntaxExprTc
fail') <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env SyntaxExprTc
old_fail
; forall (m :: * -> *) a. Monad m => a -> m a
return SyntaxExprTc
fail'
}
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL.
XApplicativeArgOne idL
-> LPat idL -> LHsExpr idL -> Bool -> ApplicativeArg idL
ApplicativeArgOne Maybe SyntaxExprTc
new_fail LPat GhcTc
pat LocatedA (HsExpr GhcTc)
new_expr Bool
isBody) }
zonk_arg ZonkEnv
env (ApplicativeArgMany XApplicativeArgMany GhcTc
x [GuardLStmt GhcTc]
stmts HsExpr GhcTc
ret LPat GhcTc
pat HsStmtContext (ApplicativeArgStmCtxPass GhcTc)
ctxt)
= do { (ZonkEnv
env1, [GenLocated
(Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
new_stmts) <- forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
~ SrcSpanAnnA) =>
ZonkEnv
-> (ZonkEnv
-> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))])
zonkStmts ZonkEnv
env ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr [GuardLStmt GhcTc]
stmts
; HsExpr GhcTc
new_ret <- ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkExpr ZonkEnv
env1 HsExpr GhcTc
ret
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL.
XApplicativeArgMany idL
-> [ExprLStmt idL]
-> HsExpr idL
-> LPat idL
-> HsStmtContext (ApplicativeArgStmCtxPass idL)
-> ApplicativeArg idL
ApplicativeArgMany XApplicativeArgMany GhcTc
x [GenLocated
(Anno (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
(StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
new_stmts HsExpr GhcTc
new_ret LPat GhcTc
pat HsStmtContext (ApplicativeArgStmCtxPass GhcTc)
ctxt) }
zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTc -> TcM (HsRecordBinds GhcTc)
zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTc -> TcM (HsRecordBinds GhcTc)
zonkRecFields ZonkEnv
env (HsRecFields [LHsRecField GhcTc (LHsExpr GhcTc)]
flds Maybe (Located ConTag)
dd)
= do { [GenLocated
SrcSpanAnnA
(HsRecField' (FieldOcc GhcTc) (LocatedA (HsExpr GhcTc)))]
flds' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated
SrcSpanAnnA
(HsRecField' (FieldOcc GhcTc) (LocatedA (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA
(HsRecField' (FieldOcc GhcTc) (LocatedA (HsExpr GhcTc))))
zonk_rbind [LHsRecField GhcTc (LHsExpr GhcTc)]
flds
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p arg.
[LHsRecField p arg] -> Maybe (Located ConTag) -> HsRecFields p arg
HsRecFields [GenLocated
SrcSpanAnnA
(HsRecField' (FieldOcc GhcTc) (LocatedA (HsExpr GhcTc)))]
flds' Maybe (Located ConTag)
dd) }
where
zonk_rbind :: GenLocated
SrcSpanAnnA
(HsRecField' (FieldOcc GhcTc) (LocatedA (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA
(HsRecField' (FieldOcc GhcTc) (LocatedA (HsExpr GhcTc))))
zonk_rbind (L SrcSpanAnnA
l HsRecField' (FieldOcc GhcTc) (LocatedA (HsExpr GhcTc))
fld)
= do { Located (FieldOcc GhcTc)
new_id <- forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM (ZonkEnv -> FieldOcc GhcTc -> TcM (FieldOcc GhcTc)
zonkFieldOcc ZonkEnv
env) (forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl HsRecField' (FieldOcc GhcTc) (LocatedA (HsExpr GhcTc))
fld)
; LocatedA (HsExpr GhcTc)
new_expr <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env (forall id arg. HsRecField' id arg -> arg
hsRecFieldArg HsRecField' (FieldOcc GhcTc) (LocatedA (HsExpr GhcTc))
fld)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsRecField' (FieldOcc GhcTc) (LocatedA (HsExpr GhcTc))
fld { hsRecFieldLbl :: Located (FieldOcc GhcTc)
hsRecFieldLbl = Located (FieldOcc GhcTc)
new_id
, hsRecFieldArg :: LocatedA (HsExpr GhcTc)
hsRecFieldArg = LocatedA (HsExpr GhcTc)
new_expr })) }
zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTc]
-> TcM [LHsRecUpdField GhcTc]
zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTc] -> TcM [LHsRecUpdField GhcTc]
zonkRecUpdFields ZonkEnv
env = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated
SrcSpanAnnA
(HsRecField' (AmbiguousFieldOcc GhcTc) (LocatedA (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA
(HsRecField' (AmbiguousFieldOcc GhcTc) (LocatedA (HsExpr GhcTc))))
zonk_rbind
where
zonk_rbind :: GenLocated
SrcSpanAnnA
(HsRecField' (AmbiguousFieldOcc GhcTc) (LocatedA (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA
(HsRecField' (AmbiguousFieldOcc GhcTc) (LocatedA (HsExpr GhcTc))))
zonk_rbind (L SrcSpanAnnA
l HsRecField' (AmbiguousFieldOcc GhcTc) (LocatedA (HsExpr GhcTc))
fld)
= do { Located (FieldOcc GhcTc)
new_id <- forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM (ZonkEnv -> FieldOcc GhcTc -> TcM (FieldOcc GhcTc)
zonkFieldOcc ZonkEnv
env) (forall arg.
HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc
hsRecUpdFieldOcc HsRecField' (AmbiguousFieldOcc GhcTc) (LocatedA (HsExpr GhcTc))
fld)
; LocatedA (HsExpr GhcTc)
new_expr <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env (forall id arg. HsRecField' id arg -> arg
hsRecFieldArg HsRecField' (AmbiguousFieldOcc GhcTc) (LocatedA (HsExpr GhcTc))
fld)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsRecField' (AmbiguousFieldOcc GhcTc) (LocatedA (HsExpr GhcTc))
fld { hsRecFieldLbl :: Located (AmbiguousFieldOcc GhcTc)
hsRecFieldLbl = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc
ambiguousFieldOcc Located (FieldOcc GhcTc)
new_id
, hsRecFieldArg :: LocatedA (HsExpr GhcTc)
hsRecFieldArg = LocatedA (HsExpr GhcTc)
new_expr })) }
mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a
-> TcM (Either (Located HsIPName) b)
mapIPNameTc :: forall a b.
(a -> TcM b)
-> Either (Located HsIPName) a -> TcM (Either (Located HsIPName) b)
mapIPNameTc a -> TcM b
_ (Left Located HsIPName
x) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left Located HsIPName
x)
mapIPNameTc a -> TcM b
f (Right a
x) = do b
r <- a -> TcM b
f a
x
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right b
r)
zonkPat :: ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
zonkPat :: ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
zonkPat ZonkEnv
env LPat GhcTc
pat = forall a b c.
(a -> TcM (b, c)) -> LocatedA a -> TcM (b, LocatedA c)
wrapLocSndMA (ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc)
zonk_pat ZonkEnv
env) LPat GhcTc
pat
zonk_pat :: ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc)
zonk_pat :: ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc)
zonk_pat ZonkEnv
env (ParPat XParPat GhcTc
x LPat GhcTc
p)
= do { (ZonkEnv
env', GenLocated SrcSpanAnnA (Pat GhcTc)
p') <- ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
zonkPat ZonkEnv
env LPat GhcTc
p
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env', forall p. XParPat p -> LPat p -> Pat p
ParPat XParPat GhcTc
x GenLocated SrcSpanAnnA (Pat GhcTc)
p') }
zonk_pat ZonkEnv
env (WildPat XWildPat GhcTc
ty)
= do { Kind
ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env XWildPat GhcTc
ty
; Kind -> SDoc -> TcM ()
ensureNotLevPoly Kind
ty'
(String -> SDoc
text String
"In a wildcard pattern")
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, forall p. XWildPat p -> Pat p
WildPat Kind
ty') }
zonk_pat ZonkEnv
env (VarPat XVarPat GhcTc
x (L SrcSpanAnnN
l TcTyVar
v))
= do { TcTyVar
v' <- ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkIdBndr ZonkEnv
env TcTyVar
v
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv -> TcTyVar -> ZonkEnv
extendIdZonkEnv ZonkEnv
env TcTyVar
v', forall p. XVarPat p -> LIdP p -> Pat p
VarPat XVarPat GhcTc
x (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l TcTyVar
v')) }
zonk_pat ZonkEnv
env (LazyPat XLazyPat GhcTc
x LPat GhcTc
pat)
= do { (ZonkEnv
env', GenLocated SrcSpanAnnA (Pat GhcTc)
pat') <- ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
zonkPat ZonkEnv
env LPat GhcTc
pat
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env', forall p. XLazyPat p -> LPat p -> Pat p
LazyPat XLazyPat GhcTc
x GenLocated SrcSpanAnnA (Pat GhcTc)
pat') }
zonk_pat ZonkEnv
env (BangPat XBangPat GhcTc
x LPat GhcTc
pat)
= do { (ZonkEnv
env', GenLocated SrcSpanAnnA (Pat GhcTc)
pat') <- ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
zonkPat ZonkEnv
env LPat GhcTc
pat
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env', forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat GhcTc
x GenLocated SrcSpanAnnA (Pat GhcTc)
pat') }
zonk_pat ZonkEnv
env (AsPat XAsPat GhcTc
x (L SrcSpanAnnN
loc TcTyVar
v) LPat GhcTc
pat)
= do { TcTyVar
v' <- ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkIdBndr ZonkEnv
env TcTyVar
v
; (ZonkEnv
env', GenLocated SrcSpanAnnA (Pat GhcTc)
pat') <- ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
zonkPat (ZonkEnv -> TcTyVar -> ZonkEnv
extendIdZonkEnv ZonkEnv
env TcTyVar
v') LPat GhcTc
pat
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env', forall p. XAsPat p -> LIdP p -> LPat p -> Pat p
AsPat XAsPat GhcTc
x (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc TcTyVar
v') GenLocated SrcSpanAnnA (Pat GhcTc)
pat') }
zonk_pat ZonkEnv
env (ViewPat XViewPat GhcTc
ty LHsExpr GhcTc
expr LPat GhcTc
pat)
= do { LocatedA (HsExpr GhcTc)
expr' <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env LHsExpr GhcTc
expr
; (ZonkEnv
env', GenLocated SrcSpanAnnA (Pat GhcTc)
pat') <- ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
zonkPat ZonkEnv
env LPat GhcTc
pat
; Kind
ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env XViewPat GhcTc
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env', forall p. XViewPat p -> LHsExpr p -> LPat p -> Pat p
ViewPat Kind
ty' LocatedA (HsExpr GhcTc)
expr' GenLocated SrcSpanAnnA (Pat GhcTc)
pat') }
zonk_pat ZonkEnv
env (ListPat (ListPatTc Kind
ty Maybe (Kind, SyntaxExpr GhcTc)
Nothing) [LPat GhcTc]
pats)
= do { Kind
ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env Kind
ty
; (ZonkEnv
env', [GenLocated SrcSpanAnnA (Pat GhcTc)]
pats') <- ZonkEnv -> [LPat GhcTc] -> TcM (ZonkEnv, [LPat GhcTc])
zonkPats ZonkEnv
env [LPat GhcTc]
pats
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env', forall p. XListPat p -> [LPat p] -> Pat p
ListPat (Kind -> Maybe (Kind, SyntaxExpr GhcTc) -> ListPatTc
ListPatTc Kind
ty' forall a. Maybe a
Nothing) [GenLocated SrcSpanAnnA (Pat GhcTc)]
pats') }
zonk_pat ZonkEnv
env (ListPat (ListPatTc Kind
ty (Just (Kind
ty2,SyntaxExpr GhcTc
wit))) [LPat GhcTc]
pats)
= do { (ZonkEnv
env', SyntaxExprTc
wit') <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env SyntaxExpr GhcTc
wit
; Kind
ty2' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env' Kind
ty2
; Kind
ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env' Kind
ty
; (ZonkEnv
env'', [GenLocated SrcSpanAnnA (Pat GhcTc)]
pats') <- ZonkEnv -> [LPat GhcTc] -> TcM (ZonkEnv, [LPat GhcTc])
zonkPats ZonkEnv
env' [LPat GhcTc]
pats
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env'', forall p. XListPat p -> [LPat p] -> Pat p
ListPat (Kind -> Maybe (Kind, SyntaxExpr GhcTc) -> ListPatTc
ListPatTc Kind
ty' (forall a. a -> Maybe a
Just (Kind
ty2',SyntaxExprTc
wit'))) [GenLocated SrcSpanAnnA (Pat GhcTc)]
pats') }
zonk_pat ZonkEnv
env (TuplePat XTuplePat GhcTc
tys [LPat GhcTc]
pats Boxity
boxed)
= do { [Kind]
tys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env) XTuplePat GhcTc
tys
; (ZonkEnv
env', [GenLocated SrcSpanAnnA (Pat GhcTc)]
pats') <- ZonkEnv -> [LPat GhcTc] -> TcM (ZonkEnv, [LPat GhcTc])
zonkPats ZonkEnv
env [LPat GhcTc]
pats
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env', forall p. XTuplePat p -> [LPat p] -> Boxity -> Pat p
TuplePat [Kind]
tys' [GenLocated SrcSpanAnnA (Pat GhcTc)]
pats' Boxity
boxed) }
zonk_pat ZonkEnv
env (SumPat XSumPat GhcTc
tys LPat GhcTc
pat ConTag
alt ConTag
arity )
= do { [Kind]
tys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env) XSumPat GhcTc
tys
; (ZonkEnv
env', GenLocated SrcSpanAnnA (Pat GhcTc)
pat') <- ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
zonkPat ZonkEnv
env LPat GhcTc
pat
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env', forall p. XSumPat p -> LPat p -> ConTag -> ConTag -> Pat p
SumPat [Kind]
tys' GenLocated SrcSpanAnnA (Pat GhcTc)
pat' ConTag
alt ConTag
arity) }
zonk_pat ZonkEnv
env p :: Pat GhcTc
p@(ConPat { pat_con :: forall p. Pat p -> XRec p (ConLikeP p)
pat_con = L SrcSpanAnnN
_ ConLike
con
, pat_args :: forall p. Pat p -> HsConPatDetails p
pat_args = HsConPatDetails GhcTc
args
, pat_con_ext :: forall p. Pat p -> XConPat p
pat_con_ext = p' :: XConPat GhcTc
p'@(ConPatTc
{ cpt_tvs :: ConPatTc -> [TcTyVar]
cpt_tvs = [TcTyVar]
tyvars
, cpt_dicts :: ConPatTc -> [TcTyVar]
cpt_dicts = [TcTyVar]
evs
, cpt_binds :: ConPatTc -> TcEvBinds
cpt_binds = TcEvBinds
binds
, cpt_wrap :: ConPatTc -> HsWrapper
cpt_wrap = HsWrapper
wrapper
, cpt_arg_tys :: ConPatTc -> [Kind]
cpt_arg_tys = [Kind]
tys
})
})
= ASSERT( all isImmutableTyVar tyvars )
do { [Kind]
new_tys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env) [Kind]
tys
; case ConLike
con of
RealDataCon DataCon
dc
| TcTyCon -> Bool
isUnboxedTupleTyCon (DataCon -> TcTyCon
dataConTyCon DataCon
dc)
-> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SDoc -> Kind -> TcM ()
checkForLevPoly SDoc
doc) ([Kind] -> [Kind]
dropRuntimeRepArgs [Kind]
new_tys)
ConLike
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
; (ZonkEnv
env0, [TcTyVar]
new_tyvars) <- ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TcTyVar])
zonkTyBndrsX ZonkEnv
env [TcTyVar]
tyvars
; (ZonkEnv
env1, [TcTyVar]
new_evs) <- ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TcTyVar])
zonkEvBndrsX ZonkEnv
env0 [TcTyVar]
evs
; (ZonkEnv
env2, TcEvBinds
new_binds) <- ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
zonkTcEvBinds ZonkEnv
env1 TcEvBinds
binds
; (ZonkEnv
env3, HsWrapper
new_wrapper) <- ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn ZonkEnv
env2 HsWrapper
wrapper
; (ZonkEnv
env', HsConDetails
(HsPatSigType GhcRn)
(GenLocated SrcSpanAnnA (Pat GhcTc))
(HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)))
new_args) <- ZonkEnv
-> HsConPatDetails GhcTc -> TcM (ZonkEnv, HsConPatDetails GhcTc)
zonkConStuff ZonkEnv
env3 HsConPatDetails GhcTc
args
; forall (f :: * -> *) a. Applicative f => a -> f a
pure ( ZonkEnv
env'
, Pat GhcTc
p
{ pat_args :: HsConPatDetails GhcTc
pat_args = HsConDetails
(HsPatSigType GhcRn)
(GenLocated SrcSpanAnnA (Pat GhcTc))
(HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)))
new_args
, pat_con_ext :: XConPat GhcTc
pat_con_ext = XConPat GhcTc
p'
{ cpt_arg_tys :: [Kind]
cpt_arg_tys = [Kind]
new_tys
, cpt_tvs :: [TcTyVar]
cpt_tvs = [TcTyVar]
new_tyvars
, cpt_dicts :: [TcTyVar]
cpt_dicts = [TcTyVar]
new_evs
, cpt_binds :: TcEvBinds
cpt_binds = TcEvBinds
new_binds
, cpt_wrap :: HsWrapper
cpt_wrap = HsWrapper
new_wrapper
}
}
)
}
where
doc :: SDoc
doc = String -> SDoc
text String
"In the type of an element of an unboxed tuple pattern:" SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Pat GhcTc
p
zonk_pat ZonkEnv
env (LitPat XLitPat GhcTc
x HsLit GhcTc
lit) = forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, forall p. XLitPat p -> HsLit p -> Pat p
LitPat XLitPat GhcTc
x HsLit GhcTc
lit)
zonk_pat ZonkEnv
env (SigPat XSigPat GhcTc
ty LPat GhcTc
pat HsPatSigType (NoGhcTc GhcTc)
hs_ty)
= do { Kind
ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env XSigPat GhcTc
ty
; (ZonkEnv
env', GenLocated SrcSpanAnnA (Pat GhcTc)
pat') <- ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
zonkPat ZonkEnv
env LPat GhcTc
pat
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env', forall p. XSigPat p -> LPat p -> HsPatSigType (NoGhcTc p) -> Pat p
SigPat Kind
ty' GenLocated SrcSpanAnnA (Pat GhcTc)
pat' HsPatSigType (NoGhcTc GhcTc)
hs_ty) }
zonk_pat ZonkEnv
env (NPat XNPat GhcTc
ty (L SrcSpan
l HsOverLit GhcTc
lit) Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
eq_expr)
= do { (ZonkEnv
env1, SyntaxExprTc
eq_expr') <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env SyntaxExpr GhcTc
eq_expr
; (ZonkEnv
env2, Maybe SyntaxExprTc
mb_neg') <- case Maybe (SyntaxExpr GhcTc)
mb_neg of
Maybe (SyntaxExpr GhcTc)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env1, forall a. Maybe a
Nothing)
Just SyntaxExpr GhcTc
n -> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env1 SyntaxExpr GhcTc
n
; HsOverLit GhcTc
lit' <- ZonkEnv -> HsOverLit GhcTc -> TcM (HsOverLit GhcTc)
zonkOverLit ZonkEnv
env2 HsOverLit GhcTc
lit
; Kind
ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env2 XNPat GhcTc
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env2, forall p.
XNPat p
-> XRec p (HsOverLit p)
-> Maybe (SyntaxExpr p)
-> SyntaxExpr p
-> Pat p
NPat Kind
ty' (forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsOverLit GhcTc
lit') Maybe SyntaxExprTc
mb_neg' SyntaxExprTc
eq_expr') }
zonk_pat ZonkEnv
env (NPlusKPat XNPlusKPat GhcTc
ty (L SrcSpanAnnN
loc TcTyVar
n) (L SrcSpan
l HsOverLit GhcTc
lit1) HsOverLit GhcTc
lit2 SyntaxExpr GhcTc
e1 SyntaxExpr GhcTc
e2)
= do { (ZonkEnv
env1, SyntaxExprTc
e1') <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env SyntaxExpr GhcTc
e1
; (ZonkEnv
env2, SyntaxExprTc
e2') <- ZonkEnv -> SyntaxExpr GhcTc -> TcM (ZonkEnv, SyntaxExpr GhcTc)
zonkSyntaxExpr ZonkEnv
env1 SyntaxExpr GhcTc
e2
; TcTyVar
n' <- ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkIdBndr ZonkEnv
env2 TcTyVar
n
; HsOverLit GhcTc
lit1' <- ZonkEnv -> HsOverLit GhcTc -> TcM (HsOverLit GhcTc)
zonkOverLit ZonkEnv
env2 HsOverLit GhcTc
lit1
; HsOverLit GhcTc
lit2' <- ZonkEnv -> HsOverLit GhcTc -> TcM (HsOverLit GhcTc)
zonkOverLit ZonkEnv
env2 HsOverLit GhcTc
lit2
; Kind
ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env2 XNPlusKPat GhcTc
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv -> TcTyVar -> ZonkEnv
extendIdZonkEnv ZonkEnv
env2 TcTyVar
n',
forall p.
XNPlusKPat p
-> LIdP p
-> XRec p (HsOverLit p)
-> HsOverLit p
-> SyntaxExpr p
-> SyntaxExpr p
-> Pat p
NPlusKPat Kind
ty' (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc TcTyVar
n') (forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsOverLit GhcTc
lit1') HsOverLit GhcTc
lit2' SyntaxExprTc
e1' SyntaxExprTc
e2') }
zonk_pat ZonkEnv
env (XPat (CoPat HsWrapper
co_fn Pat GhcTc
pat Kind
ty))
= do { (ZonkEnv
env', HsWrapper
co_fn') <- ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn ZonkEnv
env HsWrapper
co_fn
; (ZonkEnv
env'', GenLocated SrcSpanAnnA (Pat GhcTc)
pat') <- ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
zonkPat ZonkEnv
env' (forall a an. a -> LocatedAn an a
noLocA Pat GhcTc
pat)
; Kind
ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env'' Kind
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env'', forall p. XXPat p -> Pat p
XPat forall a b. (a -> b) -> a -> b
$ HsWrapper -> Pat GhcTc -> Kind -> CoPat
CoPat HsWrapper
co_fn' (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat GhcTc)
pat') Kind
ty')
}
zonk_pat ZonkEnv
_ Pat GhcTc
pat = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"zonk_pat" (forall a. Outputable a => a -> SDoc
ppr Pat GhcTc
pat)
zonkConStuff :: ZonkEnv -> HsConPatDetails GhcTc
-> TcM (ZonkEnv, HsConPatDetails GhcTc)
zonkConStuff :: ZonkEnv
-> HsConPatDetails GhcTc -> TcM (ZonkEnv, HsConPatDetails GhcTc)
zonkConStuff ZonkEnv
env (PrefixCon [HsPatSigType (NoGhcTc GhcTc)]
tyargs [LPat GhcTc]
pats)
= do { (ZonkEnv
env', [GenLocated SrcSpanAnnA (Pat GhcTc)]
pats') <- ZonkEnv -> [LPat GhcTc] -> TcM (ZonkEnv, [LPat GhcTc])
zonkPats ZonkEnv
env [LPat GhcTc]
pats
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env', forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [HsPatSigType (NoGhcTc GhcTc)]
tyargs [GenLocated SrcSpanAnnA (Pat GhcTc)]
pats') }
zonkConStuff ZonkEnv
env (InfixCon LPat GhcTc
p1 LPat GhcTc
p2)
= do { (ZonkEnv
env1, GenLocated SrcSpanAnnA (Pat GhcTc)
p1') <- ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
zonkPat ZonkEnv
env LPat GhcTc
p1
; (ZonkEnv
env', GenLocated SrcSpanAnnA (Pat GhcTc)
p2') <- ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
zonkPat ZonkEnv
env1 LPat GhcTc
p2
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env', forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon GenLocated SrcSpanAnnA (Pat GhcTc)
p1' GenLocated SrcSpanAnnA (Pat GhcTc)
p2') }
zonkConStuff ZonkEnv
env (RecCon (HsRecFields [LHsRecField GhcTc (LPat GhcTc)]
rpats Maybe (Located ConTag)
dd))
= do { (ZonkEnv
env', [GenLocated SrcSpanAnnA (Pat GhcTc)]
pats') <- ZonkEnv -> [LPat GhcTc] -> TcM (ZonkEnv, [LPat GhcTc])
zonkPats ZonkEnv
env (forall a b. (a -> b) -> [a] -> [b]
map (forall id arg. HsRecField' id arg -> arg
hsRecFieldArg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LHsRecField GhcTc (LPat GhcTc)]
rpats)
; let rpats' :: [GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcTc) (GenLocated SrcSpanAnnA (Pat GhcTc)))]
rpats' = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(L SrcSpanAnnA
l HsRecField' (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (Pat GhcTc))
rp) GenLocated SrcSpanAnnA (Pat GhcTc)
p' ->
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsRecField' (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (Pat GhcTc))
rp { hsRecFieldArg :: GenLocated SrcSpanAnnA (Pat GhcTc)
hsRecFieldArg = GenLocated SrcSpanAnnA (Pat GhcTc)
p' }))
[LHsRecField GhcTc (LPat GhcTc)]
rpats [GenLocated SrcSpanAnnA (Pat GhcTc)]
pats'
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env', forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon (forall p arg.
[LHsRecField p arg] -> Maybe (Located ConTag) -> HsRecFields p arg
HsRecFields [GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcTc) (GenLocated SrcSpanAnnA (Pat GhcTc)))]
rpats' Maybe (Located ConTag)
dd)) }
zonkPats :: ZonkEnv -> [LPat GhcTc] -> TcM (ZonkEnv, [LPat GhcTc])
zonkPats :: ZonkEnv -> [LPat GhcTc] -> TcM (ZonkEnv, [LPat GhcTc])
zonkPats ZonkEnv
env [] = forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, [])
zonkPats ZonkEnv
env (LPat GhcTc
pat:[LPat GhcTc]
pats) = do { (ZonkEnv
env1, GenLocated SrcSpanAnnA (Pat GhcTc)
pat') <- ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
zonkPat ZonkEnv
env LPat GhcTc
pat
; (ZonkEnv
env', [GenLocated SrcSpanAnnA (Pat GhcTc)]
pats') <- ZonkEnv -> [LPat GhcTc] -> TcM (ZonkEnv, [LPat GhcTc])
zonkPats ZonkEnv
env1 [LPat GhcTc]
pats
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env', GenLocated SrcSpanAnnA (Pat GhcTc)
pat'forall a. a -> [a] -> [a]
:[GenLocated SrcSpanAnnA (Pat GhcTc)]
pats') }
zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTc]
-> TcM [LForeignDecl GhcTc]
zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTc] -> TcM [LForeignDecl GhcTc]
zonkForeignExports ZonkEnv
env [LForeignDecl GhcTc]
ls = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA (ZonkEnv -> ForeignDecl GhcTc -> TcM (ForeignDecl GhcTc)
zonkForeignExport ZonkEnv
env)) [LForeignDecl GhcTc]
ls
zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTc -> TcM (ForeignDecl GhcTc)
zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTc -> TcM (ForeignDecl GhcTc)
zonkForeignExport ZonkEnv
env (ForeignExport { fd_name :: forall pass. ForeignDecl pass -> LIdP pass
fd_name = LIdP GhcTc
i, fd_e_ext :: forall pass. ForeignDecl pass -> XForeignExport pass
fd_e_ext = XForeignExport GhcTc
co
, fd_fe :: forall pass. ForeignDecl pass -> ForeignExport
fd_fe = ForeignExport
spec })
= forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignExport { fd_name :: LIdP GhcTc
fd_name = ZonkEnv
-> GenLocated SrcSpanAnnN TcTyVar -> GenLocated SrcSpanAnnN TcTyVar
zonkLIdOcc ZonkEnv
env LIdP GhcTc
i
, fd_sig_ty :: LHsSigType GhcTc
fd_sig_ty = forall a. HasCallStack => a
undefined, fd_e_ext :: XForeignExport GhcTc
fd_e_ext = XForeignExport GhcTc
co
, fd_fe :: ForeignExport
fd_fe = ForeignExport
spec })
zonkForeignExport ZonkEnv
_ ForeignDecl GhcTc
for_imp
= forall (m :: * -> *) a. Monad m => a -> m a
return ForeignDecl GhcTc
for_imp
zonkRules :: ZonkEnv -> [LRuleDecl GhcTc] -> TcM [LRuleDecl GhcTc]
zonkRules :: ZonkEnv -> [LRuleDecl GhcTc] -> TcM [LRuleDecl GhcTc]
zonkRules ZonkEnv
env [LRuleDecl GhcTc]
rs = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA (ZonkEnv -> RuleDecl GhcTc -> TcM (RuleDecl GhcTc)
zonkRule ZonkEnv
env)) [LRuleDecl GhcTc]
rs
zonkRule :: ZonkEnv -> RuleDecl GhcTc -> TcM (RuleDecl GhcTc)
zonkRule :: ZonkEnv -> RuleDecl GhcTc -> TcM (RuleDecl GhcTc)
zonkRule ZonkEnv
env rule :: RuleDecl GhcTc
rule@(HsRule { rd_tmvs :: forall pass. RuleDecl pass -> [LRuleBndr pass]
rd_tmvs = [LRuleBndr GhcTc]
tm_bndrs
, rd_lhs :: forall pass. RuleDecl pass -> XRec pass (HsExpr pass)
rd_lhs = LHsExpr GhcTc
lhs
, rd_rhs :: forall pass. RuleDecl pass -> XRec pass (HsExpr pass)
rd_rhs = LHsExpr GhcTc
rhs })
= do { (ZonkEnv
env_inside, [GenLocated SrcSpan (RuleBndr GhcTc)]
new_tm_bndrs) <- forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM ZonkEnv -> LRuleBndr GhcTc -> TcM (ZonkEnv, LRuleBndr GhcTc)
zonk_tm_bndr ZonkEnv
env [LRuleBndr GhcTc]
tm_bndrs
; let env_lhs :: ZonkEnv
env_lhs = ZonkEnv -> ZonkFlexi -> ZonkEnv
setZonkType ZonkEnv
env_inside ZonkFlexi
SkolemiseFlexi
; LocatedA (HsExpr GhcTc)
new_lhs <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env_lhs LHsExpr GhcTc
lhs
; LocatedA (HsExpr GhcTc)
new_rhs <- ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkLExpr ZonkEnv
env_inside LHsExpr GhcTc
rhs
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RuleDecl GhcTc
rule { rd_tmvs :: [LRuleBndr GhcTc]
rd_tmvs = [GenLocated SrcSpan (RuleBndr GhcTc)]
new_tm_bndrs
, rd_lhs :: LHsExpr GhcTc
rd_lhs = LocatedA (HsExpr GhcTc)
new_lhs
, rd_rhs :: LHsExpr GhcTc
rd_rhs = LocatedA (HsExpr GhcTc)
new_rhs } }
where
zonk_tm_bndr :: ZonkEnv -> LRuleBndr GhcTc -> TcM (ZonkEnv, LRuleBndr GhcTc)
zonk_tm_bndr :: ZonkEnv -> LRuleBndr GhcTc -> TcM (ZonkEnv, LRuleBndr GhcTc)
zonk_tm_bndr ZonkEnv
env (L SrcSpan
l (RuleBndr XCRuleBndr GhcTc
x (L SrcSpanAnnN
loc TcTyVar
v)))
= do { (ZonkEnv
env', TcTyVar
v') <- ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TcTyVar)
zonk_it ZonkEnv
env TcTyVar
v
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env', forall l e. l -> e -> GenLocated l e
L SrcSpan
l (forall pass. XCRuleBndr pass -> LIdP pass -> RuleBndr pass
RuleBndr XCRuleBndr GhcTc
x (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc TcTyVar
v'))) }
zonk_tm_bndr ZonkEnv
_ (L SrcSpan
_ (RuleBndrSig {})) = forall a. String -> a
panic String
"zonk_tm_bndr RuleBndrSig"
zonk_it :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TcTyVar)
zonk_it ZonkEnv
env TcTyVar
v
| TcTyVar -> Bool
isId TcTyVar
v = do { TcTyVar
v' <- ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkIdBndr ZonkEnv
env TcTyVar
v
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv -> [TcTyVar] -> ZonkEnv
extendIdZonkEnvRec ZonkEnv
env [TcTyVar
v'], TcTyVar
v') }
| Bool
otherwise = ASSERT( isImmutableTyVar v)
ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TcTyVar)
zonkTyBndrX ZonkEnv
env TcTyVar
v
zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
zonkEvTerm ZonkEnv
env (EvExpr EvExpr
e)
= EvExpr -> EvTerm
EvExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkEnv -> EvExpr -> TcM EvExpr
zonkCoreExpr ZonkEnv
env EvExpr
e
zonkEvTerm ZonkEnv
env (EvTypeable Kind
ty EvTypeable
ev)
= Kind -> EvTypeable -> EvTerm
EvTypeable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env Kind
ty forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ZonkEnv -> EvTypeable -> TcM EvTypeable
zonkEvTypeable ZonkEnv
env EvTypeable
ev
zonkEvTerm ZonkEnv
env (EvFun { et_tvs :: EvTerm -> [TcTyVar]
et_tvs = [TcTyVar]
tvs, et_given :: EvTerm -> [TcTyVar]
et_given = [TcTyVar]
evs
, et_binds :: EvTerm -> TcEvBinds
et_binds = TcEvBinds
ev_binds, et_body :: EvTerm -> TcTyVar
et_body = TcTyVar
body_id })
= do { (ZonkEnv
env0, [TcTyVar]
new_tvs) <- ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TcTyVar])
zonkTyBndrsX ZonkEnv
env [TcTyVar]
tvs
; (ZonkEnv
env1, [TcTyVar]
new_evs) <- ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TcTyVar])
zonkEvBndrsX ZonkEnv
env0 [TcTyVar]
evs
; (ZonkEnv
env2, TcEvBinds
new_ev_binds) <- ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
zonkTcEvBinds ZonkEnv
env1 TcEvBinds
ev_binds
; let new_body_id :: TcTyVar
new_body_id = ZonkEnv -> TcTyVar -> TcTyVar
zonkIdOcc ZonkEnv
env2 TcTyVar
body_id
; forall (m :: * -> *) a. Monad m => a -> m a
return (EvFun { et_tvs :: [TcTyVar]
et_tvs = [TcTyVar]
new_tvs, et_given :: [TcTyVar]
et_given = [TcTyVar]
new_evs
, et_binds :: TcEvBinds
et_binds = TcEvBinds
new_ev_binds, et_body :: TcTyVar
et_body = TcTyVar
new_body_id }) }
zonkCoreExpr :: ZonkEnv -> CoreExpr -> TcM CoreExpr
zonkCoreExpr :: ZonkEnv -> EvExpr -> TcM EvExpr
zonkCoreExpr ZonkEnv
env (Var TcTyVar
v)
| TcTyVar -> Bool
isCoVar TcTyVar
v
= forall b. TcCoercionR -> Expr b
Coercion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkEnv -> TcTyVar -> TcM TcCoercionR
zonkCoVarOcc ZonkEnv
env TcTyVar
v
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. TcTyVar -> Expr b
Var forall a b. (a -> b) -> a -> b
$ ZonkEnv -> TcTyVar -> TcTyVar
zonkIdOcc ZonkEnv
env TcTyVar
v)
zonkCoreExpr ZonkEnv
_ (Lit Literal
l)
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b. Literal -> Expr b
Lit Literal
l
zonkCoreExpr ZonkEnv
env (Coercion TcCoercionR
co)
= forall b. TcCoercionR -> Expr b
Coercion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkEnv -> TcCoercionR -> TcM TcCoercionR
zonkCoToCo ZonkEnv
env TcCoercionR
co
zonkCoreExpr ZonkEnv
env (Type Kind
ty)
= forall b. Kind -> Expr b
Type forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env Kind
ty
zonkCoreExpr ZonkEnv
env (Cast EvExpr
e TcCoercionR
co)
= forall b. Expr b -> TcCoercionR -> Expr b
Cast forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkEnv -> EvExpr -> TcM EvExpr
zonkCoreExpr ZonkEnv
env EvExpr
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ZonkEnv -> TcCoercionR -> TcM TcCoercionR
zonkCoToCo ZonkEnv
env TcCoercionR
co
zonkCoreExpr ZonkEnv
env (Tick CoreTickish
t EvExpr
e)
= forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkEnv -> EvExpr -> TcM EvExpr
zonkCoreExpr ZonkEnv
env EvExpr
e
zonkCoreExpr ZonkEnv
env (App EvExpr
e1 EvExpr
e2)
= forall b. Expr b -> Expr b -> Expr b
App forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkEnv -> EvExpr -> TcM EvExpr
zonkCoreExpr ZonkEnv
env EvExpr
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ZonkEnv -> EvExpr -> TcM EvExpr
zonkCoreExpr ZonkEnv
env EvExpr
e2
zonkCoreExpr ZonkEnv
env (Lam TcTyVar
v EvExpr
e)
= do { (ZonkEnv
env1, TcTyVar
v') <- ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TcTyVar)
zonkCoreBndrX ZonkEnv
env TcTyVar
v
; forall b. b -> Expr b -> Expr b
Lam TcTyVar
v' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkEnv -> EvExpr -> TcM EvExpr
zonkCoreExpr ZonkEnv
env1 EvExpr
e }
zonkCoreExpr ZonkEnv
env (Let Bind TcTyVar
bind EvExpr
e)
= do (ZonkEnv
env1, Bind TcTyVar
bind') <- ZonkEnv -> Bind TcTyVar -> TcM (ZonkEnv, Bind TcTyVar)
zonkCoreBind ZonkEnv
env Bind TcTyVar
bind
forall b. Bind b -> Expr b -> Expr b
Let Bind TcTyVar
bind'forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkEnv -> EvExpr -> TcM EvExpr
zonkCoreExpr ZonkEnv
env1 EvExpr
e
zonkCoreExpr ZonkEnv
env (Case EvExpr
scrut TcTyVar
b Kind
ty [Alt TcTyVar]
alts)
= do EvExpr
scrut' <- ZonkEnv -> EvExpr -> TcM EvExpr
zonkCoreExpr ZonkEnv
env EvExpr
scrut
Kind
ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env Kind
ty
TcTyVar
b' <- ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkIdBndr ZonkEnv
env TcTyVar
b
let env1 :: ZonkEnv
env1 = ZonkEnv -> TcTyVar -> ZonkEnv
extendIdZonkEnv ZonkEnv
env TcTyVar
b'
[Alt TcTyVar]
alts' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> Alt TcTyVar -> TcM (Alt TcTyVar)
zonkCoreAlt ZonkEnv
env1) [Alt TcTyVar]
alts
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b. Expr b -> b -> Kind -> [Alt b] -> Expr b
Case EvExpr
scrut' TcTyVar
b' Kind
ty' [Alt TcTyVar]
alts'
zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt
zonkCoreAlt :: ZonkEnv -> Alt TcTyVar -> TcM (Alt TcTyVar)
zonkCoreAlt ZonkEnv
env (Alt AltCon
dc [TcTyVar]
bndrs EvExpr
rhs)
= do (ZonkEnv
env1, [TcTyVar]
bndrs') <- ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TcTyVar])
zonkCoreBndrsX ZonkEnv
env [TcTyVar]
bndrs
EvExpr
rhs' <- ZonkEnv -> EvExpr -> TcM EvExpr
zonkCoreExpr ZonkEnv
env1 EvExpr
rhs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
dc [TcTyVar]
bndrs' EvExpr
rhs'
zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind)
zonkCoreBind :: ZonkEnv -> Bind TcTyVar -> TcM (ZonkEnv, Bind TcTyVar)
zonkCoreBind ZonkEnv
env (NonRec TcTyVar
v EvExpr
e)
= do TcTyVar
v' <- ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkIdBndr ZonkEnv
env TcTyVar
v
EvExpr
e' <- ZonkEnv -> EvExpr -> TcM EvExpr
zonkCoreExpr ZonkEnv
env EvExpr
e
let env1 :: ZonkEnv
env1 = ZonkEnv -> TcTyVar -> ZonkEnv
extendIdZonkEnv ZonkEnv
env TcTyVar
v'
forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env1, forall b. b -> Expr b -> Bind b
NonRec TcTyVar
v' EvExpr
e')
zonkCoreBind ZonkEnv
env (Rec [(TcTyVar, EvExpr)]
pairs)
= do (ZonkEnv
env1, [(TcTyVar, EvExpr)]
pairs') <- forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM (ZonkEnv, [(TcTyVar, EvExpr)])
-> IOEnv (Env TcGblEnv TcLclEnv) (ZonkEnv, [(TcTyVar, EvExpr)])
go
forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env1, forall b. [(b, Expr b)] -> Bind b
Rec [(TcTyVar, EvExpr)]
pairs')
where
go :: (ZonkEnv, [(TcTyVar, EvExpr)])
-> IOEnv (Env TcGblEnv TcLclEnv) (ZonkEnv, [(TcTyVar, EvExpr)])
go ~(ZonkEnv
_, [(TcTyVar, EvExpr)]
new_pairs) = do
let env1 :: ZonkEnv
env1 = ZonkEnv -> [TcTyVar] -> ZonkEnv
extendIdZonkEnvRec ZonkEnv
env (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(TcTyVar, EvExpr)]
new_pairs)
[(TcTyVar, EvExpr)]
pairs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> (TcTyVar, EvExpr) -> TcM (TcTyVar, EvExpr)
zonkCorePair ZonkEnv
env1) [(TcTyVar, EvExpr)]
pairs
forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env1, [(TcTyVar, EvExpr)]
pairs')
zonkCorePair :: ZonkEnv -> (CoreBndr, CoreExpr) -> TcM (CoreBndr, CoreExpr)
zonkCorePair :: ZonkEnv -> (TcTyVar, EvExpr) -> TcM (TcTyVar, EvExpr)
zonkCorePair ZonkEnv
env (TcTyVar
v,EvExpr
e) = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkIdBndr ZonkEnv
env TcTyVar
v forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ZonkEnv -> EvExpr -> TcM EvExpr
zonkCoreExpr ZonkEnv
env EvExpr
e
zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
zonkEvTypeable ZonkEnv
env (EvTypeableTyCon TcTyCon
tycon [EvTerm]
e)
= do { [EvTerm]
e' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> EvTerm -> TcM EvTerm
zonkEvTerm ZonkEnv
env) [EvTerm]
e
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TcTyCon -> [EvTerm] -> EvTypeable
EvTypeableTyCon TcTyCon
tycon [EvTerm]
e' }
zonkEvTypeable ZonkEnv
env (EvTypeableTyApp EvTerm
t1 EvTerm
t2)
= do { EvTerm
t1' <- ZonkEnv -> EvTerm -> TcM EvTerm
zonkEvTerm ZonkEnv
env EvTerm
t1
; EvTerm
t2' <- ZonkEnv -> EvTerm -> TcM EvTerm
zonkEvTerm ZonkEnv
env EvTerm
t2
; forall (m :: * -> *) a. Monad m => a -> m a
return (EvTerm -> EvTerm -> EvTypeable
EvTypeableTyApp EvTerm
t1' EvTerm
t2') }
zonkEvTypeable ZonkEnv
env (EvTypeableTrFun EvTerm
tm EvTerm
t1 EvTerm
t2)
= do { EvTerm
tm' <- ZonkEnv -> EvTerm -> TcM EvTerm
zonkEvTerm ZonkEnv
env EvTerm
tm
; EvTerm
t1' <- ZonkEnv -> EvTerm -> TcM EvTerm
zonkEvTerm ZonkEnv
env EvTerm
t1
; EvTerm
t2' <- ZonkEnv -> EvTerm -> TcM EvTerm
zonkEvTerm ZonkEnv
env EvTerm
t2
; forall (m :: * -> *) a. Monad m => a -> m a
return (EvTerm -> EvTerm -> EvTerm -> EvTypeable
EvTypeableTrFun EvTerm
tm' EvTerm
t1' EvTerm
t2') }
zonkEvTypeable ZonkEnv
env (EvTypeableTyLit EvTerm
t1)
= do { EvTerm
t1' <- ZonkEnv -> EvTerm -> TcM EvTerm
zonkEvTerm ZonkEnv
env EvTerm
t1
; forall (m :: * -> *) a. Monad m => a -> m a
return (EvTerm -> EvTypeable
EvTypeableTyLit EvTerm
t1') }
zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
zonkTcEvBinds_s ZonkEnv
env [TcEvBinds]
bs = do { (ZonkEnv
env, [Bag EvBind]
bs') <- forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind)
zonk_tc_ev_binds ZonkEnv
env [TcEvBinds]
bs
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, [Bag EvBind -> TcEvBinds
EvBinds (forall a. [Bag a] -> Bag a
unionManyBags [Bag EvBind]
bs')]) }
zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
zonkTcEvBinds ZonkEnv
env TcEvBinds
bs = do { (ZonkEnv
env', Bag EvBind
bs') <- ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind)
zonk_tc_ev_binds ZonkEnv
env TcEvBinds
bs
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env', Bag EvBind -> TcEvBinds
EvBinds Bag EvBind
bs') }
zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind)
zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind)
zonk_tc_ev_binds ZonkEnv
env (TcEvBinds EvBindsVar
var) = ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
zonkEvBindsVar ZonkEnv
env EvBindsVar
var
zonk_tc_ev_binds ZonkEnv
env (EvBinds Bag EvBind
bs) = ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
zonkEvBinds ZonkEnv
env Bag EvBind
bs
zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
zonkEvBindsVar ZonkEnv
env (EvBindsVar { ebv_binds :: EvBindsVar -> IORef EvBindMap
ebv_binds = IORef EvBindMap
ref })
= do { EvBindMap
bs <- forall a env. IORef a -> IOEnv env a
readMutVar IORef EvBindMap
ref
; ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
zonkEvBinds ZonkEnv
env (EvBindMap -> Bag EvBind
evBindMapBinds EvBindMap
bs) }
zonkEvBindsVar ZonkEnv
env (CoEvBindsVar {}) = forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env, forall a. Bag a
emptyBag)
zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
zonkEvBinds ZonkEnv
env Bag EvBind
binds
= {-# SCC "zonkEvBinds" #-}
forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM (\ ~( ZonkEnv
_, Bag EvBind
new_binds) -> do
{ let env1 :: ZonkEnv
env1 = ZonkEnv -> [TcTyVar] -> ZonkEnv
extendIdZonkEnvRec ZonkEnv
env (Bag EvBind -> [TcTyVar]
collect_ev_bndrs Bag EvBind
new_binds)
; Bag EvBind
binds' <- forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM (ZonkEnv -> EvBind -> TcM EvBind
zonkEvBind ZonkEnv
env1) Bag EvBind
binds
; forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkEnv
env1, Bag EvBind
binds') })
where
collect_ev_bndrs :: Bag EvBind -> [EvVar]
collect_ev_bndrs :: Bag EvBind -> [TcTyVar]
collect_ev_bndrs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr EvBind -> [TcTyVar] -> [TcTyVar]
add []
add :: EvBind -> [TcTyVar] -> [TcTyVar]
add (EvBind { eb_lhs :: EvBind -> TcTyVar
eb_lhs = TcTyVar
var }) [TcTyVar]
vars = TcTyVar
var forall a. a -> [a] -> [a]
: [TcTyVar]
vars
zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
zonkEvBind ZonkEnv
env bind :: EvBind
bind@(EvBind { eb_lhs :: EvBind -> TcTyVar
eb_lhs = TcTyVar
var, eb_rhs :: EvBind -> EvTerm
eb_rhs = EvTerm
term })
= do { TcTyVar
var' <- {-# SCC "zonkEvBndr" #-} ZonkEnv -> TcTyVar -> TcM TcTyVar
zonkEvBndr ZonkEnv
env TcTyVar
var
; EvTerm
term' <- case Kind -> Maybe (Role, Kind, Kind)
getEqPredTys_maybe (TcTyVar -> Kind
idType TcTyVar
var') of
Just (Role
r, Kind
ty1, Kind
ty2) | Kind
ty1 Kind -> Kind -> Bool
`eqType` Kind
ty2
-> forall (m :: * -> *) a. Monad m => a -> m a
return (TcCoercionR -> EvTerm
evCoercion (Role -> Kind -> TcCoercionR
mkTcReflCo Role
r Kind
ty1))
Maybe (Role, Kind, Kind)
_other -> ZonkEnv -> EvTerm -> TcM EvTerm
zonkEvTerm ZonkEnv
env EvTerm
term
; forall (m :: * -> *) a. Monad m => a -> m a
return (EvBind
bind { eb_lhs :: TcTyVar
eb_lhs = TcTyVar
var', eb_rhs :: EvTerm
eb_rhs = EvTerm
term' }) }
zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType
zonkTyVarOcc :: ZonkEnv -> TcTyVar -> TcM Kind
zonkTyVarOcc env :: ZonkEnv
env@(ZonkEnv { ze_flexi :: ZonkEnv -> ZonkFlexi
ze_flexi = ZonkFlexi
flexi
, ze_tv_env :: ZonkEnv -> TyCoVarEnv TcTyVar
ze_tv_env = TyCoVarEnv TcTyVar
tv_env
, ze_meta_tv_env :: ZonkEnv -> TcRef (TyVarEnv Kind)
ze_meta_tv_env = TcRef (TyVarEnv Kind)
mtv_env_ref }) TcTyVar
tv
| TcTyVar -> Bool
isTcTyVar TcTyVar
tv
= case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
SkolemTv {} -> TcM Kind
lookup_in_tv_env
RuntimeUnk {} -> TcM Kind
lookup_in_tv_env
MetaTv { mtv_ref :: TcTyVarDetails -> IORef MetaDetails
mtv_ref = IORef MetaDetails
ref }
-> do { TyVarEnv Kind
mtv_env <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef TcRef (TyVarEnv Kind)
mtv_env_ref
; case forall a. VarEnv a -> TcTyVar -> Maybe a
lookupVarEnv TyVarEnv Kind
mtv_env TcTyVar
tv of
Just Kind
ty -> forall (m :: * -> *) a. Monad m => a -> m a
return Kind
ty
Maybe Kind
Nothing -> do { MetaDetails
mtv_details <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef MetaDetails
ref
; IORef MetaDetails -> MetaDetails -> TcM Kind
zonk_meta IORef MetaDetails
ref MetaDetails
mtv_details } }
| Bool
otherwise
= TcM Kind
lookup_in_tv_env
where
lookup_in_tv_env :: TcM Kind
lookup_in_tv_env
= case forall a. VarEnv a -> TcTyVar -> Maybe a
lookupVarEnv TyCoVarEnv TcTyVar
tv_env TcTyVar
tv of
Maybe TcTyVar
Nothing -> TcTyVar -> Kind
mkTyVarTy forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Monad m =>
(Kind -> m Kind) -> TcTyVar -> m TcTyVar
updateTyVarKindM (ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env) TcTyVar
tv
Just TcTyVar
tv' -> forall (m :: * -> *) a. Monad m => a -> m a
return (TcTyVar -> Kind
mkTyVarTy TcTyVar
tv')
zonk_meta :: IORef MetaDetails -> MetaDetails -> TcM Kind
zonk_meta IORef MetaDetails
ref MetaDetails
Flexi
= do { Kind
kind <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env (TcTyVar -> Kind
tyVarKind TcTyVar
tv)
; Kind
ty <- ZonkFlexi -> TcTyVar -> Kind -> TcM Kind
commitFlexi ZonkFlexi
flexi TcTyVar
tv Kind
kind
; TcTyVar -> IORef MetaDetails -> Kind -> TcM ()
writeMetaTyVarRef TcTyVar
tv IORef MetaDetails
ref Kind
ty
; Kind -> TcM Kind
finish_meta Kind
ty }
zonk_meta IORef MetaDetails
_ (Indirect Kind
ty)
= do { Kind
zty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env Kind
ty
; Kind -> TcM Kind
finish_meta Kind
zty }
finish_meta :: Kind -> TcM Kind
finish_meta Kind
ty
= do { forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef TcRef (TyVarEnv Kind)
mtv_env_ref (\TyVarEnv Kind
env -> forall a. VarEnv a -> TcTyVar -> a -> VarEnv a
extendVarEnv TyVarEnv Kind
env TcTyVar
tv Kind
ty)
; forall (m :: * -> *) a. Monad m => a -> m a
return Kind
ty }
lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar
lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TcTyVar
lookupTyVarOcc (ZonkEnv { ze_tv_env :: ZonkEnv -> TyCoVarEnv TcTyVar
ze_tv_env = TyCoVarEnv TcTyVar
tv_env }) TcTyVar
tv
= forall a. VarEnv a -> TcTyVar -> Maybe a
lookupVarEnv TyCoVarEnv TcTyVar
tv_env TcTyVar
tv
commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type
commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Kind
commitFlexi ZonkFlexi
flexi TcTyVar
tv Kind
zonked_kind
= case ZonkFlexi
flexi of
ZonkFlexi
SkolemiseFlexi -> forall (m :: * -> *) a. Monad m => a -> m a
return (TcTyVar -> Kind
mkTyVarTy (Name -> Kind -> TcTyVar
mkTyVar Name
name Kind
zonked_kind))
ZonkFlexi
DefaultFlexi
| Kind -> Bool
isRuntimeRepTy Kind
zonked_kind
-> do { String -> SDoc -> TcM ()
traceTc String
"Defaulting flexi tyvar to LiftedRep:" (TcTyVar -> SDoc
pprTyVar TcTyVar
tv)
; forall (m :: * -> *) a. Monad m => a -> m a
return Kind
liftedRepTy }
| Kind -> Bool
isMultiplicityTy Kind
zonked_kind
-> do { String -> SDoc -> TcM ()
traceTc String
"Defaulting flexi tyvar to Many:" (TcTyVar -> SDoc
pprTyVar TcTyVar
tv)
; forall (m :: * -> *) a. Monad m => a -> m a
return Kind
manyDataConTy }
| Bool
otherwise
-> do { String -> SDoc -> TcM ()
traceTc String
"Defaulting flexi tyvar to Any:" (TcTyVar -> SDoc
pprTyVar TcTyVar
tv)
; forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> Kind
anyTypeOfKind Kind
zonked_kind) }
ZonkFlexi
RuntimeUnkFlexi
-> do { String -> SDoc -> TcM ()
traceTc String
"Defaulting flexi tyvar to RuntimeUnk:" (TcTyVar -> SDoc
pprTyVar TcTyVar
tv)
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcTyVar -> Kind
mkTyVarTy (Name -> Kind -> TcTyVarDetails -> TcTyVar
mkTcTyVar Name
name Kind
zonked_kind TcTyVarDetails
RuntimeUnk)) }
ZonkFlexi
NoFlexi -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"NoFlexi" (forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Kind
zonked_kind)
where
name :: Name
name = TcTyVar -> Name
tyVarName TcTyVar
tv
zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion
zonkCoVarOcc :: ZonkEnv -> TcTyVar -> TcM TcCoercionR
zonkCoVarOcc (ZonkEnv { ze_tv_env :: ZonkEnv -> TyCoVarEnv TcTyVar
ze_tv_env = TyCoVarEnv TcTyVar
tyco_env }) TcTyVar
cv
| Just TcTyVar
cv' <- forall a. VarEnv a -> TcTyVar -> Maybe a
lookupVarEnv TyCoVarEnv TcTyVar
tyco_env TcTyVar
cv
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TcTyVar -> TcCoercionR
mkCoVarCo TcTyVar
cv'
| Bool
otherwise
= do { TcTyVar
cv' <- TcTyVar -> TcM TcTyVar
zonkCoVar TcTyVar
cv; forall (m :: * -> *) a. Monad m => a -> m a
return (TcTyVar -> TcCoercionR
mkCoVarCo TcTyVar
cv') }
zonkCoHole :: ZonkEnv -> CoercionHole -> TcM Coercion
zonkCoHole :: ZonkEnv -> CoercionHole -> TcM TcCoercionR
zonkCoHole ZonkEnv
env hole :: CoercionHole
hole@(CoercionHole { ch_ref :: CoercionHole -> IORef (Maybe TcCoercionR)
ch_ref = IORef (Maybe TcCoercionR)
ref, ch_co_var :: CoercionHole -> TcTyVar
ch_co_var = TcTyVar
cv })
= do { Maybe TcCoercionR
contents <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Maybe TcCoercionR)
ref
; case Maybe TcCoercionR
contents of
Just TcCoercionR
co -> do { TcCoercionR
co' <- ZonkEnv -> TcCoercionR -> TcM TcCoercionR
zonkCoToCo ZonkEnv
env TcCoercionR
co
; TcTyVar -> TcCoercionR -> TcM TcCoercionR
checkCoercionHole TcTyVar
cv TcCoercionR
co' }
Maybe TcCoercionR
Nothing -> do { String -> SDoc -> TcM ()
traceTc String
"Zonking unfilled coercion hole" (forall a. Outputable a => a -> SDoc
ppr CoercionHole
hole)
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugIsOn forall a b. (a -> b) -> a -> b
$
TcM () -> TcM ()
whenNoErrs forall a b. (a -> b) -> a -> b
$
MASSERT2( False
, text "Type-correct unfilled coercion hole"
<+> ppr hole )
; TcTyVar
cv' <- TcTyVar -> TcM TcTyVar
zonkCoVar TcTyVar
cv
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TcTyVar -> TcCoercionR
mkCoVarCo TcTyVar
cv' } }
zonk_tycomapper :: TyCoMapper ZonkEnv TcM
zonk_tycomapper :: TyCoMapper ZonkEnv (IOEnv (Env TcGblEnv TcLclEnv))
zonk_tycomapper = TyCoMapper
{ tcm_tyvar :: ZonkEnv -> TcTyVar -> TcM Kind
tcm_tyvar = ZonkEnv -> TcTyVar -> TcM Kind
zonkTyVarOcc
, tcm_covar :: ZonkEnv -> TcTyVar -> TcM TcCoercionR
tcm_covar = ZonkEnv -> TcTyVar -> TcM TcCoercionR
zonkCoVarOcc
, tcm_hole :: ZonkEnv -> CoercionHole -> TcM TcCoercionR
tcm_hole = ZonkEnv -> CoercionHole -> TcM TcCoercionR
zonkCoHole
, tcm_tycobinder :: ZonkEnv -> TcTyVar -> ArgFlag -> TcM (ZonkEnv, TcTyVar)
tcm_tycobinder = \ZonkEnv
env TcTyVar
tv ArgFlag
_vis -> ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TcTyVar)
zonkTyBndrX ZonkEnv
env TcTyVar
tv
, tcm_tycon :: TcTyCon -> IOEnv (Env TcGblEnv TcLclEnv) TcTyCon
tcm_tycon = TcTyCon -> IOEnv (Env TcGblEnv TcLclEnv) TcTyCon
zonkTcTyConToTyCon }
zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon
zonkTcTyConToTyCon :: TcTyCon -> IOEnv (Env TcGblEnv TcLclEnv) TcTyCon
zonkTcTyConToTyCon TcTyCon
tc
| TcTyCon -> Bool
isTcTyCon TcTyCon
tc = do { TyThing
thing <- Name -> TcM TyThing
tcLookupGlobalOnly (forall a. NamedThing a => a -> Name
getName TcTyCon
tc)
; case TyThing
thing of
ATyCon TcTyCon
real_tc -> forall (m :: * -> *) a. Monad m => a -> m a
return TcTyCon
real_tc
TyThing
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"zonkTcTyCon" (forall a. Outputable a => a -> SDoc
ppr TcTyCon
tc SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr TyThing
thing) }
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return TcTyCon
tc
zonkTcTypeToType :: TcType -> TcM Type
zonkTcTypeToType :: Kind -> TcM Kind
zonkTcTypeToType Kind
ty = forall b. (ZonkEnv -> TcM b) -> TcM b
initZonkEnv forall a b. (a -> b) -> a -> b
$ \ ZonkEnv
ze -> ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
ze Kind
ty
zonkScaledTcTypeToTypeX :: ZonkEnv -> Scaled TcType -> TcM (Scaled TcType)
zonkScaledTcTypeToTypeX :: ZonkEnv -> Scaled Kind -> TcM (Scaled Kind)
zonkScaledTcTypeToTypeX ZonkEnv
env (Scaled Kind
m Kind
ty) = forall a. Kind -> a -> Scaled a
Scaled forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env Kind
m
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
env Kind
ty
zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type
zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type]
zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion
(ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX, ZonkEnv -> [Kind] -> TcM [Kind]
zonkTcTypesToTypesX, ZonkEnv -> TcCoercionR -> TcM TcCoercionR
zonkCoToCo, ZonkEnv
-> [TcCoercionR] -> IOEnv (Env TcGblEnv TcLclEnv) [TcCoercionR]
_)
= forall (m :: * -> *) env.
Monad m =>
TyCoMapper env m
-> (env -> Kind -> m Kind, env -> [Kind] -> m [Kind],
env -> TcCoercionR -> m TcCoercionR,
env -> [TcCoercionR] -> m [TcCoercionR])
mapTyCoX TyCoMapper ZonkEnv (IOEnv (Env TcGblEnv TcLclEnv))
zonk_tycomapper
zonkScaledTcTypesToTypesX :: ZonkEnv -> [Scaled TcType] -> TcM [Scaled Type]
zonkScaledTcTypesToTypesX :: ZonkEnv -> [Scaled Kind] -> TcM [Scaled Kind]
zonkScaledTcTypesToTypesX ZonkEnv
env [Scaled Kind]
scaled_tys =
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> Scaled Kind -> TcM (Scaled Kind)
zonkScaledTcTypeToTypeX ZonkEnv
env) [Scaled Kind]
scaled_tys
zonkTcMethInfoToMethInfoX :: ZonkEnv -> TcMethInfo -> TcM MethInfo
zonkTcMethInfoToMethInfoX :: ZonkEnv -> TcMethInfo -> TcM TcMethInfo
zonkTcMethInfoToMethInfoX ZonkEnv
ze (Name
name, Kind
ty, Maybe (DefMethSpec (SrcSpan, Kind))
gdm_spec)
= do { Kind
ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
ze Kind
ty
; Maybe (DefMethSpec (SrcSpan, Kind))
gdm_spec' <- Maybe (DefMethSpec (SrcSpan, Kind))
-> TcM (Maybe (DefMethSpec (SrcSpan, Kind)))
zonk_gdm Maybe (DefMethSpec (SrcSpan, Kind))
gdm_spec
; forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, Kind
ty', Maybe (DefMethSpec (SrcSpan, Kind))
gdm_spec') }
where
zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType))
-> TcM (Maybe (DefMethSpec (SrcSpan, Type)))
zonk_gdm :: Maybe (DefMethSpec (SrcSpan, Kind))
-> TcM (Maybe (DefMethSpec (SrcSpan, Kind)))
zonk_gdm Maybe (DefMethSpec (SrcSpan, Kind))
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
zonk_gdm (Just DefMethSpec (SrcSpan, Kind)
VanillaDM) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall ty. DefMethSpec ty
VanillaDM)
zonk_gdm (Just (GenericDM (SrcSpan
loc, Kind
ty)))
= do { Kind
ty' <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
ze Kind
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall ty. ty -> DefMethSpec ty
GenericDM (SrcSpan
loc, Kind
ty'))) }