{-# LANGUAGE GADTs #-}

{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1996-1998
-}

-- | Final zonking to 'Type'. See Note [Zonking to Type].
--
-- Distinct from the intra-typechecker zonking in "GHC.Tc.Zonk.TcType";
-- see Note [Module structure for zonking].
module GHC.Tc.Zonk.Type (
        -- * Zonking
        -- | For a description of "zonking", see Note [What is zonking?].
        ZonkTcM,
        zonkTopDecls, zonkTopExpr, zonkTopLExpr,
        zonkTopBndrs,
        zonkTyVarBindersX, zonkTyVarBinderX,
        zonkTyBndrX, zonkTyBndrsX,
        zonkTcTypeToType,  zonkTcTypeToTypeX,
        zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX,
        zonkTyVarOcc,
        zonkCoToCo,
        zonkEvBinds, zonkTcEvBinds,
        zonkTcMethInfoToMethInfoX,
        lookupTyVarX,

        -- ** 'ZonkEnv', and the 'ZonkT' and 'ZonkBndrT' monad transformers
        module GHC.Tc.Zonk.Env,

        -- * Tidying
        tcInitTidyEnv, tcInitOpenTidyEnv,


  ) where

import GHC.Prelude

import GHC.Builtin.Types

import GHC.Core.TyCo.Ppr ( pprTyVar )

import GHC.Hs

import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice)
import GHC.Tc.Types ( TcM )
import GHC.Tc.Types.TcRef
import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo )
import GHC.Tc.Utils.Env ( tcLookupGlobalOnly )
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Monad ( newZonkAnyType, setSrcSpanA, liftZonkM, traceTc, addErr )
import GHC.Tc.Types.Evidence
import GHC.Tc.Errors.Types
import GHC.Tc.Zonk.Env
-- Very little shared code between GHC.Tc.Zonk.TcType and GHC.Tc.Zonk.Type.
-- See Note [Module structure for zonking]
import GHC.Tc.Zonk.TcType
    ( tcInitTidyEnv, tcInitOpenTidyEnv
    , writeMetaTyVarRef
    , checkCoercionHole
    , zonkCoVar )

import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Core.TyCon

import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Monad
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.TypeEnv
import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Types.Unique.FM
import GHC.Types.TyThing

import GHC.Tc.Types.BasicTypes

import GHC.Data.Maybe
import GHC.Data.Bag

import Control.Monad
import Control.Monad.Trans.Class ( lift )
import Data.List.NonEmpty ( NonEmpty )
import Data.Foldable ( toList )

{- Note [What is zonking?]
~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC relies heavily on mutability in the typechecker for efficient operation.
For this reason, throughout much of the type checking process, meta type
variables (the MetaTv constructor of TcTyVarDetails) are represented by mutable
variables (known as TcRefs).

Zonking is the process of replacing each such mutable variable with a Type.
This involves traversing the entire type expression, but the interesting part,
replacing the mutable variables, occurs in zonkTyVarOcc.

There are two ways to zonk a Type, using one of two entirely separate zonkers,
that share essentially no code:

*  GHC.Tc.Zonk.TcType.zonkTcType, which is used /during/ type checking:
   * It leaves unfilled metavars untouched, so the resulting Type can contain TcTyVars
   * It is only defined for Type and Coercion, not for HsExpr
   * It works in a very stripped-down monad, ZonkM, make it clear that it uses
     very few effects (for example, it can't throw errors).

* GHC.Tc.Zonk.Type.zonkTcTypeToType, is used /after/ typechecking is complete:
  * It always returns a Type with no remaining TcTyVars; no meta-tyvars remain.
  * It does defaulting, replacing an unconstrained TcTyVar with Any, or failing
     (determined by the ZonkFlexi parameter used; see GHC.Tc.Zonk.Type.commitFlexi).
  * It works over HsExpr and HsBinds as well as Type and Coercion. As part of this,
    it also removes the mutable variables in evidence bindings.
  * It works in the full TcM monad, augmented with an environment.
    More precisely, it uses ZonkTcM and ZonkBndrTcM, which augment TcM with a
    ZonkEnv environment using the zonking monad transformers ZonkT and ZonkBndrT
    (see Note [The ZonkEnv] in GHC.Tc.Zonk.Env).

    Why TcM rather than a smaller monad? See Note [Using TcM for zonking to Type].

Note [Module structure for zonking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As remarked in Note [What is zonking?], there are really two different zonkers;
we have GHC.Tc.Zonk.TcType for zonking within the typechecker and
GHC.Tc.Zonk.Type for the final zonking pass.

The code relating to zonking is thus split up across the following modules:

  I. Zonking within the typechecker
    1. GHC.Tc.Zonk.Monad
    2. GHC.Tc.Zonk.TcType

  II. Final zonking to Type
    1. GHC.Tc.Zonk.Env
    2. GHC.Tc.Zonk.Type

I.1. GHC.Tc.Zonk.Monad - the ZonkM monad

  GHC.Tc.Zonk.Monad defines the ZonkM monad, which is a stripped down version
  of TcM which has just enough information to be able to zonk types.

  This is the monad used for zonking inside the typechecker,
  as used in GHC.Tc.Zonk.TcType.

  Crucially, it never errors. It is the monad we use when reporting errors
  (see ErrCtxt), and it would be quite bad if we could error in the middle
  of reporting an error!

I.2. GHC.Tc.Zonk.TcType - zonking types in the typechecker

  GHC.Tc.Zonk.TcType contains code for zonking types and constraints, for use
  within the typechecker. It uses the ZonkM monad.
  For example, it defines:

    zonkTcType :: TcType -> ZonkM TcType
    zonkCt     :: Ct     -> ZonkM Ct

II.1. GHC.Tc.Zonk.Env - the ZonkEnv and ZonkT/ZonkBndrT monad transformers

   GHC.Tc.Zonk.Env defines the the ZonkT and ZonkBndrT monad transformers.
   These are essentially "ReaderT ZonkEnv" and "StateT ZonkEnv", except
   that ZonkBndrT use continuation-passing style instead of an explicit state.
   See Note [The ZonkEnv] in GHC.Tc.Zonk.Env.

   These are used for the final zonking to type, in GHC.Tc.Zonk.Type.

II.2. GHC.Tc.Zonk.Type - final zonking to type

  GHC.Tc.Zonk.Type is concerned with the "final zonking" pass, after we finish
  typechecking. It zonks not only types, but terms. It uses the monads

    type ZonkTcM     = ZonkT     TcM
    type ZonkBndrTcM = ZonkBndrTcM

  for example:

    zonkTyBndrX       :: TcTyVar  -> ZonkBndrTcM TyVar
    zonkTcTypeToTypeX :: TcType   -> ZonkT     TcM Type

Note that ZonkTcM does a lot more things than ZonkM:

  - it uses a separate ZonkEnv state to accumulate zonked type
      (see Note [The ZonkEnv] in GHC.Tc.Zonk.Env)
  - it defaults type variables,
      (see Note [Un-unified unification variables] in GHC.Tc.Zonk.Env)
  - turns TcTyVars into TyVars,
  - ...

This means that there is essentially no code shared between "GHC.Tc.Zonk.TcType"
and "GHC.Tc.Zonk.Type'; they're really two different zonkers.

Note [Zonking to Type]
~~~~~~~~~~~~~~~~~~~~~~
Zonking to Type is a final zonking pass done *after* typechecking.
It runs over the bindings

 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
 b) convert unbound TcTyVar to Void
 c) convert each TcId to an Id by zonking its type

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

The Ids are converted by binding them in the normal Tc envt; that
way we maintain sharing; eg an Id is zonked at its binding site and they
all occurrences of that Id point to the common zonked copy

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

Note [Sharing when zonking to Type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Problem:

    In GHC.Tc.Zonk.TcType.zonkTcTyVar, we short-circuit (Indirect ty) to
    (Indirect zty), see Note [Sharing in zonking] in GHC.Tc.Zonk.TcType.
    But we /can't/ do this when zonking a TcType to a Type (#15552, esp comment:3).
    Suppose we have

       alpha -> alpha
         where
            alpha is already unified:
             alpha := T{tc-tycon} Int -> Int
         and T is knot-tied

    By "knot-tied" I mean that the occurrence of T is currently a TcTyCon,
    but the global env contains a mapping "T" :-> T{knot-tied-tc}. See
    Note [Type checking recursive type and class declarations] in
    GHC.Tc.TyCl.

    Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow
    the same path as Note [Sharing in zonking] in GHC.Tc.Zonk.TcType, we'll
    update alpha to
       alpha := T{knot-tied-tc} Int -> Int

    But alas, if we encounter alpha for a /second/ time, we end up
    looking at T{knot-tied-tc} and fall into a black hole. The whole
    point of zonkTcTypeToType is that it produces a type full of
    knot-tied tycons, and you must not look at the result!!

    To put it another way (zonkTcTypeToType . zonkTcTypeToType) is not
    the same as zonkTcTypeToType. (If we distinguished TcType from
    Type, this issue would have been a type error!)

Solutions: (see #15552 for other variants)

One possible solution is simply not to do the short-circuiting.
That has less sharing, but maybe sharing is rare. And indeed,
that usually turns out to be viable from a perf point of view

But zonkTyVarOcc implements something a bit better

* ZonkEnv contains ze_meta_tv_env, which maps
      from a MetaTyVar (unification variable)
      to a Type (not a TcType)

* In zonkTyVarOcc, we check this map to see if we have zonked
  this variable before. If so, use the previous answer; if not
  zonk it, and extend the map.

* The map is of course stateful, held in a TcRef. (That is unlike
  the treatment of lexically-scoped variables in ze_tv_env and
  ze_id_env.)

* In zonkTyVarOcc we read the TcRef to look up the unification
  variable:
    - if we get a hit we use the zonked result;
    - if not, in zonk_meta we see if the variable is `Indirect ty`,
      zonk that, and update the map (in finish_meta)
  But Nota Bene that the "update map" step must re-read the TcRef
  (or, more precisely, use updTcRef) because the zonking of the
  `Indirect ty` may have added lots of stuff to the map.  See
  #19668 for an example where this made an asymptotic difference!

Is it worth the extra work of carrying ze_meta_tv_env? Some
non-systematic perf measurements suggest that compiler allocation is
reduced overall (by 0.5% or so) but compile time really doesn't
change.  But in some cases it makes a HUGE difference: see test
T9198 and #19668.  So yes, it seems worth it.

Note [Using TcM for zonking to Type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The main zonking monads currently wrap TcM, because we need access to
the full TcM monad in order to expand typed TH splices.
See zonkExpr (HsTypedSplice s _) = ...

After the Typed TH plan has been implemented, this should no longer be necessary,
and we should be able to use a stripped down monad, similar to the ZonkM monad
which we use for zonking within the typechecker (but we will need a place to
accumulate errors).

Note [Inlining ZonkBndrT computations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Computations that use the ZonkBndrT monad transformer must be inlined:
ZonkBndrT uses continuation-passing style; failing to inline means applying
an unknown continuation (unknown function call), which prevents many
optimisations from taking place.

See test cases T14683, which regresses without these changes.
-}

-- Why do we use TcM below? See Note [Using TcM for zonking to Type]

-- | Zonking monad for a computation that zonks to Type, reading from a 'ZonkEnv'
-- but not extending or modifying it.
--
-- See Note [Zonking to Type].
type ZonkTcM = ZonkT TcM

-- | Zonking monad for a computation that zonks to Type, reading from
-- and extending or modifying a 'ZonkEnv'.
--
-- See Note [Zonking to Type].
type ZonkBndrTcM = ZonkBndrT TcM

wrapLocZonkMA :: (a -> ZonkTcM b) -> GenLocated (EpAnn ann) a
              -> ZonkTcM (GenLocated (EpAnn ann) b)
wrapLocZonkMA :: forall a b ann.
(a -> ZonkTcM b)
-> GenLocated (EpAnn ann) a -> ZonkTcM (GenLocated (EpAnn ann) b)
wrapLocZonkMA a -> ZonkTcM b
fn (L EpAnn ann
loc a
a) = (ZonkEnv -> TcM (GenLocated (EpAnn ann) b))
-> ZonkT TcM (GenLocated (EpAnn ann) b)
forall (m :: * -> *) a. (ZonkEnv -> m a) -> ZonkT m a
ZonkT ((ZonkEnv -> TcM (GenLocated (EpAnn ann) b))
 -> ZonkT TcM (GenLocated (EpAnn ann) b))
-> (ZonkEnv -> TcM (GenLocated (EpAnn ann) b))
-> ZonkT TcM (GenLocated (EpAnn ann) b)
forall a b. (a -> b) -> a -> b
$ \ ZonkEnv
ze ->
  EpAnn ann
-> TcM (GenLocated (EpAnn ann) b) -> TcM (GenLocated (EpAnn ann) b)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA EpAnn ann
loc (TcM (GenLocated (EpAnn ann) b) -> TcM (GenLocated (EpAnn ann) b))
-> TcM (GenLocated (EpAnn ann) b) -> TcM (GenLocated (EpAnn ann) b)
forall a b. (a -> b) -> a -> b
$
  do { b <- ZonkTcM b -> ZonkEnv -> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a. ZonkT m a -> ZonkEnv -> m a
runZonkT (a -> ZonkTcM b
fn a
a) ZonkEnv
ze
     ; return (L loc b) }

wrapLocZonkBndrMA :: (a -> ZonkBndrTcM b) -> GenLocated (EpAnn ann) a
                  -> ZonkBndrTcM (GenLocated (EpAnn ann) b)
wrapLocZonkBndrMA :: forall a b ann.
(a -> ZonkBndrTcM b)
-> GenLocated (EpAnn ann) a
-> ZonkBndrTcM (GenLocated (EpAnn ann) b)
wrapLocZonkBndrMA a -> ZonkBndrTcM b
fn (L EpAnn ann
loc a
a) = (forall r.
 (GenLocated (EpAnn ann) b -> ZonkT TcM r) -> ZonkT TcM r)
-> ZonkBndrT TcM (GenLocated (EpAnn ann) b)
forall (m :: * -> *) a.
(forall r. (a -> ZonkT m r) -> ZonkT m r) -> ZonkBndrT m a
ZonkBndrT ((forall r.
  (GenLocated (EpAnn ann) b -> ZonkT TcM r) -> ZonkT TcM r)
 -> ZonkBndrT TcM (GenLocated (EpAnn ann) b))
-> (forall r.
    (GenLocated (EpAnn ann) b -> ZonkT TcM r) -> ZonkT TcM r)
-> ZonkBndrT TcM (GenLocated (EpAnn ann) b)
forall a b. (a -> b) -> a -> b
$ \ GenLocated (EpAnn ann) b -> ZonkT TcM r
k -> (ZonkEnv -> TcM r) -> ZonkT TcM r
forall (m :: * -> *) a. (ZonkEnv -> m a) -> ZonkT m a
ZonkT ((ZonkEnv -> TcM r) -> ZonkT TcM r)
-> (ZonkEnv -> TcM r) -> ZonkT TcM r
forall a b. (a -> b) -> a -> b
$ \ ZonkEnv
ze ->
  EpAnn ann -> TcM r -> TcM r
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA EpAnn ann
loc (TcM r -> TcM r) -> TcM r -> TcM r
forall a b. (a -> b) -> a -> b
$
  ZonkT TcM r -> ZonkEnv -> TcM r
forall (m :: * -> *) a. ZonkT m a -> ZonkEnv -> m a
runZonkT ( ZonkBndrTcM b -> forall r. (b -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT (a -> ZonkBndrTcM b
fn a
a) ((b -> ZonkT TcM r) -> ZonkT TcM r)
-> (b -> ZonkT TcM r) -> ZonkT TcM r
forall a b. (a -> b) -> a -> b
$ \ b
b -> GenLocated (EpAnn ann) b -> ZonkT TcM r
k (EpAnn ann -> b -> GenLocated (EpAnn ann) b
forall l e. l -> e -> GenLocated l e
L EpAnn ann
loc b
b) ) ZonkEnv
ze

--------------------------------------------------------------------------------

zonkTyBndrsX :: [TcTyVar] -> ZonkBndrTcM [TcTyVar]
zonkTyBndrsX :: [Id] -> ZonkBndrTcM [Id]
zonkTyBndrsX = (Id -> ZonkBndrT TcM Id) -> [Id] -> ZonkBndrTcM [Id]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Id -> ZonkBndrT TcM Id
zonkTyBndrX
{-# INLINE zonkTyBndrsX #-} -- See Note [Inlining ZonkBndrT computations]

zonkTyBndrX :: TcTyVar -> ZonkBndrTcM TyVar
-- This guarantees to return a TyVar (not a TcTyVar)
-- then we add it to the envt, so all occurrences are replaced
--
-- It does not clone: the new TyVar has the sane Name
-- as the old one.  This important when zonking the
-- TyVarBndrs of a TyCon, whose Names may scope.
zonkTyBndrX :: Id -> ZonkBndrT TcM Id
zonkTyBndrX Id
tv
  = Bool -> SDoc -> ZonkBndrT TcM Id -> ZonkBndrT TcM Id
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Bool
isImmutableTyVar Id
tv) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
tv SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
tyVarKind Id
tv)) (ZonkBndrT TcM Id -> ZonkBndrT TcM Id)
-> ZonkBndrT TcM Id -> ZonkBndrT TcM Id
forall a b. (a -> b) -> a -> b
$
    do { ki <- ZonkT TcM Kind -> ZonkBndrT TcM Kind
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkT TcM Kind -> ZonkBndrT TcM Kind)
-> ZonkT TcM Kind -> ZonkBndrT TcM Kind
forall a b. (a -> b) -> a -> b
$ Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX (Id -> Kind
tyVarKind Id
tv)
               -- Internal names tidy up better, for iface files.
       ; let tv' = Name -> Kind -> Id
mkTyVar (Id -> Name
tyVarName Id
tv) Kind
ki
       ; extendTyZonkEnv tv'
       ; return tv' }
{-# INLINE zonkTyBndrX #-} -- See Note [Inlining ZonkBndrT computations]

zonkTyVarBindersX :: [VarBndr TcTyVar vis]
                  -> ZonkBndrTcM [VarBndr TyVar vis]
zonkTyVarBindersX :: forall vis. [VarBndr Id vis] -> ZonkBndrTcM [VarBndr Id vis]
zonkTyVarBindersX = (VarBndr Id vis -> ZonkBndrT TcM (VarBndr Id vis))
-> [VarBndr Id vis] -> ZonkBndrT TcM [VarBndr Id vis]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse VarBndr Id vis -> ZonkBndrT TcM (VarBndr Id vis)
forall vis. VarBndr Id vis -> ZonkBndrTcM (VarBndr Id vis)
zonkTyVarBinderX
{-# INLINE zonkTyVarBindersX #-} -- See Note [Inlining ZonkBndrT computations]

zonkTyVarBinderX :: VarBndr TcTyVar vis
                 -> ZonkBndrTcM (VarBndr TyVar vis)
-- Takes a TcTyVar and guarantees to return a TyVar
zonkTyVarBinderX :: forall vis. VarBndr Id vis -> ZonkBndrTcM (VarBndr Id vis)
zonkTyVarBinderX (Bndr Id
tv vis
vis)
  = do { tv' <- Id -> ZonkBndrT TcM Id
zonkTyBndrX Id
tv
       ; return (Bndr tv' vis) }
{-# INLINE zonkTyVarBinderX #-} -- See Note [Inlining ZonkBndrT computations]

zonkTyVarOcc :: HasDebugCallStack => TcTyVar -> ZonkTcM Type
zonkTyVarOcc :: HasDebugCallStack => Id -> ZonkT TcM Kind
zonkTyVarOcc Id
tv
  = do { ZonkEnv { ze_tv_env = tv_env, ze_flexi = zonk_flexi } <- ZonkT TcM ZonkEnv
forall (m :: * -> *). Monad m => ZonkT m ZonkEnv
getZonkEnv

       ; let lookup_in_tv_env    -- Look up in the env just as we do for Ids
               = case TyCoVarEnv Id -> Id -> Maybe Id
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv TyCoVarEnv Id
tv_env Id
tv of
                   Maybe Id
Nothing  -> -- TyVar/SkolemTv/RuntimeUnk that isn't in the ZonkEnv
                               -- This can happen for RuntimeUnk variables (which
                               -- should stay as RuntimeUnk), but I think it should
                               -- not happen for SkolemTv.
                               Id -> Kind
mkTyVarTy (Id -> Kind) -> ZonkT TcM Id -> ZonkT TcM Kind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Kind -> ZonkT TcM Kind) -> Id -> ZonkT TcM Id
forall (m :: * -> *). Monad m => (Kind -> m Kind) -> Id -> m Id
updateTyVarKindM Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Id
tv

                   Just Id
tv' -> Kind -> ZonkT TcM Kind
forall a. a -> ZonkT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Kind
mkTyVarTy Id
tv')

             zonk_meta TcRef MetaDetails
ref MetaDetails
Flexi
               = do { kind <- Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX (Id -> Kind
tyVarKind Id
tv)
                    ; ty <- lift $ commitFlexi zonk_flexi tv kind

                    ; lift $ liftZonkM $ writeMetaTyVarRef tv ref ty  -- Belt and braces
                    ; finish_meta ty }

             zonk_meta TcRef MetaDetails
_ (Indirect Kind
ty)
               = do { zty <- Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Kind
ty
                    ; finish_meta zty }

             finish_meta Kind
ty
               = do { Id -> Kind -> ZonkT TcM ()
extendMetaEnv Id
tv Kind
ty
                    ; Kind -> ZonkT TcM Kind
forall a. a -> ZonkT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
ty }

       ; if isTcTyVar tv
         then case tcTyVarDetails tv of
           SkolemTv {}    -> ZonkT TcM Kind
lookup_in_tv_env
           RuntimeUnk {}  -> ZonkT TcM Kind
lookup_in_tv_env
           MetaTv { mtv_ref :: TcTyVarDetails -> TcRef MetaDetails
mtv_ref = TcRef MetaDetails
ref }
             -> do { mb_ty <- Id -> ZonkTcM (Maybe Kind)
lookupMetaTv Id
tv
                     -- See Note [Sharing when zonking to Type]
                   ; case mb_ty of
                       Just Kind
ty -> Kind -> ZonkT TcM Kind
forall a. a -> ZonkT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
ty
                       Maybe Kind
Nothing -> do { mtv_details <- TcRef MetaDetails -> ZonkT TcM MetaDetails
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef TcRef MetaDetails
ref
                                     ; zonk_meta ref mtv_details } }

         -- This should never really happen;
         -- TyVars should not occur in the typechecker
         else lookup_in_tv_env }

extendMetaEnv :: TcTyVar -> Type -> ZonkTcM ()
extendMetaEnv :: Id -> Kind -> ZonkT TcM ()
extendMetaEnv Id
tv Kind
ty =
  (ZonkEnv -> IOEnv (Env TcGblEnv TcLclEnv) ()) -> ZonkT TcM ()
forall (m :: * -> *) a. (ZonkEnv -> m a) -> ZonkT m a
ZonkT ((ZonkEnv -> IOEnv (Env TcGblEnv TcLclEnv) ()) -> ZonkT TcM ())
-> (ZonkEnv -> IOEnv (Env TcGblEnv TcLclEnv) ()) -> ZonkT TcM ()
forall a b. (a -> b) -> a -> b
$ \ ( ZonkEnv { ze_meta_tv_env :: ZonkEnv -> IORef (TyVarEnv Kind)
ze_meta_tv_env = IORef (TyVarEnv Kind)
mtv_env_ref } ) ->
    IORef (TyVarEnv Kind)
-> (TyVarEnv Kind -> TyVarEnv Kind)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => TcRef a -> (a -> a) -> m ()
updTcRef IORef (TyVarEnv Kind)
mtv_env_ref (\TyVarEnv Kind
env -> TyVarEnv Kind -> Id -> Kind -> TyVarEnv Kind
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv TyVarEnv Kind
env Id
tv Kind
ty)

lookupMetaTv :: TcTyVar -> ZonkTcM (Maybe Type)
lookupMetaTv :: Id -> ZonkTcM (Maybe Kind)
lookupMetaTv Id
tv =
  (ZonkEnv -> TcM (Maybe Kind)) -> ZonkTcM (Maybe Kind)
forall (m :: * -> *) a. (ZonkEnv -> m a) -> ZonkT m a
ZonkT ((ZonkEnv -> TcM (Maybe Kind)) -> ZonkTcM (Maybe Kind))
-> (ZonkEnv -> TcM (Maybe Kind)) -> ZonkTcM (Maybe Kind)
forall a b. (a -> b) -> a -> b
$ \ ( ZonkEnv { ze_meta_tv_env :: ZonkEnv -> IORef (TyVarEnv Kind)
ze_meta_tv_env = IORef (TyVarEnv Kind)
mtv_env_ref } ) ->
    do { mtv_env <- IORef (TyVarEnv Kind)
-> IOEnv (Env TcGblEnv TcLclEnv) (TyVarEnv Kind)
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef IORef (TyVarEnv Kind)
mtv_env_ref
       ; return $ lookupVarEnv mtv_env tv }

lookupTyVarX :: TcTyVar -> ZonkTcM TyVar
lookupTyVarX :: Id -> ZonkT TcM Id
lookupTyVarX Id
tv
  = do { ZonkEnv { ze_tv_env = tv_env } <- ZonkT TcM ZonkEnv
forall (m :: * -> *). Monad m => ZonkT m ZonkEnv
getZonkEnv
       ; let !res = case TyCoVarEnv Id -> Id -> Maybe Id
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv TyCoVarEnv Id
tv_env Id
tv of
                      Just Id
tv -> Id
tv
                      Maybe Id
Nothing -> String -> SDoc -> Id
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"lookupTyVarOcc" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
tv SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TyCoVarEnv Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVarEnv Id
tv_env)
       ; return res }

commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type
commitFlexi :: ZonkFlexi -> Id -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) Kind
commitFlexi ZonkFlexi
NoFlexi Id
tv Kind
zonked_kind
  = String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Kind
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"NoFlexi" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
tv SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
zonked_kind)

commitFlexi (SkolemiseFlexi IORef [Id]
tvs_ref) Id
tv Kind
zonked_kind
  = do { let skol_tv :: Id
skol_tv = Name -> Kind -> Id
mkTyVar (Id -> Name
tyVarName Id
tv) Kind
zonked_kind
       ; IORef [Id] -> ([Id] -> [Id]) -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => TcRef a -> (a -> a) -> m ()
updTcRef IORef [Id]
tvs_ref (Id
skol_tv Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:)
       ; Kind -> IOEnv (Env TcGblEnv TcLclEnv) Kind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Kind
mkTyVarTy Id
skol_tv) }

commitFlexi ZonkFlexi
RuntimeUnkFlexi Id
tv Kind
zonked_kind
  = do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Defaulting flexi tyvar to RuntimeUnk:" (Id -> SDoc
pprTyVar Id
tv)
       ; Kind -> IOEnv (Env TcGblEnv TcLclEnv) Kind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Kind
mkTyVarTy (Name -> Kind -> TcTyVarDetails -> Id
mkTcTyVar (Id -> Name
tyVarName Id
tv) Kind
zonked_kind TcTyVarDetails
RuntimeUnk)) }
            -- This is where RuntimeUnks are born:
            -- otherwise-unconstrained unification variables are
            -- turned into RuntimeUnks as they leave the
            -- typechecker's monad

commitFlexi ZonkFlexi
DefaultFlexi Id
tv Kind
zonked_kind
  -- Normally, RuntimeRep variables are defaulted in GHC.Tc.Utils.TcMType.defaultTyVar
  -- But that sees only type variables that appear in, say, an inferred type.
  -- Defaulting here, in the zonker, is needed to catch e.g.
  --    y :: Bool
  --    y = (\x -> True) undefined
  -- We need *some* known RuntimeRep for the x and undefined, but no one
  -- will choose it until we get here, in the zonker.
  | Kind -> Bool
isRuntimeRepTy Kind
zonked_kind
  = do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Defaulting flexi tyvar to LiftedRep:" (Id -> SDoc
pprTyVar Id
tv)
       ; Kind -> IOEnv (Env TcGblEnv TcLclEnv) Kind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
liftedRepTy }
  | Kind -> Bool
isLevityTy Kind
zonked_kind
  = do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Defaulting flexi tyvar to Lifted:" (Id -> SDoc
pprTyVar Id
tv)
       ; Kind -> IOEnv (Env TcGblEnv TcLclEnv) Kind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
liftedDataConTy }
  | Kind -> Bool
isMultiplicityTy Kind
zonked_kind
  = do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Defaulting flexi tyvar to Many:" (Id -> SDoc
pprTyVar Id
tv)
       ; Kind -> IOEnv (Env TcGblEnv TcLclEnv) Kind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
manyDataConTy }
  | Just (ConcreteFRR FixedRuntimeRepOrigin
origin) <- Id -> Maybe ConcreteTvOrigin
isConcreteTyVar_maybe Id
tv
  = do { TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ ZonkerMessage -> TcRnMessage
TcRnZonkerMessage (FixedRuntimeRepOrigin -> ZonkerMessage
ZonkerCannotDefaultConcrete FixedRuntimeRepOrigin
origin)
       ; Kind -> IOEnv (Env TcGblEnv TcLclEnv) Kind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> Kind
anyTypeOfKind Kind
zonked_kind) }
  | Bool
otherwise
  = do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Defaulting flexi tyvar to ZonkAny:" (Id -> SDoc
pprTyVar Id
tv)
          -- See Note [Any types] in GHC.Builtin.Types, esp wrinkle (Any4)
       ; Kind -> IOEnv (Env TcGblEnv TcLclEnv) Kind
newZonkAnyType Kind
zonked_kind }

zonkCoVarOcc :: CoVar -> ZonkTcM Coercion
zonkCoVarOcc :: Id -> ZonkTcM Coercion
zonkCoVarOcc Id
cv
  = do { ZonkEnv { ze_tv_env = tyco_env } <- ZonkT TcM ZonkEnv
forall (m :: * -> *). Monad m => ZonkT m ZonkEnv
getZonkEnv
         -- don't look in the knot-tied env
       ; case lookupVarEnv tyco_env cv of
          Just Id
cv' -> Coercion -> ZonkTcM Coercion
forall a. a -> ZonkT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> ZonkTcM Coercion) -> Coercion -> ZonkTcM Coercion
forall a b. (a -> b) -> a -> b
$ Id -> Coercion
mkCoVarCo Id
cv'
          Maybe Id
_        -> Id -> Coercion
mkCoVarCo (Id -> Coercion) -> ZonkT TcM Id -> ZonkTcM Coercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IOEnv (Env TcGblEnv TcLclEnv) Id -> ZonkT TcM Id
forall (m :: * -> *) a. Monad m => m a -> ZonkT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) Id -> ZonkT TcM Id)
-> IOEnv (Env TcGblEnv TcLclEnv) Id -> ZonkT TcM Id
forall a b. (a -> b) -> a -> b
$ ZonkM Id -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM Id -> IOEnv (Env TcGblEnv TcLclEnv) Id)
-> ZonkM Id -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall a b. (a -> b) -> a -> b
$ Id -> ZonkM Id
zonkCoVar Id
cv) }

zonkCoHole :: CoercionHole -> ZonkTcM Coercion
zonkCoHole :: CoercionHole -> ZonkTcM Coercion
zonkCoHole hole :: CoercionHole
hole@(CoercionHole { ch_ref :: CoercionHole -> IORef (Maybe Coercion)
ch_ref = IORef (Maybe Coercion)
ref, ch_co_var :: CoercionHole -> Id
ch_co_var = Id
cv })
  = do { contents <- IORef (Maybe Coercion) -> ZonkT TcM (Maybe Coercion)
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef IORef (Maybe Coercion)
ref
       ; case contents of
           Just Coercion
co -> do { co' <- Coercion -> ZonkTcM Coercion
zonkCoToCo Coercion
co
                         ; lift $ liftZonkM $ checkCoercionHole cv co' }

              -- This next case should happen only in the presence of
              -- (undeferred) type errors. Originally, I put in a panic
              -- here, but that caused too many uses of `failIfErrsM`.
           Maybe Coercion
Nothing -> do { IOEnv (Env TcGblEnv TcLclEnv) () -> ZonkT TcM ()
forall (m :: * -> *) a. Monad m => m a -> ZonkT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) () -> ZonkT TcM ())
-> IOEnv (Env TcGblEnv TcLclEnv) () -> ZonkT TcM ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Zonking unfilled coercion hole" (CoercionHole -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoercionHole
hole)
                         ; cv' <- IOEnv (Env TcGblEnv TcLclEnv) Id -> ZonkT TcM Id
forall (m :: * -> *) a. Monad m => m a -> ZonkT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) Id -> ZonkT TcM Id)
-> IOEnv (Env TcGblEnv TcLclEnv) Id -> ZonkT TcM Id
forall a b. (a -> b) -> a -> b
$ ZonkM Id -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM Id -> IOEnv (Env TcGblEnv TcLclEnv) Id)
-> ZonkM Id -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall a b. (a -> b) -> a -> b
$ Id -> ZonkM Id
zonkCoVar Id
cv
                         ; return $ mkCoVarCo cv' } }
                             -- This will be an out-of-scope variable, but keeping
                             -- this as a coercion hole led to #15787

zonk_tycomapper :: TyCoMapper ZonkEnv TcM
zonk_tycomapper :: TyCoMapper ZonkEnv TcM
zonk_tycomapper = TyCoMapper
  { tcm_tyvar :: ZonkEnv -> Id -> IOEnv (Env TcGblEnv TcLclEnv) Kind
tcm_tyvar      = \ ZonkEnv
env Id
tv -> ZonkT TcM Kind -> ZonkEnv -> IOEnv (Env TcGblEnv TcLclEnv) Kind
forall (m :: * -> *) a. ZonkT m a -> ZonkEnv -> m a
runZonkT (HasDebugCallStack => Id -> ZonkT TcM Kind
Id -> ZonkT TcM Kind
zonkTyVarOcc Id
tv) ZonkEnv
env
  , tcm_covar :: ZonkEnv -> Id -> IOEnv (Env TcGblEnv TcLclEnv) Coercion
tcm_covar      = \ ZonkEnv
env Id
cv -> ZonkTcM Coercion
-> ZonkEnv -> IOEnv (Env TcGblEnv TcLclEnv) Coercion
forall (m :: * -> *) a. ZonkT m a -> ZonkEnv -> m a
runZonkT (Id -> ZonkTcM Coercion
zonkCoVarOcc Id
cv) ZonkEnv
env
  , tcm_hole :: ZonkEnv -> CoercionHole -> IOEnv (Env TcGblEnv TcLclEnv) Coercion
tcm_hole       = \ ZonkEnv
env CoercionHole
co -> ZonkTcM Coercion
-> ZonkEnv -> IOEnv (Env TcGblEnv TcLclEnv) Coercion
forall (m :: * -> *) a. ZonkT m a -> ZonkEnv -> m a
runZonkT (CoercionHole -> ZonkTcM Coercion
zonkCoHole   CoercionHole
co) ZonkEnv
env
  , tcm_tycobinder :: forall r.
ZonkEnv -> Id -> ForAllTyFlag -> (ZonkEnv -> Id -> TcM r) -> TcM r
tcm_tycobinder = \ ZonkEnv
env Id
tcv ForAllTyFlag
_vis ZonkEnv -> Id -> TcM r
k -> (ZonkT TcM r -> ZonkEnv -> TcM r)
-> ZonkEnv -> ZonkT TcM r -> TcM r
forall a b c. (a -> b -> c) -> b -> a -> c
flip ZonkT TcM r -> ZonkEnv -> TcM r
forall (m :: * -> *) a. ZonkT m a -> ZonkEnv -> m a
runZonkT ZonkEnv
env (ZonkT TcM r -> TcM r) -> ZonkT TcM r -> TcM r
forall a b. (a -> b) -> a -> b
$
                     ZonkBndrT TcM Id -> forall r. (Id -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT (Id -> ZonkBndrT TcM Id
zonkTyBndrX Id
tcv) ((Id -> ZonkT TcM r) -> ZonkT TcM r)
-> (Id -> ZonkT TcM r) -> ZonkT TcM r
forall a b. (a -> b) -> a -> b
$
                     \ Id
tcv' -> (ZonkEnv -> TcM r) -> ZonkT TcM r
forall (m :: * -> *) a. (ZonkEnv -> m a) -> ZonkT m a
ZonkT ((ZonkEnv -> TcM r) -> ZonkT TcM r)
-> (ZonkEnv -> TcM r) -> ZonkT TcM r
forall a b. (a -> b) -> a -> b
$ \ ZonkEnv
env' -> (ZonkEnv -> Id -> TcM r
k ZonkEnv
env' Id
tcv')
  , tcm_tycon :: TcTyCon -> TcM TcTyCon
tcm_tycon      = \ TcTyCon
tc -> TcTyCon -> TcM TcTyCon
zonkTcTyConToTyCon TcTyCon
tc
  }

-- Zonk a TyCon by changing a TcTyCon to a regular TyCon
zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon
zonkTcTyConToTyCon :: TcTyCon -> TcM TcTyCon
zonkTcTyConToTyCon TcTyCon
tc
  | TcTyCon -> Bool
isTcTyCon TcTyCon
tc = do { thing <- Name -> TcM TyThing
tcLookupGlobalOnly (TcTyCon -> Name
forall a. NamedThing a => a -> Name
getName TcTyCon
tc)
                      ; case thing of
                          ATyCon TcTyCon
real_tc -> TcTyCon -> TcM TcTyCon
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcTyCon
real_tc
                          TyThing
_              -> String -> SDoc -> TcM TcTyCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"zonkTcTyCon" (TcTyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyCon
tc SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
thing) }
  | Bool
otherwise    = TcTyCon -> TcM TcTyCon
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcTyCon
tc -- it's already zonked

-- | Confused by zonking? See Note [What is zonking?] in "GHC.Tc.Zonk.Type".
zonkTcTypeToType :: TcType -> TcM Type
zonkTcTypeToType :: Kind -> IOEnv (Env TcGblEnv TcLclEnv) Kind
zonkTcTypeToType Kind
ty = ZonkFlexi -> ZonkT TcM Kind -> IOEnv (Env TcGblEnv TcLclEnv) Kind
forall (m :: * -> *) b. MonadIO m => ZonkFlexi -> ZonkT m b -> m b
initZonkEnv ZonkFlexi
DefaultFlexi (ZonkT TcM Kind -> IOEnv (Env TcGblEnv TcLclEnv) Kind)
-> ZonkT TcM Kind -> IOEnv (Env TcGblEnv TcLclEnv) Kind
forall a b. (a -> b) -> a -> b
$ Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Kind
ty

zonkScaledTcTypeToTypeX :: Scaled TcType -> ZonkTcM (Scaled TcType)
zonkScaledTcTypeToTypeX :: Scaled Kind -> ZonkTcM (Scaled Kind)
zonkScaledTcTypeToTypeX (Scaled Kind
m Kind
ty) = Kind -> Kind -> Scaled Kind
forall a. Kind -> a -> Scaled a
Scaled (Kind -> Kind -> Scaled Kind)
-> ZonkT TcM Kind -> ZonkT TcM (Kind -> Scaled Kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Kind
m
                                               ZonkT TcM (Kind -> Scaled Kind)
-> ZonkT TcM Kind -> ZonkTcM (Scaled Kind)
forall a b. ZonkT TcM (a -> b) -> ZonkT TcM a -> ZonkT TcM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Kind
ty

zonkTcTypeToTypeX   :: TcType   -> ZonkTcM Type
zonkTcTypesToTypesX :: [TcType] -> ZonkTcM [Type]
zonkCoToCo          :: Coercion -> ZonkTcM Coercion
(Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX, [Kind] -> ZonkTcM [Kind]
zonkTcTypesToTypesX, Coercion -> ZonkTcM Coercion
zonkCoToCo)
  = case TyCoMapper ZonkEnv TcM
-> (ZonkEnv -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) Kind,
    ZonkEnv -> [Kind] -> TcM [Kind],
    ZonkEnv -> Coercion -> IOEnv (Env TcGblEnv TcLclEnv) Coercion,
    ZonkEnv -> [Coercion] -> TcM [Coercion])
forall (m :: * -> *) env.
Monad m =>
TyCoMapper env m
-> (env -> Kind -> m Kind, env -> [Kind] -> m [Kind],
    env -> Coercion -> m Coercion, env -> [Coercion] -> m [Coercion])
mapTyCoX TyCoMapper ZonkEnv TcM
zonk_tycomapper of
      (ZonkEnv -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) Kind
zty, ZonkEnv -> [Kind] -> TcM [Kind]
ztys, ZonkEnv -> Coercion -> IOEnv (Env TcGblEnv TcLclEnv) Coercion
zco, ZonkEnv -> [Coercion] -> TcM [Coercion]
_) ->
        ((ZonkEnv -> IOEnv (Env TcGblEnv TcLclEnv) Kind) -> ZonkT TcM Kind
forall (m :: * -> *) a. (ZonkEnv -> m a) -> ZonkT m a
ZonkT ((ZonkEnv -> IOEnv (Env TcGblEnv TcLclEnv) Kind) -> ZonkT TcM Kind)
-> (Kind -> ZonkEnv -> IOEnv (Env TcGblEnv TcLclEnv) Kind)
-> Kind
-> ZonkT TcM Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ZonkEnv -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) Kind)
-> Kind -> ZonkEnv -> IOEnv (Env TcGblEnv TcLclEnv) Kind
forall a b c. (a -> b -> c) -> b -> a -> c
flip ZonkEnv -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) Kind
zty, (ZonkEnv -> TcM [Kind]) -> ZonkTcM [Kind]
forall (m :: * -> *) a. (ZonkEnv -> m a) -> ZonkT m a
ZonkT ((ZonkEnv -> TcM [Kind]) -> ZonkTcM [Kind])
-> ([Kind] -> ZonkEnv -> TcM [Kind]) -> [Kind] -> ZonkTcM [Kind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ZonkEnv -> [Kind] -> TcM [Kind])
-> [Kind] -> ZonkEnv -> TcM [Kind]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ZonkEnv -> [Kind] -> TcM [Kind]
ztys, (ZonkEnv -> IOEnv (Env TcGblEnv TcLclEnv) Coercion)
-> ZonkTcM Coercion
forall (m :: * -> *) a. (ZonkEnv -> m a) -> ZonkT m a
ZonkT ((ZonkEnv -> IOEnv (Env TcGblEnv TcLclEnv) Coercion)
 -> ZonkTcM Coercion)
-> (Coercion -> ZonkEnv -> IOEnv (Env TcGblEnv TcLclEnv) Coercion)
-> Coercion
-> ZonkTcM Coercion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ZonkEnv -> Coercion -> IOEnv (Env TcGblEnv TcLclEnv) Coercion)
-> Coercion -> ZonkEnv -> IOEnv (Env TcGblEnv TcLclEnv) Coercion
forall a b c. (a -> b -> c) -> b -> a -> c
flip ZonkEnv -> Coercion -> IOEnv (Env TcGblEnv TcLclEnv) Coercion
zco)

zonkScaledTcTypesToTypesX :: [Scaled TcType] -> ZonkTcM [Scaled Type]
zonkScaledTcTypesToTypesX :: [Scaled Kind] -> ZonkTcM [Scaled Kind]
zonkScaledTcTypesToTypesX [Scaled Kind]
scaled_tys =
   (Scaled Kind -> ZonkTcM (Scaled Kind))
-> [Scaled Kind] -> ZonkTcM [Scaled Kind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Scaled Kind -> ZonkTcM (Scaled Kind)
zonkScaledTcTypeToTypeX [Scaled Kind]
scaled_tys


zonkEnvIds :: ZonkEnv -> TypeEnv
zonkEnvIds :: ZonkEnv -> TypeEnv
zonkEnvIds (ZonkEnv { ze_id_env :: ZonkEnv -> TyCoVarEnv Id
ze_id_env = TyCoVarEnv Id
id_env })
  = [(Name, TyThing)] -> TypeEnv
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Id -> Name
forall a. NamedThing a => a -> Name
getName Id
id, Id -> TyThing
AnId Id
id) | Id
id <- TyCoVarEnv Id -> [Id]
forall {k} (key :: k) elt. UniqFM key elt -> [elt]
nonDetEltsUFM TyCoVarEnv Id
id_env]
  -- It's OK to use nonDetEltsUFM here because we forget the ordering
  -- immediately by creating a TypeEnv

zonkLIdOcc :: LocatedN TcId -> ZonkTcM (LocatedN Id)
zonkLIdOcc :: GenLocated SrcSpanAnnN Id -> ZonkTcM (GenLocated SrcSpanAnnN Id)
zonkLIdOcc = (Id -> ZonkT TcM Id)
-> GenLocated SrcSpanAnnN Id -> ZonkTcM (GenLocated SrcSpanAnnN Id)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> GenLocated SrcSpanAnnN a -> f (GenLocated SrcSpanAnnN b)
traverse Id -> ZonkT TcM Id
zonkIdOcc

zonkIdOcc :: TcId -> ZonkTcM Id
-- Ids defined in this module should be in the envt;
-- ignore others.  (Actually, data constructors are also
-- not LocalVars, even when locally defined, but that is fine.)
-- (Also foreign-imported things aren't currently in the ZonkEnv;
--  that's ok because they don't need zonking.)
--
-- Actually, Template Haskell works in 'chunks' of declarations, and
-- an earlier chunk won't be in the 'env' that the zonking phase
-- carries around.  Instead it'll be in the tcg_gbl_env, already fully
-- zonked.  There's no point in looking it up there (except for error
-- checking), and it's not conveniently to hand; hence the simple
-- 'orElse' case in the LocalVar branch.
--
-- Even without template splices, in module Main, the checking of
-- 'main' is done as a separate chunk.
zonkIdOcc :: Id -> ZonkT TcM Id
zonkIdOcc Id
id
  | Id -> Bool
isLocalVar Id
id =
    do { ZonkEnv { ze_id_env = id_env } <- ZonkT TcM ZonkEnv
forall (m :: * -> *). Monad m => ZonkT m ZonkEnv
getZonkEnv
       ; return $ lookupVarEnv id_env id `orElse` id }
  | Bool
otherwise
  = Id -> ZonkT TcM Id
forall a. a -> ZonkT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return Id
id

zonkIdOccs :: [TcId] -> ZonkTcM [Id]
zonkIdOccs :: [Id] -> ZonkTcM [Id]
zonkIdOccs [Id]
ids = (Id -> ZonkT TcM Id) -> [Id] -> ZonkTcM [Id]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Id -> ZonkT TcM Id
zonkIdOcc [Id]
ids

-- zonkIdBndr is used *after* typechecking to get the Id's type
-- to its final form.  The TyVarEnv give
zonkIdBndrX :: TcId -> ZonkBndrTcM Id
zonkIdBndrX :: Id -> ZonkBndrT TcM Id
zonkIdBndrX Id
v
  = do { id <- ZonkT TcM Id -> ZonkBndrT TcM Id
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkT TcM Id -> ZonkBndrT TcM Id)
-> ZonkT TcM Id -> ZonkBndrT TcM Id
forall a b. (a -> b) -> a -> b
$ Id -> ZonkT TcM Id
zonkIdBndr Id
v
       ; extendIdZonkEnv id
       ; return id }
{-# INLINE zonkIdBndrX #-} -- See Note [Inlining ZonkBndrT computations]

zonkIdBndr :: TcId -> ZonkTcM Id
zonkIdBndr :: Id -> ZonkT TcM Id
zonkIdBndr Id
v
  = do { Scaled w' ty' <- Scaled Kind -> ZonkTcM (Scaled Kind)
zonkScaledTcTypeToTypeX (Id -> Scaled Kind
idScaledType Id
v)
       ; return $ setIdMult (setIdType v ty') w' }

zonkIdBndrs :: [TcId] -> ZonkTcM [Id]
zonkIdBndrs :: [Id] -> ZonkTcM [Id]
zonkIdBndrs [Id]
ids = (Id -> ZonkT TcM Id) -> [Id] -> ZonkTcM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Id -> ZonkT TcM Id
zonkIdBndr [Id]
ids

zonkTopBndrs :: [TcId] -> TcM [Id]
zonkTopBndrs :: [Id] -> TcM [Id]
zonkTopBndrs [Id]
ids = ZonkFlexi -> ZonkTcM [Id] -> TcM [Id]
forall (m :: * -> *) b. MonadIO m => ZonkFlexi -> ZonkT m b -> m b
initZonkEnv ZonkFlexi
DefaultFlexi (ZonkTcM [Id] -> TcM [Id]) -> ZonkTcM [Id] -> TcM [Id]
forall a b. (a -> b) -> a -> b
$ [Id] -> ZonkTcM [Id]
zonkIdBndrs [Id]
ids

zonkFieldOcc :: FieldOcc GhcTc -> ZonkTcM (FieldOcc GhcTc)
zonkFieldOcc :: FieldOcc GhcTc -> ZonkTcM (FieldOcc GhcTc)
zonkFieldOcc (FieldOcc XCFieldOcc GhcTc
lbl (L SrcSpanAnnN
l Id
sel))
  = XCFieldOcc GhcTc -> LIdP GhcTc -> FieldOcc GhcTc
forall pass. XCFieldOcc pass -> LIdP pass -> FieldOcc pass
FieldOcc XCFieldOcc GhcTc
lbl (GenLocated SrcSpanAnnN Id -> FieldOcc GhcTc)
-> (Id -> GenLocated SrcSpanAnnN Id) -> Id -> FieldOcc GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpanAnnN -> Id -> GenLocated SrcSpanAnnN Id
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l (Id -> FieldOcc GhcTc) -> ZonkT TcM Id -> ZonkTcM (FieldOcc GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> ZonkT TcM Id
zonkIdBndr Id
sel

zonkEvBndrsX :: [EvVar] -> ZonkBndrTcM [EvVar]
zonkEvBndrsX :: [Id] -> ZonkBndrTcM [Id]
zonkEvBndrsX = (Id -> ZonkBndrT TcM Id) -> [Id] -> ZonkBndrTcM [Id]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Id -> ZonkBndrT TcM Id
zonkEvBndrX
{-# INLINE zonkEvBndrsX #-} -- See Note [Inlining ZonkBndrT computations]

zonkEvBndrX :: EvVar -> ZonkBndrTcM EvVar
-- Works for dictionaries and coercions
zonkEvBndrX :: Id -> ZonkBndrT TcM Id
zonkEvBndrX Id
var
  = do { var' <- ZonkT TcM Id -> ZonkBndrT TcM Id
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkT TcM Id -> ZonkBndrT TcM Id)
-> ZonkT TcM Id -> ZonkBndrT TcM Id
forall a b. (a -> b) -> a -> b
$ Id -> ZonkT TcM Id
zonkEvBndr Id
var
       ; extendZonkEnv [var']
       ; return var' }
{-# INLINE zonkEvBndr #-} -- See Note [Inlining ZonkBndrT computations]

zonkEvBndr :: EvVar -> ZonkTcM EvVar
-- Works for dictionaries and coercions
-- Does not extend the ZonkEnv
zonkEvBndr :: Id -> ZonkT TcM Id
zonkEvBndr Id
var
  = (Kind -> ZonkT TcM Kind) -> Id -> ZonkT TcM Id
forall (m :: * -> *). Monad m => (Kind -> m Kind) -> Id -> m Id
updateIdTypeAndMultM ({-# SCC "zonkEvBndr_zonkTcTypeToType" #-} Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX) Id
var

{-
zonkEvVarOcc :: EvVar -> ZonkTcM EvTerm
zonkEvVarOcc env v
  | isCoVar v
  = EvCoercion <$> zonkCoVarOcc env v
  | otherwise
  = return (EvId $ zonkIdOcc env v)
-}

zonkCoreBndrX :: Var -> ZonkBndrTcM Var
zonkCoreBndrX :: Id -> ZonkBndrT TcM Id
zonkCoreBndrX Id
v
  | Id -> Bool
isId Id
v    = Id -> ZonkBndrT TcM Id
zonkIdBndrX Id
v
  | Bool
otherwise = Id -> ZonkBndrT TcM Id
zonkTyBndrX Id
v
{-# INLINE zonkCoreBndrX #-} -- See Note [Inlining ZonkBndrT computations]

zonkCoreBndrsX :: [Var] -> ZonkBndrTcM [Var]
zonkCoreBndrsX :: [Id] -> ZonkBndrTcM [Id]
zonkCoreBndrsX = (Id -> ZonkBndrT TcM Id) -> [Id] -> ZonkBndrTcM [Id]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Id -> ZonkBndrT TcM Id
zonkCoreBndrX
{-# INLINE zonkCoreBndrsX #-} -- See Note [Inlining ZonkBndrT computations]

zonkTopExpr :: HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkTopExpr :: HsExpr GhcTc -> TcM (HsExpr GhcTc)
zonkTopExpr HsExpr GhcTc
e = ZonkFlexi -> ZonkT TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall (m :: * -> *) b. MonadIO m => ZonkFlexi -> ZonkT m b -> m b
initZonkEnv ZonkFlexi
DefaultFlexi (ZonkT TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> ZonkT TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> ZonkT TcM (HsExpr GhcTc)
zonkExpr HsExpr GhcTc
e

zonkTopLExpr :: LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkTopLExpr :: LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkTopLExpr LHsExpr GhcTc
e = ZonkFlexi -> ZonkT TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall (m :: * -> *) b. MonadIO m => ZonkFlexi -> ZonkT m b -> m b
initZonkEnv ZonkFlexi
DefaultFlexi (ZonkT TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> ZonkT TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr 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
  = ZonkFlexi
-> ZonkT
     TcM
     (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
      [LTcSpecPrag], [LRuleDecl GhcTc])
-> TcM
     (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
      [LTcSpecPrag], [LRuleDecl GhcTc])
forall (m :: * -> *) b. MonadIO m => ZonkFlexi -> ZonkT m b -> m b
initZonkEnv ZonkFlexi
DefaultFlexi (ZonkT
   TcM
   (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
    [LTcSpecPrag], [LRuleDecl GhcTc])
 -> TcM
      (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
       [LTcSpecPrag], [LRuleDecl GhcTc]))
-> ZonkT
     TcM
     (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
      [LTcSpecPrag], [LRuleDecl GhcTc])
-> TcM
     (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
      [LTcSpecPrag], [LRuleDecl GhcTc])
forall a b. (a -> b) -> a -> b
$
    ZonkBndrT TcM (Bag EvBind)
-> forall r. (Bag EvBind -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT (Bag EvBind -> ZonkBndrT TcM (Bag EvBind)
zonkEvBinds Bag EvBind
ev_binds)   ((Bag EvBind
  -> ZonkT
       TcM
       (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
        [LTcSpecPrag], [LRuleDecl GhcTc]))
 -> ZonkT
      TcM
      (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
       [LTcSpecPrag], [LRuleDecl GhcTc]))
-> (Bag EvBind
    -> ZonkT
         TcM
         (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
          [LTcSpecPrag], [LRuleDecl GhcTc]))
-> ZonkT
     TcM
     (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
      [LTcSpecPrag], [LRuleDecl GhcTc])
forall a b. (a -> b) -> a -> b
$ \ Bag EvBind
ev_binds' ->
    ZonkBndrT TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> forall r.
   ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)] -> ZonkT TcM r)
   -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT (LHsBinds GhcTc -> ZonkBndrTcM (LHsBinds GhcTc)
zonkRecMonoBinds LHsBinds GhcTc
binds) (([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
  -> ZonkT
       TcM
       (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
        [LTcSpecPrag], [LRuleDecl GhcTc]))
 -> ZonkT
      TcM
      (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
       [LTcSpecPrag], [LRuleDecl GhcTc]))
-> ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    -> ZonkT
         TcM
         (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
          [LTcSpecPrag], [LRuleDecl GhcTc]))
-> ZonkT
     TcM
     (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
      [LTcSpecPrag], [LRuleDecl GhcTc])
forall a b. (a -> b) -> a -> b
$ \ [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds'    ->
     -- Top level is implicitly recursive
  do  { rules' <- [LRuleDecl GhcTc] -> ZonkTcM [LRuleDecl GhcTc]
zonkRules [LRuleDecl GhcTc]
rules
      ; specs' <- zonkLTcSpecPrags imp_specs
      ; fords' <- zonkForeignExports fords
      ; ty_env <- zonkEnvIds <$> getZonkEnv
      ; return (ty_env, ev_binds', binds', fords', specs', rules') }


---------------------------------------------
zonkLocalBinds :: HsLocalBinds GhcTc
               -> ZonkBndrTcM (HsLocalBinds GhcTc)
zonkLocalBinds :: HsLocalBinds GhcTc -> ZonkBndrTcM (HsLocalBinds GhcTc)
zonkLocalBinds (EmptyLocalBinds XEmptyLocalBinds GhcTc GhcTc
x)
  = HsLocalBinds GhcTc -> ZonkBndrTcM (HsLocalBinds GhcTc)
forall a. a -> ZonkBndrT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (XEmptyLocalBinds GhcTc GhcTc -> HsLocalBinds GhcTc
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcTc GhcTc
x)

zonkLocalBinds (HsValBinds XHsValBinds GhcTc GhcTc
_ (ValBinds {}))
  = String -> ZonkBndrTcM (HsLocalBinds GhcTc)
forall a. HasCallStack => String -> a
panic String
"zonkLocalBinds" -- Not in typechecker output

zonkLocalBinds (HsValBinds XHsValBinds GhcTc GhcTc
x (XValBindsLR (NValBinds [(RecFlag, LHsBinds GhcTc)]
binds [LSig GhcRn]
sigs)))
  = do  { new_binds <- ((RecFlag, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])
 -> ZonkBndrT
      TcM (RecFlag, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]))
-> [(RecFlag, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])]
-> ZonkBndrT
     TcM [(RecFlag, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (RecFlag, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])
-> ZonkBndrT
     TcM (RecFlag, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])
forall {a}.
(a, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])
-> ZonkBndrT
     TcM (a, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])
go [(RecFlag, LHsBinds GhcTc)]
[(RecFlag, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])]
binds
        ; return (HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) }
  where
    go :: (a, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])
-> ZonkBndrT
     TcM (a, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])
go (a
r,[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
b)
      = do { b' <- LHsBinds GhcTc -> ZonkBndrTcM (LHsBinds GhcTc)
zonkRecMonoBinds LHsBinds GhcTc
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
b
           ; return (r,b') }

zonkLocalBinds (HsIPBinds XHsIPBinds GhcTc GhcTc
x (IPBinds XIPBinds GhcTc
dict_binds [LIPBind GhcTc]
binds )) = do
    new_binds <- ZonkT TcM [GenLocated SrcSpanAnnA (IPBind GhcTc)]
-> ZonkBndrT TcM [GenLocated SrcSpanAnnA (IPBind GhcTc)]
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkT TcM [GenLocated SrcSpanAnnA (IPBind GhcTc)]
 -> ZonkBndrT TcM [GenLocated SrcSpanAnnA (IPBind GhcTc)])
-> ZonkT TcM [GenLocated SrcSpanAnnA (IPBind GhcTc)]
-> ZonkBndrT TcM [GenLocated SrcSpanAnnA (IPBind GhcTc)]
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (IPBind GhcTc)
 -> ZonkT TcM (GenLocated SrcSpanAnnA (IPBind GhcTc)))
-> [GenLocated SrcSpanAnnA (IPBind GhcTc)]
-> ZonkT TcM [GenLocated SrcSpanAnnA (IPBind GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((IPBind GhcTc -> ZonkTcM (IPBind GhcTc))
-> GenLocated SrcSpanAnnA (IPBind GhcTc)
-> ZonkT TcM (GenLocated SrcSpanAnnA (IPBind GhcTc))
forall a b ann.
(a -> ZonkTcM b)
-> GenLocated (EpAnn ann) a -> ZonkTcM (GenLocated (EpAnn ann) b)
wrapLocZonkMA IPBind GhcTc -> ZonkTcM (IPBind GhcTc)
zonk_ip_bind) [LIPBind GhcTc]
[GenLocated SrcSpanAnnA (IPBind GhcTc)]
binds
    extendIdZonkEnvRec [ n | (L _ (IPBind n _ _)) <- new_binds]
    new_dict_binds <- zonkTcEvBinds dict_binds
    return $ HsIPBinds x (IPBinds new_dict_binds new_binds)
  where
    zonk_ip_bind :: IPBind GhcTc -> ZonkTcM (IPBind GhcTc)
zonk_ip_bind (IPBind XCIPBind GhcTc
dict_id XRec GhcTc HsIPName
n LHsExpr GhcTc
e)
        = do dict_id' <- Id -> ZonkT TcM Id
zonkIdBndr XCIPBind GhcTc
Id
dict_id
             e'       <- zonkLExpr e
             return (IPBind dict_id' n e')

---------------------------------------------
zonkRecMonoBinds :: LHsBinds GhcTc -> ZonkBndrTcM (LHsBinds GhcTc)
zonkRecMonoBinds :: LHsBinds GhcTc -> ZonkBndrTcM (LHsBinds GhcTc)
zonkRecMonoBinds LHsBinds GhcTc
binds
  = (LHsBinds GhcTc -> ZonkBndrTcM (LHsBinds GhcTc))
-> ZonkBndrTcM (LHsBinds GhcTc)
forall a. (a -> ZonkBndrT TcM a) -> ZonkBndrT TcM a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((LHsBinds GhcTc -> ZonkBndrTcM (LHsBinds GhcTc))
 -> ZonkBndrTcM (LHsBinds GhcTc))
-> (LHsBinds GhcTc -> ZonkBndrTcM (LHsBinds GhcTc))
-> ZonkBndrTcM (LHsBinds GhcTc)
forall a b. (a -> b) -> a -> b
$ \ LHsBinds GhcTc
new_binds ->
  do { [Id] -> ZonkBndrT TcM ()
forall (m :: * -> *). [Id] -> ZonkBndrT m ()
extendIdZonkEnvRec (CollectFlag GhcTc -> LHsBinds GhcTc -> [IdP GhcTc]
forall p idR.
CollectPass p =>
CollectFlag p -> LHsBindsLR p idR -> [IdP p]
collectHsBindsBinders CollectFlag GhcTc
forall p. CollectFlag p
CollNoDictBinders LHsBinds GhcTc
new_binds)
     ; ZonkT TcM (LHsBinds GhcTc) -> ZonkBndrTcM (LHsBinds GhcTc)
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkT TcM (LHsBinds GhcTc) -> ZonkBndrTcM (LHsBinds GhcTc))
-> ZonkT TcM (LHsBinds GhcTc) -> ZonkBndrTcM (LHsBinds GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsBinds GhcTc -> ZonkT TcM (LHsBinds GhcTc)
zonkMonoBinds LHsBinds GhcTc
binds }

---------------------------------------------
zonkMonoBinds :: LHsBinds GhcTc -> ZonkTcM (LHsBinds GhcTc)
zonkMonoBinds :: LHsBinds GhcTc -> ZonkT TcM (LHsBinds GhcTc)
zonkMonoBinds LHsBinds GhcTc
binds = (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
 -> ZonkT TcM (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> ZonkT TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LHsBind GhcTc -> ZonkTcM (LHsBind GhcTc)
GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> ZonkT TcM (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
zonk_lbind LHsBinds GhcTc
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds

zonk_lbind :: LHsBind GhcTc -> ZonkTcM (LHsBind GhcTc)
zonk_lbind :: LHsBind GhcTc -> ZonkTcM (LHsBind GhcTc)
zonk_lbind = (HsBindLR GhcTc GhcTc -> ZonkTcM (HsBindLR GhcTc GhcTc))
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> ZonkT TcM (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a b ann.
(a -> ZonkTcM b)
-> GenLocated (EpAnn ann) a -> ZonkTcM (GenLocated (EpAnn ann) b)
wrapLocZonkMA HsBindLR GhcTc GhcTc -> ZonkTcM (HsBindLR GhcTc GhcTc)
zonk_bind

zonk_bind :: HsBind GhcTc -> ZonkTcM (HsBind GhcTc)
zonk_bind :: HsBindLR GhcTc GhcTc -> ZonkTcM (HsBindLR GhcTc GhcTc)
zonk_bind 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_mult :: forall idL idR. HsBindLR idL idR -> HsMultAnn idL
pat_mult = HsMultAnn GhcTc
mult_ann
                        , pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_ext = (Kind
ty, ([CoreTickish], [[CoreTickish]])
ticks)})
  = do  { new_pat   <- ZonkBndrT TcM (LPat GhcTc) -> ZonkT TcM (LPat GhcTc)
forall (m :: * -> *) a. Monad m => ZonkBndrT m a -> ZonkT m a
don'tBind (ZonkBndrT TcM (LPat GhcTc) -> ZonkT TcM (LPat GhcTc))
-> ZonkBndrT TcM (LPat GhcTc) -> ZonkT TcM (LPat GhcTc)
forall a b. (a -> b) -> a -> b
$ LPat GhcTc -> ZonkBndrT TcM (LPat GhcTc)
zonkPat LPat GhcTc
pat            -- Env already extended
        ; new_grhss <- zonkGRHSs zonkLExpr grhss
        ; new_ty    <- zonkTcTypeToTypeX ty
        ; new_mult  <- zonkMultAnn mult_ann
        ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss
                       , pat_mult = new_mult
                       , pat_ext = (new_ty, ticks) }) }

zonk_bind (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 { new_var  <- Id -> ZonkT TcM Id
zonkIdBndr IdP GhcTc
Id
var
       ; new_expr <- zonkLExpr expr
       ; return (VarBind { var_ext = x
                         , var_id = new_var
                         , var_rhs = new_expr }) }

zonk_bind bind :: HsBindLR GhcTc GhcTc
bind@(FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
loc Id
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 = (HsWrapper
co_fn, [CoreTickish]
ticks) })
  = do { new_var <- Id -> ZonkT TcM Id
zonkIdBndr Id
var
       ; runZonkBndrT (zonkCoFn co_fn) $ \ HsWrapper
new_co_fn ->
    do { new_ms <- (LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc)))
-> MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
-> ZonkTcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
-> ZonkTcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
zonkMatchGroup LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc))
zonkLExpr MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
ms
       ; return (bind { fun_id = L loc new_var
                      , fun_matches = new_ms
                      , fun_ext = (new_co_fn, ticks) }) } }

zonk_bind (XHsBindsLR (AbsBinds { abs_tvs :: AbsBinds -> [Id]
abs_tvs = [Id]
tyvars, abs_ev_vars :: AbsBinds -> [Id]
abs_ev_vars = [Id]
evs
                                , abs_ev_binds :: AbsBinds -> [TcEvBinds]
abs_ev_binds = [TcEvBinds]
ev_binds
                                , abs_exports :: AbsBinds -> [ABExport]
abs_exports = [ABExport]
exports
                                , abs_binds :: AbsBinds -> LHsBinds GhcTc
abs_binds = LHsBinds GhcTc
val_binds
                                , abs_sig :: AbsBinds -> Bool
abs_sig = Bool
has_sig }))
  = Bool
-> ZonkTcM (HsBindLR GhcTc GhcTc) -> ZonkTcM (HsBindLR GhcTc GhcTc)
forall a. HasCallStack => Bool -> a -> a
assert ( (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isImmutableTyVar [Id]
tyvars ) (ZonkTcM (HsBindLR GhcTc GhcTc) -> ZonkTcM (HsBindLR GhcTc GhcTc))
-> ZonkTcM (HsBindLR GhcTc GhcTc) -> ZonkTcM (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$
    ZonkBndrTcM [Id] -> forall r. ([Id] -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ([Id] -> ZonkBndrTcM [Id]
zonkTyBndrsX    [Id]
tyvars  ) (([Id] -> ZonkTcM (HsBindLR GhcTc GhcTc))
 -> ZonkTcM (HsBindLR GhcTc GhcTc))
-> ([Id] -> ZonkTcM (HsBindLR GhcTc GhcTc))
-> ZonkTcM (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$ \ [Id]
new_tyvars   ->
    ZonkBndrTcM [Id] -> forall r. ([Id] -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ([Id] -> ZonkBndrTcM [Id]
zonkEvBndrsX    [Id]
evs     ) (([Id] -> ZonkTcM (HsBindLR GhcTc GhcTc))
 -> ZonkTcM (HsBindLR GhcTc GhcTc))
-> ([Id] -> ZonkTcM (HsBindLR GhcTc GhcTc))
-> ZonkTcM (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$ \ [Id]
new_evs      ->
    ZonkBndrT TcM [TcEvBinds]
-> forall r. ([TcEvBinds] -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ([TcEvBinds] -> ZonkBndrT TcM [TcEvBinds]
zonkTcEvBinds_s [TcEvBinds]
ev_binds) (([TcEvBinds] -> ZonkTcM (HsBindLR GhcTc GhcTc))
 -> ZonkTcM (HsBindLR GhcTc GhcTc))
-> ([TcEvBinds] -> ZonkTcM (HsBindLR GhcTc GhcTc))
-> ZonkTcM (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$ \ [TcEvBinds]
new_ev_binds ->
  do { (new_val_bind, new_exports) <- (([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)], [ABExport])
 -> ZonkT
      TcM ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)], [ABExport]))
-> ZonkT
     TcM ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)], [ABExport])
forall a. (a -> ZonkT TcM a) -> ZonkT TcM a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)], [ABExport])
  -> ZonkT
       TcM ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)], [ABExport]))
 -> ZonkT
      TcM ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)], [ABExport]))
-> (([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)], [ABExport])
    -> ZonkT
         TcM ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)], [ABExport]))
-> ZonkT
     TcM ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)], [ABExport])
forall a b. (a -> b) -> a -> b
$ \ ~([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
new_val_binds, [ABExport]
_) ->
       ZonkBndrT TcM () -> forall r. (() -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ([Id] -> ZonkBndrT TcM ()
forall (m :: * -> *). [Id] -> ZonkBndrT m ()
extendIdZonkEnvRec ([Id] -> ZonkBndrT TcM ()) -> [Id] -> ZonkBndrT TcM ()
forall a b. (a -> b) -> a -> b
$ CollectFlag GhcTc -> LHsBinds GhcTc -> [IdP GhcTc]
forall p idR.
CollectPass p =>
CollectFlag p -> LHsBindsLR p idR -> [IdP p]
collectHsBindsBinders CollectFlag GhcTc
forall p. CollectFlag p
CollNoDictBinders LHsBinds GhcTc
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
new_val_binds) ((()
  -> ZonkT
       TcM ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)], [ABExport]))
 -> ZonkT
      TcM ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)], [ABExport]))
-> (()
    -> ZonkT
         TcM ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)], [ABExport]))
-> ZonkT
     TcM ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)], [ABExport])
forall a b. (a -> b) -> a -> b
$ \ ()
_ ->
       do { new_val_binds <- (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
 -> ZonkT TcM (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> ZonkT TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> ZonkT TcM (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
zonk_val_bind LHsBinds GhcTc
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
val_binds
          ; new_exports   <- mapM zonk_export exports
          ; return (new_val_binds, new_exports)
          }
     ; return $ XHsBindsLR $
                AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
                         , abs_ev_binds = new_ev_binds
                         , abs_exports = new_exports, abs_binds = new_val_bind
                         , abs_sig = has_sig } }
  where
    zonk_val_bind :: GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> ZonkT TcM (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
zonk_val_bind 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 Id
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     = (HsWrapper
co_fn, [CoreTickish]
ticks) })) <- GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
lbind
      = do { new_mono_id <- (Kind -> ZonkT TcM Kind) -> Id -> ZonkT TcM Id
forall (m :: * -> *). Monad m => (Kind -> m Kind) -> Id -> m Id
updateIdTypeAndMultM Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Id
mono_id
                            -- Specifically /not/ zonkIdBndr; we do not want to
                            -- complain about a representation-polymorphic binder
           ; runZonkBndrT (zonkCoFn co_fn) $ \ HsWrapper
new_co_fn ->
        do { new_ms            <- (LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc)))
-> MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
-> ZonkTcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
-> ZonkTcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
zonkMatchGroup LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc))
zonkLExpr MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
ms
           ; return $ L loc $
             bind { fun_id      = L mloc new_mono_id
                  , fun_matches = new_ms
                  , fun_ext     = (new_co_fn, ticks) } } }
      | Bool
otherwise
      = LHsBind GhcTc -> ZonkTcM (LHsBind GhcTc)
zonk_lbind LHsBind GhcTc
GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
lbind   -- The normal case

    zonk_export :: ABExport -> ZonkTcM ABExport
    zonk_export :: ABExport -> ZonkT TcM ABExport
zonk_export (ABE{ abe_wrap :: ABExport -> HsWrapper
abe_wrap  = HsWrapper
wrap
                    , abe_poly :: ABExport -> Id
abe_poly  = Id
poly_id
                    , abe_mono :: ABExport -> Id
abe_mono  = Id
mono_id
                    , abe_prags :: ABExport -> TcSpecPrags
abe_prags = TcSpecPrags
prags })
        = do new_poly_id <- Id -> ZonkT TcM Id
zonkIdBndr Id
poly_id
             new_wrap    <- don'tBind $ zonkCoFn wrap
             new_prags   <- zonkSpecPrags prags
             new_mono_id <- zonkIdOcc mono_id
             return (ABE{ abe_wrap  = new_wrap
                        , abe_poly  = new_poly_id
                        , abe_mono  = new_mono_id
                        , abe_prags = new_prags })

zonk_bind (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 Id
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 { id' <- Id -> ZonkT TcM Id
zonkIdBndr Id
id
       ; runZonkBndrT (zonkPat lpat) $ \ GenLocated SrcSpanAnnA (Pat GhcTc)
lpat' ->
    do { details' <- HsPatSynDetails GhcTc -> ZonkTcM (HsPatSynDetails GhcTc)
zonkPatSynDetails HsPatSynDetails GhcTc
details
       ; dir'     <- zonkPatSynDir dir
       ; return $ PatSynBind x $
                  bind { psb_id   = L loc id'
                       , psb_args = details'
                       , psb_def  = lpat'
                       , psb_dir  = dir' } } }

zonkMultAnn :: HsMultAnn GhcTc -> ZonkTcM (HsMultAnn GhcTc)
zonkMultAnn :: HsMultAnn GhcTc -> ZonkTcM (HsMultAnn GhcTc)
zonkMultAnn (HsUnannotated XUnannotated (LHsType (NoGhcTc GhcTc)) GhcTc
mult)
  = do { mult' <- Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Kind
XUnannotated (LHsType (NoGhcTc GhcTc)) GhcTc
mult
       ; return (HsUnannotated mult') }
zonkMultAnn (HsLinearAnn XLinearAnn (LHsType (NoGhcTc GhcTc)) GhcTc
mult)
  = do { mult' <- Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Kind
XLinearAnn (LHsType (NoGhcTc GhcTc)) GhcTc
mult
       ; return (HsLinearAnn mult') }
zonkMultAnn (HsExplicitMult XExplicitMult (LHsType (NoGhcTc GhcTc)) GhcTc
mult LHsType (NoGhcTc GhcTc)
hs_ty)
  = do { mult' <- Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Kind
XExplicitMult (LHsType (NoGhcTc GhcTc)) GhcTc
mult
       ; return (HsExplicitMult mult' hs_ty) }

zonkPatSynDetails :: HsPatSynDetails GhcTc
                  -> ZonkTcM (HsPatSynDetails GhcTc)
zonkPatSynDetails :: HsPatSynDetails GhcTc -> ZonkTcM (HsPatSynDetails GhcTc)
zonkPatSynDetails (PrefixCon [LIdP GhcTc]
as)
  = [GenLocated SrcSpanAnnN Id]
-> HsConDetails
     (GenLocated SrcSpanAnnN Id) [RecordPatSynField GhcTc]
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon ([GenLocated SrcSpanAnnN Id]
 -> HsConDetails
      (GenLocated SrcSpanAnnN Id) [RecordPatSynField GhcTc])
-> ZonkT TcM [GenLocated SrcSpanAnnN Id]
-> ZonkT
     TcM
     (HsConDetails
        (GenLocated SrcSpanAnnN Id) [RecordPatSynField GhcTc])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenLocated SrcSpanAnnN Id -> ZonkTcM (GenLocated SrcSpanAnnN Id))
-> [GenLocated SrcSpanAnnN Id]
-> ZonkT TcM [GenLocated SrcSpanAnnN Id]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse GenLocated SrcSpanAnnN Id -> ZonkTcM (GenLocated SrcSpanAnnN Id)
zonkLIdOcc [LIdP GhcTc]
[GenLocated SrcSpanAnnN Id]
as
zonkPatSynDetails (InfixCon LIdP GhcTc
a1 LIdP GhcTc
a2)
  = GenLocated SrcSpanAnnN Id
-> GenLocated SrcSpanAnnN Id
-> HsConDetails
     (GenLocated SrcSpanAnnN Id) [RecordPatSynField GhcTc]
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon (GenLocated SrcSpanAnnN Id
 -> GenLocated SrcSpanAnnN Id
 -> HsConDetails
      (GenLocated SrcSpanAnnN Id) [RecordPatSynField GhcTc])
-> ZonkTcM (GenLocated SrcSpanAnnN Id)
-> ZonkT
     TcM
     (GenLocated SrcSpanAnnN Id
      -> HsConDetails
           (GenLocated SrcSpanAnnN Id) [RecordPatSynField GhcTc])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnN Id -> ZonkTcM (GenLocated SrcSpanAnnN Id)
zonkLIdOcc LIdP GhcTc
GenLocated SrcSpanAnnN Id
a1 ZonkT
  TcM
  (GenLocated SrcSpanAnnN Id
   -> HsConDetails
        (GenLocated SrcSpanAnnN Id) [RecordPatSynField GhcTc])
-> ZonkTcM (GenLocated SrcSpanAnnN Id)
-> ZonkT
     TcM
     (HsConDetails
        (GenLocated SrcSpanAnnN Id) [RecordPatSynField GhcTc])
forall a b. ZonkT TcM (a -> b) -> ZonkT TcM a -> ZonkT TcM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenLocated SrcSpanAnnN Id -> ZonkTcM (GenLocated SrcSpanAnnN Id)
zonkLIdOcc LIdP GhcTc
GenLocated SrcSpanAnnN Id
a2
zonkPatSynDetails (RecCon [RecordPatSynField GhcTc]
flds)
  = [RecordPatSynField GhcTc]
-> HsConDetails
     (GenLocated SrcSpanAnnN Id) [RecordPatSynField GhcTc]
forall arg rec. rec -> HsConDetails arg rec
RecCon ([RecordPatSynField GhcTc]
 -> HsConDetails
      (GenLocated SrcSpanAnnN Id) [RecordPatSynField GhcTc])
-> ZonkT TcM [RecordPatSynField GhcTc]
-> ZonkT
     TcM
     (HsConDetails
        (GenLocated SrcSpanAnnN Id) [RecordPatSynField GhcTc])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RecordPatSynField GhcTc -> ZonkT TcM (RecordPatSynField GhcTc))
-> [RecordPatSynField GhcTc] -> ZonkT TcM [RecordPatSynField GhcTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM RecordPatSynField GhcTc -> ZonkT TcM (RecordPatSynField GhcTc)
zonkPatSynField [RecordPatSynField GhcTc]
flds

zonkPatSynField :: RecordPatSynField GhcTc -> ZonkTcM (RecordPatSynField GhcTc)
zonkPatSynField :: RecordPatSynField GhcTc -> ZonkT TcM (RecordPatSynField GhcTc)
zonkPatSynField (RecordPatSynField FieldOcc GhcTc
x LIdP GhcTc
y) =
  FieldOcc GhcTc -> LIdP GhcTc -> RecordPatSynField GhcTc
FieldOcc GhcTc
-> GenLocated SrcSpanAnnN Id -> RecordPatSynField GhcTc
forall pass. FieldOcc pass -> LIdP pass -> RecordPatSynField pass
RecordPatSynField (FieldOcc GhcTc
 -> GenLocated SrcSpanAnnN Id -> RecordPatSynField GhcTc)
-> ZonkTcM (FieldOcc GhcTc)
-> ZonkT TcM (GenLocated SrcSpanAnnN Id -> RecordPatSynField GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldOcc GhcTc -> ZonkTcM (FieldOcc GhcTc)
zonkFieldOcc FieldOcc GhcTc
x ZonkT TcM (GenLocated SrcSpanAnnN Id -> RecordPatSynField GhcTc)
-> ZonkTcM (GenLocated SrcSpanAnnN Id)
-> ZonkT TcM (RecordPatSynField GhcTc)
forall a b. ZonkT TcM (a -> b) -> ZonkT TcM a -> ZonkT TcM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenLocated SrcSpanAnnN Id -> ZonkTcM (GenLocated SrcSpanAnnN Id)
zonkLIdOcc LIdP GhcTc
GenLocated SrcSpanAnnN Id
y

zonkPatSynDir :: HsPatSynDir GhcTc
              -> ZonkTcM (HsPatSynDir GhcTc)
zonkPatSynDir :: HsPatSynDir GhcTc -> ZonkTcM (HsPatSynDir GhcTc)
zonkPatSynDir HsPatSynDir GhcTc
Unidirectional             = HsPatSynDir GhcTc -> ZonkTcM (HsPatSynDir GhcTc)
forall a. a -> ZonkT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return HsPatSynDir GhcTc
forall id. HsPatSynDir id
Unidirectional
zonkPatSynDir HsPatSynDir GhcTc
ImplicitBidirectional      = HsPatSynDir GhcTc -> ZonkTcM (HsPatSynDir GhcTc)
forall a. a -> ZonkT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return HsPatSynDir GhcTc
forall id. HsPatSynDir id
ImplicitBidirectional
zonkPatSynDir (ExplicitBidirectional MatchGroup GhcTc (LHsExpr GhcTc)
mg) = MatchGroup GhcTc (LHsExpr GhcTc) -> HsPatSynDir GhcTc
MatchGroup GhcTc (LocatedA (HsExpr GhcTc)) -> HsPatSynDir GhcTc
forall id. MatchGroup id (LHsExpr id) -> HsPatSynDir id
ExplicitBidirectional (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)) -> HsPatSynDir GhcTc)
-> ZonkTcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
-> ZonkTcM (HsPatSynDir GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc)))
-> MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
-> ZonkTcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
-> ZonkTcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
zonkMatchGroup LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc))
zonkLExpr MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
mg

zonkSpecPrags :: TcSpecPrags -> ZonkTcM TcSpecPrags
zonkSpecPrags :: TcSpecPrags -> ZonkTcM TcSpecPrags
zonkSpecPrags TcSpecPrags
IsDefaultMethod = TcSpecPrags -> ZonkTcM TcSpecPrags
forall a. a -> ZonkT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return TcSpecPrags
IsDefaultMethod
zonkSpecPrags (SpecPrags [LTcSpecPrag]
ps)  = do { ps' <- [LTcSpecPrag] -> ZonkTcM [LTcSpecPrag]
zonkLTcSpecPrags [LTcSpecPrag]
ps
                                   ; return (SpecPrags ps') }

zonkLTcSpecPrags :: [LTcSpecPrag] -> ZonkTcM [LTcSpecPrag]
zonkLTcSpecPrags :: [LTcSpecPrag] -> ZonkTcM [LTcSpecPrag]
zonkLTcSpecPrags [LTcSpecPrag]
ps
  = (LTcSpecPrag -> ZonkT TcM LTcSpecPrag)
-> [LTcSpecPrag] -> ZonkTcM [LTcSpecPrag]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LTcSpecPrag -> ZonkT TcM LTcSpecPrag
forall {l}.
GenLocated l TcSpecPrag -> ZonkT TcM (GenLocated l TcSpecPrag)
zonk_prag [LTcSpecPrag]
ps
  where
    zonk_prag :: GenLocated l TcSpecPrag -> ZonkT TcM (GenLocated l TcSpecPrag)
zonk_prag (L l
loc (SpecPrag Id
id HsWrapper
co_fn InlinePragma
inl))
      = do { co_fn' <- ZonkBndrT TcM HsWrapper -> ZonkT TcM HsWrapper
forall (m :: * -> *) a. Monad m => ZonkBndrT m a -> ZonkT m a
don'tBind (ZonkBndrT TcM HsWrapper -> ZonkT TcM HsWrapper)
-> ZonkBndrT TcM HsWrapper -> ZonkT TcM HsWrapper
forall a b. (a -> b) -> a -> b
$ HsWrapper -> ZonkBndrT TcM HsWrapper
zonkCoFn HsWrapper
co_fn
           ; id' <- zonkIdOcc id
           ; return (L loc (SpecPrag id' co_fn' inl)) }
    zonk_prag (L l
loc prag :: TcSpecPrag
prag@(SpecPragE { spe_fn_id :: TcSpecPrag -> Id
spe_fn_id = Id
poly_id
                                     , spe_bndrs :: TcSpecPrag -> [Id]
spe_bndrs = [Id]
bndrs
                                     , spe_call :: TcSpecPrag -> LHsExpr GhcTc
spe_call  = LHsExpr GhcTc
spec_e }))
      = do { poly_id' <- Id -> ZonkT TcM Id
zonkIdOcc Id
poly_id

           ; skol_tvs_ref <- lift $ newTcRef []
           ; setZonkType (SkolemiseFlexi skol_tvs_ref) $
               -- SkolemiseFlexi: see Note [Free tyvars on rule LHS]
             runZonkBndrT (zonkCoreBndrsX bndrs)       $ \ [Id]
bndrs' ->
             do { spec_e' <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
spec_e
                ; skol_tvs <- lift $ readTcRef skol_tvs_ref
                ; return (L loc (prag { spe_fn_id = poly_id'
                                      , spe_bndrs = skol_tvs ++ bndrs'
                                      , spe_call  = spec_e'
                                      }))
                }}

{-
************************************************************************
*                                                                      *
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
*                                                                      *
************************************************************************
-}

zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO
               => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
               -> MatchGroup GhcTc (LocatedA (body GhcTc))
               -> ZonkTcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
zonkMatchGroup :: forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
-> ZonkTcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
zonkMatchGroup LocatedA (body GhcTc) -> ZonkTcM (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 Origin
origin
                         })
  = do  { ms' <- (GenLocated
   (Anno (Match GhcTc (LocatedA (body GhcTc))))
   (Match GhcTc (LocatedA (body GhcTc)))
 -> ZonkT
      TcM
      (GenLocated
         (Anno (Match GhcTc (LocatedA (body GhcTc))))
         (Match GhcTc (LocatedA (body GhcTc)))))
-> [GenLocated
      (Anno (Match GhcTc (LocatedA (body GhcTc))))
      (Match GhcTc (LocatedA (body GhcTc)))]
-> ZonkT
     TcM
     [GenLocated
        (Anno (Match GhcTc (LocatedA (body GhcTc))))
        (Match GhcTc (LocatedA (body GhcTc)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> LMatch GhcTc (LocatedA (body GhcTc))
-> ZonkTcM (LMatch GhcTc (LocatedA (body GhcTc)))
forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> LMatch GhcTc (LocatedA (body GhcTc))
-> ZonkTcM (LMatch GhcTc (LocatedA (body GhcTc)))
zonkMatch LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))
zBody) [GenLocated
   (Anno (Match GhcTc (LocatedA (body GhcTc))))
   (Match GhcTc (LocatedA (body GhcTc)))]
ms
        ; arg_tys' <- zonkScaledTcTypesToTypesX arg_tys
        ; res_ty'  <- zonkTcTypeToTypeX res_ty
        ; return (MG { mg_alts = L l ms'
                     , mg_ext = MatchGroupTc arg_tys' res_ty' origin
                     }) }

zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO
          => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
          -> LMatch GhcTc (LocatedA (body GhcTc))
          -> ZonkTcM (LMatch GhcTc (LocatedA (body GhcTc)))
zonkMatch :: forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> LMatch GhcTc (LocatedA (body GhcTc))
-> ZonkTcM (LMatch GhcTc (LocatedA (body GhcTc)))
zonkMatch LocatedA (body GhcTc) -> ZonkTcM (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 -> XRec p [LPat p]
m_pats = L EpaLocation
l [GenLocated SrcSpanAnnA (Pat GhcTc)]
pats
                                    , m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcTc (LocatedA (body GhcTc))
grhss }))
  = ZonkBndrT TcM [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> forall r.
   ([GenLocated SrcSpanAnnA (Pat GhcTc)] -> ZonkT TcM r)
   -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ([LPat GhcTc] -> ZonkBndrTcM [LPat GhcTc]
forall (f :: * -> *).
Traversable f =>
f (LPat GhcTc) -> ZonkBndrTcM (f (LPat GhcTc))
zonkPats [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
pats) (([GenLocated SrcSpanAnnA (Pat GhcTc)]
  -> ZonkT TcM (LMatch GhcTc (LocatedA (body GhcTc))))
 -> ZonkT TcM (LMatch GhcTc (LocatedA (body GhcTc))))
-> ([GenLocated SrcSpanAnnA (Pat GhcTc)]
    -> ZonkT TcM (LMatch GhcTc (LocatedA (body GhcTc))))
-> ZonkT TcM (LMatch GhcTc (LocatedA (body GhcTc)))
forall a b. (a -> b) -> a -> b
$ \ [GenLocated SrcSpanAnnA (Pat GhcTc)]
new_pats ->
  do  { new_grhss <- (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> GRHSs GhcTc (LocatedA (body GhcTc))
-> ZonkTcM (GRHSs GhcTc (LocatedA (body GhcTc)))
forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> GRHSs GhcTc (LocatedA (body GhcTc))
-> ZonkTcM (GRHSs GhcTc (LocatedA (body GhcTc)))
zonkGRHSs LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))
zBody GRHSs GhcTc (LocatedA (body GhcTc))
grhss
      ; return (L loc (match { m_pats = L l new_pats, m_grhss = new_grhss })) }

-------------------------------------------------------------------------
zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO
          => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
          -> GRHSs GhcTc (LocatedA (body GhcTc))
          -> ZonkTcM (GRHSs GhcTc (LocatedA (body GhcTc)))

zonkGRHSs :: forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> GRHSs GhcTc (LocatedA (body GhcTc))
-> ZonkTcM (GRHSs GhcTc (LocatedA (body GhcTc)))
zonkGRHSs LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))
zBody (GRHSs XCGRHSs GhcTc (LocatedA (body GhcTc))
x NonEmpty (LGRHS GhcTc (LocatedA (body GhcTc)))
grhss HsLocalBinds GhcTc
binds) =
  ZonkBndrTcM (HsLocalBinds GhcTc)
-> forall r. (HsLocalBinds GhcTc -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT (HsLocalBinds GhcTc -> ZonkBndrTcM (HsLocalBinds GhcTc)
zonkLocalBinds HsLocalBinds GhcTc
binds) ((HsLocalBinds GhcTc
  -> ZonkT TcM (GRHSs GhcTc (LocatedA (body GhcTc))))
 -> ZonkT TcM (GRHSs GhcTc (LocatedA (body GhcTc))))
-> (HsLocalBinds GhcTc
    -> ZonkT TcM (GRHSs GhcTc (LocatedA (body GhcTc))))
-> ZonkT TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
forall a b. (a -> b) -> a -> b
$ \ HsLocalBinds GhcTc
new_binds ->
    do { new_grhss <- (GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))
 -> ZonkT
      TcM (GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))))
-> NonEmpty
     (GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc))))
-> ZonkT
     TcM
     (NonEmpty
        (GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM ((GRHS GhcTc (LocatedA (body GhcTc))
 -> ZonkTcM (GRHS GhcTc (LocatedA (body GhcTc))))
-> GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc)))
-> ZonkT
     TcM (GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc))))
forall a b ann.
(a -> ZonkTcM b)
-> GenLocated (EpAnn ann) a -> ZonkTcM (GenLocated (EpAnn ann) b)
wrapLocZonkMA GRHS GhcTc (LocatedA (body GhcTc))
-> ZonkTcM (GRHS GhcTc (LocatedA (body GhcTc)))
zonk_grhs) NonEmpty (LGRHS GhcTc (LocatedA (body GhcTc)))
NonEmpty (GenLocated EpAnnCO (GRHS GhcTc (LocatedA (body GhcTc))))
grhss
       ; return (GRHSs x new_grhss new_binds) }
  where
     zonk_grhs :: GRHS GhcTc (LocatedA (body GhcTc))
-> ZonkTcM (GRHS GhcTc (LocatedA (body GhcTc)))
zonk_grhs (GRHS XCGRHS GhcTc (LocatedA (body GhcTc))
xx [GuardLStmt GhcTc]
guarded LocatedA (body GhcTc)
rhs) =
       ZonkBndrT
  TcM
  [GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> forall r.
   ([GenLocated
       SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
    -> ZonkT TcM r)
   -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ((LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc)))
-> [LStmt GhcTc (LocatedA (HsExpr GhcTc))]
-> ZonkBndrTcM [LStmt GhcTc (LocatedA (HsExpr GhcTc))]
forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
 ~ SrcSpanAnnA) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> ZonkBndrTcM [LStmt GhcTc (LocatedA (body GhcTc))]
zonkStmts LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc))
zonkLExpr [GuardLStmt GhcTc]
[LStmt GhcTc (LocatedA (HsExpr GhcTc))]
guarded) (([GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
  -> ZonkTcM (GRHS GhcTc (LocatedA (body GhcTc))))
 -> ZonkTcM (GRHS GhcTc (LocatedA (body GhcTc))))
-> ([GenLocated
       SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
    -> ZonkTcM (GRHS GhcTc (LocatedA (body GhcTc))))
-> ZonkTcM (GRHS GhcTc (LocatedA (body GhcTc)))
forall a b. (a -> b) -> a -> b
$ \ [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
new_guarded ->
         XCGRHS GhcTc (LocatedA (body GhcTc))
-> [GuardLStmt GhcTc]
-> LocatedA (body GhcTc)
-> GRHS GhcTc (LocatedA (body GhcTc))
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcTc (LocatedA (body GhcTc))
xx [GuardLStmt GhcTc]
[GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
new_guarded (LocatedA (body GhcTc) -> GRHS GhcTc (LocatedA (body GhcTc)))
-> ZonkTcM (LocatedA (body GhcTc))
-> ZonkTcM (GRHS GhcTc (LocatedA (body GhcTc)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))
zBody LocatedA (body GhcTc)
rhs

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

zonkLExprs :: [LHsExpr GhcTc] -> ZonkTcM [LHsExpr GhcTc]
zonkLExpr  :: LHsExpr GhcTc   -> ZonkTcM (LHsExpr GhcTc)
zonkExpr   :: HsExpr GhcTc    -> ZonkTcM (HsExpr GhcTc)

zonkLExprs :: [LHsExpr GhcTc] -> ZonkTcM [LHsExpr GhcTc]
zonkLExprs [LHsExpr GhcTc]
exprs = (LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc)))
-> [LocatedA (HsExpr GhcTc)] -> ZonkT TcM [LocatedA (HsExpr GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc))
zonkLExpr [LHsExpr GhcTc]
[LocatedA (HsExpr GhcTc)]
exprs
zonkLExpr :: LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr  LHsExpr GhcTc
expr  = (HsExpr GhcTc -> ZonkT TcM (HsExpr GhcTc))
-> LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc))
forall a b ann.
(a -> ZonkTcM b)
-> GenLocated (EpAnn ann) a -> ZonkTcM (GenLocated (EpAnn ann) b)
wrapLocZonkMA HsExpr GhcTc -> ZonkT TcM (HsExpr GhcTc)
zonkExpr LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
expr

zonkExpr :: HsExpr GhcTc -> ZonkT TcM (HsExpr GhcTc)
zonkExpr (HsVar XVar GhcTc
x (L SrcSpanAnnN
l Id
id))
  = Bool
-> SDoc -> ZonkT TcM (HsExpr GhcTc) -> ZonkT TcM (HsExpr GhcTc)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Maybe DataCon -> Bool
forall a. Maybe a -> Bool
isNothing (Id -> Maybe DataCon
isDataConId_maybe Id
id)) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id) (ZonkT TcM (HsExpr GhcTc) -> ZonkT TcM (HsExpr GhcTc))
-> ZonkT TcM (HsExpr GhcTc) -> ZonkT TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
  do { id' <- Id -> ZonkT TcM Id
zonkIdOcc Id
id
     ; return (HsVar x (L l id')) }

zonkExpr (HsHole (HoleKind
h, HoleExprRef
her))
  = do her' <- HoleExprRef -> ZonkTcM HoleExprRef
zonk_her HoleExprRef
her
       return (HsHole (h, her'))
  where
    zonk_her :: HoleExprRef -> ZonkTcM HoleExprRef
    zonk_her :: HoleExprRef -> ZonkTcM HoleExprRef
zonk_her (HER IORef EvTerm
ref Kind
ty Unique
u)
      = do IORef EvTerm -> (EvTerm -> ZonkT TcM EvTerm) -> ZonkT TcM ()
forall (m :: * -> *) a. MonadIO m => TcRef a -> (a -> m a) -> m ()
updTcRefM IORef EvTerm
ref EvTerm -> ZonkT TcM EvTerm
zonkEvTerm
           ty'  <- Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Kind
ty
           return (HER ref ty' u)

zonkExpr (HsIPVar XIPVar GhcTc
x HsIPName
_) = DataConCantHappen -> ZonkT TcM (HsExpr GhcTc)
forall a. DataConCantHappen -> a
dataConCantHappen XIPVar GhcTc
DataConCantHappen
x

zonkExpr (HsOverLabel XOverLabel GhcTc
x FastString
_) = DataConCantHappen -> ZonkT TcM (HsExpr GhcTc)
forall a. DataConCantHappen -> a
dataConCantHappen XOverLabel GhcTc
DataConCantHappen
x

zonkExpr (HsLit XLitE GhcTc
x (XLit (HsRat FractionalLit
f Kind
ty)))
  = do new_ty <- Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Kind
ty
       return (HsLit x (XLit $ HsRat f new_ty))

zonkExpr (HsLit XLitE GhcTc
x HsLit GhcTc
lit)
  = HsExpr GhcTc -> ZonkT TcM (HsExpr GhcTc)
forall a. a -> ZonkT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (XLitE GhcTc -> HsLit GhcTc -> HsExpr GhcTc
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcTc
x HsLit GhcTc
lit)

zonkExpr (HsOverLit XOverLitE GhcTc
x HsOverLit GhcTc
lit)
  = do  { lit' <- HsOverLit GhcTc -> ZonkTcM (HsOverLit GhcTc)
zonkOverLit HsOverLit GhcTc
lit
        ; return (HsOverLit x lit') }

zonkExpr (HsLam XLam GhcTc
x HsLamVariant
lam_variant MatchGroup GhcTc (LHsExpr GhcTc)
matches)
  = do new_matches <- (LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc)))
-> MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
-> ZonkTcM (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))
forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
-> ZonkTcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
zonkMatchGroup LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc))
zonkLExpr MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (LocatedA (HsExpr GhcTc))
matches
       return (HsLam x lam_variant new_matches)

zonkExpr (HsApp XApp GhcTc
x LHsExpr GhcTc
e1 LHsExpr GhcTc
e2)
  = do new_e1 <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
e1
       new_e2 <- zonkLExpr e2
       return (HsApp x new_e1 new_e2)

zonkExpr (HsAppType XAppTypeE GhcTc
ty LHsExpr GhcTc
e LHsWcType (NoGhcTc GhcTc)
t)
  = do new_e <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
e
       new_ty <- zonkTcTypeToTypeX ty
       return (HsAppType new_ty new_e t)
       -- NB: the type is an HsType; can't zonk that!

zonkExpr (HsTypedBracket XTypedBracket GhcTc
hsb_tc LHsExpr GhcTc
body)
  = (\HsBracketTc
x -> XTypedBracket GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XTypedBracket p -> LHsExpr p -> HsExpr p
HsTypedBracket XTypedBracket GhcTc
HsBracketTc
x LHsExpr GhcTc
body) (HsBracketTc -> HsExpr GhcTc)
-> ZonkT TcM HsBracketTc -> ZonkT TcM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsBracketTc -> ZonkT TcM HsBracketTc
zonkBracket XTypedBracket GhcTc
HsBracketTc
hsb_tc

zonkExpr (HsUntypedBracket XUntypedBracket GhcTc
hsb_tc HsQuote GhcTc
body)
  = (\HsBracketTc
x -> XUntypedBracket GhcTc -> HsQuote GhcTc -> HsExpr GhcTc
forall p. XUntypedBracket p -> HsQuote p -> HsExpr p
HsUntypedBracket XUntypedBracket GhcTc
HsBracketTc
x HsQuote GhcTc
body) (HsBracketTc -> HsExpr GhcTc)
-> ZonkT TcM HsBracketTc -> ZonkT TcM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsBracketTc -> ZonkT TcM HsBracketTc
zonkBracket XUntypedBracket GhcTc
HsBracketTc
hsb_tc

zonkExpr (HsTypedSplice XTypedSplice GhcTc
s LHsExpr GhcTc
_) = (ZonkEnv -> TcM (HsExpr GhcTc)) -> ZonkT TcM (HsExpr GhcTc)
forall (m :: * -> *) a. (ZonkEnv -> m a) -> ZonkT m a
ZonkT (\ ZonkEnv
_ -> DelayedSplice -> TcM (HsExpr GhcTc)
runTopSplice XTypedSplice GhcTc
DelayedSplice
s) ZonkT TcM (HsExpr GhcTc)
-> (HsExpr GhcTc -> ZonkT TcM (HsExpr GhcTc))
-> ZonkT TcM (HsExpr GhcTc)
forall a b. ZonkT TcM a -> (a -> ZonkT TcM b) -> ZonkT TcM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HsExpr GhcTc -> ZonkT TcM (HsExpr GhcTc)
zonkExpr

zonkExpr (HsUntypedSplice XUntypedSplice GhcTc
x HsUntypedSplice GhcTc
_) = DataConCantHappen -> ZonkT TcM (HsExpr GhcTc)
forall a. DataConCantHappen -> a
dataConCantHappen XUntypedSplice GhcTc
DataConCantHappen
x

zonkExpr (OpApp XOpApp GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_ LHsExpr GhcTc
_) = DataConCantHappen -> ZonkT TcM (HsExpr GhcTc)
forall a. DataConCantHappen -> a
dataConCantHappen XOpApp GhcTc
DataConCantHappen
x

zonkExpr (NegApp XNegApp GhcTc
x LHsExpr GhcTc
expr SyntaxExpr GhcTc
op)
  = ZonkBndrT TcM SyntaxExprTc
-> forall r. (SyntaxExprTc -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT (SyntaxExpr GhcTc -> ZonkBndrTcM (SyntaxExpr GhcTc)
zonkSyntaxExpr SyntaxExpr GhcTc
op) ((SyntaxExprTc -> ZonkT TcM (HsExpr GhcTc))
 -> ZonkT TcM (HsExpr GhcTc))
-> (SyntaxExprTc -> ZonkT TcM (HsExpr GhcTc))
-> ZonkT TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ \ SyntaxExprTc
new_op ->
    do { new_expr <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
expr
       ; return (NegApp x new_expr new_op) }

zonkExpr (HsPar XPar GhcTc
x LHsExpr GhcTc
e)
  = do { new_e <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
e
       ; return (HsPar x new_e) }

zonkExpr (SectionL XSectionL GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_) = DataConCantHappen -> ZonkT TcM (HsExpr GhcTc)
forall a. DataConCantHappen -> a
dataConCantHappen XSectionL GhcTc
DataConCantHappen
x
zonkExpr (SectionR XSectionR GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_) = DataConCantHappen -> ZonkT TcM (HsExpr GhcTc)
forall a. DataConCantHappen -> a
dataConCantHappen XSectionR GhcTc
DataConCantHappen
x
zonkExpr (ExplicitTuple XExplicitTuple GhcTc
x [HsTupArg GhcTc]
tup_args Boxity
boxed)
  = do { new_tup_args <- (HsTupArg GhcTc -> ZonkT TcM (HsTupArg GhcTc))
-> [HsTupArg GhcTc] -> ZonkT TcM [HsTupArg GhcTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HsTupArg GhcTc -> ZonkT TcM (HsTupArg GhcTc)
zonk_tup_arg [HsTupArg GhcTc]
tup_args
       ; return (ExplicitTuple x new_tup_args boxed) }
  where
    zonk_tup_arg :: HsTupArg GhcTc -> ZonkT TcM (HsTupArg GhcTc)
zonk_tup_arg (Present XPresent GhcTc
x LHsExpr GhcTc
e) = do { e' <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
e
                                    ; return (Present x e') }
    zonk_tup_arg (Missing XMissing GhcTc
t) = do { t' <- Scaled Kind -> ZonkTcM (Scaled Kind)
zonkScaledTcTypeToTypeX XMissing GhcTc
Scaled Kind
t
                                  ; return (Missing t') }


zonkExpr (ExplicitSum XExplicitSum GhcTc
args ConTag
alt ConTag
arity LHsExpr GhcTc
expr)
  = do new_args <- (Kind -> ZonkT TcM Kind) -> [Kind] -> ZonkTcM [Kind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX [Kind]
XExplicitSum GhcTc
args
       new_expr <- zonkLExpr expr
       return (ExplicitSum new_args alt arity new_expr)

zonkExpr (HsCase XCase GhcTc
x LHsExpr GhcTc
expr MatchGroup GhcTc (LHsExpr GhcTc)
ms)
  = do new_expr <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
expr
       new_ms <- zonkMatchGroup zonkLExpr ms
       return (HsCase x new_expr new_ms)

zonkExpr (HsIf XIf GhcTc
x LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3)
  = do new_e1 <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
e1
       new_e2 <- zonkLExpr e2
       new_e3 <- zonkLExpr e3
       return (HsIf x new_e1 new_e2 new_e3)

zonkExpr (HsMultiIf XMultiIf GhcTc
ty NonEmpty (LGRHS GhcTc (LHsExpr GhcTc))
alts)
  = do { alts' <- (GenLocated EpAnnCO (GRHS GhcTc (LocatedA (HsExpr GhcTc)))
 -> ZonkT
      TcM (GenLocated EpAnnCO (GRHS GhcTc (LocatedA (HsExpr GhcTc)))))
-> NonEmpty
     (GenLocated EpAnnCO (GRHS GhcTc (LocatedA (HsExpr GhcTc))))
-> ZonkT
     TcM
     (NonEmpty
        (GenLocated EpAnnCO (GRHS GhcTc (LocatedA (HsExpr GhcTc)))))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM ((GRHS GhcTc (LocatedA (HsExpr GhcTc))
 -> ZonkTcM (GRHS GhcTc (LocatedA (HsExpr GhcTc))))
-> GenLocated EpAnnCO (GRHS GhcTc (LocatedA (HsExpr GhcTc)))
-> ZonkT
     TcM (GenLocated EpAnnCO (GRHS GhcTc (LocatedA (HsExpr GhcTc))))
forall a b ann.
(a -> ZonkTcM b)
-> GenLocated (EpAnn ann) a -> ZonkTcM (GenLocated (EpAnn ann) b)
wrapLocZonkMA GRHS GhcTc (LocatedA (HsExpr GhcTc))
-> ZonkTcM (GRHS GhcTc (LocatedA (HsExpr GhcTc)))
zonk_alt) NonEmpty (LGRHS GhcTc (LHsExpr GhcTc))
NonEmpty
  (GenLocated EpAnnCO (GRHS GhcTc (LocatedA (HsExpr GhcTc))))
alts
       ; ty'   <- zonkTcTypeToTypeX ty
       ; return $ HsMultiIf ty' alts' }
  where zonk_alt :: GRHS GhcTc (LocatedA (HsExpr GhcTc))
-> ZonkTcM (GRHS GhcTc (LocatedA (HsExpr GhcTc)))
zonk_alt (GRHS XCGRHS GhcTc (LocatedA (HsExpr GhcTc))
x [GuardLStmt GhcTc]
guard LocatedA (HsExpr GhcTc)
expr)
          = ZonkBndrT
  TcM
  [GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> forall r.
   ([GenLocated
       SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
    -> ZonkT TcM r)
   -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ((LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc)))
-> [LStmt GhcTc (LocatedA (HsExpr GhcTc))]
-> ZonkBndrTcM [LStmt GhcTc (LocatedA (HsExpr GhcTc))]
forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
 ~ SrcSpanAnnA) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> ZonkBndrTcM [LStmt GhcTc (LocatedA (body GhcTc))]
zonkStmts LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc))
zonkLExpr [GuardLStmt GhcTc]
[LStmt GhcTc (LocatedA (HsExpr GhcTc))]
guard) (([GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
  -> ZonkTcM (GRHS GhcTc (LocatedA (HsExpr GhcTc))))
 -> ZonkTcM (GRHS GhcTc (LocatedA (HsExpr GhcTc))))
-> ([GenLocated
       SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
    -> ZonkTcM (GRHS GhcTc (LocatedA (HsExpr GhcTc))))
-> ZonkTcM (GRHS GhcTc (LocatedA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ \ [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
guard' ->
            do { expr' <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
expr
               ; return $ GRHS x guard' expr' }

zonkExpr (HsLet XLet GhcTc
x HsLocalBinds GhcTc
binds LHsExpr GhcTc
expr)
  = ZonkBndrTcM (HsLocalBinds GhcTc)
-> forall r. (HsLocalBinds GhcTc -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT (HsLocalBinds GhcTc -> ZonkBndrTcM (HsLocalBinds GhcTc)
zonkLocalBinds HsLocalBinds GhcTc
binds) ((HsLocalBinds GhcTc -> ZonkT TcM (HsExpr GhcTc))
 -> ZonkT TcM (HsExpr GhcTc))
-> (HsLocalBinds GhcTc -> ZonkT TcM (HsExpr GhcTc))
-> ZonkT TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ \ HsLocalBinds GhcTc
new_binds ->
    do { new_expr <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
expr
       ; return (HsLet x new_binds new_expr) }

zonkExpr (HsDo XDo GhcTc
ty HsDoFlavour
do_or_lc (L SrcSpanAnnLW
l [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts))
  = do new_stmts <- ZonkBndrT
  TcM
  [GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> ZonkT
     TcM
     [GenLocated
        SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
forall (m :: * -> *) a. Monad m => ZonkBndrT m a -> ZonkT m a
don'tBind (ZonkBndrT
   TcM
   [GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
 -> ZonkT
      TcM
      [GenLocated
         SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))])
-> ZonkBndrT
     TcM
     [GenLocated
        SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> ZonkT
     TcM
     [GenLocated
        SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
forall a b. (a -> b) -> a -> b
$ (LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc)))
-> [LStmt GhcTc (LocatedA (HsExpr GhcTc))]
-> ZonkBndrTcM [LStmt GhcTc (LocatedA (HsExpr GhcTc))]
forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
 ~ SrcSpanAnnA) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> ZonkBndrTcM [LStmt GhcTc (LocatedA (body GhcTc))]
zonkStmts LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc))
zonkLExpr [LStmt GhcTc (LocatedA (HsExpr GhcTc))]
[GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
       new_ty <- zonkTcTypeToTypeX ty
       return (HsDo new_ty do_or_lc (L l new_stmts))

zonkExpr (ExplicitList XExplicitList GhcTc
ty [LHsExpr GhcTc]
exprs)
  = do new_ty <- Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX XExplicitList GhcTc
Kind
ty
       new_exprs <- zonkLExprs exprs
       return (ExplicitList new_ty new_exprs)

zonkExpr 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  { new_con_expr <- HsExpr GhcTc -> ZonkT TcM (HsExpr GhcTc)
zonkExpr XRecordCon GhcTc
HsExpr GhcTc
con_expr
        ; new_rbinds   <- zonkRecFields rbinds
        ; return (expr { rcon_ext  = new_con_expr
                       , rcon_flds = new_rbinds }) }

zonkExpr (ExprWithTySig XExprWithTySig GhcTc
_ LHsExpr GhcTc
e LHsSigWcType (NoGhcTc GhcTc)
ty)
  = do { e' <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
e
       ; return (ExprWithTySig noExtField e' ty) }

zonkExpr (ArithSeq XArithSeq GhcTc
expr Maybe (SyntaxExpr GhcTc)
wit ArithSeqInfo GhcTc
info)
  = do { new_expr <- HsExpr GhcTc -> ZonkT TcM (HsExpr GhcTc)
zonkExpr XArithSeq GhcTc
HsExpr GhcTc
expr
       ; runZonkBndrT (zonkWit wit) $ \ Maybe SyntaxExprTc
new_wit ->
    do { new_info <- ArithSeqInfo GhcTc -> ZonkTcM (ArithSeqInfo GhcTc)
zonkArithSeq  ArithSeqInfo GhcTc
info
       ; return (ArithSeq new_expr new_wit new_info) } }
   where zonkWit :: Maybe SyntaxExprTc -> ZonkBndrT TcM (Maybe SyntaxExprTc)
zonkWit Maybe SyntaxExprTc
Nothing    = Maybe SyntaxExprTc -> ZonkBndrT TcM (Maybe SyntaxExprTc)
forall a. a -> ZonkBndrT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SyntaxExprTc
forall a. Maybe a
Nothing
         zonkWit (Just SyntaxExprTc
fln) = SyntaxExprTc -> Maybe SyntaxExprTc
forall a. a -> Maybe a
Just (SyntaxExprTc -> Maybe SyntaxExprTc)
-> ZonkBndrT TcM SyntaxExprTc -> ZonkBndrT TcM (Maybe SyntaxExprTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SyntaxExpr GhcTc -> ZonkBndrTcM (SyntaxExpr GhcTc)
zonkSyntaxExpr SyntaxExpr GhcTc
SyntaxExprTc
fln

zonkExpr (HsPragE XPragE GhcTc
x HsPragE GhcTc
prag LHsExpr GhcTc
expr)
  = do new_expr <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
expr
       return (HsPragE x prag new_expr)

-- arrow notation extensions
zonkExpr (HsProc XProc GhcTc
x LPat GhcTc
pat LHsCmdTop GhcTc
body)
  = ZonkBndrT TcM (GenLocated SrcSpanAnnA (Pat GhcTc))
-> forall r.
   (GenLocated SrcSpanAnnA (Pat GhcTc) -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT (LPat GhcTc -> ZonkBndrT TcM (LPat GhcTc)
zonkPat LPat GhcTc
pat) ((GenLocated SrcSpanAnnA (Pat GhcTc) -> ZonkT TcM (HsExpr GhcTc))
 -> ZonkT TcM (HsExpr GhcTc))
-> (GenLocated SrcSpanAnnA (Pat GhcTc) -> ZonkT TcM (HsExpr GhcTc))
-> ZonkT TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ \ GenLocated SrcSpanAnnA (Pat GhcTc)
new_pat ->
    do  { new_body <- LHsCmdTop GhcTc -> ZonkTcM (LHsCmdTop GhcTc)
zonkCmdTop LHsCmdTop GhcTc
body
        ; return (HsProc x new_pat new_body) }

-- StaticPointers extension
zonkExpr (HsStatic (NameSet
fvs, Kind
ty) LHsExpr GhcTc
expr)
  = do new_ty <- Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Kind
ty
       HsStatic (fvs, new_ty) <$> zonkLExpr expr

zonkExpr (HsEmbTy XEmbTy GhcTc
x LHsWcType (NoGhcTc GhcTc)
_) = DataConCantHappen -> ZonkT TcM (HsExpr GhcTc)
forall a. DataConCantHappen -> a
dataConCantHappen XEmbTy GhcTc
DataConCantHappen
x
zonkExpr (HsQual XQual GhcTc
x XRec GhcTc [LHsExpr GhcTc]
_ LHsExpr GhcTc
_) = DataConCantHappen -> ZonkT TcM (HsExpr GhcTc)
forall a. DataConCantHappen -> a
dataConCantHappen XQual GhcTc
DataConCantHappen
x
zonkExpr (HsForAll XForAll GhcTc
x HsForAllTelescope GhcTc
_ LHsExpr GhcTc
_) = DataConCantHappen -> ZonkT TcM (HsExpr GhcTc)
forall a. DataConCantHappen -> a
dataConCantHappen XForAll GhcTc
DataConCantHappen
x
zonkExpr (HsFunArr XFunArr GhcTc
x HsMultAnnOf (LHsExpr GhcTc) GhcTc
_ LHsExpr GhcTc
_ LHsExpr GhcTc
_) = DataConCantHappen -> ZonkT TcM (HsExpr GhcTc)
forall a. DataConCantHappen -> a
dataConCantHappen XFunArr GhcTc
DataConCantHappen
x

zonkExpr (XExpr (WrapExpr HsWrapper
co_fn HsExpr GhcTc
expr))
  = ZonkBndrT TcM HsWrapper
-> forall r. (HsWrapper -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT (HsWrapper -> ZonkBndrT TcM HsWrapper
zonkCoFn HsWrapper
co_fn) ((HsWrapper -> ZonkT TcM (HsExpr GhcTc))
 -> ZonkT TcM (HsExpr GhcTc))
-> (HsWrapper -> ZonkT TcM (HsExpr GhcTc))
-> ZonkT TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ \ HsWrapper
new_co_fn ->
    do new_expr <- HsExpr GhcTc -> ZonkT TcM (HsExpr GhcTc)
zonkExpr HsExpr GhcTc
expr
       return (XExpr (WrapExpr new_co_fn new_expr))

zonkExpr (XExpr (ExpandedThingTc HsThingRn
thing HsExpr GhcTc
e))
  = do e' <- HsExpr GhcTc -> ZonkT TcM (HsExpr GhcTc)
zonkExpr HsExpr GhcTc
e
       return $ XExpr (ExpandedThingTc thing e')


zonkExpr (XExpr (ConLikeTc ConLike
con [Id]
tvs [Scaled Kind]
tys))
  = XXExpr GhcTc -> HsExpr GhcTc
XXExprGhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (XXExprGhcTc -> HsExpr GhcTc)
-> ([Scaled Kind] -> XXExprGhcTc) -> [Scaled Kind] -> HsExpr GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConLike -> [Id] -> [Scaled Kind] -> XXExprGhcTc
ConLikeTc ConLike
con [Id]
tvs ([Scaled Kind] -> HsExpr GhcTc)
-> ZonkTcM [Scaled Kind] -> ZonkT TcM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Scaled Kind -> ZonkTcM (Scaled Kind))
-> [Scaled Kind] -> ZonkTcM [Scaled Kind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Scaled Kind -> ZonkTcM (Scaled Kind)
forall {a}. Scaled a -> ZonkT TcM (Scaled a)
zonk_scale [Scaled Kind]
tys
  where
    zonk_scale :: Scaled a -> ZonkT TcM (Scaled a)
zonk_scale (Scaled Kind
m a
ty) = Kind -> a -> Scaled a
forall a. Kind -> a -> Scaled a
Scaled (Kind -> a -> Scaled a)
-> ZonkT TcM Kind -> ZonkT TcM (a -> Scaled a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Kind
m ZonkT TcM (a -> Scaled a) -> ZonkT TcM a -> ZonkT TcM (Scaled a)
forall a b. ZonkT TcM (a -> b) -> ZonkT TcM a -> ZonkT TcM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> ZonkT TcM a
forall a. a -> ZonkT TcM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
ty
    -- Only the multiplicity can contain unification variables
    -- The tvs come straight from the data-con, and so are strictly redundant
    -- See Wrinkles of Note [Typechecking data constructors] in GHC.Tc.Gen.Head

zonkExpr (XExpr (HsRecSelTc (FieldOcc XCFieldOcc GhcTc
occ (L SrcSpanAnnN
l Id
v))))
  = do { v' <- Id -> ZonkT TcM Id
zonkIdOcc Id
v
       ; return (XExpr (HsRecSelTc (FieldOcc occ (L l v')))) }

zonkExpr (RecordUpd XRecordUpd GhcTc
x LHsExpr GhcTc
_ LHsRecUpdFields GhcTc
_)  = DataConCantHappen -> ZonkT TcM (HsExpr GhcTc)
forall a. DataConCantHappen -> a
dataConCantHappen XRecordUpd GhcTc
DataConCantHappen
x
zonkExpr (HsGetField XGetField GhcTc
x LHsExpr GhcTc
_ XRec GhcTc (DotFieldOcc GhcTc)
_) = DataConCantHappen -> ZonkT TcM (HsExpr GhcTc)
forall a. DataConCantHappen -> a
dataConCantHappen XGetField GhcTc
DataConCantHappen
x
zonkExpr (HsProjection XProjection GhcTc
x NonEmpty (DotFieldOcc GhcTc)
_) = DataConCantHappen -> ZonkT TcM (HsExpr GhcTc)
forall a. DataConCantHappen -> a
dataConCantHappen XProjection GhcTc
DataConCantHappen
x
zonkExpr e :: HsExpr GhcTc
e@(XExpr (HsTick {})) = String -> SDoc -> ZonkT TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"zonkExpr" (HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
e)
zonkExpr e :: HsExpr GhcTc
e@(XExpr (HsBinTick {})) = String -> SDoc -> ZonkT TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"zonkExpr" (HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
e)

-------------------------------------------------------------------------
{-
Note [Skolems in zonkSyntaxExpr]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider rebindable syntax with something like

  (>>=) :: (forall x. blah) -> (forall y. blah') -> blah''

The x and y become skolems that are in scope when type-checking the
arguments to the bind. This means that we must extend the ZonkEnv with
these skolems when zonking the arguments to the bind. But the skolems
are different between the two arguments, and so we should theoretically
carry around different environments to use for the different arguments.

However, this becomes a logistical nightmare, especially in dealing with
the more exotic Stmt forms. So, we simplify by making the critical
assumption that the uniques of the skolems are different. (This assumption
is justified by the use of newUnique in GHC.Tc.Utils.TcMType.instSkolTyCoVarX.)
Now, we can safely just extend one environment.
-}

-- See Note [Skolems in zonkSyntaxExpr]
zonkSyntaxExpr :: SyntaxExpr GhcTc
               -> ZonkBndrTcM (SyntaxExpr GhcTc)
zonkSyntaxExpr :: SyntaxExpr GhcTc -> ZonkBndrTcM (SyntaxExpr GhcTc)
zonkSyntaxExpr (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 { res_wrap'  <- HsWrapper -> ZonkBndrT TcM HsWrapper
zonkCoFn HsWrapper
res_wrap
       ; expr'      <- noBinders $ zonkExpr expr
       ; arg_wraps' <- traverse zonkCoFn arg_wraps
       ; return SyntaxExprTc { syn_expr      = expr'
                             , syn_arg_wraps = arg_wraps'
                             , syn_res_wrap  = res_wrap' } }
zonkSyntaxExpr SyntaxExpr GhcTc
SyntaxExprTc
NoSyntaxExprTc = SyntaxExprTc -> ZonkBndrT TcM SyntaxExprTc
forall a. a -> ZonkBndrT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return SyntaxExprTc
NoSyntaxExprTc

-------------------------------------------------------------------------

zonkLCmd  :: LHsCmd GhcTc -> ZonkTcM (LHsCmd GhcTc)
zonkCmd   :: HsCmd GhcTc  -> ZonkTcM (HsCmd GhcTc)

zonkLCmd :: LHsCmd GhcTc -> ZonkTcM (LHsCmd GhcTc)
zonkLCmd  LHsCmd GhcTc
cmd  = (HsCmd GhcTc -> ZonkTcM (HsCmd GhcTc))
-> LocatedA (HsCmd GhcTc) -> ZonkTcM (LocatedA (HsCmd GhcTc))
forall a b ann.
(a -> ZonkTcM b)
-> GenLocated (EpAnn ann) a -> ZonkTcM (GenLocated (EpAnn ann) b)
wrapLocZonkMA HsCmd GhcTc -> ZonkTcM (HsCmd GhcTc)
zonkCmd LHsCmd GhcTc
LocatedA (HsCmd GhcTc)
cmd

zonkCmd :: HsCmd GhcTc -> ZonkTcM (HsCmd GhcTc)
zonkCmd (XCmd (HsWrap HsWrapper
w HsCmd GhcTc
cmd))
  = ZonkBndrT TcM HsWrapper
-> forall r. (HsWrapper -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT (HsWrapper -> ZonkBndrT TcM HsWrapper
zonkCoFn HsWrapper
w) ((HsWrapper -> ZonkTcM (HsCmd GhcTc)) -> ZonkTcM (HsCmd GhcTc))
-> (HsWrapper -> ZonkTcM (HsCmd GhcTc)) -> ZonkTcM (HsCmd GhcTc)
forall a b. (a -> b) -> a -> b
$ \ HsWrapper
w' ->
    do { cmd' <- HsCmd GhcTc -> ZonkTcM (HsCmd GhcTc)
zonkCmd HsCmd GhcTc
cmd
       ; return (XCmd (HsWrap w' cmd')) }
zonkCmd (HsCmdArrApp XCmdArrApp GhcTc
ty LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 HsArrAppType
ho Bool
rl)
  = do new_e1 <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
e1
       new_e2 <- zonkLExpr e2
       new_ty <- zonkTcTypeToTypeX ty
       return (HsCmdArrApp new_ty new_e1 new_e2 ho rl)

zonkCmd (HsCmdArrForm XCmdArrForm GhcTc
x LHsExpr GhcTc
op LexicalFixity
fixity [LHsCmdTop GhcTc]
args)
  = do new_op <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
op
       new_args <- mapM zonkCmdTop args
       return (HsCmdArrForm x new_op fixity new_args)

zonkCmd (HsCmdApp XCmdApp GhcTc
x LHsCmd GhcTc
c LHsExpr GhcTc
e)
  = do new_c <- LHsCmd GhcTc -> ZonkTcM (LHsCmd GhcTc)
zonkLCmd LHsCmd GhcTc
c
       new_e <- zonkLExpr e
       return (HsCmdApp x new_c new_e)

zonkCmd (HsCmdPar XCmdPar GhcTc
x LHsCmd GhcTc
c)
  = do new_c <- LHsCmd GhcTc -> ZonkTcM (LHsCmd GhcTc)
zonkLCmd LHsCmd GhcTc
c
       return (HsCmdPar x new_c)

zonkCmd (HsCmdCase XCmdCase GhcTc
x LHsExpr GhcTc
expr MatchGroup GhcTc (LHsCmd GhcTc)
ms)
  = do new_expr <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
expr
       new_ms <- zonkMatchGroup zonkLCmd ms
       return (HsCmdCase x new_expr new_ms)

zonkCmd (HsCmdLam XCmdLamCase GhcTc
x HsLamVariant
lam_variant MatchGroup GhcTc (LHsCmd GhcTc)
ms)
  = do new_ms <- (LocatedA (HsCmd GhcTc) -> ZonkTcM (LocatedA (HsCmd GhcTc)))
-> MatchGroup GhcTc (LocatedA (HsCmd GhcTc))
-> ZonkTcM (MatchGroup GhcTc (LocatedA (HsCmd GhcTc)))
forall (body :: * -> *).
(Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
-> ZonkTcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
zonkMatchGroup LHsCmd GhcTc -> ZonkTcM (LHsCmd GhcTc)
LocatedA (HsCmd GhcTc) -> ZonkTcM (LocatedA (HsCmd GhcTc))
zonkLCmd MatchGroup GhcTc (LHsCmd GhcTc)
MatchGroup GhcTc (LocatedA (HsCmd GhcTc))
ms
       return (HsCmdLam x lam_variant new_ms)

zonkCmd (HsCmdIf XCmdIf GhcTc
x SyntaxExpr GhcTc
eCond LHsExpr GhcTc
ePred LHsCmd GhcTc
cThen LHsCmd GhcTc
cElse)
  = ZonkBndrT TcM SyntaxExprTc
-> forall r. (SyntaxExprTc -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT (SyntaxExpr GhcTc -> ZonkBndrTcM (SyntaxExpr GhcTc)
zonkSyntaxExpr SyntaxExpr GhcTc
eCond) ((SyntaxExprTc -> ZonkTcM (HsCmd GhcTc)) -> ZonkTcM (HsCmd GhcTc))
-> (SyntaxExprTc -> ZonkTcM (HsCmd GhcTc)) -> ZonkTcM (HsCmd GhcTc)
forall a b. (a -> b) -> a -> b
$ \ SyntaxExprTc
new_eCond ->
    do { new_ePred <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
ePred
       ; new_cThen <- zonkLCmd cThen
       ; new_cElse <- zonkLCmd cElse
       ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) }

zonkCmd (HsCmdLet XCmdLet GhcTc
x HsLocalBinds GhcTc
binds LHsCmd GhcTc
cmd)
  = ZonkBndrTcM (HsLocalBinds GhcTc)
-> forall r. (HsLocalBinds GhcTc -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT (HsLocalBinds GhcTc -> ZonkBndrTcM (HsLocalBinds GhcTc)
zonkLocalBinds HsLocalBinds GhcTc
binds) ((HsLocalBinds GhcTc -> ZonkTcM (HsCmd GhcTc))
 -> ZonkTcM (HsCmd GhcTc))
-> (HsLocalBinds GhcTc -> ZonkTcM (HsCmd GhcTc))
-> ZonkTcM (HsCmd GhcTc)
forall a b. (a -> b) -> a -> b
$ \ HsLocalBinds GhcTc
new_binds ->
    do new_cmd <- LHsCmd GhcTc -> ZonkTcM (LHsCmd GhcTc)
zonkLCmd LHsCmd GhcTc
cmd
       return (HsCmdLet x new_binds new_cmd)

zonkCmd (HsCmdDo XCmdDo GhcTc
ty (L SrcSpanAnnLW
l [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsCmd GhcTc)))]
stmts))
  = do new_stmts <- ZonkBndrT
  TcM
  [GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsCmd GhcTc)))]
-> ZonkT
     TcM
     [GenLocated
        SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsCmd GhcTc)))]
forall (m :: * -> *) a. Monad m => ZonkBndrT m a -> ZonkT m a
don'tBind (ZonkBndrT
   TcM
   [GenLocated
      SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsCmd GhcTc)))]
 -> ZonkT
      TcM
      [GenLocated
         SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsCmd GhcTc)))])
-> ZonkBndrT
     TcM
     [GenLocated
        SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsCmd GhcTc)))]
-> ZonkT
     TcM
     [GenLocated
        SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsCmd GhcTc)))]
forall a b. (a -> b) -> a -> b
$ (LocatedA (HsCmd GhcTc) -> ZonkTcM (LocatedA (HsCmd GhcTc)))
-> [LStmt GhcTc (LocatedA (HsCmd GhcTc))]
-> ZonkBndrTcM [LStmt GhcTc (LocatedA (HsCmd GhcTc))]
forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
 ~ SrcSpanAnnA) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> ZonkBndrTcM [LStmt GhcTc (LocatedA (body GhcTc))]
zonkStmts LHsCmd GhcTc -> ZonkTcM (LHsCmd GhcTc)
LocatedA (HsCmd GhcTc) -> ZonkTcM (LocatedA (HsCmd GhcTc))
zonkLCmd [LStmt GhcTc (LocatedA (HsCmd GhcTc))]
[GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsCmd GhcTc)))]
stmts
       new_ty <- zonkTcTypeToTypeX ty
       return (HsCmdDo new_ty (L l new_stmts))



zonkCmdTop :: LHsCmdTop GhcTc -> ZonkTcM (LHsCmdTop GhcTc)
zonkCmdTop :: LHsCmdTop GhcTc -> ZonkTcM (LHsCmdTop GhcTc)
zonkCmdTop LHsCmdTop GhcTc
cmd = (HsCmdTop GhcTc -> ZonkTcM (HsCmdTop GhcTc))
-> GenLocated EpAnnCO (HsCmdTop GhcTc)
-> ZonkT TcM (GenLocated EpAnnCO (HsCmdTop GhcTc))
forall a b ann.
(a -> ZonkTcM b)
-> GenLocated (EpAnn ann) a -> ZonkTcM (GenLocated (EpAnn ann) b)
wrapLocZonkMA (HsCmdTop GhcTc -> ZonkTcM (HsCmdTop GhcTc)
zonk_cmd_top) LHsCmdTop GhcTc
GenLocated EpAnnCO (HsCmdTop GhcTc)
cmd

zonk_cmd_top :: HsCmdTop GhcTc -> ZonkTcM (HsCmdTop GhcTc)
zonk_cmd_top :: HsCmdTop GhcTc -> ZonkTcM (HsCmdTop GhcTc)
zonk_cmd_top (HsCmdTop (CmdTopTc Kind
stack_tys Kind
ty CmdSyntaxTable GhcTc
ids) LHsCmd GhcTc
cmd)
  = do new_cmd <- LHsCmd GhcTc -> ZonkTcM (LHsCmd GhcTc)
zonkLCmd LHsCmd GhcTc
cmd
       new_stack_tys <- zonkTcTypeToTypeX stack_tys
       new_ty <- zonkTcTypeToTypeX ty
       new_ids <- mapSndM zonkExpr ids

       massert (definitelyLiftedType new_stack_tys)
         -- desugarer assumes that this is not representation-polymorphic...
         -- but indeed it should always be lifted due to the typing
         -- rules for arrows

       return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd)

-------------------------------------------------------------------------
zonkCoFn :: HsWrapper -> ZonkBndrTcM HsWrapper
zonkCoFn :: HsWrapper -> ZonkBndrT TcM HsWrapper
zonkCoFn HsWrapper
WpHole   = HsWrapper -> ZonkBndrT TcM HsWrapper
forall a. a -> ZonkBndrT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
WpHole
zonkCoFn (WpCompose HsWrapper
c1 HsWrapper
c2) = do { c1' <- HsWrapper -> ZonkBndrT TcM HsWrapper
zonkCoFn HsWrapper
c1
                                ; c2' <- zonkCoFn c2
                                ; return (WpCompose c1' c2') }
zonkCoFn (WpFun HsWrapper
c1 HsWrapper
c2 Scaled Kind
t1)  = do { c1' <- HsWrapper -> ZonkBndrT TcM HsWrapper
zonkCoFn HsWrapper
c1
                                ; c2' <- zonkCoFn c2
                                ; t1' <- noBinders $ zonkScaledTcTypeToTypeX t1
                                ; return (WpFun c1' c2' t1') }
zonkCoFn (WpCast Coercion
co)   = Coercion -> HsWrapper
WpCast  (Coercion -> HsWrapper)
-> ZonkBndrT TcM Coercion -> ZonkBndrT TcM HsWrapper
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkTcM Coercion -> ZonkBndrT TcM Coercion
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (Coercion -> ZonkTcM Coercion
zonkCoToCo Coercion
co)
zonkCoFn (WpEvLam Id
ev)  = Id -> HsWrapper
WpEvLam (Id -> HsWrapper) -> ZonkBndrT TcM Id -> ZonkBndrT TcM HsWrapper
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> ZonkBndrT TcM Id
zonkEvBndrX Id
ev
zonkCoFn (WpEvApp EvTerm
arg) = EvTerm -> HsWrapper
WpEvApp (EvTerm -> HsWrapper)
-> ZonkBndrT TcM EvTerm -> ZonkBndrT TcM HsWrapper
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkT TcM EvTerm -> ZonkBndrT TcM EvTerm
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (EvTerm -> ZonkT TcM EvTerm
zonkEvTerm EvTerm
arg)
zonkCoFn (WpTyLam Id
tv)  = Bool -> ZonkBndrT TcM HsWrapper -> ZonkBndrT TcM HsWrapper
forall a. HasCallStack => Bool -> a -> a
assert (Id -> Bool
isImmutableTyVar Id
tv) (ZonkBndrT TcM HsWrapper -> ZonkBndrT TcM HsWrapper)
-> ZonkBndrT TcM HsWrapper -> ZonkBndrT TcM HsWrapper
forall a b. (a -> b) -> a -> b
$
                         Id -> HsWrapper
WpTyLam (Id -> HsWrapper) -> ZonkBndrT TcM Id -> ZonkBndrT TcM HsWrapper
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> ZonkBndrT TcM Id
zonkTyBndrX Id
tv
zonkCoFn (WpTyApp Kind
ty)  = Kind -> HsWrapper
WpTyApp (Kind -> HsWrapper)
-> ZonkBndrT TcM Kind -> ZonkBndrT TcM HsWrapper
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkT TcM Kind -> ZonkBndrT TcM Kind
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Kind
ty)
zonkCoFn (WpLet TcEvBinds
bs)    = TcEvBinds -> HsWrapper
WpLet   (TcEvBinds -> HsWrapper)
-> ZonkBndrTcM TcEvBinds -> ZonkBndrT TcM HsWrapper
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcEvBinds -> ZonkBndrTcM TcEvBinds
zonkTcEvBinds TcEvBinds
bs

-------------------------------------------------------------------------
zonkOverLit :: HsOverLit GhcTc -> ZonkTcM (HsOverLit GhcTc)
zonkOverLit :: HsOverLit GhcTc -> ZonkTcM (HsOverLit GhcTc)
zonkOverLit lit :: HsOverLit GhcTc
lit@(OverLit {ol_ext :: forall p. HsOverLit p -> XOverLit p
ol_ext = x :: XOverLit GhcTc
x@OverLitTc { ol_witness :: OverLitTc -> HsExpr GhcTc
ol_witness = HsExpr GhcTc
e, ol_type :: OverLitTc -> Kind
ol_type = Kind
ty } })
  = do  { ty' <- Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Kind
ty
        ; e' <- zonkExpr e
        ; return (lit { ol_ext = x { ol_witness = e'
                                   , ol_type = ty' } }) }

-------------------------------------------------------------------------
zonkBracket :: HsBracketTc -> ZonkTcM HsBracketTc
zonkBracket :: HsBracketTc -> ZonkT TcM HsBracketTc
zonkBracket (HsBracketTc HsQuote GhcRn
hsb_thing Kind
ty Maybe QuoteWrapper
wrap [PendingTcSplice]
bs)
  = do wrap' <- (QuoteWrapper -> ZonkT TcM QuoteWrapper)
-> Maybe QuoteWrapper -> ZonkT TcM (Maybe QuoteWrapper)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse QuoteWrapper -> ZonkT TcM QuoteWrapper
zonkQuoteWrap Maybe QuoteWrapper
wrap
       bs' <- mapM zonk_b bs
       new_ty <- zonkTcTypeToTypeX ty
       return (HsBracketTc hsb_thing new_ty wrap' bs')
  where
    zonkQuoteWrap :: QuoteWrapper -> ZonkT TcM QuoteWrapper
zonkQuoteWrap (QuoteWrapper Id
ev Kind
ty) = do
        ev' <- Id -> ZonkT TcM Id
zonkIdOcc Id
ev
        ty' <- zonkTcTypeToTypeX ty
        return (QuoteWrapper ev' ty')

    zonk_b :: PendingTcSplice -> ZonkT TcM PendingTcSplice
zonk_b (PendingTcSplice Name
n LHsExpr GhcTc
e) = do e' <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
e
                                      return (PendingTcSplice n e')

-------------------------------------------------------------------------
zonkArithSeq :: ArithSeqInfo GhcTc -> ZonkTcM (ArithSeqInfo GhcTc)

zonkArithSeq :: ArithSeqInfo GhcTc -> ZonkTcM (ArithSeqInfo GhcTc)
zonkArithSeq (From LHsExpr GhcTc
e)
  = do new_e <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
e
       return (From new_e)

zonkArithSeq (FromThen LHsExpr GhcTc
e1 LHsExpr GhcTc
e2)
  = do new_e1 <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
e1
       new_e2 <- zonkLExpr e2
       return (FromThen new_e1 new_e2)

zonkArithSeq (FromTo LHsExpr GhcTc
e1 LHsExpr GhcTc
e2)
  = do new_e1 <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
e1
       new_e2 <- zonkLExpr e2
       return (FromTo new_e1 new_e2)

zonkArithSeq (FromThenTo LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3)
  = do new_e1 <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
e1
       new_e2 <- zonkLExpr e2
       new_e3 <- zonkLExpr e3
       return (FromThenTo new_e1 new_e2 new_e3)

-------------------------------------------------------------------------
zonkStmts :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
          => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
          -> [LStmt GhcTc (LocatedA (body GhcTc))]
          -> ZonkBndrTcM [LStmt GhcTc (LocatedA (body GhcTc))]
zonkStmts :: forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
 ~ SrcSpanAnnA) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> ZonkBndrTcM [LStmt GhcTc (LocatedA (body GhcTc))]
zonkStmts LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))
_ []     = [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
-> ZonkBndrT
     TcM
     [GenLocated
        SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))]
forall a. a -> ZonkBndrT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return []
zonkStmts LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))
zBody (LStmt GhcTc (LocatedA (body GhcTc))
s:[LStmt GhcTc (LocatedA (body GhcTc))]
ss) = do { s'  <- (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
 -> ZonkBndrTcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))))
-> GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
-> ZonkBndrTcM
     (GenLocated
        SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))))
forall a b ann.
(a -> ZonkBndrTcM b)
-> GenLocated (EpAnn ann) a
-> ZonkBndrTcM (GenLocated (EpAnn ann) b)
wrapLocZonkBndrMA ((LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
-> ZonkBndrTcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
 ~ SrcSpanAnnA) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
-> ZonkBndrTcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
zonkStmt LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))
zBody) LStmt GhcTc (LocatedA (body GhcTc))
GenLocated SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
s
                            ; ss' <- zonkStmts zBody ss
                            ; return (s' : ss') }

zonkStmt :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
         => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
         -> Stmt GhcTc (LocatedA (body GhcTc))
         -> ZonkBndrTcM (Stmt GhcTc (LocatedA (body GhcTc)))
zonkStmt :: forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
 ~ SrcSpanAnnA) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
-> ZonkBndrTcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
zonkStmt LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))
_ (ParStmt XParStmt GhcTc GhcTc (LocatedA (body GhcTc))
bind_ty NonEmpty (ParStmtBlock GhcTc GhcTc)
stmts_w_bndrs HsExpr GhcTc
mzip_op SyntaxExpr GhcTc
bind_op)
  = do { new_bind_op <- SyntaxExpr GhcTc -> ZonkBndrTcM (SyntaxExpr GhcTc)
zonkSyntaxExpr SyntaxExpr GhcTc
bind_op
       ; new_bind_ty <- noBinders $ zonkTcTypeToTypeX bind_ty
       ; new_stmts_w_bndrs <- noBinders $ mapM zonk_branch stmts_w_bndrs

       -- Add in the binders after we're done with all the branches.
       ; let new_binders = [ Id
b | ParStmtBlock XParStmtBlock GhcTc GhcTc
_ [GuardLStmt GhcTc]
_ [IdP GhcTc]
bs SyntaxExpr GhcTc
_ <- NonEmpty (ParStmtBlock GhcTc GhcTc) -> [ParStmtBlock GhcTc GhcTc]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (ParStmtBlock GhcTc GhcTc)
new_stmts_w_bndrs
                           , Id
b <- [IdP GhcTc]
[Id]
bs ]
       ; extendIdZonkEnvRec new_binders
       ; new_mzip <- noBinders $ zonkExpr mzip_op
       ; return (ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)}
  where
    zonk_branch :: ParStmtBlock GhcTc GhcTc
                -> ZonkTcM (ParStmtBlock GhcTc GhcTc)
    zonk_branch :: ParStmtBlock GhcTc GhcTc -> ZonkT TcM (ParStmtBlock GhcTc GhcTc)
zonk_branch (ParStmtBlock XParStmtBlock GhcTc GhcTc
x [GuardLStmt GhcTc]
stmts [IdP GhcTc]
bndrs SyntaxExpr GhcTc
return_op)
       = ZonkBndrT
  TcM
  [GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> forall r.
   ([GenLocated
       SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
    -> ZonkT TcM r)
   -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ((LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc)))
-> [LStmt GhcTc (LocatedA (HsExpr GhcTc))]
-> ZonkBndrTcM [LStmt GhcTc (LocatedA (HsExpr GhcTc))]
forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
 ~ SrcSpanAnnA) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> ZonkBndrTcM [LStmt GhcTc (LocatedA (body GhcTc))]
zonkStmts LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc))
zonkLExpr [GuardLStmt GhcTc]
[LStmt GhcTc (LocatedA (HsExpr GhcTc))]
stmts) (([GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
  -> ZonkT TcM (ParStmtBlock GhcTc GhcTc))
 -> ZonkT TcM (ParStmtBlock GhcTc GhcTc))
-> ([GenLocated
       SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
    -> ZonkT TcM (ParStmtBlock GhcTc GhcTc))
-> ZonkT TcM (ParStmtBlock GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$ \ [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
new_stmts ->
         ZonkBndrT TcM SyntaxExprTc
-> forall r. (SyntaxExprTc -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT (SyntaxExpr GhcTc -> ZonkBndrTcM (SyntaxExpr GhcTc)
zonkSyntaxExpr SyntaxExpr GhcTc
return_op)  ((SyntaxExprTc -> ZonkT TcM (ParStmtBlock GhcTc GhcTc))
 -> ZonkT TcM (ParStmtBlock GhcTc GhcTc))
-> (SyntaxExprTc -> ZonkT TcM (ParStmtBlock GhcTc GhcTc))
-> ZonkT TcM (ParStmtBlock GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$ \ SyntaxExprTc
new_return ->
         do { new_bndrs <- [Id] -> ZonkTcM [Id]
zonkIdOccs [IdP GhcTc]
[Id]
bndrs
            ; return (ParStmtBlock x new_stmts new_bndrs new_return) }

zonkStmt LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))
zBody (RecStmt { recS_stmts :: forall idL idR body.
StmtLR idL idR body -> XRec idR [LStmtLR idL idR body]
recS_stmts = L SrcSpanAnnLW
_ [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 { new_bind_id <- SyntaxExpr GhcTc -> ZonkBndrTcM (SyntaxExpr GhcTc)
zonkSyntaxExpr SyntaxExpr GhcTc
bind_id
       ; new_mfix_id <- zonkSyntaxExpr mfix_id
       ; new_ret_id  <- zonkSyntaxExpr ret_id
       ; new_bind_ty <- noBinders $ zonkTcTypeToTypeX bind_ty
       ; new_rvs     <- noBinders $ zonkIdBndrs rvs
       ; new_lvs     <- noBinders $ zonkIdBndrs lvs
       ; new_ret_ty  <- noBinders $ zonkTcTypeToTypeX ret_ty

    -- Zonk the ret-expressions in an environment that
    -- has the polymorphic bindings
       ; rec_stmt <- noBinders $ don'tBind $
          do { extendIdZonkEnvRec new_rvs
             ; new_segStmts   <- zonkStmts zBody segStmts
             ; new_later_rets <- noBinders $ mapM zonkExpr later_rets
             ; new_rec_rets   <- noBinders $ mapM zonkExpr rec_rets
             ; return $
               RecStmt { recS_stmts = noLocA new_segStmts
                       , recS_later_ids = new_lvs
                       , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
                       , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
                       , recS_ext = RecStmtTc
                           { recS_bind_ty = new_bind_ty
                           , recS_later_rets = new_later_rets
                           , recS_rec_rets = new_rec_rets
                           , recS_ret_ty = new_ret_ty } } }

    -- Only the lvs are needed
       ; extendIdZonkEnvRec new_lvs
       ; return rec_stmt }

zonkStmt LocatedA (body GhcTc) -> ZonkTcM (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 { new_then_op  <- SyntaxExpr GhcTc -> ZonkBndrTcM (SyntaxExpr GhcTc)
zonkSyntaxExpr SyntaxExpr GhcTc
then_op
       ; new_guard_op <- zonkSyntaxExpr guard_op
       ; new_body     <- noBinders $ zBody body
       ; new_ty       <- noBinders $ zonkTcTypeToTypeX  ty
       ; return $ BodyStmt new_ty new_body new_then_op new_guard_op }

zonkStmt LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))
zBody (LastStmt XLastStmt GhcTc GhcTc (LocatedA (body GhcTc))
x LocatedA (body GhcTc)
body Maybe Bool
noret SyntaxExpr GhcTc
ret_op)
  = ZonkT TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
-> ZonkBndrT TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkT TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
 -> ZonkBndrT TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))))
-> ZonkT TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
-> ZonkBndrT TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
forall a b. (a -> b) -> a -> b
$ ZonkBndrT TcM SyntaxExprTc
-> forall r. (SyntaxExprTc -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT (SyntaxExpr GhcTc -> ZonkBndrTcM (SyntaxExpr GhcTc)
zonkSyntaxExpr SyntaxExpr GhcTc
ret_op) ((SyntaxExprTc
  -> ZonkT TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))))
 -> ZonkT TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))))
-> (SyntaxExprTc
    -> ZonkT TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))))
-> ZonkT TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
forall a b. (a -> b) -> a -> b
$ \ SyntaxExprTc
new_ret ->
    do { new_body <- LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))
zBody LocatedA (body GhcTc)
body
       ; return $ LastStmt x new_body noret new_ret }

zonkStmt LocatedA (body GhcTc) -> ZonkTcM (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 { bind_op'     <- SyntaxExpr GhcTc -> ZonkBndrTcM (SyntaxExpr GhcTc)
zonkSyntaxExpr SyntaxExpr GhcTc
bind_op
       ; bind_arg_ty' <- noBinders $ zonkTcTypeToTypeX bind_arg_ty
       ; stmts'       <- zonkStmts zonkLExpr stmts
       ; by'          <- noBinders $ traverse zonkLExpr by
       ; using'       <- noBinders $ zonkLExpr using
       ; return_op'   <- zonkSyntaxExpr return_op
       ; liftM_op'    <- noBinders $ zonkExpr liftM_op
       ; binderMap'   <- mapM zonkBinderMapEntry binderMap
       ; return (TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
                           , trS_by = by', trS_form = form, trS_using = using'
                           , trS_ret = return_op', trS_bind = bind_op'
                           , trS_ext = bind_arg_ty'
                           , trS_fmap = liftM_op' }) }
  where
    zonkBinderMapEntry :: (Id, Id) -> ZonkBndrT TcM (Id, Id)
zonkBinderMapEntry (Id
oldBinder, Id
newBinder) = do
        oldBinder' <- ZonkT TcM Id -> ZonkBndrT TcM Id
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkT TcM Id -> ZonkBndrT TcM Id)
-> ZonkT TcM Id -> ZonkBndrT TcM Id
forall a b. (a -> b) -> a -> b
$ Id -> ZonkT TcM Id
zonkIdOcc Id
oldBinder
        newBinder' <- zonkIdBndrX newBinder
        return (oldBinder', newBinder')

zonkStmt LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))
_ (LetStmt XLetStmt GhcTc GhcTc (LocatedA (body GhcTc))
x HsLocalBinds GhcTc
binds)
  = XLetStmt GhcTc GhcTc (LocatedA (body GhcTc))
-> HsLocalBinds GhcTc -> StmtLR GhcTc GhcTc (LocatedA (body GhcTc))
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 -> StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
-> ZonkBndrTcM (HsLocalBinds GhcTc)
-> ZonkBndrT TcM (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsLocalBinds GhcTc -> ZonkBndrTcM (HsLocalBinds GhcTc)
zonkLocalBinds HsLocalBinds GhcTc
binds

zonkStmt LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))
zBody (BindStmt XBindStmt GhcTc GhcTc (LocatedA (body GhcTc))
xbs LPat GhcTc
pat LocatedA (body GhcTc)
body)
  = do  { new_bind    <- SyntaxExpr GhcTc -> ZonkBndrTcM (SyntaxExpr GhcTc)
zonkSyntaxExpr (XBindStmtTc -> SyntaxExpr GhcTc
xbstc_bindOp XBindStmt GhcTc GhcTc (LocatedA (body GhcTc))
XBindStmtTc
xbs)
        ; new_w       <- noBinders $ zonkTcTypeToTypeX (xbstc_boundResultMult xbs)
        ; new_bind_ty <- noBinders $ zonkTcTypeToTypeX (xbstc_boundResultType xbs)
        ; new_body    <- noBinders $ zBody body
        ; new_fail <- case xbstc_failOp xbs of
            Maybe (SyntaxExpr GhcTc)
Nothing      -> Maybe SyntaxExprTc -> ZonkBndrT TcM (Maybe SyntaxExprTc)
forall a. a -> ZonkBndrT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SyntaxExprTc
forall a. Maybe a
Nothing
            Just SyntaxExpr GhcTc
fail_op -> (SyntaxExprTc -> Maybe SyntaxExprTc)
-> ZonkBndrT TcM SyntaxExprTc -> ZonkBndrT TcM (Maybe SyntaxExprTc)
forall a b. (a -> b) -> ZonkBndrT TcM a -> ZonkBndrT TcM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SyntaxExprTc -> Maybe SyntaxExprTc
forall a. a -> Maybe a
Just (ZonkBndrT TcM SyntaxExprTc -> ZonkBndrT TcM (Maybe SyntaxExprTc))
-> (ZonkT TcM SyntaxExprTc -> ZonkBndrT TcM SyntaxExprTc)
-> ZonkT TcM SyntaxExprTc
-> ZonkBndrT TcM (Maybe SyntaxExprTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZonkT TcM SyntaxExprTc -> ZonkBndrT TcM SyntaxExprTc
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkT TcM SyntaxExprTc -> ZonkBndrT TcM (Maybe SyntaxExprTc))
-> ZonkT TcM SyntaxExprTc -> ZonkBndrT TcM (Maybe SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$ ZonkBndrT TcM SyntaxExprTc -> ZonkT TcM SyntaxExprTc
forall (m :: * -> *) a. Monad m => ZonkBndrT m a -> ZonkT m a
don'tBind (SyntaxExpr GhcTc -> ZonkBndrTcM (SyntaxExpr GhcTc)
zonkSyntaxExpr SyntaxExpr GhcTc
fail_op)

        ; new_pat     <- zonkPat pat
        ; return $
            BindStmt
            (XBindStmtTc
              { xbstc_bindOp = new_bind
              , xbstc_boundResultType = new_bind_ty
              , xbstc_boundResultMult = new_w
              , xbstc_failOp = new_fail
              })
            new_pat new_body }

-- Scopes: join > ops (in reverse order) > pats (in forward order)
--              > rest of stmts
zonkStmt LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))
_zBody (XStmtLR (ApplicativeStmt XApplicativeStmt GhcTc GhcTc
body_ty [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
args Maybe (SyntaxExpr GhcTc)
mb_join))
  = do  { new_mb_join   <- Maybe SyntaxExprTc -> ZonkBndrT TcM (Maybe SyntaxExprTc)
zonk_join Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
mb_join
        ; new_args      <- zonk_args args
        ; new_body_ty   <- noBinders $ zonkTcTypeToTypeX body_ty
        ; return $ XStmtLR $ ApplicativeStmt new_body_ty new_args new_mb_join }
  where
    zonk_join :: Maybe SyntaxExprTc -> ZonkBndrT TcM (Maybe SyntaxExprTc)
zonk_join Maybe SyntaxExprTc
Nothing  = Maybe SyntaxExprTc -> ZonkBndrT TcM (Maybe SyntaxExprTc)
forall a. a -> ZonkBndrT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SyntaxExprTc
forall a. Maybe a
Nothing
    zonk_join (Just SyntaxExprTc
j) = SyntaxExprTc -> Maybe SyntaxExprTc
forall a. a -> Maybe a
Just (SyntaxExprTc -> Maybe SyntaxExprTc)
-> ZonkBndrT TcM SyntaxExprTc -> ZonkBndrT TcM (Maybe SyntaxExprTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SyntaxExpr GhcTc -> ZonkBndrTcM (SyntaxExpr GhcTc)
zonkSyntaxExpr SyntaxExpr GhcTc
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 HsDoFlavour
_) = 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, XApplicativeArgOne GhcTc
-> LPat GhcTc -> LHsExpr GhcTc -> Bool -> ApplicativeArg GhcTc
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
_ HsDoFlavour
c)
      = (SyntaxExpr GhcTc
op, XApplicativeArgMany GhcTc
-> [GuardLStmt GhcTc]
-> HsExpr GhcTc
-> LPat GhcTc
-> HsDoFlavour
-> ApplicativeArg GhcTc
forall idL.
XApplicativeArgMany idL
-> [ExprLStmt idL]
-> HsExpr idL
-> LPat idL
-> HsDoFlavour
-> ApplicativeArg idL
ApplicativeArgMany XApplicativeArgMany GhcTc
x [GuardLStmt GhcTc]
a HsExpr GhcTc
b LPat GhcTc
pat HsDoFlavour
c)

    zonk_args :: [(SyntaxExprTc, ApplicativeArg GhcTc)]
-> ZonkBndrT TcM [(SyntaxExprTc, ApplicativeArg GhcTc)]
zonk_args [(SyntaxExprTc, ApplicativeArg GhcTc)]
args
      = do { new_args_rev <- [(SyntaxExprTc, ApplicativeArg GhcTc)]
-> ZonkBndrT TcM [(SyntaxExprTc, ApplicativeArg GhcTc)]
zonk_args_rev ([(SyntaxExprTc, ApplicativeArg GhcTc)]
-> [(SyntaxExprTc, ApplicativeArg GhcTc)]
forall a. [a] -> [a]
reverse [(SyntaxExprTc, ApplicativeArg GhcTc)]
args)
           ; new_pats     <- zonkPats (map get_pat args)
           ; return $ zipWithEqual replace_pat
                        new_pats (reverse new_args_rev) }

     -- these need to go backward, because if any operators are higher-rank,
     -- later operators may introduce skolems that are in scope for earlier
     -- arguments
    zonk_args_rev :: [(SyntaxExprTc, ApplicativeArg GhcTc)]
-> ZonkBndrT TcM [(SyntaxExprTc, ApplicativeArg GhcTc)]
zonk_args_rev ((SyntaxExprTc
op, ApplicativeArg GhcTc
arg) : [(SyntaxExprTc, ApplicativeArg GhcTc)]
args)
      = do { new_op   <- SyntaxExpr GhcTc -> ZonkBndrTcM (SyntaxExpr GhcTc)
zonkSyntaxExpr SyntaxExpr GhcTc
SyntaxExprTc
op
           ; new_arg  <- noBinders $ zonk_arg arg
           ; new_args <- zonk_args_rev args
           ; return $ (new_op, new_arg) : new_args }
    zonk_args_rev [] = [(SyntaxExprTc, ApplicativeArg GhcTc)]
-> ZonkBndrT TcM [(SyntaxExprTc, ApplicativeArg GhcTc)]
forall a. a -> ZonkBndrT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return []

    zonk_arg :: ApplicativeArg GhcTc -> ZonkT TcM (ApplicativeArg GhcTc)
zonk_arg (ApplicativeArgOne XApplicativeArgOne GhcTc
fail_op LPat GhcTc
pat LHsExpr GhcTc
expr Bool
isBody)
      = do { new_expr <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
expr
           ; new_fail <- forM fail_op $ don'tBind . zonkSyntaxExpr
           ; return (ApplicativeArgOne new_fail pat new_expr isBody) }
    zonk_arg (ApplicativeArgMany XApplicativeArgMany GhcTc
x [GuardLStmt GhcTc]
stmts HsExpr GhcTc
ret LPat GhcTc
pat HsDoFlavour
ctxt)
      = ZonkBndrT
  TcM
  [GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> forall r.
   ([GenLocated
       SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
    -> ZonkT TcM r)
   -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ((LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc)))
-> [LStmt GhcTc (LocatedA (HsExpr GhcTc))]
-> ZonkBndrTcM [LStmt GhcTc (LocatedA (HsExpr GhcTc))]
forall (body :: * -> *).
(Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc)))
 ~ SrcSpanAnnA) =>
(LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))
-> [LStmt GhcTc (LocatedA (body GhcTc))]
-> ZonkBndrTcM [LStmt GhcTc (LocatedA (body GhcTc))]
zonkStmts LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
LocatedA (HsExpr GhcTc) -> ZonkT TcM (LocatedA (HsExpr GhcTc))
zonkLExpr [GuardLStmt GhcTc]
[LStmt GhcTc (LocatedA (HsExpr GhcTc))]
stmts) (([GenLocated
     SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
  -> ZonkT TcM (ApplicativeArg GhcTc))
 -> ZonkT TcM (ApplicativeArg GhcTc))
-> ([GenLocated
       SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
    -> ZonkT TcM (ApplicativeArg GhcTc))
-> ZonkT TcM (ApplicativeArg GhcTc)
forall a b. (a -> b) -> a -> b
$ \ [GenLocated
   SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
new_stmts ->
        do { new_ret <- HsExpr GhcTc -> ZonkT TcM (HsExpr GhcTc)
zonkExpr HsExpr GhcTc
ret
           ; return (ApplicativeArgMany x new_stmts new_ret pat ctxt) }

-------------------------------------------------------------------------
zonkRecFields :: HsRecordBinds GhcTc -> ZonkTcM (HsRecordBinds GhcTc)
zonkRecFields :: HsRecordBinds GhcTc -> ZonkTcM (HsRecordBinds GhcTc)
zonkRecFields (HsRecFields XHsRecFields GhcTc
x [LHsRecField GhcTc (LHsExpr GhcTc)]
flds Maybe (XRec GhcTc RecFieldsDotDot)
dd)
  = do  { flds' <- (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
      (LocatedA (HsExpr GhcTc)))
 -> ZonkT
      TcM
      (GenLocated
         SrcSpanAnnA
         (HsFieldBind
            (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
            (LocatedA (HsExpr GhcTc)))))
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
         (LocatedA (HsExpr GhcTc)))]
-> ZonkT
     TcM
     [GenLocated
        SrcSpanAnnA
        (HsFieldBind
           (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
           (LocatedA (HsExpr GhcTc)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
     (LocatedA (HsExpr GhcTc)))
-> ZonkT
     TcM
     (GenLocated
        SrcSpanAnnA
        (HsFieldBind
           (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
           (LocatedA (HsExpr GhcTc))))
forall {l} {ann}.
GenLocated
  l
  (HsFieldBind
     (GenLocated (EpAnn ann) (FieldOcc GhcTc))
     (LocatedA (HsExpr GhcTc)))
-> ZonkT
     TcM
     (GenLocated
        l
        (HsFieldBind
           (GenLocated (EpAnn ann) (FieldOcc GhcTc))
           (LocatedA (HsExpr GhcTc))))
zonk_rbind [LHsRecField GhcTc (LHsExpr GhcTc)]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
      (LocatedA (HsExpr GhcTc)))]
flds
        ; return (HsRecFields x flds' dd) }
  where
    zonk_rbind :: GenLocated
  l
  (HsFieldBind
     (GenLocated (EpAnn ann) (FieldOcc GhcTc))
     (LocatedA (HsExpr GhcTc)))
-> ZonkT
     TcM
     (GenLocated
        l
        (HsFieldBind
           (GenLocated (EpAnn ann) (FieldOcc GhcTc))
           (LocatedA (HsExpr GhcTc))))
zonk_rbind (L l
l HsFieldBind
  (GenLocated (EpAnn ann) (FieldOcc GhcTc)) (LocatedA (HsExpr GhcTc))
fld)
      = do { new_id   <- (FieldOcc GhcTc -> ZonkTcM (FieldOcc GhcTc))
-> GenLocated (EpAnn ann) (FieldOcc GhcTc)
-> ZonkTcM (GenLocated (EpAnn ann) (FieldOcc GhcTc))
forall a b ann.
(a -> ZonkTcM b)
-> GenLocated (EpAnn ann) a -> ZonkTcM (GenLocated (EpAnn ann) b)
wrapLocZonkMA FieldOcc GhcTc -> ZonkTcM (FieldOcc GhcTc)
zonkFieldOcc (HsFieldBind
  (GenLocated (EpAnn ann) (FieldOcc GhcTc)) (LocatedA (HsExpr GhcTc))
-> GenLocated (EpAnn ann) (FieldOcc GhcTc)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS HsFieldBind
  (GenLocated (EpAnn ann) (FieldOcc GhcTc)) (LocatedA (HsExpr GhcTc))
fld)
           ; new_expr <- zonkLExpr (hfbRHS fld)
           ; return (L l (fld { hfbLHS = new_id
                              , hfbRHS = new_expr })) }

{-
************************************************************************
*                                                                      *
\subsection[BackSubst-Pats]{Patterns}
*                                                                      *
************************************************************************
-}


zonkPat :: LPat GhcTc -> ZonkBndrTcM (LPat GhcTc)
-- Extend the environment as we go, because it's possible for one
-- pattern to bind something that is used in another (inside or
-- to the right)
zonkPat :: LPat GhcTc -> ZonkBndrT TcM (LPat GhcTc)
zonkPat LPat GhcTc
pat = (Pat GhcTc -> ZonkBndrTcM (Pat GhcTc))
-> GenLocated SrcSpanAnnA (Pat GhcTc)
-> ZonkBndrT TcM (GenLocated SrcSpanAnnA (Pat GhcTc))
forall a b ann.
(a -> ZonkBndrTcM b)
-> GenLocated (EpAnn ann) a
-> ZonkBndrTcM (GenLocated (EpAnn ann) b)
wrapLocZonkBndrMA Pat GhcTc -> ZonkBndrTcM (Pat GhcTc)
zonk_pat LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat

zonk_pat :: Pat GhcTc -> ZonkBndrTcM (Pat GhcTc)
zonk_pat :: Pat GhcTc -> ZonkBndrTcM (Pat GhcTc)
zonk_pat (ParPat XParPat GhcTc
x LPat GhcTc
p)
  = do  { p' <- LPat GhcTc -> ZonkBndrT TcM (LPat GhcTc)
zonkPat LPat GhcTc
p
        ; return (ParPat x p') }

zonk_pat (WildPat XWildPat GhcTc
ty)
  = do  { ty' <- ZonkT TcM Kind -> ZonkBndrT TcM Kind
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkT TcM Kind -> ZonkBndrT TcM Kind)
-> ZonkT TcM Kind -> ZonkBndrT TcM Kind
forall a b. (a -> b) -> a -> b
$ Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX XWildPat GhcTc
Kind
ty
        ; return (WildPat ty') }

zonk_pat (VarPat XVarPat GhcTc
x (L SrcSpanAnnN
l Id
v))
  = do  { v' <- Id -> ZonkBndrT TcM Id
zonkIdBndrX Id
v
        ; return (VarPat x (L l v')) }

zonk_pat (LazyPat XLazyPat GhcTc
x LPat GhcTc
pat)
  = do  { pat' <- LPat GhcTc -> ZonkBndrT TcM (LPat GhcTc)
zonkPat LPat GhcTc
pat
        ; return (LazyPat x pat') }

zonk_pat (BangPat XBangPat GhcTc
x LPat GhcTc
pat)
  = do  { pat' <- LPat GhcTc -> ZonkBndrT TcM (LPat GhcTc)
zonkPat LPat GhcTc
pat
        ; return (BangPat x pat') }

zonk_pat (AsPat XAsPat GhcTc
x (L SrcSpanAnnN
loc Id
v) LPat GhcTc
pat)
  = do  { v'   <- Id -> ZonkBndrT TcM Id
zonkIdBndrX Id
v
        ; pat' <- zonkPat pat
        ; return (AsPat x (L loc v') pat') }

zonk_pat (ViewPat XViewPat GhcTc
ty LHsExpr GhcTc
expr LPat GhcTc
pat)
  = do  { expr' <- ZonkT TcM (LHsExpr GhcTc) -> ZonkBndrT TcM (LHsExpr GhcTc)
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkT TcM (LHsExpr GhcTc) -> ZonkBndrT TcM (LHsExpr GhcTc))
-> ZonkT TcM (LHsExpr GhcTc) -> ZonkBndrT TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
expr
        ; pat'  <- zonkPat pat
        ; ty'   <- noBinders $ zonkTcTypeToTypeX ty
        ; return (ViewPat ty' expr' pat') }

zonk_pat (ListPat XListPat GhcTc
ty [LPat GhcTc]
pats)
  = do  { ty'   <- ZonkT TcM Kind -> ZonkBndrT TcM Kind
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkT TcM Kind -> ZonkBndrT TcM Kind)
-> ZonkT TcM Kind -> ZonkBndrT TcM Kind
forall a b. (a -> b) -> a -> b
$ Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX XListPat GhcTc
Kind
ty
        ; pats' <- zonkPats pats
        ; return (ListPat ty' pats') }

zonk_pat (TuplePat XTuplePat GhcTc
tys [LPat GhcTc]
pats Boxity
boxed)
  = do  { tys' <- ZonkTcM [Kind] -> ZonkBndrT TcM [Kind]
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkTcM [Kind] -> ZonkBndrT TcM [Kind])
-> ZonkTcM [Kind] -> ZonkBndrT TcM [Kind]
forall a b. (a -> b) -> a -> b
$ (Kind -> ZonkT TcM Kind) -> [Kind] -> ZonkTcM [Kind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX [Kind]
XTuplePat GhcTc
tys
        ; pats' <- zonkPats pats
        ; return (TuplePat tys' pats' boxed) }

zonk_pat (OrPat XOrPat GhcTc
ty NonEmpty (LPat GhcTc)
pats)
  = do  { ty' <- ZonkT TcM Kind -> ZonkBndrT TcM Kind
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkT TcM Kind -> ZonkBndrT TcM Kind)
-> ZonkT TcM Kind -> ZonkBndrT TcM Kind
forall a b. (a -> b) -> a -> b
$ Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX XOrPat GhcTc
Kind
ty
        ; pats' <- zonkPats pats
        ; return (OrPat ty' pats') }

zonk_pat (SumPat XSumPat GhcTc
tys LPat GhcTc
pat ConTag
alt ConTag
arity )
  = do  { tys' <- ZonkTcM [Kind] -> ZonkBndrT TcM [Kind]
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkTcM [Kind] -> ZonkBndrT TcM [Kind])
-> ZonkTcM [Kind] -> ZonkBndrT TcM [Kind]
forall a b. (a -> b) -> a -> b
$ (Kind -> ZonkT TcM Kind) -> [Kind] -> ZonkTcM [Kind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX [Kind]
XSumPat GhcTc
tys
        ; pat' <- zonkPat pat
        ; return (SumPat tys' pat' alt arity) }

zonk_pat p :: Pat GhcTc
p@(ConPat { 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 -> [Id]
cpt_tvs = [Id]
tyvars
                     , cpt_dicts :: ConPatTc -> [Id]
cpt_dicts = [Id]
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
                     })
                   })
  = Bool -> ZonkBndrTcM (Pat GhcTc) -> ZonkBndrTcM (Pat GhcTc)
forall a. HasCallStack => Bool -> a -> a
assert ((Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isImmutableTyVar [Id]
tyvars) (ZonkBndrTcM (Pat GhcTc) -> ZonkBndrTcM (Pat GhcTc))
-> ZonkBndrTcM (Pat GhcTc) -> ZonkBndrTcM (Pat GhcTc)
forall a b. (a -> b) -> a -> b
$
    do  { new_tys     <- ZonkTcM [Kind] -> ZonkBndrT TcM [Kind]
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkTcM [Kind] -> ZonkBndrT TcM [Kind])
-> ZonkTcM [Kind] -> ZonkBndrT TcM [Kind]
forall a b. (a -> b) -> a -> b
$ (Kind -> ZonkT TcM Kind) -> [Kind] -> ZonkTcM [Kind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX [Kind]
tys
        ; new_tyvars  <- zonkTyBndrsX tyvars
          -- Must zonk the existential variables, because their
          -- /kind/ need potential zonking.
          -- cf typecheck/should_compile/tc221.hs
        ; new_evs     <- zonkEvBndrsX evs
        ; new_binds   <- zonkTcEvBinds binds
        ; new_wrapper <- zonkCoFn wrapper
        ; new_args    <- zonkConStuff args
        ; pure $ p
                 { pat_args = new_args
                 , pat_con_ext = p'
                   { cpt_arg_tys = new_tys
                   , cpt_tvs = new_tyvars
                   , cpt_dicts = new_evs
                   , cpt_binds = new_binds
                   , cpt_wrap = new_wrapper
                   }
                 }
        }

zonk_pat (LitPat XLitPat GhcTc
x HsLit GhcTc
lit) = Pat GhcTc -> ZonkBndrTcM (Pat GhcTc)
forall a. a -> ZonkBndrT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (XLitPat GhcTc -> HsLit GhcTc -> Pat GhcTc
forall p. XLitPat p -> HsLit p -> Pat p
LitPat XLitPat GhcTc
x HsLit GhcTc
lit)

zonk_pat (SigPat XSigPat GhcTc
ty LPat GhcTc
pat HsPatSigType (NoGhcTc GhcTc)
hs_ty)
  = do  { ty' <- ZonkT TcM Kind -> ZonkBndrT TcM Kind
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkT TcM Kind -> ZonkBndrT TcM Kind)
-> ZonkT TcM Kind -> ZonkBndrT TcM Kind
forall a b. (a -> b) -> a -> b
$ Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX XSigPat GhcTc
Kind
ty
        ; pat' <- zonkPat pat
        ; return (SigPat ty' pat' hs_ty) }

zonk_pat (NPat XNPat GhcTc
ty (L EpAnnCO
l HsOverLit GhcTc
lit) Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
eq_expr)
  =  do { eq_expr' <- SyntaxExpr GhcTc -> ZonkBndrTcM (SyntaxExpr GhcTc)
zonkSyntaxExpr SyntaxExpr GhcTc
eq_expr
        ; mb_neg' <- case mb_neg of
            Maybe (SyntaxExpr GhcTc)
Nothing -> Maybe SyntaxExprTc -> ZonkBndrT TcM (Maybe SyntaxExprTc)
forall a. a -> ZonkBndrT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SyntaxExprTc
forall a. Maybe a
Nothing
            Just SyntaxExpr GhcTc
n  -> SyntaxExprTc -> Maybe SyntaxExprTc
forall a. a -> Maybe a
Just (SyntaxExprTc -> Maybe SyntaxExprTc)
-> ZonkBndrT TcM SyntaxExprTc -> ZonkBndrT TcM (Maybe SyntaxExprTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SyntaxExpr GhcTc -> ZonkBndrTcM (SyntaxExpr GhcTc)
zonkSyntaxExpr SyntaxExpr GhcTc
n
        ; noBinders $
     do { lit' <- zonkOverLit lit
        ; ty'  <- zonkTcTypeToTypeX ty
        ; return (NPat ty' (L l lit') mb_neg' eq_expr') } }

zonk_pat (NPlusKPat XNPlusKPat GhcTc
ty (L SrcSpanAnnN
loc Id
n) (L EpAnnCO
l HsOverLit GhcTc
lit1) HsOverLit GhcTc
lit2 SyntaxExpr GhcTc
e1 SyntaxExpr GhcTc
e2)
  = do  { e1' <- SyntaxExpr GhcTc -> ZonkBndrTcM (SyntaxExpr GhcTc)
zonkSyntaxExpr  SyntaxExpr GhcTc
e1
        ; e2' <- zonkSyntaxExpr e2
        ; lit1' <- noBinders $ zonkOverLit lit1
        ; lit2' <- noBinders $ zonkOverLit lit2
        ; ty'   <- noBinders $ zonkTcTypeToTypeX ty
        ; n'    <- zonkIdBndrX n
        ; return (NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') }

zonk_pat (EmbTyPat XEmbTyPat GhcTc
ty HsTyPat (NoGhcTc GhcTc)
tp)
  = do { ty' <- ZonkT TcM Kind -> ZonkBndrT TcM Kind
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkT TcM Kind -> ZonkBndrT TcM Kind)
-> ZonkT TcM Kind -> ZonkBndrT TcM Kind
forall a b. (a -> b) -> a -> b
$ Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX XEmbTyPat GhcTc
Kind
ty
       ; return (EmbTyPat ty' tp) }

zonk_pat (InvisPat XInvisPat GhcTc
ty HsTyPat (NoGhcTc GhcTc)
tp)
  = do { ty' <- ZonkT TcM Kind -> ZonkBndrT TcM Kind
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkT TcM Kind -> ZonkBndrT TcM Kind)
-> ZonkT TcM Kind -> ZonkBndrT TcM Kind
forall a b. (a -> b) -> a -> b
$ Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX XInvisPat GhcTc
Kind
ty
       ; return (InvisPat ty' tp) }

zonk_pat (XPat XXPat GhcTc
ext) = case XXPat GhcTc
ext of
  { ExpansionPat Pat GhcRn
orig Pat GhcTc
pat->
    do { pat' <- Pat GhcTc -> ZonkBndrTcM (Pat GhcTc)
zonk_pat Pat GhcTc
pat
       ; return $ XPat $ ExpansionPat orig pat' }
  ; CoPat HsWrapper
co_fn Pat GhcTc
pat Kind
ty ->
    do { co_fn' <- HsWrapper -> ZonkBndrT TcM HsWrapper
zonkCoFn HsWrapper
co_fn
       ; pat'   <- zonkPat (noLocA pat)
       ; ty'    <- noBinders $ zonkTcTypeToTypeX ty
       ; return (XPat $ CoPat co_fn' (unLoc pat') ty')
       } }

zonk_pat Pat GhcTc
pat = String -> SDoc -> ZonkBndrTcM (Pat GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"zonk_pat" (Pat GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat GhcTc
pat)

---------------------------
zonkConStuff :: HsConPatDetails GhcTc
             -> ZonkBndrTcM (HsConPatDetails GhcTc)
zonkConStuff :: HsConPatDetails GhcTc -> ZonkBndrTcM (HsConPatDetails GhcTc)
zonkConStuff (PrefixCon [LPat GhcTc]
pats)
  = do  { pats' <- [LPat GhcTc] -> ZonkBndrTcM [LPat GhcTc]
forall (f :: * -> *).
Traversable f =>
f (LPat GhcTc) -> ZonkBndrTcM (f (LPat GhcTc))
zonkPats [LPat GhcTc]
pats
        ; return (PrefixCon pats') }

zonkConStuff (InfixCon LPat GhcTc
p1 LPat GhcTc
p2)
  = do  { p1' <- LPat GhcTc -> ZonkBndrT TcM (LPat GhcTc)
zonkPat LPat GhcTc
p1
        ; p2' <- zonkPat p2
        ; return (InfixCon p1' p2') }

zonkConStuff (RecCon (HsRecFields XHsRecFields GhcTc
x [LHsRecField GhcTc (LPat GhcTc)]
rpats Maybe (XRec GhcTc RecFieldsDotDot)
dd))
  = do  { pats' <- [LPat GhcTc] -> ZonkBndrTcM [LPat GhcTc]
forall (f :: * -> *).
Traversable f =>
f (LPat GhcTc) -> ZonkBndrTcM (f (LPat GhcTc))
zonkPats ((GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
      (GenLocated SrcSpanAnnA (Pat GhcTc)))
 -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
         (GenLocated SrcSpanAnnA (Pat GhcTc)))]
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map (HsFieldBind
  (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
  (GenLocated SrcSpanAnnA (Pat GhcTc))
-> GenLocated SrcSpanAnnA (Pat GhcTc)
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS (HsFieldBind
   (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
   (GenLocated SrcSpanAnnA (Pat GhcTc))
 -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
         (GenLocated SrcSpanAnnA (Pat GhcTc)))
    -> HsFieldBind
         (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
         (GenLocated SrcSpanAnnA (Pat GhcTc)))
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
        (GenLocated SrcSpanAnnA (Pat GhcTc)))
-> GenLocated SrcSpanAnnA (Pat GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
     (GenLocated SrcSpanAnnA (Pat GhcTc)))
-> HsFieldBind
     (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
     (GenLocated SrcSpanAnnA (Pat GhcTc))
forall l e. GenLocated l e -> e
unLoc) [LHsRecField GhcTc (LPat GhcTc)]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
      (GenLocated SrcSpanAnnA (Pat GhcTc)))]
rpats)
        ; let rpats' = (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
      (GenLocated SrcSpanAnnA (Pat GhcTc)))
 -> GenLocated SrcSpanAnnA (Pat GhcTc)
 -> GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
         (GenLocated SrcSpanAnnA (Pat GhcTc))))
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
         (GenLocated SrcSpanAnnA (Pat GhcTc)))]
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
         (GenLocated SrcSpanAnnA (Pat GhcTc)))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(L SrcSpanAnnA
l HsFieldBind
  (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
  (GenLocated SrcSpanAnnA (Pat GhcTc))
rp) GenLocated SrcSpanAnnA (Pat GhcTc)
p' ->
                                  SrcSpanAnnA
-> HsFieldBind
     (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
     (GenLocated SrcSpanAnnA (Pat GhcTc))
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
        (GenLocated SrcSpanAnnA (Pat GhcTc)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsFieldBind
  (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
  (GenLocated SrcSpanAnnA (Pat GhcTc))
rp { hfbRHS = p' }))
                               [LHsRecField GhcTc (LPat GhcTc)]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (FieldOcc GhcTc))
      (GenLocated SrcSpanAnnA (Pat GhcTc)))]
rpats [GenLocated SrcSpanAnnA (Pat GhcTc)]
pats'
        ; return (RecCon (HsRecFields x rpats' dd)) }
        -- Field selectors have declared types; hence no zonking

---------------------------
zonkPats :: Traversable f => f (LPat GhcTc) -> ZonkBndrTcM (f (LPat GhcTc))
zonkPats :: forall (f :: * -> *).
Traversable f =>
f (LPat GhcTc) -> ZonkBndrTcM (f (LPat GhcTc))
zonkPats = (GenLocated SrcSpanAnnA (Pat GhcTc)
 -> ZonkBndrT TcM (GenLocated SrcSpanAnnA (Pat GhcTc)))
-> f (GenLocated SrcSpanAnnA (Pat GhcTc))
-> ZonkBndrT TcM (f (GenLocated SrcSpanAnnA (Pat GhcTc)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> f a -> f (f b)
traverse LPat GhcTc -> ZonkBndrT TcM (LPat GhcTc)
GenLocated SrcSpanAnnA (Pat GhcTc)
-> ZonkBndrT TcM (GenLocated SrcSpanAnnA (Pat GhcTc))
zonkPat
{-# SPECIALISE zonkPats :: [LPat GhcTc] -> ZonkBndrTcM [LPat GhcTc] #-}
{-# SPECIALISE zonkPats :: NonEmpty (LPat GhcTc) -> ZonkBndrTcM (NonEmpty (LPat GhcTc)) #-}

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

zonkForeignExports :: [LForeignDecl GhcTc]
                   -> ZonkTcM [LForeignDecl GhcTc]
zonkForeignExports :: [LForeignDecl GhcTc] -> ZonkTcM [LForeignDecl GhcTc]
zonkForeignExports [LForeignDecl GhcTc]
ls = (GenLocated SrcSpanAnnA (ForeignDecl GhcTc)
 -> ZonkT TcM (GenLocated SrcSpanAnnA (ForeignDecl GhcTc)))
-> [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
-> ZonkT TcM [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((ForeignDecl GhcTc -> ZonkTcM (ForeignDecl GhcTc))
-> GenLocated SrcSpanAnnA (ForeignDecl GhcTc)
-> ZonkT TcM (GenLocated SrcSpanAnnA (ForeignDecl GhcTc))
forall a b ann.
(a -> ZonkTcM b)
-> GenLocated (EpAnn ann) a -> ZonkTcM (GenLocated (EpAnn ann) b)
wrapLocZonkMA ForeignDecl GhcTc -> ZonkTcM (ForeignDecl GhcTc)
zonkForeignExport) [LForeignDecl GhcTc]
[GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
ls

zonkForeignExport :: ForeignDecl GhcTc -> ZonkTcM (ForeignDecl GhcTc)
zonkForeignExport :: ForeignDecl GhcTc -> ZonkTcM (ForeignDecl GhcTc)
zonkForeignExport (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 pass
fd_fe = ForeignExport GhcTc
spec })
  = do { i' <- GenLocated SrcSpanAnnN Id -> ZonkTcM (GenLocated SrcSpanAnnN Id)
zonkLIdOcc LIdP GhcTc
GenLocated SrcSpanAnnN Id
i
       ; return (ForeignExport { fd_name = i'
                               , fd_sig_ty = undefined, fd_e_ext = co
                               , fd_fe = spec }) }
zonkForeignExport ForeignDecl GhcTc
for_imp
  = ForeignDecl GhcTc -> ZonkTcM (ForeignDecl GhcTc)
forall a. a -> ZonkT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignDecl GhcTc
for_imp     -- Foreign imports don't need zonking

zonkRules :: [LRuleDecl GhcTc] -> ZonkTcM [LRuleDecl GhcTc]
zonkRules :: [LRuleDecl GhcTc] -> ZonkTcM [LRuleDecl GhcTc]
zonkRules [LRuleDecl GhcTc]
rs = (GenLocated SrcSpanAnnA (RuleDecl GhcTc)
 -> ZonkT TcM (GenLocated SrcSpanAnnA (RuleDecl GhcTc)))
-> [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
-> ZonkT TcM [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((RuleDecl GhcTc -> ZonkTcM (RuleDecl GhcTc))
-> GenLocated SrcSpanAnnA (RuleDecl GhcTc)
-> ZonkT TcM (GenLocated SrcSpanAnnA (RuleDecl GhcTc))
forall a b ann.
(a -> ZonkTcM b)
-> GenLocated (EpAnn ann) a -> ZonkTcM (GenLocated (EpAnn ann) b)
wrapLocZonkMA RuleDecl GhcTc -> ZonkTcM (RuleDecl GhcTc)
zonkRule) [LRuleDecl GhcTc]
[GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
rs

zonkRule :: RuleDecl GhcTc -> ZonkTcM (RuleDecl GhcTc)
zonkRule :: RuleDecl GhcTc -> ZonkTcM (RuleDecl GhcTc)
zonkRule rule :: RuleDecl GhcTc
rule@(HsRule { rd_bndrs :: forall pass. RuleDecl pass -> RuleBndrs pass
rd_bndrs = RuleBndrs GhcTc
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 { skol_tvs_ref <- TcM (IORef [Id]) -> ZonkT TcM (IORef [Id])
forall (m :: * -> *) a. Monad m => m a -> ZonkT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcM (IORef [Id]) -> ZonkT TcM (IORef [Id]))
-> TcM (IORef [Id]) -> ZonkT TcM (IORef [Id])
forall a b. (a -> b) -> a -> b
$ [Id] -> TcM (IORef [Id])
forall (m :: * -> *) a. MonadIO m => a -> m (TcRef a)
newTcRef []
       ; setZonkType (SkolemiseFlexi skol_tvs_ref) $
           -- setZonkType: see Note [Free tyvars on rule LHS]
         zonkRuleBndrs bndrs $ \ RuleBndrs GhcTc
new_bndrs ->
         do { new_lhs  <- LHsExpr GhcTc -> ZonkT TcM (LHsExpr GhcTc)
zonkLExpr LHsExpr GhcTc
lhs
            ; skol_tvs <- lift $ readTcRef skol_tvs_ref
            ; new_rhs  <- setZonkType DefaultFlexi $ zonkLExpr rhs
            ; return $ rule { rd_bndrs = add_tvs skol_tvs new_bndrs
                            , rd_lhs   = new_lhs
                            , rd_rhs   = new_rhs } } }
   where
     add_tvs :: [TyVar] -> RuleBndrs GhcTc -> RuleBndrs GhcTc
     add_tvs :: [Id] -> RuleBndrs GhcTc -> RuleBndrs GhcTc
add_tvs [Id]
tvs rbs :: RuleBndrs GhcTc
rbs@(RuleBndrs { rb_ext :: forall pass. RuleBndrs pass -> XCRuleBndrs pass
rb_ext = XCRuleBndrs GhcTc
bndrs }) = RuleBndrs GhcTc
rbs { rb_ext = tvs ++ bndrs }


zonkRuleBndrs :: RuleBndrs GhcTc -> (RuleBndrs GhcTc -> ZonkTcM a) -> ZonkTcM a
zonkRuleBndrs :: forall a.
RuleBndrs GhcTc -> (RuleBndrs GhcTc -> ZonkTcM a) -> ZonkTcM a
zonkRuleBndrs rb :: RuleBndrs GhcTc
rb@(RuleBndrs { rb_ext :: forall pass. RuleBndrs pass -> XCRuleBndrs pass
rb_ext = XCRuleBndrs GhcTc
bndrs }) RuleBndrs GhcTc -> ZonkTcM a
thing_inside
  = ZonkBndrTcM [Id] -> forall r. ([Id] -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ((Id -> ZonkBndrT TcM Id) -> [Id] -> ZonkBndrTcM [Id]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Id -> ZonkBndrT TcM Id
zonk_it [Id]
XCRuleBndrs GhcTc
bndrs) (([Id] -> ZonkTcM a) -> ZonkTcM a)
-> ([Id] -> ZonkTcM a) -> ZonkTcM a
forall a b. (a -> b) -> a -> b
$ \ [Id]
new_bndrs ->
    RuleBndrs GhcTc -> ZonkTcM a
thing_inside (RuleBndrs GhcTc
rb { rb_ext = new_bndrs })
  where
    zonk_it :: Id -> ZonkBndrT TcM Id
zonk_it Id
v
      | Id -> Bool
isId Id
v     = Id -> ZonkBndrT TcM Id
zonkIdBndrX Id
v
      | Bool
otherwise  = Bool -> ZonkBndrT TcM Id -> ZonkBndrT TcM Id
forall a. HasCallStack => Bool -> a -> a
assert (Id -> Bool
isImmutableTyVar Id
v) (ZonkBndrT TcM Id -> ZonkBndrT TcM Id)
-> ZonkBndrT TcM Id -> ZonkBndrT TcM Id
forall a b. (a -> b) -> a -> b
$
                     Id -> ZonkBndrT TcM Id
zonkTyBndrX Id
v
                     -- We may need to go inside the kind of v and zonk there!

{- Note [Free tyvars on rule LHS]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  data T a = C

  foo :: T a -> Int
  foo C = 1

  {-# RULES "myrule"  foo C = 1 #-}

After type checking the LHS becomes (foo alpha (C alpha)), where alpha
is an unbound meta-tyvar.  The zonker in GHC.Tc.Zonk.Type is careful not to
turn the free alpha into Any (as it usually does).  Instead we want to quantify
over it.   Here is how:

* We set the ze_flexi field of ZonkEnv to (SkolemiseFlexi ref), to tell the
  zonker to zonk a Flexi meta-tyvar to a TyVar, not to Any.  See the
  SkolemiseFlexi case of `commitFlexi`.

* Here (ref :: TcRef [TyVar]) collects the type variables thus skolemised;
  again see `commitFlexi`.

* When zonking a RULE, in `zonkRule` we
   - make a fresh ref-cell to collect the skolemised type variables,
   - zonk the binders and LHS with ze_flexi = SkolemiseFlexi ref
   - read the ref-cell to get all the skolemised TyVars
   - add them to the binders

All this applies for SPECIALISE pragmas too.

Wrinkles:

(FTV1) We just add the new tyvars to the front of the binder-list, but
  that may make the list not be in dependency order.  Example (T12925):
  the existing list is  [k:Type, b:k], and we add (a:k) to the front.
  Also we just collect the new skolemised type variables in any old order,
  so they may not be ordered with respect to each other.
-}

{-
************************************************************************
*                                                                      *
              Constraints and evidence
*                                                                      *
************************************************************************
-}

zonkEvTerm :: EvTerm -> ZonkTcM EvTerm
zonkEvTerm :: EvTerm -> ZonkT TcM EvTerm
zonkEvTerm (EvExpr EvExpr
e)
  = EvExpr -> EvTerm
EvExpr (EvExpr -> EvTerm) -> ZonkT TcM EvExpr -> ZonkT TcM EvTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvExpr -> ZonkT TcM EvExpr
zonkCoreExpr EvExpr
e
zonkEvTerm (EvTypeable Kind
ty EvTypeable
ev)
  = Kind -> EvTypeable -> EvTerm
EvTypeable (Kind -> EvTypeable -> EvTerm)
-> ZonkT TcM Kind -> ZonkT TcM (EvTypeable -> EvTerm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Kind
ty ZonkT TcM (EvTypeable -> EvTerm)
-> ZonkT TcM EvTypeable -> ZonkT TcM EvTerm
forall a b. ZonkT TcM (a -> b) -> ZonkT TcM a -> ZonkT TcM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EvTypeable -> ZonkT TcM EvTypeable
zonkEvTypeable EvTypeable
ev
zonkEvTerm (EvFun { et_tvs :: EvTerm -> [Id]
et_tvs = [Id]
tvs, et_given :: EvTerm -> [Id]
et_given = [Id]
evs
                  , et_binds :: EvTerm -> TcEvBinds
et_binds = TcEvBinds
ev_binds, et_body :: EvTerm -> Id
et_body = Id
body_id })
  = ZonkBndrTcM [Id] -> forall r. ([Id] -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ([Id] -> ZonkBndrTcM [Id]
zonkTyBndrsX [Id]
tvs)       (([Id] -> ZonkT TcM EvTerm) -> ZonkT TcM EvTerm)
-> ([Id] -> ZonkT TcM EvTerm) -> ZonkT TcM EvTerm
forall a b. (a -> b) -> a -> b
$ \ [Id]
new_tvs      ->
    ZonkBndrTcM [Id] -> forall r. ([Id] -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ([Id] -> ZonkBndrTcM [Id]
zonkEvBndrsX [Id]
evs)       (([Id] -> ZonkT TcM EvTerm) -> ZonkT TcM EvTerm)
-> ([Id] -> ZonkT TcM EvTerm) -> ZonkT TcM EvTerm
forall a b. (a -> b) -> a -> b
$ \ [Id]
new_evs      ->
    ZonkBndrTcM TcEvBinds
-> forall r. (TcEvBinds -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT (TcEvBinds -> ZonkBndrTcM TcEvBinds
zonkTcEvBinds TcEvBinds
ev_binds) ((TcEvBinds -> ZonkT TcM EvTerm) -> ZonkT TcM EvTerm)
-> (TcEvBinds -> ZonkT TcM EvTerm) -> ZonkT TcM EvTerm
forall a b. (a -> b) -> a -> b
$ \ TcEvBinds
new_ev_binds ->
  do { new_body_id  <- Id -> ZonkT TcM Id
zonkIdOcc Id
body_id
     ; return (EvFun { et_tvs = new_tvs, et_given = new_evs
                     , et_binds = new_ev_binds, et_body = new_body_id }) }

zonkCoreExpr :: CoreExpr -> ZonkTcM CoreExpr
zonkCoreExpr :: EvExpr -> ZonkT TcM EvExpr
zonkCoreExpr (Var Id
v)
    | Id -> Bool
isCoVar Id
v
    = Coercion -> EvExpr
forall b. Coercion -> Expr b
Coercion (Coercion -> EvExpr) -> ZonkTcM Coercion -> ZonkT TcM EvExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> ZonkTcM Coercion
zonkCoVarOcc Id
v
    | Bool
otherwise
    = Id -> EvExpr
forall b. Id -> Expr b
Var (Id -> EvExpr) -> ZonkT TcM Id -> ZonkT TcM EvExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> ZonkT TcM Id
zonkIdOcc Id
v
zonkCoreExpr (Lit Literal
l)
    = EvExpr -> ZonkT TcM EvExpr
forall a. a -> ZonkT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (EvExpr -> ZonkT TcM EvExpr) -> EvExpr -> ZonkT TcM EvExpr
forall a b. (a -> b) -> a -> b
$ Literal -> EvExpr
forall b. Literal -> Expr b
Lit Literal
l
zonkCoreExpr (Coercion Coercion
co)
    = Coercion -> EvExpr
forall b. Coercion -> Expr b
Coercion (Coercion -> EvExpr) -> ZonkTcM Coercion -> ZonkT TcM EvExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Coercion -> ZonkTcM Coercion
zonkCoToCo Coercion
co
zonkCoreExpr (Type Kind
ty)
    = Kind -> EvExpr
forall b. Kind -> Expr b
Type (Kind -> EvExpr) -> ZonkT TcM Kind -> ZonkT TcM EvExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Kind
ty

zonkCoreExpr (Cast EvExpr
e Coercion
co)
    = EvExpr -> Coercion -> EvExpr
forall b. Expr b -> Coercion -> Expr b
Cast (EvExpr -> Coercion -> EvExpr)
-> ZonkT TcM EvExpr -> ZonkT TcM (Coercion -> EvExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvExpr -> ZonkT TcM EvExpr
zonkCoreExpr EvExpr
e ZonkT TcM (Coercion -> EvExpr)
-> ZonkTcM Coercion -> ZonkT TcM EvExpr
forall a b. ZonkT TcM (a -> b) -> ZonkT TcM a -> ZonkT TcM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Coercion -> ZonkTcM Coercion
zonkCoToCo Coercion
co
zonkCoreExpr (Tick CoreTickish
t EvExpr
e)
    = CoreTickish -> EvExpr -> EvExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t (EvExpr -> EvExpr) -> ZonkT TcM EvExpr -> ZonkT TcM EvExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvExpr -> ZonkT TcM EvExpr
zonkCoreExpr EvExpr
e -- Do we need to zonk in ticks?

zonkCoreExpr (App EvExpr
e1 EvExpr
e2)
    = EvExpr -> EvExpr -> EvExpr
forall b. Expr b -> Expr b -> Expr b
App (EvExpr -> EvExpr -> EvExpr)
-> ZonkT TcM EvExpr -> ZonkT TcM (EvExpr -> EvExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvExpr -> ZonkT TcM EvExpr
zonkCoreExpr EvExpr
e1 ZonkT TcM (EvExpr -> EvExpr)
-> ZonkT TcM EvExpr -> ZonkT TcM EvExpr
forall a b. ZonkT TcM (a -> b) -> ZonkT TcM a -> ZonkT TcM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EvExpr -> ZonkT TcM EvExpr
zonkCoreExpr EvExpr
e2
zonkCoreExpr (Lam Id
v EvExpr
e)
    = ZonkBndrT TcM Id -> forall r. (Id -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT (Id -> ZonkBndrT TcM Id
zonkCoreBndrX Id
v) ((Id -> ZonkT TcM EvExpr) -> ZonkT TcM EvExpr)
-> (Id -> ZonkT TcM EvExpr) -> ZonkT TcM EvExpr
forall a b. (a -> b) -> a -> b
$ \ Id
v' ->
      Id -> EvExpr -> EvExpr
forall b. b -> Expr b -> Expr b
Lam Id
v' (EvExpr -> EvExpr) -> ZonkT TcM EvExpr -> ZonkT TcM EvExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvExpr -> ZonkT TcM EvExpr
zonkCoreExpr EvExpr
e
zonkCoreExpr (Let Bind Id
bind EvExpr
e)
    = ZonkBndrT TcM (Bind Id)
-> forall r. (Bind Id -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT (Bind Id -> ZonkBndrT TcM (Bind Id)
zonkCoreBind Bind Id
bind) ((Bind Id -> ZonkT TcM EvExpr) -> ZonkT TcM EvExpr)
-> (Bind Id -> ZonkT TcM EvExpr) -> ZonkT TcM EvExpr
forall a b. (a -> b) -> a -> b
$ \ Bind Id
bind' ->
      Bind Id -> EvExpr -> EvExpr
forall b. Bind b -> Expr b -> Expr b
Let Bind Id
bind' (EvExpr -> EvExpr) -> ZonkT TcM EvExpr -> ZonkT TcM EvExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvExpr -> ZonkT TcM EvExpr
zonkCoreExpr EvExpr
e
zonkCoreExpr (Case EvExpr
scrut Id
b Kind
ty [Alt Id]
alts)
    = do { scrut' <- EvExpr -> ZonkT TcM EvExpr
zonkCoreExpr EvExpr
scrut
         ; ty' <- zonkTcTypeToTypeX ty
         ; runZonkBndrT (zonkIdBndrX b) $ \ Id
b' ->
      do { alts' <- (Alt Id -> ZonkT TcM (Alt Id)) -> [Alt Id] -> ZonkT TcM [Alt Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Alt Id -> ZonkT TcM (Alt Id)
zonkCoreAlt [Alt Id]
alts
         ; return $ Case scrut' b' ty' alts' } }

zonkCoreAlt :: CoreAlt -> ZonkTcM CoreAlt
zonkCoreAlt :: Alt Id -> ZonkT TcM (Alt Id)
zonkCoreAlt (Alt AltCon
dc [Id]
bndrs EvExpr
rhs)
    = ZonkBndrTcM [Id] -> forall r. ([Id] -> ZonkT TcM r) -> ZonkT TcM r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ([Id] -> ZonkBndrTcM [Id]
zonkCoreBndrsX [Id]
bndrs) (([Id] -> ZonkT TcM (Alt Id)) -> ZonkT TcM (Alt Id))
-> ([Id] -> ZonkT TcM (Alt Id)) -> ZonkT TcM (Alt Id)
forall a b. (a -> b) -> a -> b
$ \ [Id]
bndrs' ->
      do { rhs' <- EvExpr -> ZonkT TcM EvExpr
zonkCoreExpr EvExpr
rhs
         ; return $ Alt dc bndrs' rhs' }

zonkCoreBind :: CoreBind -> ZonkBndrTcM CoreBind
zonkCoreBind :: Bind Id -> ZonkBndrT TcM (Bind Id)
zonkCoreBind (NonRec Id
v EvExpr
e)
    = do { (v',e') <- ZonkT TcM (Id, EvExpr) -> ZonkBndrT TcM (Id, EvExpr)
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkT TcM (Id, EvExpr) -> ZonkBndrT TcM (Id, EvExpr))
-> ZonkT TcM (Id, EvExpr) -> ZonkBndrT TcM (Id, EvExpr)
forall a b. (a -> b) -> a -> b
$ (Id, EvExpr) -> ZonkT TcM (Id, EvExpr)
zonkCorePair (Id
v,EvExpr
e)
         ; extendIdZonkEnv v'
         ; return (NonRec v' e') }
zonkCoreBind (Rec [(Id, EvExpr)]
pairs)
    = do pairs' <- ([(Id, EvExpr)] -> ZonkBndrT TcM [(Id, EvExpr)])
-> ZonkBndrT TcM [(Id, EvExpr)]
forall a. (a -> ZonkBndrT TcM a) -> ZonkBndrT TcM a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix [(Id, EvExpr)] -> ZonkBndrT TcM [(Id, EvExpr)]
go
         return $ Rec pairs'
  where
    go :: [(Id, EvExpr)] -> ZonkBndrT TcM [(Id, EvExpr)]
go [(Id, EvExpr)]
new_pairs = do
      [Id] -> ZonkBndrT TcM ()
forall (m :: * -> *). [Id] -> ZonkBndrT m ()
extendIdZonkEnvRec (((Id, EvExpr) -> Id) -> [(Id, EvExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, EvExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, EvExpr)]
new_pairs)
      ZonkT TcM [(Id, EvExpr)] -> ZonkBndrT TcM [(Id, EvExpr)]
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkT TcM [(Id, EvExpr)] -> ZonkBndrT TcM [(Id, EvExpr)])
-> ZonkT TcM [(Id, EvExpr)] -> ZonkBndrT TcM [(Id, EvExpr)]
forall a b. (a -> b) -> a -> b
$ ((Id, EvExpr) -> ZonkT TcM (Id, EvExpr))
-> [(Id, EvExpr)] -> ZonkT TcM [(Id, EvExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Id, EvExpr) -> ZonkT TcM (Id, EvExpr)
zonkCorePair [(Id, EvExpr)]
pairs

zonkCorePair :: (CoreBndr, CoreExpr) -> ZonkTcM (CoreBndr, CoreExpr)
zonkCorePair :: (Id, EvExpr) -> ZonkT TcM (Id, EvExpr)
zonkCorePair (Id
v,EvExpr
e) =
  do { v' <- Id -> ZonkT TcM Id
zonkIdBndr Id
v
     ; e' <- zonkCoreExpr e
     ; return (v',e') }

zonkEvTypeable :: EvTypeable -> ZonkTcM EvTypeable
zonkEvTypeable :: EvTypeable -> ZonkT TcM EvTypeable
zonkEvTypeable (EvTypeableTyCon TcTyCon
tycon [EvTerm]
e)
  = do { e'  <- (EvTerm -> ZonkT TcM EvTerm) -> [EvTerm] -> ZonkT TcM [EvTerm]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM EvTerm -> ZonkT TcM EvTerm
zonkEvTerm [EvTerm]
e
       ; return $ EvTypeableTyCon tycon e' }
zonkEvTypeable (EvTypeableTyApp EvTerm
t1 EvTerm
t2)
  = do { t1' <- EvTerm -> ZonkT TcM EvTerm
zonkEvTerm EvTerm
t1
       ; t2' <- zonkEvTerm t2
       ; return (EvTypeableTyApp t1' t2') }
zonkEvTypeable (EvTypeableTrFun EvTerm
tm EvTerm
t1 EvTerm
t2)
  = do { tm' <- EvTerm -> ZonkT TcM EvTerm
zonkEvTerm EvTerm
tm
       ; t1' <- zonkEvTerm t1
       ; t2' <- zonkEvTerm t2
       ; return (EvTypeableTrFun tm' t1' t2') }
zonkEvTypeable (EvTypeableTyLit EvTerm
t1)
  = do { t1' <- EvTerm -> ZonkT TcM EvTerm
zonkEvTerm EvTerm
t1
       ; return (EvTypeableTyLit t1') }

zonkTcEvBinds_s :: [TcEvBinds] -> ZonkBndrTcM [TcEvBinds]
zonkTcEvBinds_s :: [TcEvBinds] -> ZonkBndrT TcM [TcEvBinds]
zonkTcEvBinds_s [TcEvBinds]
bs = do { bs' <- (TcEvBinds -> ZonkBndrT TcM (Bag EvBind))
-> [TcEvBinds] -> ZonkBndrT TcM [Bag EvBind]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse TcEvBinds -> ZonkBndrT TcM (Bag EvBind)
zonk_tc_ev_binds [TcEvBinds]
bs
                        ; return ([EvBinds (unionManyBags bs')]) }

zonkTcEvBinds :: TcEvBinds -> ZonkBndrTcM TcEvBinds
zonkTcEvBinds :: TcEvBinds -> ZonkBndrTcM TcEvBinds
zonkTcEvBinds TcEvBinds
bs = do { bs' <- TcEvBinds -> ZonkBndrT TcM (Bag EvBind)
zonk_tc_ev_binds TcEvBinds
bs
                      ; return (EvBinds bs') }

zonk_tc_ev_binds :: TcEvBinds -> ZonkBndrTcM (Bag EvBind)
zonk_tc_ev_binds :: TcEvBinds -> ZonkBndrT TcM (Bag EvBind)
zonk_tc_ev_binds (TcEvBinds EvBindsVar
var) = EvBindsVar -> ZonkBndrT TcM (Bag EvBind)
zonkEvBindsVar EvBindsVar
var
zonk_tc_ev_binds (EvBinds Bag EvBind
bs)    = Bag EvBind -> ZonkBndrT TcM (Bag EvBind)
zonkEvBinds Bag EvBind
bs

zonkEvBindsVar :: EvBindsVar -> ZonkBndrTcM (Bag EvBind)
zonkEvBindsVar :: EvBindsVar -> ZonkBndrT TcM (Bag EvBind)
zonkEvBindsVar (EvBindsVar { ebv_binds :: EvBindsVar -> IORef EvBindMap
ebv_binds = IORef EvBindMap
ref })
  = do { bs <- IORef EvBindMap -> ZonkBndrT TcM EvBindMap
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef IORef EvBindMap
ref
       ; zonkEvBinds (evBindMapBinds bs) }
zonkEvBindsVar (CoEvBindsVar {}) = Bag EvBind -> ZonkBndrT TcM (Bag EvBind)
forall a. a -> ZonkBndrT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bag EvBind
forall a. Bag a
emptyBag

zonkEvBinds :: Bag EvBind -> ZonkBndrTcM (Bag EvBind)
zonkEvBinds :: Bag EvBind -> ZonkBndrT TcM (Bag EvBind)
zonkEvBinds Bag EvBind
binds
  = {-# SCC "zonkEvBinds" #-}
    (Bag EvBind -> ZonkBndrT TcM (Bag EvBind))
-> ZonkBndrT TcM (Bag EvBind)
forall a. (a -> ZonkBndrT TcM a) -> ZonkBndrT TcM a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((Bag EvBind -> ZonkBndrT TcM (Bag EvBind))
 -> ZonkBndrT TcM (Bag EvBind))
-> (Bag EvBind -> ZonkBndrT TcM (Bag EvBind))
-> ZonkBndrT TcM (Bag EvBind)
forall a b. (a -> b) -> a -> b
$ \ Bag EvBind
new_binds ->
  do { [Id] -> ZonkBndrT TcM ()
forall (m :: * -> *). [Id] -> ZonkBndrT m ()
extendIdZonkEnvRec (Bag EvBind -> [Id]
collect_ev_bndrs Bag EvBind
new_binds)
     ; ZonkT TcM (Bag EvBind) -> ZonkBndrT TcM (Bag EvBind)
forall (m :: * -> *) a. Monad m => ZonkT m a -> ZonkBndrT m a
noBinders (ZonkT TcM (Bag EvBind) -> ZonkBndrT TcM (Bag EvBind))
-> ZonkT TcM (Bag EvBind) -> ZonkBndrT TcM (Bag EvBind)
forall a b. (a -> b) -> a -> b
$ (EvBind -> ZonkT TcM EvBind)
-> Bag EvBind -> ZonkT TcM (Bag EvBind)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM EvBind -> ZonkT TcM EvBind
zonkEvBind Bag EvBind
binds }
  where
    collect_ev_bndrs :: Bag EvBind -> [EvVar]
    collect_ev_bndrs :: Bag EvBind -> [Id]
collect_ev_bndrs = (EvBind -> [Id] -> [Id]) -> [Id] -> Bag EvBind -> [Id]
forall a b. (a -> b -> b) -> b -> Bag a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr EvBind -> [Id] -> [Id]
add []
    add :: EvBind -> [Id] -> [Id]
add (EvBind { eb_lhs :: EvBind -> Id
eb_lhs = Id
var }) [Id]
vars = Id
var Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
vars

zonkEvBind :: EvBind -> ZonkTcM EvBind
zonkEvBind :: EvBind -> ZonkT TcM EvBind
zonkEvBind bind :: EvBind
bind@(EvBind { eb_lhs :: EvBind -> Id
eb_lhs = Id
var, eb_rhs :: EvBind -> EvTerm
eb_rhs = EvTerm
term })
  = do { var'  <- {-# SCC "zonkEvBndr" #-} Id -> ZonkT TcM Id
zonkEvBndr Id
var

         -- Optimise the common case of Refl coercions
         -- See Note [Optimise coercion zonking]
         -- This has a very big effect on some programs (eg #5030)

       ; term' <- case getEqPredTys_maybe (idType var') of
           Just (Role
r, Kind
ty1, Kind
ty2) | Kind
ty1 HasCallStack => Kind -> Kind -> Bool
Kind -> Kind -> Bool
`eqType` Kind
ty2
                  -> EvTerm -> ZonkT TcM EvTerm
forall a. a -> ZonkT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> EvTerm
evCoercion (Role -> Kind -> Coercion
mkReflCo Role
r Kind
ty1))
           Maybe (Role, Kind, Kind)
_other -> EvTerm -> ZonkT TcM EvTerm
zonkEvTerm EvTerm
term

       ; return (bind { eb_lhs = var', eb_rhs = term' }) }

{- Note [Optimise coercion zonking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When optimising evidence binds we may come across situations where
a coercion looks like
      cv = ReflCo ty
or    cv1 = cv2
where the type 'ty' is big.  In such cases it is a waste of time to zonk both
  * The variable on the LHS
  * The coercion on the RHS
Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just
use Refl on the right, ignoring the actual coercion on the RHS.

This can have a very big effect, because the constraint solver sometimes does go
to a lot of effort to prove Refl!  (Eg when solving  10+3 = 10+3; cf #5030)
-}

zonkTcMethInfoToMethInfoX :: TcMethInfo -> ZonkTcM MethInfo
zonkTcMethInfoToMethInfoX :: TcMethInfo -> ZonkTcM TcMethInfo
zonkTcMethInfoToMethInfoX (Name
name, Kind
ty, Maybe (DefMethSpec (SrcSpan, Kind))
gdm_spec)
  = do { ty' <- Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Kind
ty
       ; gdm_spec' <- zonk_gdm gdm_spec
       ; return (name, ty', gdm_spec') }
  where
    zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType))
             -> ZonkTcM (Maybe (DefMethSpec (SrcSpan, Type)))
    zonk_gdm :: Maybe (DefMethSpec (SrcSpan, Kind))
-> ZonkTcM (Maybe (DefMethSpec (SrcSpan, Kind)))
zonk_gdm Maybe (DefMethSpec (SrcSpan, Kind))
Nothing = Maybe (DefMethSpec (SrcSpan, Kind))
-> ZonkTcM (Maybe (DefMethSpec (SrcSpan, Kind)))
forall a. a -> ZonkT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (DefMethSpec (SrcSpan, Kind))
forall a. Maybe a
Nothing
    zonk_gdm (Just DefMethSpec (SrcSpan, Kind)
VanillaDM) = Maybe (DefMethSpec (SrcSpan, Kind))
-> ZonkTcM (Maybe (DefMethSpec (SrcSpan, Kind)))
forall a. a -> ZonkT TcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (DefMethSpec (SrcSpan, Kind) -> Maybe (DefMethSpec (SrcSpan, Kind))
forall a. a -> Maybe a
Just DefMethSpec (SrcSpan, Kind)
forall ty. DefMethSpec ty
VanillaDM)
    zonk_gdm (Just (GenericDM (SrcSpan
loc, Kind
ty)))
      = do { ty' <- Kind -> ZonkT TcM Kind
zonkTcTypeToTypeX Kind
ty
           ; return (Just (GenericDM (loc, ty'))) }

---------------------------------------
{- Note [Zonking the LHS of a RULE]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See also GHC.HsToCore.Binds Note [Free tyvars on rule LHS]

We need to gather the type variables mentioned on the LHS so we can
quantify over them.  Example:
  data T a = C

  foo :: T a -> Int
  foo C = 1

  {-# RULES "myrule"  foo C = 1 #-}

After type checking the LHS becomes (foo alpha (C alpha)) and we do
not want to zap the unbound meta-tyvar 'alpha' to Any, because that
limits the applicability of the rule.  Instead, we want to quantify
over it!

We do this in two stages.

* During zonking, we skolemise the TcTyVar 'alpha' to TyVar 'a'.  We
  do this by using zonkTvSkolemising as the UnboundTyVarZonker in the
  ZonkEnv.  (This is in fact the whole reason that the ZonkEnv has a
  UnboundTyVarZonker.)

* In GHC.HsToCore.Binds, we quantify over it.  See GHC.HsToCore.Binds
  Note [Free tyvars on rule LHS]

Quantifying here is awkward because (a) the data type is big and (b)
finding the free type vars of an expression is necessarily monadic
operation. (consider /\a -> f @ b, where b is side-effected to a)
-}