{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
                                      -- in module Language.Haskell.Syntax.Extension
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}

{-
%
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

-}

module GHC.Tc.Gen.Expr
       ( tcCheckPolyExpr, tcCheckPolyExprNC,
         tcCheckMonoExpr, tcCheckMonoExprNC,
         tcMonoExpr, tcMonoExprNC,
         tcInferRho, tcInferRhoNC,
         tcPolyExpr, tcExpr,
         tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
         tcCheckId,
         ) where

import GHC.Prelude

import {-# SOURCE #-}   GHC.Tc.Gen.Splice( tcTypedSplice, tcTypedBracket, tcUntypedBracket )

import GHC.Hs
import GHC.Hs.Syn.Type
import GHC.Rename.Utils
import GHC.Tc.Utils.Zonk
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Types.Basic
import GHC.Types.Error
import GHC.Types.FieldLabel
import GHC.Types.Unique.Map ( UniqMap, listToUniqMap, lookupUniqMap )
import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic, hasFixedRuntimeRep )
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Gen.App
import GHC.Tc.Gen.Head
import GHC.Tc.Gen.Bind        ( tcLocalBinds )
import GHC.Tc.Instance.Family ( tcGetFamInstEnvs )
import GHC.Core.FamInstEnv    ( FamInstEnvs )
import GHC.Rename.Expr        ( mkExpandedExpr )
import GHC.Rename.Env         ( addUsedGRE )
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Arrow
import GHC.Tc.Gen.Match
import GHC.Tc.Gen.HsType
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType as TcType
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Coercion( mkSymCo )
import GHC.Tc.Types.Evidence
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Builtin.Uniques ( mkBuiltinUnique )
import GHC.Driver.Session
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Data.List.SetOps
import GHC.Data.Maybe
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import Control.Monad
import GHC.Core.Class(classTyCon)
import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )

import Language.Haskell.Syntax.Basic (FieldLabelString(..))

import Data.Function
import Data.List (partition, sortBy, intersect)
import qualified Data.List.NonEmpty as NE

import GHC.Data.Bag ( unitBag )

{-
************************************************************************
*                                                                      *
\subsection{Main wrappers}
*                                                                      *
************************************************************************
-}


tcCheckPolyExpr, tcCheckPolyExprNC
  :: LHsExpr GhcRn         -- Expression to type check
  -> TcSigmaType           -- Expected type (could be a polytype)
  -> TcM (LHsExpr GhcTc) -- Generalised expr with expected type

-- tcCheckPolyExpr is a convenient place (frequent but not too frequent)
-- place to add context information.
-- The NC version does not do so, usually because the caller wants
-- to do so themselves.

tcCheckPolyExpr :: LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr   LHsExpr GhcRn
expr Type
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExpr   LHsExpr GhcRn
expr (Type -> ExpRhoType
mkCheckExpType Type
res_ty)
tcCheckPolyExprNC :: LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
expr Type
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExprNC LHsExpr GhcRn
expr (Type -> ExpRhoType
mkCheckExpType Type
res_ty)

-- These versions take an ExpType
tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType
                           -> TcM (LHsExpr GhcTc)

tcPolyLExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExpr (L SrcSpanAnnA
loc HsExpr GhcRn
expr) ExpRhoType
res_ty
  = SrcSpanAnnA -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc   (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$  -- Set location /first/; see GHC.Tc.Utils.Monad
    HsExpr GhcRn -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
expr (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$  -- Note [Error contexts in generated code]
    do { HsExpr GhcTc
expr' <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr GhcRn
expr ExpRhoType
res_ty
       ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcTc
expr') }

tcPolyLExprNC :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExprNC (L SrcSpanAnnA
loc HsExpr GhcRn
expr) ExpRhoType
res_ty
  = SrcSpanAnnA -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc    (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
    do { HsExpr GhcTc
expr' <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr GhcRn
expr ExpRhoType
res_ty
       ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcTc
expr') }

---------------
tcCheckMonoExpr, tcCheckMonoExprNC
    :: LHsExpr GhcRn     -- Expression to type check
    -> TcRhoType         -- Expected type
                         -- Definitely no foralls at the top
    -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr :: LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr   LHsExpr GhcRn
expr Type
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr   LHsExpr GhcRn
expr (Type -> ExpRhoType
mkCheckExpType Type
res_ty)
tcCheckMonoExprNC :: LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
expr Type
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr GhcRn
expr (Type -> ExpRhoType
mkCheckExpType Type
res_ty)

tcMonoExpr, tcMonoExprNC
    :: LHsExpr GhcRn     -- Expression to type check
    -> ExpRhoType        -- Expected type
                         -- Definitely no foralls at the top
    -> TcM (LHsExpr GhcTc)

tcMonoExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr (L SrcSpanAnnA
loc HsExpr GhcRn
expr) ExpRhoType
res_ty
  = SrcSpanAnnA -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc   (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$  -- Set location /first/; see GHC.Tc.Utils.Monad
    HsExpr GhcRn -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
expr (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$  -- Note [Error contexts in generated code]
    do  { HsExpr GhcTc
expr' <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpRhoType
res_ty
        ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcTc
expr') }

tcMonoExprNC :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC (L SrcSpanAnnA
loc HsExpr GhcRn
expr) ExpRhoType
res_ty
  = SrcSpanAnnA -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
    do  { HsExpr GhcTc
expr' <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpRhoType
res_ty
        ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcTc
expr') }

---------------
tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
-- Infer a *rho*-type. The return type is always instantiated.
tcInferRho :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Type)
tcInferRho (L SrcSpanAnnA
loc HsExpr GhcRn
expr)
  = SrcSpanAnnA
-> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc   (TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type))
-> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall a b. (a -> b) -> a -> b
$  -- Set location /first/; see GHC.Tc.Utils.Monad
    HsExpr GhcRn
-> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
expr (TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type))
-> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall a b. (a -> b) -> a -> b
$  -- Note [Error contexts in generated code]
    do { (HsExpr GhcTc
expr', Type
rho) <- (ExpRhoType -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc, Type)
forall a. (ExpRhoType -> TcM a) -> TcM (a, Type)
tcInfer (HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr)
       ; (GenLocated SrcSpanAnnA (HsExpr GhcTc), Type)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr GhcTc), Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcTc
expr', Type
rho) }

tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Type)
tcInferRhoNC (L SrcSpanAnnA
loc HsExpr GhcRn
expr)
  = SrcSpanAnnA
-> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type))
-> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall a b. (a -> b) -> a -> b
$
    do { (HsExpr GhcTc
expr', Type
rho) <- (ExpRhoType -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc, Type)
forall a. (ExpRhoType -> TcM a) -> TcM (a, Type)
tcInfer (HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr)
       ; (GenLocated SrcSpanAnnA (HsExpr GhcTc), Type)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr GhcTc), Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcTc
expr', Type
rho) }


{- *********************************************************************
*                                                                      *
        tcExpr: the main expression typechecker
*                                                                      *
********************************************************************* -}

tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcPolyExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr GhcRn
expr ExpRhoType
res_ty
  = do { String -> SDoc -> TcRn ()
traceTc String
"tcPolyExpr" (ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty)
       ; (HsWrapper
wrap, HsExpr GhcTc
expr') <- UserTypeCtxt
-> ExpRhoType
-> (ExpRhoType -> TcM (HsExpr GhcTc))
-> TcM (HsWrapper, HsExpr GhcTc)
forall result.
UserTypeCtxt
-> ExpRhoType
-> (ExpRhoType -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemiseExpType UserTypeCtxt
GenSigCtxt ExpRhoType
res_ty ((ExpRhoType -> TcM (HsExpr GhcTc))
 -> TcM (HsWrapper, HsExpr GhcTc))
-> (ExpRhoType -> TcM (HsExpr GhcTc))
-> TcM (HsWrapper, HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ \ ExpRhoType
res_ty ->
                          HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpRhoType
res_ty
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap HsExpr GhcTc
expr' }

tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)

-- Use tcApp to typecheck applications, which are treated specially
-- by Quick Look.  Specifically:
--   - HsVar         lone variables, to ensure that they can get an
--                     impredicative instantiation (via Quick Look
--                     driven by res_ty (in checking mode)).
--   - HsApp         value applications
--   - HsAppType     type applications
--   - ExprWithTySig (e :: type)
--   - HsRecSel      overloaded record fields
--   - HsExpanded    renamer expansions
--   - HsOpApp       operator applications
--   - HsOverLit     overloaded literals
-- These constructors are the union of
--   - ones taken apart by GHC.Tc.Gen.Head.splitHsApps
--   - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe
-- See Note [Application chains and heads] in GHC.Tc.Gen.App
tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr e :: HsExpr GhcRn
e@(HsVar {})              ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsApp {})              ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(OpApp {})              ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsAppType {})          ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(ExprWithTySig {})      ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsRecSel {})           ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(XExpr (HsExpanded {})) ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty

tcExpr e :: HsExpr GhcRn
e@(HsOverLit XOverLitE GhcRn
_ HsOverLit GhcRn
lit) ExpRhoType
res_ty
  = do { Maybe (HsOverLit GhcTc)
mb_res <- HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc))
tcShortCutLit HsOverLit GhcRn
lit ExpRhoType
res_ty
         -- See Note [Short cut for overloaded literals] in GHC.Tc.Utils.Zonk
       ; case Maybe (HsOverLit GhcTc)
mb_res of
           Just HsOverLit GhcTc
lit' -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XOverLitE GhcTc -> HsOverLit GhcTc -> HsExpr GhcTc
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcTc
EpAnn NoEpAnns
forall a. EpAnn a
noAnn HsOverLit GhcTc
lit')
           Maybe (HsOverLit GhcTc)
Nothing   -> HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty }

-- Typecheck an occurrence of an unbound Id
--
-- Some of these started life as a true expression hole "_".
-- Others might simply be variables that accidentally have no binding site
tcExpr (HsUnboundVar XUnboundVar GhcRn
_ RdrName
occ) ExpRhoType
res_ty
  = do { Type
ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty    -- Allow Int# etc (#12531)
       ; HoleExprRef
her <- RdrName -> Type -> TcM HoleExprRef
emitNewExprHole RdrName
occ Type
ty
       ; UsageEnv -> TcRn ()
tcEmitBindingUsage UsageEnv
bottomUE   -- Holes fit any usage environment
                                       -- (#18491)
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XUnboundVar GhcTc -> RdrName -> HsExpr GhcTc
forall p. XUnboundVar p -> RdrName -> HsExpr p
HsUnboundVar XUnboundVar GhcTc
HoleExprRef
her RdrName
occ) }

tcExpr e :: HsExpr GhcRn
e@(HsLit XLitE GhcRn
x HsLit GhcRn
lit) ExpRhoType
res_ty
  = do { let lit_ty :: Type
lit_ty = HsLit GhcRn -> Type
forall (p :: Pass). HsLit (GhcPass p) -> Type
hsLitType HsLit GhcRn
lit
       ; HsExpr GhcRn
-> HsExpr GhcTc -> Type -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
e (XLitE GhcTc -> HsLit GhcTc -> HsExpr GhcTc
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcRn
XLitE GhcTc
x (HsLit GhcRn -> HsLit GhcTc
forall (p1 :: Pass) (p2 :: Pass).
HsLit (GhcPass p1) -> HsLit (GhcPass p2)
convertLit HsLit GhcRn
lit)) Type
lit_ty ExpRhoType
res_ty }

tcExpr (HsPar XPar GhcRn
x LHsToken "(" GhcRn
lpar LHsExpr GhcRn
expr LHsToken ")" GhcRn
rpar) ExpRhoType
res_ty
  = do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr GhcRn
expr ExpRhoType
res_ty
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XPar GhcTc
-> LHsToken "(" GhcTc
-> LHsExpr GhcTc
-> LHsToken ")" GhcTc
-> HsExpr GhcTc
forall p.
XPar p -> LHsToken "(" p -> LHsExpr p -> LHsToken ")" p -> HsExpr p
HsPar XPar GhcRn
XPar GhcTc
x LHsToken "(" GhcRn
LHsToken "(" GhcTc
lpar LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' LHsToken ")" GhcRn
LHsToken ")" GhcTc
rpar) }

tcExpr (HsPragE XPragE GhcRn
x HsPragE GhcRn
prag LHsExpr GhcRn
expr) ExpRhoType
res_ty
  = do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
expr ExpRhoType
res_ty
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XPragE GhcTc -> HsPragE GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p
HsPragE XPragE GhcRn
XPragE GhcTc
x (HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag HsPragE GhcRn
prag) LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') }

tcExpr (NegApp XNegApp GhcRn
x LHsExpr GhcRn
expr SyntaxExpr GhcRn
neg_expr) ExpRhoType
res_ty
  = do  { (GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', SyntaxExprTc
neg_expr')
            <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Type]
    -> [Type]
    -> IOEnv
         (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
NegateOrigin SyntaxExpr GhcRn
SyntaxExprRn
neg_expr [SyntaxOpType
SynAny] ExpRhoType
res_ty (([Type]
  -> [Type]
  -> IOEnv
       (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
 -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), SyntaxExprTc))
-> ([Type]
    -> [Type]
    -> IOEnv
         (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
               \[Type
arg_ty] [Type
arg_mult] ->
               Type -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
arg_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
expr Type
arg_ty
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XNegApp GhcTc -> LHsExpr GhcTc -> SyntaxExpr GhcTc -> HsExpr GhcTc
forall p. XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p
NegApp XNegApp GhcRn
XNegApp GhcTc
x LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' SyntaxExpr GhcTc
SyntaxExprTc
neg_expr') }

tcExpr e :: HsExpr GhcRn
e@(HsIPVar XIPVar GhcRn
_ HsIPName
x) ExpRhoType
res_ty
  = do { Type
ip_ty <- Type -> TcM Type
newFlexiTyVarTy Type
liftedTypeKind
          -- Create a unification type variable of kind 'Type'.
          -- (The type of an implicit parameter must have kind 'Type'.)
       ; let ip_name :: Type
ip_name = FastString -> Type
mkStrLitTy (HsIPName -> FastString
hsIPNameFS HsIPName
x)
       ; Class
ipClass <- Name -> TcM Class
tcLookupClass Name
ipClassName
       ; TyCoVar
ip_var <- CtOrigin -> Type -> TcM TyCoVar
emitWantedEvVar CtOrigin
origin (Class -> [Type] -> Type
mkClassPred Class
ipClass [Type
ip_name, Type
ip_ty])
       ; HsExpr GhcRn
-> HsExpr GhcTc -> Type -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
e
                   (Class -> Type -> Type -> HsExpr GhcTc -> HsExpr GhcTc
fromDict Class
ipClass Type
ip_name Type
ip_ty (XVar GhcTc -> LIdP GhcTc -> HsExpr GhcTc
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcTc
NoExtField
noExtField (TyCoVar -> LocatedAn NameAnn TyCoVar
forall a an. a -> LocatedAn an a
noLocA TyCoVar
ip_var)))
                   Type
ip_ty ExpRhoType
res_ty }
  where
  -- Coerces a dictionary for `IP "x" t` into `t`.
  fromDict :: Class -> Type -> Type -> HsExpr GhcTc -> HsExpr GhcTc
fromDict Class
ipClass Type
x Type
ty = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc)
-> HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsWrapper
mkWpCastR (TcCoercionR -> HsWrapper) -> TcCoercionR -> HsWrapper
forall a b. (a -> b) -> a -> b
$
                          Type -> TcCoercionR
unwrapIP (Type -> TcCoercionR) -> Type -> TcCoercionR
forall a b. (a -> b) -> a -> b
$ Class -> [Type] -> Type
mkClassPred Class
ipClass [Type
x,Type
ty]
  origin :: CtOrigin
origin = HsIPName -> CtOrigin
IPOccOrigin HsIPName
x

tcExpr (HsLam XLam GhcRn
_ MatchGroup GhcRn (LHsExpr GhcRn)
match) ExpRhoType
res_ty
  = do  { (HsWrapper
wrap, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
match') <- ExpectedFunTyOrigin
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchLambda ExpectedFunTyOrigin
herald TcMatchCtxt HsExpr
match_ctxt MatchGroup GhcRn (LHsExpr GhcRn)
match ExpRhoType
res_ty
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (XLam GhcTc -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcTc
NoExtField
noExtField MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
match')) }
  where
    match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC { mc_what :: HsMatchContext GhcTc
mc_what = HsMatchContext GhcTc
forall p. HsMatchContext p
LambdaExpr, mc_body :: LocatedA (HsExpr GhcRn)
-> ExpRhoType
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
LocatedA (HsExpr GhcRn)
-> ExpRhoType
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
tcBody }
    herald :: ExpectedFunTyOrigin
herald = MatchGroup GhcRn (LHsExpr GhcRn) -> ExpectedFunTyOrigin
ExpectedFunTyLam MatchGroup GhcRn (LHsExpr GhcRn)
match

tcExpr e :: HsExpr GhcRn
e@(HsLamCase XLamCase GhcRn
x LamCaseVariant
lc_variant MatchGroup GhcRn (LHsExpr GhcRn)
matches) ExpRhoType
res_ty
  = do { (HsWrapper
wrap, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches')
           <- ExpectedFunTyOrigin
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchLambda ExpectedFunTyOrigin
herald TcMatchCtxt HsExpr
match_ctxt MatchGroup GhcRn (LHsExpr GhcRn)
matches ExpRhoType
res_ty
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XLamCase GhcTc
-> LamCaseVariant
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> HsExpr GhcTc
forall p.
XLamCase p
-> LamCaseVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase XLamCase GhcRn
XLamCase GhcTc
x LamCaseVariant
lc_variant MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches') }
  where
    match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC { mc_what :: HsMatchContext GhcTc
mc_what = LamCaseVariant -> HsMatchContext GhcTc
forall p. LamCaseVariant -> HsMatchContext p
LamCaseAlt LamCaseVariant
lc_variant, mc_body :: LocatedA (HsExpr GhcRn)
-> ExpRhoType
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
LocatedA (HsExpr GhcRn)
-> ExpRhoType
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
tcBody }
    herald :: ExpectedFunTyOrigin
herald = LamCaseVariant -> HsExpr GhcRn -> ExpectedFunTyOrigin
ExpectedFunTyLamCase LamCaseVariant
lc_variant HsExpr GhcRn
e



{-
************************************************************************
*                                                                      *
                Explicit lists
*                                                                      *
************************************************************************
-}

-- Explicit lists [e1,e2,e3] have been expanded already in the renamer
-- The expansion includes an ExplicitList, but it is always the built-in
-- list type, so that's all we need concern ourselves with here.  See
-- GHC.Rename.Expr. Note [Handling overloaded and rebindable constructs]
tcExpr (ExplicitList XExplicitList GhcRn
_ [LHsExpr GhcRn]
exprs) ExpRhoType
res_ty
  = do  { Type
res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
        ; (TcCoercionR
coi, Type
elt_ty) <- Type -> TcM (TcCoercionR, Type)
matchExpectedListTy Type
res_ty
        ; let tc_elt :: LocatedA (HsExpr GhcRn) -> TcM (LHsExpr GhcTc)
tc_elt LocatedA (HsExpr GhcRn)
expr = LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
expr Type
elt_ty
        ; [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
exprs' <- (LocatedA (HsExpr GhcRn)
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> [LocatedA (HsExpr GhcRn)]
-> IOEnv
     (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnA (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 LocatedA (HsExpr GhcRn) -> TcM (LHsExpr GhcTc)
LocatedA (HsExpr GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
tc_elt [LHsExpr GhcRn]
[LocatedA (HsExpr GhcRn)]
exprs
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcTc -> [LHsExpr GhcTc] -> HsExpr GhcTc
forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList XExplicitList GhcTc
Type
elt_ty [LHsExpr GhcTc]
[GenLocated SrcSpanAnnA (HsExpr GhcTc)]
exprs' }

tcExpr expr :: HsExpr GhcRn
expr@(ExplicitTuple XExplicitTuple GhcRn
x [HsTupArg GhcRn]
tup_args Boxity
boxity) ExpRhoType
res_ty
  | (HsTupArg GhcRn -> Bool) -> [HsTupArg GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all HsTupArg GhcRn -> Bool
forall (p :: Pass). HsTupArg (GhcPass p) -> Bool
tupArgPresent [HsTupArg GhcRn]
tup_args
  = do { let arity :: Int
arity  = [HsTupArg GhcRn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsTupArg GhcRn]
tup_args
             tup_tc :: TyCon
tup_tc = Boxity -> Int -> TyCon
tupleTyCon Boxity
boxity Int
arity
               -- NB: tupleTyCon doesn't flatten 1-tuples
               -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
       ; Type
res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
       ; (TcCoercionR
coi, [Type]
arg_tys) <- TyCon -> Type -> TcM (TcCoercionR, [Type])
matchExpectedTyConApp TyCon
tup_tc Type
res_ty
                           -- Unboxed tuples have RuntimeRep vars, which we
                           -- don't care about here
                           -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
       ; let arg_tys' :: [Type]
arg_tys' = case Boxity
boxity of Boxity
Unboxed -> Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop Int
arity [Type]
arg_tys
                                       Boxity
Boxed   -> [Type]
arg_tys
       ; [HsTupArg GhcTc]
tup_args1 <- [HsTupArg GhcRn] -> [Type] -> TcM [HsTupArg GhcTc]
tcTupArgs [HsTupArg GhcRn]
tup_args [Type]
arg_tys'
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (XExplicitTuple GhcTc -> [HsTupArg GhcTc] -> Boxity -> HsExpr GhcTc
forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcRn
XExplicitTuple GhcTc
x [HsTupArg GhcTc]
tup_args1 Boxity
boxity) }

  | Bool
otherwise
  = -- The tup_args are a mixture of Present and Missing (for tuple sections)
    do { let arity :: Int
arity = [HsTupArg GhcRn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsTupArg GhcRn]
tup_args

       ; [Type]
arg_tys <- case Boxity
boxity of
           { Boxity
Boxed   -> Int -> Type -> IOEnv (Env TcGblEnv TcLclEnv) [Type]
newFlexiTyVarTys Int
arity Type
liftedTypeKind
           ; Boxity
Unboxed -> Int -> TcM Type -> IOEnv (Env TcGblEnv TcLclEnv) [Type]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
arity TcM Type
newOpenFlexiTyVarTy }

       -- Handle tuple sections where
       ; [HsTupArg GhcTc]
tup_args1 <- [HsTupArg GhcRn] -> [Type] -> TcM [HsTupArg GhcTc]
tcTupArgs [HsTupArg GhcRn]
tup_args [Type]
arg_tys

       ; let expr' :: HsExpr GhcTc
expr'       = XExplicitTuple GhcTc -> [HsTupArg GhcTc] -> Boxity -> HsExpr GhcTc
forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcRn
XExplicitTuple GhcTc
x [HsTupArg GhcTc]
tup_args1 Boxity
boxity
             missing_tys :: [Scaled Type]
missing_tys = [Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
mult Type
ty | (Missing (Scaled Type
mult Type
_), Type
ty) <- [HsTupArg GhcTc] -> [Type] -> [(HsTupArg GhcTc, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [HsTupArg GhcTc]
tup_args1 [Type]
arg_tys]

             -- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head
             -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
             act_res_ty :: Type
act_res_ty = [Scaled Type] -> Type -> Type
(() :: Constraint) => [Scaled Type] -> Type -> Type
mkScaledFunTys [Scaled Type]
missing_tys (Boxity -> [Type] -> Type
mkTupleTy1 Boxity
boxity [Type]
arg_tys)

       ; String -> SDoc -> TcRn ()
traceTc String
"ExplicitTuple" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
act_res_ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty)

       ; HsExpr GhcRn
-> HsExpr GhcTc -> Type -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' Type
act_res_ty ExpRhoType
res_ty }

tcExpr (ExplicitSum XExplicitSum GhcRn
_ Int
alt Int
arity LHsExpr GhcRn
expr) ExpRhoType
res_ty
  = do { let sum_tc :: TyCon
sum_tc = Int -> TyCon
sumTyCon Int
arity
       ; Type
res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
       ; (TcCoercionR
coi, [Type]
arg_tys) <- TyCon -> Type -> TcM (TcCoercionR, [Type])
matchExpectedTyConApp TyCon
sum_tc Type
res_ty
       ; -- Drop levity vars, we don't care about them here
         let arg_tys' :: [Type]
arg_tys' = Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop Int
arity [Type]
arg_tys
             arg_ty :: Type
arg_ty   = [Type]
arg_tys' [Type] -> Int -> Type
forall a. Outputable a => [a] -> Int -> a
`getNth` (Int
alt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
       ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr Type
arg_ty
       -- Check the whole res_ty, not just the arg_ty, to avoid #20277.
       -- Example:
       --   a :: TYPE rep (representation-polymorphic)
       --   (# 17# | #) :: (# Int# | a #)
       -- This should cause an error, even though (17# :: Int#)
       -- is not representation-polymorphic: we don't know how
       -- wide the concrete representation of the sum type will be.
       ; (() :: Constraint) => FixedRuntimeRepContext -> Type -> TcRn ()
FixedRuntimeRepContext -> Type -> TcRn ()
hasFixedRuntimeRep_syntactic FixedRuntimeRepContext
FRRUnboxedSum Type
res_ty
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (XExplicitSum GhcTc -> Int -> Int -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum [Type]
XExplicitSum GhcTc
arg_tys' Int
alt Int
arity LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' ) }


{-
************************************************************************
*                                                                      *
                Let, case, if, do
*                                                                      *
************************************************************************
-}

tcExpr (HsLet XLet GhcRn
x LHsToken "let" GhcRn
tkLet HsLocalBinds GhcRn
binds LHsToken "in" GhcRn
tkIn LHsExpr GhcRn
expr) ExpRhoType
res_ty
  = do  { (HsLocalBinds GhcTc
binds', GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') <- HsLocalBinds GhcRn
-> TcM (LHsExpr GhcTc) -> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
forall thing.
HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (TcM (LHsExpr GhcTc) -> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
                             LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
expr ExpRhoType
res_ty
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XLet GhcTc
-> LHsToken "let" GhcTc
-> HsLocalBinds GhcTc
-> LHsToken "in" GhcTc
-> LHsExpr GhcTc
-> HsExpr GhcTc
forall p.
XLet p
-> LHsToken "let" p
-> HsLocalBinds p
-> LHsToken "in" p
-> LHsExpr p
-> HsExpr p
HsLet XLet GhcRn
XLet GhcTc
x LHsToken "let" GhcRn
LHsToken "let" GhcTc
tkLet HsLocalBinds GhcTc
binds' LHsToken "in" GhcRn
LHsToken "in" GhcTc
tkIn LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') }

tcExpr (HsCase XCase GhcRn
x LHsExpr GhcRn
scrut MatchGroup GhcRn (LHsExpr GhcRn)
matches) ExpRhoType
res_ty
  = do  {  -- We used to typecheck the case alternatives first.
           -- The case patterns tend to give good type info to use
           -- when typechecking the scrutinee.  For example
           --   case (map f) of
           --     (x:xs) -> ...
           -- will report that map is applied to too few arguments
           --
           -- But now, in the GADT world, we need to typecheck the scrutinee
           -- first, to get type info that may be refined in the case alternatives
          Type
mult <- Type -> TcM Type
newFlexiTyVarTy Type
multiplicityTy

          -- Typecheck the scrutinee.  We use tcInferRho but tcInferSigma
          -- would also be possible (tcMatchesCase accepts sigma-types)
          -- Interesting litmus test: do these two behave the same?
          --     case id        of {..}
          --     case (\v -> v) of {..}
          -- This design choice is discussed in #17790
        ; (GenLocated SrcSpanAnnA (HsExpr GhcTc)
scrut', Type
scrut_ty) <- Type -> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
mult (TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type))
-> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Type)
tcInferRho LHsExpr GhcRn
scrut

        ; String -> SDoc -> TcRn ()
traceTc String
"HsCase" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
scrut_ty)
        ; (() :: Constraint) => FixedRuntimeRepContext -> Type -> TcRn ()
FixedRuntimeRepContext -> Type -> TcRn ()
hasFixedRuntimeRep_syntactic FixedRuntimeRepContext
FRRCase Type
scrut_ty
        ; MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches' <- TcMatchCtxt HsExpr
-> Scaled Type
-> MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
-> ExpRhoType
-> TcM (MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall (body :: * -> *).
AnnoBody body =>
TcMatchCtxt body
-> Scaled Type
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatchesCase TcMatchCtxt HsExpr
match_ctxt (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
mult Type
scrut_ty) MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
matches ExpRhoType
res_ty
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XCase GhcTc
-> LHsExpr GhcTc
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> HsExpr GhcTc
forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase XCase GhcRn
XCase GhcTc
x LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
scrut' MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches') }
 where
    match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC { mc_what :: HsMatchContext GhcTc
mc_what = HsMatchContext GhcTc
forall p. HsMatchContext p
CaseAlt,
                      mc_body :: LocatedA (HsExpr GhcRn)
-> ExpRhoType
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
LocatedA (HsExpr GhcRn)
-> ExpRhoType
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
tcBody }

tcExpr (HsIf XIf GhcRn
x LHsExpr GhcRn
pred LHsExpr GhcRn
b1 LHsExpr GhcRn
b2) ExpRhoType
res_ty
  = do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
pred'    <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
pred Type
boolTy
       ; (UsageEnv
u1,GenLocated SrcSpanAnnA (HsExpr GhcTc)
b1') <- TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc)
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage (TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
b1 ExpRhoType
res_ty
       ; (UsageEnv
u2,GenLocated SrcSpanAnnA (HsExpr GhcTc)
b2') <- TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc)
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage (TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
b2 ExpRhoType
res_ty
       ; UsageEnv -> TcRn ()
tcEmitBindingUsage (UsageEnv -> UsageEnv -> UsageEnv
supUE UsageEnv
u1 UsageEnv
u2)
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XIf GhcTc
-> LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XIf p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsIf XIf GhcRn
XIf GhcTc
x LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
pred' LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
b1' LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
b2') }

tcExpr (HsMultiIf XMultiIf GhcRn
_ [LGRHS GhcRn (LHsExpr GhcRn)]
alts) ExpRhoType
res_ty
  = do { [GenLocated
   (SrcAnn NoEpAnns)
   (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
alts' <- (GenLocated
   (SrcAnn NoEpAnns) (GRHS GhcRn (LocatedA (HsExpr GhcRn)))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated
         (SrcAnn NoEpAnns)
         (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> [GenLocated
      (SrcAnn NoEpAnns) (GRHS GhcRn (LocatedA (HsExpr GhcRn)))]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [GenLocated
        (SrcAnn NoEpAnns)
        (GRHS GhcTc (GenLocated SrcSpanAnnA (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 ((GRHS GhcRn (LocatedA (HsExpr GhcRn))
 -> TcM (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> GenLocated
     (SrcAnn NoEpAnns) (GRHS GhcRn (LocatedA (HsExpr GhcRn)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated
        (SrcAnn NoEpAnns)
        (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA ((GRHS GhcRn (LocatedA (HsExpr GhcRn))
  -> TcM (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
 -> GenLocated
      (SrcAnn NoEpAnns) (GRHS GhcRn (LocatedA (HsExpr GhcRn)))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated
         (SrcAnn NoEpAnns)
         (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> (GRHS GhcRn (LocatedA (HsExpr GhcRn))
    -> TcM (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> GenLocated
     (SrcAnn NoEpAnns) (GRHS GhcRn (LocatedA (HsExpr GhcRn)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated
        (SrcAnn NoEpAnns)
        (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a b. (a -> b) -> a -> b
$ TcMatchCtxt HsExpr
-> ExpRhoType
-> GRHS GhcRn (LocatedA (HsExpr GhcRn))
-> TcM (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall (body :: * -> *).
TcMatchCtxt body
-> ExpRhoType
-> GRHS GhcRn (LocatedA (body GhcRn))
-> TcM (GRHS GhcTc (LocatedA (body GhcTc)))
tcGRHS TcMatchCtxt HsExpr
match_ctxt ExpRhoType
res_ty) [LGRHS GhcRn (LHsExpr GhcRn)]
[GenLocated
   (SrcAnn NoEpAnns) (GRHS GhcRn (LocatedA (HsExpr GhcRn)))]
alts
       ; Type
res_ty <- ExpRhoType -> TcM Type
readExpType ExpRhoType
res_ty
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XMultiIf GhcTc -> [LGRHS GhcTc (LHsExpr GhcTc)] -> HsExpr GhcTc
forall p. XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p
HsMultiIf XMultiIf GhcTc
Type
res_ty [LGRHS GhcTc (LHsExpr GhcTc)]
[GenLocated
   (SrcAnn NoEpAnns)
   (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
alts') }
  where match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC { mc_what :: HsMatchContext GhcTc
mc_what = HsMatchContext GhcTc
forall p. HsMatchContext p
IfAlt, mc_body :: LocatedA (HsExpr GhcRn)
-> ExpRhoType
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
LocatedA (HsExpr GhcRn)
-> ExpRhoType
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
tcBody }

tcExpr (HsDo XDo GhcRn
_ HsDoFlavour
do_or_lc XRec GhcRn [ExprLStmt GhcRn]
stmts) ExpRhoType
res_ty
  = HsDoFlavour
-> LocatedL [ExprLStmt GhcRn] -> ExpRhoType -> TcM (HsExpr GhcTc)
tcDoStmts HsDoFlavour
do_or_lc XRec GhcRn [ExprLStmt GhcRn]
LocatedL [ExprLStmt GhcRn]
stmts ExpRhoType
res_ty

tcExpr (HsProc XProc GhcRn
x LPat GhcRn
pat LHsCmdTop GhcRn
cmd) ExpRhoType
res_ty
  = do  { (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', GenLocated (SrcAnn NoEpAnns) (HsCmdTop GhcTc)
cmd', TcCoercionR
coi) <- LPat GhcRn
-> LHsCmdTop GhcRn
-> ExpRhoType
-> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercionR)
tcProc LPat GhcRn
pat LHsCmdTop GhcRn
cmd ExpRhoType
res_ty
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (XProc GhcTc -> LPat GhcTc -> LHsCmdTop GhcTc -> HsExpr GhcTc
forall p. XProc p -> LPat p -> LHsCmdTop p -> HsExpr p
HsProc XProc GhcRn
XProc GhcTc
x LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' LHsCmdTop GhcTc
GenLocated (SrcAnn NoEpAnns) (HsCmdTop GhcTc)
cmd') }

-- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.
-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview.
-- To type check
--      (static e) :: p a
-- we want to check (e :: a),
-- and wrap (static e) in a call to
--    fromStaticPtr :: IsStatic p => StaticPtr a -> p a

tcExpr (HsStatic XStatic GhcRn
fvs LHsExpr GhcRn
expr) ExpRhoType
res_ty
  = do  { Type
res_ty          <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
        ; (TcCoercionR
co, (Type
p_ty, Type
expr_ty)) <- Type -> TcM (TcCoercionR, (Type, Type))
matchExpectedAppTy Type
res_ty
        ; (GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', WantedConstraints
lie)    <- IOEnv
  (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (IOEnv
   (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
 -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), WantedConstraints))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
            SDoc -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the body of a static form:")
                             Int
2 (LocatedA (HsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
expr)
                       ) (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
            LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
expr Type
expr_ty

        -- Check that the free variables of the static form are closed.
        -- It's OK to use nonDetEltsUniqSet here as the only side effects of
        -- checkClosedInStaticForm are error messages.
        ; (Name -> TcRn ()) -> [Name] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Name -> TcRn ()
checkClosedInStaticForm ([Name] -> TcRn ()) -> [Name] -> TcRn ()
forall a b. (a -> b) -> a -> b
$ UniqSet Name -> [Name]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet XStatic GhcRn
UniqSet Name
fvs

        -- Require the type of the argument to be Typeable.
        ; Class
typeableClass <- Name -> TcM Class
tcLookupClass Name
typeableClassName
        ; TyCoVar
typeable_ev <- CtOrigin -> Type -> TcM TyCoVar
emitWantedEvVar CtOrigin
StaticOrigin (Type -> TcM TyCoVar) -> Type -> TcM TyCoVar
forall a b. (a -> b) -> a -> b
$
                  TyCon -> [Type] -> Type
mkTyConApp (Class -> TyCon
classTyCon Class
typeableClass)
                             [Type
liftedTypeKind, Type
expr_ty]

        -- Insert the constraints of the static form in a global list for later
        -- validation.
        ; WantedConstraints -> TcRn ()
emitStaticConstraints WantedConstraints
lie

        -- Wrap the static form with the 'fromStaticPtr' call.
        ; HsExpr GhcTc
fromStaticPtr <- CtOrigin -> Name -> [Type] -> TcM (HsExpr GhcTc)
newMethodFromName CtOrigin
StaticOrigin Name
fromStaticPtrName
                                             [Type
p_ty]
        ; let wrap :: HsWrapper
wrap = [TyCoVar] -> HsWrapper
mkWpEvVarApps [TyCoVar
typeable_ev] HsWrapper -> HsWrapper -> HsWrapper
<.> [Type] -> HsWrapper
mkWpTyApps [Type
expr_ty]
        ; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
        ; TyCon
static_ptr_ty_con <- Name -> TcM TyCon
tcLookupTyCon Name
staticPtrTyConName
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
co (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTc
EpAnn NoEpAnns
noComments
                            (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap HsExpr GhcTc
fromStaticPtr)
                            (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (XStatic GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XStatic p -> LHsExpr p -> HsExpr p
HsStatic (XStatic GhcRn
UniqSet Name
fvs, TyCon -> [Type] -> Type
mkTyConApp TyCon
static_ptr_ty_con [Type
expr_ty]) LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr'))
        }

{-
************************************************************************
*                                                                      *
                Record construction and update
*                                                                      *
************************************************************************
-}

tcExpr expr :: HsExpr GhcRn
expr@(RecordCon { rcon_con :: forall p. HsExpr p -> XRec p (ConLikeP p)
rcon_con = L SrcSpanAnnN
loc Name
con_name
                       , rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcRn
rbinds }) ExpRhoType
res_ty
  = do  { ConLike
con_like <- Name -> TcM ConLike
tcLookupConLike Name
con_name

        ; (HsExpr GhcTc
con_expr, Type
con_sigma) <- Name -> TcM (HsExpr GhcTc, Type)
tcInferId Name
con_name
        ; (HsWrapper
con_wrap, Type
con_tau)   <- CtOrigin -> Type -> TcM (HsWrapper, Type)
topInstantiate CtOrigin
orig Type
con_sigma
              -- a shallow instantiation should really be enough for
              -- a data constructor.
        ; let arity :: Int
arity = ConLike -> Int
conLikeArity ConLike
con_like
              Right ([Scaled Type]
arg_tys, Type
actual_res_ty) = Int -> Type -> Either Int ([Scaled Type], Type)
tcSplitFunTysN Int
arity Type
con_tau

        ; Bool -> TcRnMessage -> TcRn ()
checkTc (ConLike -> Bool
conLikeHasBuilder ConLike
con_like) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
          Name -> TcRnMessage
nonBidirectionalErr (ConLike -> Name
conLikeName ConLike
con_like)

        ; HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rbinds' <- ConLike
-> [Type] -> HsRecordBinds GhcRn -> TcM (HsRecordBinds GhcTc)
tcRecordBinds ConLike
con_like ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys) HsRecordBinds GhcRn
rbinds
                   -- It is currently not possible for a record to have
                   -- multiplicities. When they do, `tcRecordBinds` will take
                   -- scaled types instead. Meanwhile, it's safe to take
                   -- `scaledThing` above, as we know all the multiplicities are
                   -- Many.

        ; let rcon_tc :: HsExpr GhcTc
rcon_tc = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
con_wrap HsExpr GhcTc
con_expr
              expr' :: HsExpr GhcTc
expr' = RecordCon { rcon_ext :: XRecordCon GhcTc
rcon_ext = XRecordCon GhcTc
HsExpr GhcTc
rcon_tc
                                , rcon_con :: XRec GhcTc (ConLikeP GhcTc)
rcon_con = SrcSpanAnnN -> ConLike -> GenLocated SrcSpanAnnN ConLike
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc ConLike
con_like
                                , rcon_flds :: HsRecordBinds GhcTc
rcon_flds = HsRecordBinds GhcTc
HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rbinds' }

        ; HsExpr GhcTc
ret <- HsExpr GhcRn
-> HsExpr GhcTc -> Type -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' Type
actual_res_ty ExpRhoType
res_ty

        -- Check for missing fields.  We do this after type-checking to get
        -- better types in error messages (cf #18869).  For example:
        --     data T a = MkT { x :: a, y :: a }
        --     r = MkT { y = True }
        -- Then we'd like to warn about a missing field `x :: True`, rather than `x :: a0`.
        --
        -- NB: to do this really properly we should delay reporting until typechecking is complete,
        -- via a new `HoleSort`.  But that seems too much work.
        ; ConLike -> HsRecordBinds GhcRn -> [Scaled Type] -> TcRn ()
checkMissingFields ConLike
con_like HsRecordBinds GhcRn
rbinds [Scaled Type]
arg_tys

        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
ret }
  where
    orig :: CtOrigin
orig = Name -> CtOrigin
OccurrenceOf Name
con_name

-- Record updates via dot syntax are replaced by desugared expressions
-- in the renamer. See Note [Overview of record dot syntax] in
-- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here
-- and panic otherwise.
tcExpr expr :: HsExpr GhcRn
expr@(RecordUpd { rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr = LHsExpr GhcRn
record_expr, rupd_flds :: forall p. HsExpr p -> Either [LHsRecUpdField p] [LHsRecUpdProj p]
rupd_flds = Left [LHsRecUpdField GhcRn]
rbnds }) ExpRhoType
res_ty
  = Bool -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a. HasCallStack => Bool -> a -> a
assert ([GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
      (LocatedA (HsExpr GhcRn)))]
-> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [LHsRecUpdField GhcRn]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
      (LocatedA (HsExpr GhcRn)))]
rbnds) (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
    do  { -- Desugar the record update. See Note [Record Updates].
        ; (HsExpr GhcRn
ds_expr, Type
ds_res_ty, SDoc
err_ctxt) <- LHsExpr GhcRn
-> [LHsRecUpdField GhcRn]
-> ExpRhoType
-> TcM (HsExpr GhcRn, Type, SDoc)
desugarRecordUpd LHsExpr GhcRn
record_expr [LHsRecUpdField GhcRn]
rbnds ExpRhoType
res_ty

          -- Typecheck the desugared expression.
        ; HsExpr GhcTc
expr' <- SDoc -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
err_ctxt (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
                   HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr (HsExpr GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
mkExpandedExpr HsExpr GhcRn
expr HsExpr GhcRn
ds_expr) (Type -> ExpRhoType
Check Type
ds_res_ty)
            -- NB: it's important to use ds_res_ty and not res_ty here.
            -- Test case: T18802b.

        ; SDoc -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
err_ctxt (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcRn
-> HsExpr GhcTc -> Type -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' Type
ds_res_ty ExpRhoType
res_ty
            -- We need to unify the result type of the desugared
            -- expression with the expected result type.
            --
            -- See Note [Unifying result types in tcRecordUpd].
            -- Test case: T10808.
        }

tcExpr (RecordUpd {}) ExpRhoType
_ = String -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> a
panic String
"tcExpr: unexpected overloaded-dot RecordUpd"

{-
************************************************************************
*                                                                      *
        Arithmetic sequences                    e.g. [a,b..]
        and their parallel-array counterparts   e.g. [: a,b.. :]

*                                                                      *
************************************************************************
-}

tcExpr (ArithSeq XArithSeq GhcRn
_ Maybe (SyntaxExpr GhcRn)
witness ArithSeqInfo GhcRn
seq) ExpRhoType
res_ty
  = Maybe (SyntaxExpr GhcRn)
-> ArithSeqInfo GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness ArithSeqInfo GhcRn
seq ExpRhoType
res_ty

{-
************************************************************************
*                                                                      *
                Record dot syntax
*                                                                      *
************************************************************************
-}

-- These terms have been replaced by desugaring in the renamer. See
-- Note [Overview of record dot syntax].
tcExpr (HsGetField XGetField GhcRn
_ LHsExpr GhcRn
_ XRec GhcRn (DotFieldOcc GhcRn)
_) ExpRhoType
_ = String -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> a
panic String
"GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented"
tcExpr (HsProjection XProjection GhcRn
_ NonEmpty (XRec GhcRn (DotFieldOcc GhcRn))
_) ExpRhoType
_ = String -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> a
panic String
"GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented"

{-
************************************************************************
*                                                                      *
                Template Haskell
*                                                                      *
************************************************************************
-}

-- Here we get rid of it and add the finalizers to the global environment.
-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
tcExpr (HsTypedSplice XTypedSplice GhcRn
ext LHsExpr GhcRn
splice)   ExpRhoType
res_ty = Name -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcTypedSplice XTypedSplice GhcRn
Name
ext LHsExpr GhcRn
splice ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsTypedBracket XTypedBracket GhcRn
_ LHsExpr GhcRn
body)    ExpRhoType
res_ty = HsExpr GhcRn -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcTypedBracket HsExpr GhcRn
e LHsExpr GhcRn
body ExpRhoType
res_ty

tcExpr e :: HsExpr GhcRn
e@(HsUntypedBracket XUntypedBracket GhcRn
ps HsQuote GhcRn
body) ExpRhoType
res_ty = HsExpr GhcRn
-> HsQuote GhcRn
-> [PendingRnSplice]
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcUntypedBracket HsExpr GhcRn
e HsQuote GhcRn
body [PendingRnSplice]
XUntypedBracket GhcRn
ps ExpRhoType
res_ty
tcExpr (HsUntypedSplice XUntypedSplice GhcRn
splice HsUntypedSplice GhcRn
_)   ExpRhoType
res_ty
  = case XUntypedSplice GhcRn
splice of
      HsUntypedSpliceTop ThModFinalizers
mod_finalizers HsExpr GhcRn
expr
        -> do { ThModFinalizers -> TcRn ()
addModFinalizersWithLclEnv ThModFinalizers
mod_finalizers
              ; HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpRhoType
res_ty }
      HsUntypedSpliceNested {} -> String -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> a
panic String
"tcExpr: invalid nested splice"

{-
************************************************************************
*                                                                      *
                Catch-all
*                                                                      *
************************************************************************
-}

tcExpr (HsOverLabel {})    ExpRhoType
ty = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:HsOverLabel"  (ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
ty)
tcExpr (SectionL {})       ExpRhoType
ty = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:SectionL"    (ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
ty)
tcExpr (SectionR {})       ExpRhoType
ty = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:SectionR"    (ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
ty)


{-
************************************************************************
*                                                                      *
                Arithmetic sequences [a..b] etc
*                                                                      *
************************************************************************
-}

tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType
           -> TcM (HsExpr GhcTc)

tcArithSeq :: Maybe (SyntaxExpr GhcRn)
-> ArithSeqInfo GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(From LHsExpr GhcRn
expr) ExpRhoType
res_ty
  = do { (HsWrapper
wrap, Type
elt_mult, Type
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
       ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <-Type -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr Type
elt_ty
       ; HsExpr GhcTc
enum_from <- CtOrigin -> Name -> [Type] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
                              Name
enumFromName [Type
elt_ty]
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
         XArithSeq GhcTc
-> Maybe (SyntaxExpr GhcTc) -> ArithSeqInfo GhcTc -> HsExpr GhcTc
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcTc
HsExpr GhcTc
enum_from Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
wit' (LHsExpr GhcTc -> ArithSeqInfo GhcTc
forall id. LHsExpr id -> ArithSeqInfo id
From LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') }

tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromThen LHsExpr GhcRn
expr1 LHsExpr GhcRn
expr2) ExpRhoType
res_ty
  = do { (HsWrapper
wrap, Type
elt_mult, Type
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
       ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' <- Type -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 Type
elt_ty
       ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2' <- Type -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 Type
elt_ty
       ; HsExpr GhcTc
enum_from_then <- CtOrigin -> Name -> [Type] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
                              Name
enumFromThenName [Type
elt_ty]
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
         XArithSeq GhcTc
-> Maybe (SyntaxExpr GhcTc) -> ArithSeqInfo GhcTc -> HsExpr GhcTc
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcTc
HsExpr GhcTc
enum_from_then Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
wit' (LHsExpr GhcTc -> LHsExpr GhcTc -> ArithSeqInfo GhcTc
forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThen LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2') }

tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromTo LHsExpr GhcRn
expr1 LHsExpr GhcRn
expr2) ExpRhoType
res_ty
  = do { (HsWrapper
wrap, Type
elt_mult, Type
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
       ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' <- Type -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 Type
elt_ty
       ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2' <- Type -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 Type
elt_ty
       ; HsExpr GhcTc
enum_from_to <- CtOrigin -> Name -> [Type] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
                              Name
enumFromToName [Type
elt_ty]
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
         XArithSeq GhcTc
-> Maybe (SyntaxExpr GhcTc) -> ArithSeqInfo GhcTc -> HsExpr GhcTc
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcTc
HsExpr GhcTc
enum_from_to Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
wit' (LHsExpr GhcTc -> LHsExpr GhcTc -> ArithSeqInfo GhcTc
forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromTo LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2') }

tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromThenTo LHsExpr GhcRn
expr1 LHsExpr GhcRn
expr2 LHsExpr GhcRn
expr3) ExpRhoType
res_ty
  = do { (HsWrapper
wrap, Type
elt_mult, Type
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
        ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' <- Type -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 Type
elt_ty
        ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2' <- Type -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 Type
elt_ty
        ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr3' <- Type -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr3 Type
elt_ty
        ; HsExpr GhcTc
eft <- CtOrigin -> Name -> [Type] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
                              Name
enumFromThenToName [Type
elt_ty]
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
          XArithSeq GhcTc
-> Maybe (SyntaxExpr GhcTc) -> ArithSeqInfo GhcTc -> HsExpr GhcTc
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcTc
HsExpr GhcTc
eft Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
wit' (LHsExpr GhcTc
-> LHsExpr GhcTc -> LHsExpr GhcTc -> ArithSeqInfo GhcTc
forall id.
LHsExpr id -> LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThenTo LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2' LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr3') }

-----------------
arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType
                -> TcM (HsWrapper, Mult, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType :: Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, Type, Type, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
Nothing ExpRhoType
res_ty
  = do { Type
res_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty
       ; (TcCoercionR
coi, Type
elt_ty) <- Type -> TcM (TcCoercionR, Type)
matchExpectedListTy Type
res_ty
       ; (HsWrapper, Type, Type, Maybe SyntaxExprTc)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (HsWrapper, Type, Type, Maybe SyntaxExprTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcCoercionR -> HsWrapper
mkWpCastN TcCoercionR
coi, Type
OneTy, Type
elt_ty, Maybe SyntaxExprTc
forall a. Maybe a
Nothing) }
arithSeqEltType (Just SyntaxExpr GhcRn
fl) ExpRhoType
res_ty
  = do { ((Type
elt_mult, Type
elt_ty), SyntaxExprTc
fl')
           <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Type] -> [Type] -> TcM (Type, Type))
-> TcM ((Type, Type), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
ListOrigin SyntaxExpr GhcRn
SyntaxExprRn
fl [SyntaxOpType
SynList] ExpRhoType
res_ty (([Type] -> [Type] -> TcM (Type, Type))
 -> TcM ((Type, Type), SyntaxExprTc))
-> ([Type] -> [Type] -> TcM (Type, Type))
-> TcM ((Type, Type), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
              \ [Type
elt_ty] [Type
elt_mult] -> (Type, Type) -> TcM (Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
elt_mult, Type
elt_ty)
       ; (HsWrapper, Type, Type, Maybe SyntaxExprTc)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (HsWrapper, Type, Type, Maybe SyntaxExprTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
idHsWrapper, Type
elt_mult, Type
elt_ty, SyntaxExprTc -> Maybe SyntaxExprTc
forall a. a -> Maybe a
Just SyntaxExprTc
fl') }

----------------
tcTupArgs :: [HsTupArg GhcRn]
          -> [TcSigmaType]
              -- ^ Argument types.
              -- This function ensures they all have
              -- a fixed runtime representation.
          -> TcM [HsTupArg GhcTc]
tcTupArgs :: [HsTupArg GhcRn] -> [Type] -> TcM [HsTupArg GhcTc]
tcTupArgs [HsTupArg GhcRn]
args [Type]
tys
  = do Bool -> TcRn ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ([HsTupArg GhcRn] -> [Type] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [HsTupArg GhcRn]
args [Type]
tys)
       Int -> TcRn ()
checkTupSize ([HsTupArg GhcRn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsTupArg GhcRn]
args)
       (Int
 -> HsTupArg GhcRn
 -> Type
 -> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc))
-> [Int] -> [HsTupArg GhcRn] -> [Type] -> TcM [HsTupArg GhcTc]
forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]
zipWith3M Int
-> HsTupArg GhcRn
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
go [Int
1,Int
2..] [HsTupArg GhcRn]
args [Type]
tys
  where
    go :: Int -> HsTupArg GhcRn -> TcType -> TcM (HsTupArg GhcTc)
    go :: Int
-> HsTupArg GhcRn
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
go Int
i (Missing {})     Type
arg_ty
      = do { Type
mult <- Type -> TcM Type
newFlexiTyVarTy Type
multiplicityTy
           ; (() :: Constraint) => FixedRuntimeRepContext -> Type -> TcRn ()
FixedRuntimeRepContext -> Type -> TcRn ()
hasFixedRuntimeRep_syntactic (Int -> FixedRuntimeRepContext
FRRTupleSection Int
i) Type
arg_ty
           ; HsTupArg GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XMissing GhcTc -> HsTupArg GhcTc
forall id. XMissing id -> HsTupArg id
Missing (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
mult Type
arg_ty)) }
    go Int
i (Present XPresent GhcRn
x LHsExpr GhcRn
expr) Type
arg_ty
      = do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr Type
arg_ty
           ; (() :: Constraint) => FixedRuntimeRepContext -> Type -> TcRn ()
FixedRuntimeRepContext -> Type -> TcRn ()
hasFixedRuntimeRep_syntactic (Int -> FixedRuntimeRepContext
FRRTupleArg Int
i) Type
arg_ty
           ; HsTupArg GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XPresent GhcTc -> LHsExpr GhcTc -> HsTupArg GhcTc
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcRn
XPresent GhcTc
x LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') }

---------------------------
-- See TcType.SyntaxOpType also for commentary
tcSyntaxOp :: CtOrigin
           -> SyntaxExprRn
           -> [SyntaxOpType]           -- ^ shape of syntax operator arguments
           -> ExpRhoType               -- ^ overall result type
           -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments,
                                                 -- takes a type per hole and a
                                                 -- multiplicity per arrow in
                                                 -- the shape.
           -> TcM (a, SyntaxExprTc)
-- ^ Typecheck a syntax operator
-- The operator is a variable or a lambda at this stage (i.e. renamer
-- output)t
tcSyntaxOp :: forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
orig SyntaxExprRn
expr [SyntaxOpType]
arg_tys ExpRhoType
res_ty
  = CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen CtOrigin
orig SyntaxExprRn
expr [SyntaxOpType]
arg_tys (ExpRhoType -> SyntaxOpType
SynType ExpRhoType
res_ty)

-- | Slightly more general version of 'tcSyntaxOp' that allows the caller
-- to specify the shape of the result of the syntax operator
tcSyntaxOpGen :: CtOrigin
              -> SyntaxExprRn
              -> [SyntaxOpType]
              -> SyntaxOpType
              -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
              -> TcM (a, SyntaxExprTc)
tcSyntaxOpGen :: forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen CtOrigin
orig (SyntaxExprRn HsExpr GhcRn
op) [SyntaxOpType]
arg_tys SyntaxOpType
res_ty [Type] -> [Type] -> TcM a
thing_inside
  = do { (HsExpr GhcTc
expr, Type
sigma) <- (HsExpr GhcRn, AppCtxt)
-> [HsExprArg 'TcpRn] -> TcM (HsExpr GhcTc, Type)
tcInferAppHead (HsExpr GhcRn
op, HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
op Int
0 SrcSpan
noSrcSpan) []
             -- Ugh!! But all this code is scheduled for demolition anyway
       ; String -> SDoc -> TcRn ()
traceTc String
"tcSyntaxOpGen" (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
op SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
sigma)
       ; (a
result, HsWrapper
expr_wrap, [HsWrapper]
arg_wraps, HsWrapper
res_wrap)
           <- CtOrigin
-> HsExpr GhcRn
-> Type
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall a.
CtOrigin
-> HsExpr GhcRn
-> Type
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig HsExpr GhcRn
op Type
sigma [SyntaxOpType]
arg_tys SyntaxOpType
res_ty (([Type] -> [Type] -> TcM a)
 -> TcM (a, HsWrapper, [HsWrapper], HsWrapper))
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall a b. (a -> b) -> a -> b
$
              [Type] -> [Type] -> TcM a
thing_inside
       ; String -> SDoc -> TcRn ()
traceTc String
"tcSyntaxOpGen" (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
op SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
sigma )
       ; (a, SyntaxExprTc) -> TcM (a, SyntaxExprTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, SyntaxExprTc { syn_expr :: HsExpr GhcTc
syn_expr = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
expr_wrap HsExpr GhcTc
expr
                                      , syn_arg_wraps :: [HsWrapper]
syn_arg_wraps = [HsWrapper]
arg_wraps
                                      , syn_res_wrap :: HsWrapper
syn_res_wrap  = HsWrapper
res_wrap }) }
tcSyntaxOpGen CtOrigin
_ SyntaxExprRn
NoSyntaxExprRn [SyntaxOpType]
_ SyntaxOpType
_ [Type] -> [Type] -> TcM a
_ = String -> TcM (a, SyntaxExprTc)
forall a. HasCallStack => String -> a
panic String
"tcSyntaxOpGen"

{-
Note [tcSynArg]
~~~~~~~~~~~~~~~
Because of the rich structure of SyntaxOpType, we must do the
contra-/covariant thing when working down arrows, to get the
instantiation vs. skolemisation decisions correct (and, more
obviously, the orientation of the HsWrappers). We thus have
two tcSynArgs.
-}

-- works on "expected" types, skolemising where necessary
-- See Note [tcSynArg]
tcSynArgE :: CtOrigin
          -> HsExpr GhcRn -- ^ the operator to check (for error messages only)
          -> TcSigmaType
          -> SyntaxOpType                -- ^ shape it is expected to have
          -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments
          -> TcM (a, HsWrapper)
           -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
tcSynArgE :: forall a.
CtOrigin
-> HsExpr GhcRn
-> Type
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig HsExpr GhcRn
op Type
sigma_ty SyntaxOpType
syn_ty [Type] -> [Type] -> TcM a
thing_inside
  = do { (HsWrapper
skol_wrap, (a
result, HsWrapper
ty_wrapper))
           <- UserTypeCtxt
-> Type
-> (Type -> TcM (a, HsWrapper))
-> TcM (HsWrapper, (a, HsWrapper))
forall result.
UserTypeCtxt
-> Type -> (Type -> TcM result) -> TcM (HsWrapper, result)
tcTopSkolemise UserTypeCtxt
GenSigCtxt Type
sigma_ty
                (\ Type
rho_ty -> Type -> SyntaxOpType -> TcM (a, HsWrapper)
go Type
rho_ty SyntaxOpType
syn_ty)
       ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
skol_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
ty_wrapper) }
    where
    go :: Type -> SyntaxOpType -> TcM (a, HsWrapper)
go Type
rho_ty SyntaxOpType
SynAny
      = do { a
result <- [Type] -> [Type] -> TcM a
thing_inside [Type
rho_ty] []
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }

    go Type
rho_ty SyntaxOpType
SynRho   -- same as SynAny, because we skolemise eagerly
      = do { a
result <- [Type] -> [Type] -> TcM a
thing_inside [Type
rho_ty] []
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }

    go Type
rho_ty SyntaxOpType
SynList
      = do { (TcCoercionR
list_co, Type
elt_ty) <- Type -> TcM (TcCoercionR, Type)
matchExpectedListTy Type
rho_ty
           ; a
result <- [Type] -> [Type] -> TcM a
thing_inside [Type
elt_ty] []
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, TcCoercionR -> HsWrapper
mkWpCastN TcCoercionR
list_co) }

    go Type
rho_ty (SynFun SyntaxOpType
arg_shape SyntaxOpType
res_shape)
      = do { ( HsWrapper
match_wrapper                         -- :: (arg_ty -> res_ty) "->" rho_ty
             , ( ( (a
result, Type
arg_ty, Type
res_ty, Type
op_mult)
                 , HsWrapper
res_wrapper )                     -- :: res_ty_out "->" res_ty
               , HsWrapper
arg_wrapper1, [], HsWrapper
arg_wrapper2 ) )  -- :: arg_ty "->" arg_ty_out
               <- ExpectedFunTyOrigin
-> UserTypeCtxt
-> Int
-> ExpRhoType
-> ([Scaled ExpRhoType]
    -> ExpRhoType
    -> TcM
         (((a, Type, Type, Type), HsWrapper), HsWrapper, [HsWrapper],
          HsWrapper))
-> TcM
     (HsWrapper,
      (((a, Type, Type, Type), HsWrapper), HsWrapper, [HsWrapper],
       HsWrapper))
forall a.
ExpectedFunTyOrigin
-> UserTypeCtxt
-> Int
-> ExpRhoType
-> ([Scaled ExpRhoType] -> ExpRhoType -> TcM a)
-> TcM (HsWrapper, a)
matchExpectedFunTys ExpectedFunTyOrigin
herald UserTypeCtxt
GenSigCtxt Int
1 (Type -> ExpRhoType
mkCheckExpType Type
rho_ty) (([Scaled ExpRhoType]
  -> ExpRhoType
  -> TcM
       (((a, Type, Type, Type), HsWrapper), HsWrapper, [HsWrapper],
        HsWrapper))
 -> TcM
      (HsWrapper,
       (((a, Type, Type, Type), HsWrapper), HsWrapper, [HsWrapper],
        HsWrapper)))
-> ([Scaled ExpRhoType]
    -> ExpRhoType
    -> TcM
         (((a, Type, Type, Type), HsWrapper), HsWrapper, [HsWrapper],
          HsWrapper))
-> TcM
     (HsWrapper,
      (((a, Type, Type, Type), HsWrapper), HsWrapper, [HsWrapper],
       HsWrapper))
forall a b. (a -> b) -> a -> b
$
                  \ [Scaled ExpRhoType
arg_ty] ExpRhoType
res_ty ->
                  do { Type
arg_tc_ty <- ExpRhoType -> TcM Type
expTypeToType (Scaled ExpRhoType -> ExpRhoType
forall a. Scaled a -> a
scaledThing Scaled ExpRhoType
arg_ty)
                     ; Type
res_tc_ty <- ExpRhoType -> TcM Type
expTypeToType ExpRhoType
res_ty

                         -- another nested arrow is too much for now,
                         -- but I bet we'll never need this
                     ; Bool -> SDoc -> TcRn ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (case SyntaxOpType
arg_shape of
                                   SynFun {} -> Bool
False;
                                   SyntaxOpType
_         -> Bool
True)
                                  (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Too many nested arrows in SyntaxOpType" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                                   CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig)

                     ; let arg_mult :: Type
arg_mult = Scaled ExpRhoType -> Type
forall a. Scaled a -> Type
scaledMult Scaled ExpRhoType
arg_ty
                     ; CtOrigin
-> HsExpr GhcRn
-> Type
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM ((a, Type, Type, Type), HsWrapper))
-> TcM
     (((a, Type, Type, Type), HsWrapper), HsWrapper, [HsWrapper],
      HsWrapper)
forall a.
CtOrigin
-> HsExpr GhcRn
-> Type
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig HsExpr GhcRn
op Type
arg_tc_ty [] SyntaxOpType
arg_shape (([Type] -> [Type] -> TcM ((a, Type, Type, Type), HsWrapper))
 -> TcM
      (((a, Type, Type, Type), HsWrapper), HsWrapper, [HsWrapper],
       HsWrapper))
-> ([Type] -> [Type] -> TcM ((a, Type, Type, Type), HsWrapper))
-> TcM
     (((a, Type, Type, Type), HsWrapper), HsWrapper, [HsWrapper],
      HsWrapper)
forall a b. (a -> b) -> a -> b
$
                       \ [Type]
arg_results [Type]
arg_res_mults ->
                       CtOrigin
-> HsExpr GhcRn
-> Type
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM (a, Type, Type, Type))
-> TcM ((a, Type, Type, Type), HsWrapper)
forall a.
CtOrigin
-> HsExpr GhcRn
-> Type
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig HsExpr GhcRn
op Type
res_tc_ty SyntaxOpType
res_shape (([Type] -> [Type] -> TcM (a, Type, Type, Type))
 -> TcM ((a, Type, Type, Type), HsWrapper))
-> ([Type] -> [Type] -> TcM (a, Type, Type, Type))
-> TcM ((a, Type, Type, Type), HsWrapper)
forall a b. (a -> b) -> a -> b
$
                       \ [Type]
res_results [Type]
res_res_mults ->
                       do { a
result <- [Type] -> [Type] -> TcM a
thing_inside ([Type]
arg_results [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
res_results) ([Type
arg_mult] [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
arg_res_mults [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
res_res_mults)
                          ; (a, Type, Type, Type) -> TcM (a, Type, Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, Type
arg_tc_ty, Type
res_tc_ty, Type
arg_mult) }}

           ; let fun_wrap :: HsWrapper
fun_wrap = HsWrapper -> HsWrapper -> Scaled Type -> Type -> HsWrapper
mkWpFun (HsWrapper
arg_wrapper2 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
arg_wrapper1) HsWrapper
res_wrapper
                              (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
op_mult Type
arg_ty) Type
res_ty
               -- NB: arg_ty comes from matchExpectedFunTys, so it has a
               -- fixed RuntimeRep, as needed to call mkWpFun.
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
match_wrapper HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
fun_wrap) }
      where
        herald :: ExpectedFunTyOrigin
herald = CtOrigin -> HsExpr GhcRn -> ExpectedFunTyOrigin
ExpectedFunTySyntaxOp CtOrigin
orig HsExpr GhcRn
op

    go Type
rho_ty (SynType ExpRhoType
the_ty)
      = do { HsWrapper
wrap   <- CtOrigin -> UserTypeCtxt -> ExpRhoType -> Type -> TcM HsWrapper
tcSubTypePat CtOrigin
orig UserTypeCtxt
GenSigCtxt ExpRhoType
the_ty Type
rho_ty
           ; a
result <- [Type] -> [Type] -> TcM a
thing_inside [] []
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
wrap) }

-- works on "actual" types, instantiating where necessary
-- See Note [tcSynArg]
tcSynArgA :: CtOrigin
          -> HsExpr GhcRn -- ^ the operator we are checking (for error messages)
          -> TcSigmaType
          -> [SyntaxOpType]              -- ^ argument shapes
          -> SyntaxOpType                -- ^ result shape
          -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments
          -> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
            -- ^ returns a wrapper to be applied to the original function,
            -- wrappers to be applied to arguments
            -- and a wrapper to be applied to the overall expression
tcSynArgA :: forall a.
CtOrigin
-> HsExpr GhcRn
-> Type
-> [SyntaxOpType]
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig HsExpr GhcRn
op Type
sigma_ty [SyntaxOpType]
arg_shapes SyntaxOpType
res_shape [Type] -> [Type] -> TcM a
thing_inside
  = do { (HsWrapper
match_wrapper, [Scaled Type]
arg_tys, Type
res_ty)
           <- ExpectedFunTyOrigin
-> CtOrigin
-> Maybe TypedThing
-> Int
-> Type
-> TcM (HsWrapper, [Scaled Type], Type)
matchActualFunTysRho ExpectedFunTyOrigin
herald CtOrigin
orig Maybe TypedThing
forall a. Maybe a
Nothing
                                   ([SyntaxOpType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SyntaxOpType]
arg_shapes) Type
sigma_ty
              -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
       ; ((a
result, HsWrapper
res_wrapper), [HsWrapper]
arg_wrappers)
           <- [Type]
-> [SyntaxOpType]
-> ([Type] -> [Type] -> TcM (a, HsWrapper))
-> TcM ((a, HsWrapper), [HsWrapper])
forall a.
[Type]
-> [SyntaxOpType]
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys) [SyntaxOpType]
arg_shapes (([Type] -> [Type] -> TcM (a, HsWrapper))
 -> TcM ((a, HsWrapper), [HsWrapper]))
-> ([Type] -> [Type] -> TcM (a, HsWrapper))
-> TcM ((a, HsWrapper), [HsWrapper])
forall a b. (a -> b) -> a -> b
$ \ [Type]
arg_results [Type]
arg_res_mults ->
              Type -> SyntaxOpType -> ([Type] -> TcM a) -> TcM (a, HsWrapper)
forall a.
Type -> SyntaxOpType -> ([Type] -> TcM a) -> TcM (a, HsWrapper)
tc_syn_arg    Type
res_ty  SyntaxOpType
res_shape  (([Type] -> TcM a) -> TcM (a, HsWrapper))
-> ([Type] -> TcM a) -> TcM (a, HsWrapper)
forall a b. (a -> b) -> a -> b
$ \ [Type]
res_results ->
              [Type] -> [Type] -> TcM a
thing_inside ([Type]
arg_results [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
res_results) ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> Type
scaledMult [Scaled Type]
arg_tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
arg_res_mults)
       ; (a, HsWrapper, [HsWrapper], HsWrapper)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
match_wrapper, [HsWrapper]
arg_wrappers, HsWrapper
res_wrapper) }
  where
    herald :: ExpectedFunTyOrigin
herald = CtOrigin -> HsExpr GhcRn -> ExpectedFunTyOrigin
ExpectedFunTySyntaxOp CtOrigin
orig HsExpr GhcRn
op

    tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType]
                  -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
                  -> TcM (a, [HsWrapper])
                    -- the wrappers are for arguments
    tc_syn_args_e :: forall a.
[Type]
-> [SyntaxOpType]
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e (Type
arg_ty : [Type]
arg_tys) (SyntaxOpType
arg_shape : [SyntaxOpType]
arg_shapes) [Type] -> [Type] -> TcM a
thing_inside
      = do { ((a
result, [HsWrapper]
arg_wraps), HsWrapper
arg_wrap)
               <- CtOrigin
-> HsExpr GhcRn
-> Type
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM (a, [HsWrapper]))
-> TcM ((a, [HsWrapper]), HsWrapper)
forall a.
CtOrigin
-> HsExpr GhcRn
-> Type
-> SyntaxOpType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE     CtOrigin
orig  HsExpr GhcRn
op Type
arg_ty  SyntaxOpType
arg_shape  (([Type] -> [Type] -> TcM (a, [HsWrapper]))
 -> TcM ((a, [HsWrapper]), HsWrapper))
-> ([Type] -> [Type] -> TcM (a, [HsWrapper]))
-> TcM ((a, [HsWrapper]), HsWrapper)
forall a b. (a -> b) -> a -> b
$ \ [Type]
arg1_results [Type]
arg1_mults ->
                  [Type]
-> [SyntaxOpType]
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, [HsWrapper])
forall a.
[Type]
-> [SyntaxOpType]
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e          [Type]
arg_tys [SyntaxOpType]
arg_shapes (([Type] -> [Type] -> TcM a) -> TcM (a, [HsWrapper]))
-> ([Type] -> [Type] -> TcM a) -> TcM (a, [HsWrapper])
forall a b. (a -> b) -> a -> b
$ \ [Type]
args_results [Type]
args_mults ->
                  [Type] -> [Type] -> TcM a
thing_inside ([Type]
arg1_results [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
args_results) ([Type]
arg1_mults [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
args_mults)
           ; (a, [HsWrapper]) -> TcM (a, [HsWrapper])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
arg_wrap HsWrapper -> [HsWrapper] -> [HsWrapper]
forall a. a -> [a] -> [a]
: [HsWrapper]
arg_wraps) }
    tc_syn_args_e [Type]
_ [SyntaxOpType]
_ [Type] -> [Type] -> TcM a
thing_inside = (, []) (a -> (a, [HsWrapper])) -> TcM a -> TcM (a, [HsWrapper])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> [Type] -> TcM a
thing_inside [] []

    tc_syn_arg :: TcSigmaTypeFRR -> SyntaxOpType
               -> ([TcSigmaTypeFRR] -> TcM a)
               -> TcM (a, HsWrapper)
                  -- the wrapper applies to the overall result
    tc_syn_arg :: forall a.
Type -> SyntaxOpType -> ([Type] -> TcM a) -> TcM (a, HsWrapper)
tc_syn_arg Type
res_ty SyntaxOpType
SynAny [Type] -> TcM a
thing_inside
      = do { a
result <- [Type] -> TcM a
thing_inside [Type
res_ty]
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }
    tc_syn_arg Type
res_ty SyntaxOpType
SynRho [Type] -> TcM a
thing_inside
      = do { (HsWrapper
inst_wrap, Type
rho_ty) <- CtOrigin -> Type -> TcM (HsWrapper, Type)
topInstantiate CtOrigin
orig Type
res_ty
               -- inst_wrap :: res_ty "->" rho_ty
           ; a
result <- [Type] -> TcM a
thing_inside [Type
rho_ty]
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
inst_wrap) }
    tc_syn_arg Type
res_ty SyntaxOpType
SynList [Type] -> TcM a
thing_inside
      = do { (HsWrapper
inst_wrap, Type
rho_ty) <- CtOrigin -> Type -> TcM (HsWrapper, Type)
topInstantiate CtOrigin
orig Type
res_ty
               -- inst_wrap :: res_ty "->" rho_ty
           ; (TcCoercionR
list_co, Type
elt_ty)   <- Type -> TcM (TcCoercionR, Type)
matchExpectedListTy Type
rho_ty
               -- list_co :: [elt_ty] ~N rho_ty
           ; a
result <- [Type] -> TcM a
thing_inside [Type
elt_ty]
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, TcCoercionR -> HsWrapper
mkWpCastN (TcCoercionR -> TcCoercionR
mkSymCo TcCoercionR
list_co) HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
inst_wrap) }
    tc_syn_arg Type
_ (SynFun {}) [Type] -> TcM a
_
      = String -> SDoc -> TcM (a, HsWrapper)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcSynArgA hits a SynFun" (CtOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr CtOrigin
orig)
    tc_syn_arg Type
res_ty (SynType ExpRhoType
the_ty) [Type] -> TcM a
thing_inside
      = do { HsWrapper
wrap   <- CtOrigin -> UserTypeCtxt -> Type -> ExpRhoType -> TcM HsWrapper
tcSubType CtOrigin
orig UserTypeCtxt
GenSigCtxt Type
res_ty ExpRhoType
the_ty
           ; a
result <- [Type] -> TcM a
thing_inside []
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
wrap) }

{-
Note [Push result type in]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Unify with expected result before type-checking the args so that the
info from res_ty percolates to args.  This is when we might detect a
too-few args situation.  (One can think of cases when the opposite
order would give a better error message.)
experimenting with putting this first.

Here's an example where it actually makes a real difference

   class C t a b | t a -> b
   instance C Char a Bool

   data P t a = forall b. (C t a b) => MkP b
   data Q t   = MkQ (forall a. P t a)

   f1, f2 :: Q Char;
   f1 = MkQ (MkP True)
   f2 = MkQ (MkP True :: forall a. P Char a)

With the change, f1 will type-check, because the 'Char' info from
the signature is propagated into MkQ's argument. With the check
in the other order, the extra signature in f2 is reqd.
-}

{- *********************************************************************
*                                                                      *
                 Desugaring record update
*                                                                      *
********************************************************************* -}

{-
Note [Type of a record update]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The main complication with RecordUpd is that we need to explicitly
handle the *non-updated* fields.  Consider:

        data T a b c = MkT1 { fa :: a, fb :: (b,c) }
                     | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
                     | MkT3 { fd :: a }

        upd :: T a b c -> (b',c) -> T a b' c
        upd t x = t { fb = x}

The result type should be (T a b' c)
not (T a b c),   because 'b' *is not* mentioned in a non-updated field
not (T a b' c'), because 'c' *is*     mentioned in a non-updated field
NB that it's not good enough to look at just one constructor; we must
look at them all; cf #3219

After all, upd should be equivalent to:
        upd t x = case t of
                        MkT1 p q -> MkT1 p x
                        MkT2 a b -> MkT2 p b
                        MkT3 d   -> error ...

So we need to give a completely fresh type to the result record,
and then constrain it by the fields that are *not* updated ("p" above).
We call these the "fixed" type variables, and compute them in getFixedTyVars.

Note that because MkT3 doesn't contain all the fields being updated,
its RHS is simply an error, so it doesn't impose any type constraints.
Hence the use of 'relevant_cont'.

Note [Implicit type sharing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
We also take into account any "implicit" non-update fields.  For example
        data T a b where { MkT { f::a } :: T a a; ... }
So the "real" type of MkT is: forall ab. (a~b) => a -> T a b

Then consider
        upd t x = t { f=x }
We infer the type
        upd :: T a b -> a -> T a b
        upd (t::T a b) (x::a)
           = case t of { MkT (co:a~b) (_:a) -> MkT co x }
We can't give it the more general type
        upd :: T a b -> c -> T c b

Note [Criteria for update]
~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to allow update for existentials etc, provided the updated
field isn't part of the existential. For example, this should be ok.
  data T a where { MkT { f1::a, f2::b->b } :: T a }
  f :: T a -> b -> T b
  f t b = t { f1=b }

The criterion we use is this:

  The types of the updated fields
  mention only the universally-quantified type variables
  of the data constructor

NB: this is not (quite) the same as being a "naughty" record selector
(See Note [Naughty record selectors]) in GHC.Tc.TyCl), at least
in the case of GADTs. Consider
   data T a where { MkT :: { f :: a } :: T [a] }
Then f is not "naughty" because it has a well-typed record selector.
But we don't allow updates for 'f'.  (One could consider trying to
allow this, but it makes my head hurt.  Badly.  And no one has asked
for it.)

In principle one could go further, and allow
  g :: T a -> T a
  g t = t { f2 = \x -> x }
because the expression is polymorphic...but that seems a bridge too far.

Note [Data family example]
~~~~~~~~~~~~~~~~~~~~~~~~~~
    data instance T (a,b) = MkT { x::a, y::b }
  --->
    data :TP a b = MkT { a::a, y::b }
    coTP a b :: T (a,b) ~ :TP a b

Suppose r :: T (t1,t2), e :: t3
Then  r { x=e } :: T (t3,t1)
  --->
      case r |> co1 of
        MkT x y -> MkT e y |> co2
      where co1 :: T (t1,t2) ~ :TP t1 t2
            co2 :: :TP t3 t2 ~ T (t3,t2)
The wrapping with co2 is done by the constructor wrapper for MkT

Outgoing invariants
~~~~~~~~~~~~~~~~~~~
In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):

  * cons are the data constructors to be updated

  * in_inst_tys, out_inst_tys have same length, and instantiate the
        *representation* tycon of the data cons.  In Note [Data
        family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]

Note [Mixed Record Field Updates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following pattern synonym.

  data MyRec = MyRec { foo :: Int, qux :: String }

  pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}

This allows updates such as the following

  updater :: MyRec -> MyRec
  updater a = a {f1 = 1 }

It would also make sense to allow the following update (which we reject).

  updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"

This leads to confusing behaviour when the selectors in fact refer the same
field.

  updater a = a {f1 = 1, foo = 2} ==? ???

For this reason, we reject a mixture of pattern synonym and normal record
selectors in the same update block. Although of course we still allow the
following.

  updater a = (a {f1 = 1}) {foo = 2}

  > updater (MyRec 0 "str")
  MyRec 2 "str"

Note [Record Updates]
~~~~~~~~~~~~~~~~~~~~~
To typecheck a record update, we desugar it first.  Suppose we have
    data T p q = T1 { x :: Int, y :: Bool, z :: Char }
               | T2 { v :: Char }
               | T3 { x :: Int }
               | T4 { p :: Float, y :: Bool, x :: Int }
               | T5
Then the record update `e { x=e1, y=e2 }` desugars as follows

       e { x=e1, y=e2 }
    ===>
       let { x' = e1; y' = e2 } in
       case e of
          T1 _ _ z -> T1 x' y' z
          T4 p _ _ -> T4 p y' x'
T2, T3 and T5 should not occur, so we omit them from the match.
The critical part of desugaring is to identify T and then T1/T4.

Wrinkle [Disambiguating fields]
As outlined above, to typecheck a record update via desugaring, we first need
to identify the parent record `TyCon` (`T` above). This can be tricky when several
record types share the same field (with `-XDuplicateRecordFields`).

Currently, we use the inferred type of the record to help disambiguate the record
fields. For example, in

  ( mempty :: T a b ) { x = 3 }

the type signature on `mempty` allows us to disambiguate the record `TyCon` to `T`,
when there might be other datatypes with field `x :: Int`.
This complexity is scheduled for removal via the implementation of GHC proposal #366
https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst

However, for the time being, we still need to disambiguate record fields using the
inferred types. This means that, when typechecking a record update via desugaring,
we need to do the following:

  D1. Perform a first typechecking pass on the record expression (`e` in the example above),
      to infer the type of the record being updated.
  D2. Desugar the record update as described above, using an HsExpansion.
  D3. Typecheck the desugared code.

In (D1), we call inferRho to infer the type of the record being updated. This returns the
inferred type of the record, together with a typechecked expression (of type HsExpr GhcTc)
and a collection of residual constraints.
We have no need for the latter two, because we will typecheck again in (D3). So, for
the time being (and until GHC proposal #366 is implemented), we simply drop them.

Wrinkle [Using IdSig]
As noted above, we want to let-bind the updated fields to avoid code duplication:

  let { x' = e1; y' = e2 } in
  case e of
     T1 _ _ z -> T1 x' y' z
     T4 p _ _ -> T4 p y' x'

However, doing so in a naive way would cause difficulties for type inference.
For example:

  data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int }
  foo r = r { f = \ k -> (k 3, k 'x') }

If we desugar to:

  ds_foo r =
    let f' = \ k -> (k 3, k 'x')
    in case r of
      MkR _ b -> MkR f' b

then we are unable to infer an appropriately polymorphic type for f', because we
never infer higher-rank types. To circumvent this problem, we proceed as follows:

  1. Obtain general field types by instantiating any of the constructors
     that contain all the necessary fields. (Note that the field type must be
     identical across different constructors of a given data constructor).
  2. Let-bind an 'IdSig' with this type. This amounts to giving the let-bound
     'Id's a partial type signature.

In the above example, it's as if we wrote:

  ds_foo r =
    let f' :: (forall a. a -> a) -> (Int, _b)
        f' = \ k -> (k 3, k 'x')
    in case r of
      MkR _ b -> MkR f' b

This allows us to compute the right type for f', and thus accept this record update.

Note [Unifying result types in tcRecordUpd]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
After desugaring and typechecking a record update in the way described in
Note [Record Updates], we must take care to unify the result types.

Example:

  type family F (a :: Type) :: Type where {}
  data D a = MkD { fld :: F a }

  f :: F Int -> D Bool -> D Int
  f i r = r { fld = i }

This record update desugars to:

  let x :: F alpha -- metavariable
      x = i
  in case r of
    MkD _ -> MkD x

Because the type family F is not injective, our only hope for unifying the
metavariable alpha is through the result type of the record update, which tells
us that we should unify alpha := Int.

Test case: T10808.

Wrinkle [GADT result type in tcRecordUpd]

  When dealing with a GADT, we want to be careful about which result type we use.

  Example:

    data G a b where
      MkG :: { bar :: F a } -> G a Int

    g :: F Int -> G Float b -> G Int b
    g i r = r { bar = i }

    We **do not** want to use the result type from the constructor MkG, which would
    leave us with a result type "G alpha Int". Instead, we should use the result type
    from the GADT header, instantiating as above, to get "G alpha beta" which will get
    unified withy "G Int b".

    Test cases: T18809, HardRecordUpdate.

-}

-- | Desugars a record update @record_expr { fld1 = e1, fld2 = e2}@ into a case expression
-- that matches on the constructors of the record @r@, as described in
-- Note [Record Updates].
--
-- Returns a renamed but not-yet-typechecked expression, together with the
-- result type of this desugared record update.
desugarRecordUpd :: LHsExpr GhcRn
                      -- ^ @record_expr@: expression to which the record update is applied
                 -> [LHsRecUpdField GhcRn]
                      -- ^ the record update fields
                 -> ExpRhoType
                      -- ^ the expected result type of the record update
                 -> TcM ( HsExpr GhcRn
                           -- desugared record update expression
                        , TcType
                           -- result type of desugared record update
                        , SDoc
                           -- error context to push when typechecking
                           -- the desugared code
                        )
desugarRecordUpd :: LHsExpr GhcRn
-> [LHsRecUpdField GhcRn]
-> ExpRhoType
-> TcM (HsExpr GhcRn, Type, SDoc)
desugarRecordUpd LHsExpr GhcRn
record_expr [LHsRecUpdField GhcRn]
rbnds ExpRhoType
res_ty
  = do {  -- STEP -2: typecheck the record_expr, the record to be updated
          -- Until GHC proposal #366 is implemented, we still use the type of
          -- the record to disambiguate its fields, so we must infer the record
          -- type here before we can desugar. See Wrinkle [Disambiguating fields]
          -- in Note [Record Updates].
       ; ((GenLocated SrcSpanAnnA (HsExpr GhcTc)
_, Type
record_rho), WantedConstraints
_lie) <- IOEnv
  (Env TcGblEnv TcLclEnv)
  (GenLocated SrcSpanAnnA (HsExpr GhcTc), Type)
-> TcM
     ((GenLocated SrcSpanAnnA (HsExpr GhcTc), Type), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints    (IOEnv
   (Env TcGblEnv TcLclEnv)
   (GenLocated SrcSpanAnnA (HsExpr GhcTc), Type)
 -> TcM
      ((GenLocated SrcSpanAnnA (HsExpr GhcTc), Type), WantedConstraints))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr GhcTc), Type)
-> TcM
     ((GenLocated SrcSpanAnnA (HsExpr GhcTc), Type), WantedConstraints)
forall a b. (a -> b) -> a -> b
$ -- see (1) below
                                    Type -> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
ManyTy (TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type))
-> TcM (LHsExpr GhcTc, Type) -> TcM (LHsExpr GhcTc, Type)
forall a b. (a -> b) -> a -> b
$ -- see (2) below
                                    LHsExpr GhcRn -> TcM (LHsExpr GhcTc, Type)
tcInferRho LHsExpr GhcRn
record_expr

            -- (1)
            -- Note that we capture, and then discard, the constraints.
            -- This `tcInferRho` is used *only* to identify the data type,
            -- so we can deal with field disambiguation.
            -- Then we are going to generate a desugared record update, including `record_expr`,
            -- and typecheck it from scratch.  We don't want to generate the constraints twice!

            -- (2)
            -- Record update drops some of the content of the record (namely the
            -- content of the field being updated). As a consequence, unless the
            -- field being updated is unrestricted in the record, we need an
            -- unrestricted record. Currently, we simply always require an
            -- unrestricted record.
            --
            -- Consider the following example:
            --
            -- data R a = R { self :: a }
            -- bad :: a ⊸ ()
            -- bad x = let r = R x in case r { self = () } of { R x' -> x' }
            --
            -- This should definitely *not* typecheck.

       -- STEP -1  See Note [Disambiguating record fields] in GHC.Tc.Gen.Head
       -- After this we know that rbinds is unambiguous
       ; [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
      (LocatedA (HsExpr GhcRn)))]
rbinds <- LHsExpr GhcRn
-> Type
-> [LHsRecUpdField GhcRn]
-> ExpRhoType
-> TcM
     [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds LHsExpr GhcRn
record_expr Type
record_rho [LHsRecUpdField GhcRn]
rbnds ExpRhoType
res_ty
       ; let upd_flds :: [AmbiguousFieldOcc GhcTc]
upd_flds = (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
      (LocatedA (HsExpr GhcRn)))
 -> AmbiguousFieldOcc GhcTc)
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
         (LocatedA (HsExpr GhcRn)))]
-> [AmbiguousFieldOcc GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc)
-> AmbiguousFieldOcc GhcTc
forall l e. GenLocated l e -> e
unLoc (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc)
 -> AmbiguousFieldOcc GhcTc)
-> (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
         (LocatedA (HsExpr GhcRn)))
    -> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
        (LocatedA (HsExpr GhcRn)))
-> AmbiguousFieldOcc GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
  (LocatedA (HsExpr GhcRn))
-> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS (HsFieldBind
   (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
   (LocatedA (HsExpr GhcRn))
 -> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
-> (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
         (LocatedA (HsExpr GhcRn)))
    -> HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
         (LocatedA (HsExpr GhcRn)))
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
        (LocatedA (HsExpr GhcRn)))
-> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
     (LocatedA (HsExpr GhcRn)))
-> HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
     (LocatedA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc) [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
      (LocatedA (HsExpr GhcRn)))]
rbinds
             upd_fld_occs :: [FieldLabelString]
upd_fld_occs = (AmbiguousFieldOcc GhcTc -> FieldLabelString)
-> [AmbiguousFieldOcc GhcTc] -> [FieldLabelString]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> FieldLabelString
FieldLabelString (FastString -> FieldLabelString)
-> (AmbiguousFieldOcc GhcTc -> FastString)
-> AmbiguousFieldOcc GhcTc
-> FieldLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> FastString
occNameFS (OccName -> FastString)
-> (AmbiguousFieldOcc GhcTc -> OccName)
-> AmbiguousFieldOcc GhcTc
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> OccName)
-> (AmbiguousFieldOcc GhcTc -> RdrName)
-> AmbiguousFieldOcc GhcTc
-> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AmbiguousFieldOcc GhcTc -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc) [AmbiguousFieldOcc GhcTc]
upd_flds
             sel_ids :: [TyCoVar]
sel_ids      = (AmbiguousFieldOcc GhcTc -> TyCoVar)
-> [AmbiguousFieldOcc GhcTc] -> [TyCoVar]
forall a b. (a -> b) -> [a] -> [b]
map AmbiguousFieldOcc GhcTc -> TyCoVar
selectorAmbiguousFieldOcc [AmbiguousFieldOcc GhcTc]
upd_flds
             upd_fld_names :: [Name]
upd_fld_names = (TyCoVar -> Name) -> [TyCoVar] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyCoVar -> Name
idName [TyCoVar]
sel_ids

       -- STEP 0
       -- Check that the field names are really field names
       -- and they are all field names for proper records or
       -- all field names for pattern synonyms.
       ; let bad_guys :: [TcRn ()]
bad_guys = [ SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
addErrTc (Name -> TcRnMessage
notSelector Name
fld_name)
                        | GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
     (LocatedA (HsExpr GhcRn)))
fld <- [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
      (LocatedA (HsExpr GhcRn)))]
rbinds,
                          -- Excludes class ops
                          let L SrcSpan
loc TyCoVar
sel_id = HsFieldBind (LAmbiguousFieldOcc GhcTc) (LocatedA (HsExpr GhcRn))
-> GenLocated SrcSpan TyCoVar
forall arg.
HsFieldBind (LAmbiguousFieldOcc GhcTc) arg
-> GenLocated SrcSpan TyCoVar
hsRecUpdFieldId (GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
     (LocatedA (HsExpr GhcRn)))
-> HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
     (LocatedA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
     (LocatedA (HsExpr GhcRn)))
fld),
                          Bool -> Bool
not (TyCoVar -> Bool
isRecordSelector TyCoVar
sel_id),
                          let fld_name :: Name
fld_name = TyCoVar -> Name
idName TyCoVar
sel_id ]
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([TcRn ()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcRn ()]
bad_guys) ([TcRn ()] -> IOEnv (Env TcGblEnv TcLclEnv) [()]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [TcRn ()]
bad_guys IOEnv (Env TcGblEnv TcLclEnv) [()] -> TcRn () -> TcRn ()
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TcRn ()
forall env a. IOEnv env a
failM)
       -- See Note [Mixed Record Field Updates]
       ; let ([TyCoVar]
data_sels, [TyCoVar]
pat_syn_sels) =
               (TyCoVar -> Bool) -> [TyCoVar] -> ([TyCoVar], [TyCoVar])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition TyCoVar -> Bool
isDataConRecordSelector [TyCoVar]
sel_ids
       ; Bool -> TcRn ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ((TyCoVar -> Bool) -> [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TyCoVar -> Bool
isPatSynRecordSelector [TyCoVar]
pat_syn_sels)
       ; Bool -> TcRnMessage -> TcRn ()
checkTc ( [TyCoVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
data_sels Bool -> Bool -> Bool
|| [TyCoVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
pat_syn_sels )
                 ( [TyCoVar] -> [TyCoVar] -> TcRnMessage
mixedSelectors [TyCoVar]
data_sels [TyCoVar]
pat_syn_sels )

       -- STEP 1
       -- Figure out the tycon and data cons from the first field name
       ; let   -- It's OK to use the non-tc splitters here (for a selector)
             TyCoVar
sel_id : [TyCoVar]
_  = [TyCoVar]
sel_ids
             con_likes :: [ConLike]
             con_likes :: [ConLike]
con_likes = case TyCoVar -> IdDetails
idDetails TyCoVar
sel_id of
                            RecSelId (RecSelData TyCon
tc) Bool
_
                               -> (DataCon -> ConLike) -> [DataCon] -> [ConLike]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> ConLike
RealDataCon (TyCon -> [DataCon]
tyConDataCons TyCon
tc)
                            RecSelId (RecSelPatSyn PatSyn
ps) Bool
_
                               -> [PatSyn -> ConLike
PatSynCon PatSyn
ps]
                            IdDetails
_  -> String -> [ConLike]
forall a. HasCallStack => String -> a
panic String
"tcRecordUpd"
               -- NB: for a data type family, the tycon is the instance tycon
             relevant_cons :: [ConLike]
relevant_cons = [ConLike] -> [FieldLabelString] -> [ConLike]
conLikesWithFields [ConLike]
con_likes [FieldLabelString]
upd_fld_occs
               -- A constructor is only relevant to this process if
               -- it contains *all* the fields that are being updated
               -- Other ones will cause a runtime error if they occur

       -- STEP 2
       -- Check that at least one constructor has all the named fields
       -- i.e. has an empty set of bad fields returned by badFields
       ; case [ConLike]
relevant_cons of
         { [] -> TcRnMessage -> TcM (HsExpr GhcRn, Type, SDoc)
forall a. TcRnMessage -> TcM a
failWithTc ([LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike] -> TcRnMessage
badFieldsUpd [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
      (LocatedA (HsExpr GhcRn)))]
rbinds [ConLike]
con_likes)
         ; ConLike
relevant_con : [ConLike]
_ ->

      -- STEP 3
      -- Create new variables for the fields we are updating,
      -- so that we can share them across constructors.
      --
      -- Example:
      --
      --   e { x=e1, y=e2 }
      --
      -- We want to let-bind variables to `e1` and `e2`:
      --
      --   let x' :: Int
      --       x' = e1
      --       y' :: Bool
      --       y' = e2
      --   in ...

    do { -- Instantiate the type variables of any relevant constuctor
         -- with metavariables to obtain a type for each 'Id'.
         -- This will allow us to have 'Id's with polymorphic types
         -- by using 'IdSig'. See Wrinkle [Using IdSig] in Note [Record Updates].
       ; let ([TyCoVar]
univ_tvs, [TyCoVar]
ex_tvs, [EqSpec]
eq_spec, [Type]
_, [Type]
_, [Scaled Type]
arg_tys, Type
con_res_ty) = ConLike
-> ([TyCoVar], [TyCoVar], [EqSpec], [Type], [Type], [Scaled Type],
    Type)
conLikeFullSig ConLike
relevant_con
       ; (Subst
subst, [TyCoVar]
tc_tvs) <- [TyCoVar] -> TcM (Subst, [TyCoVar])
newMetaTyVars ([TyCoVar]
univ_tvs [TyCoVar] -> [TyCoVar] -> [TyCoVar]
forall a. [a] -> [a] -> [a]
++ [TyCoVar]
ex_tvs)
       ; let ([Type]
actual_univ_tys, [Type]
_actual_ex_tys) = [TyCoVar] -> [Type] -> ([Type], [Type])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [TyCoVar]
univ_tvs ([Type] -> ([Type], [Type])) -> [Type] -> ([Type], [Type])
forall a b. (a -> b) -> a -> b
$ (TyCoVar -> Type) -> [TyCoVar] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyCoVar -> Type
mkTyVarTy [TyCoVar]
tc_tvs

             -- See Wrinkle [GADT result type in tcRecordUpd]
             -- for an explanation of the following.
             ds_res_ty :: Type
ds_res_ty = case ConLike
relevant_con of
               RealDataCon DataCon
con
                 | Bool -> Bool
not ([EqSpec] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EqSpec]
eq_spec) -- We only need to do this if we have actual GADT equalities.
                 -> TyCon -> [Type] -> Type
mkFamilyTyConApp (DataCon -> TyCon
dataConTyCon DataCon
con) [Type]
actual_univ_tys
               ConLike
_ -> (() :: Constraint) => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst Type
con_res_ty

       -- Gather pairs of let-bound Ids and their right-hand sides,
       -- e.g. (x', e1), (y', e2), ...
       ; let mk_upd_id :: Name -> LHsFieldBind GhcTc fld (LHsExpr GhcRn) -> TcM (Name, (TcId, LHsExpr GhcRn))
             mk_upd_id :: forall fld.
Name
-> LHsFieldBind GhcTc fld (LHsExpr GhcRn)
-> TcM (Name, (TyCoVar, LHsExpr GhcRn))
mk_upd_id Name
fld_nm (L SrcSpanAnnA
_ HsFieldBind fld (LocatedA (HsExpr GhcRn))
rbind)
               = do { let Scaled Type
m Type
arg_ty = NameEnv (Scaled Type) -> Name -> Scaled Type
forall a. NameEnv a -> Name -> a
lookupNameEnv_NF NameEnv (Scaled Type)
arg_ty_env Name
fld_nm
                          nm_occ :: OccName
nm_occ = RdrName -> OccName
rdrNameOcc (RdrName -> OccName) -> (Name -> RdrName) -> Name -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> RdrName
nameRdrName (Name -> OccName) -> Name -> OccName
forall a b. (a -> b) -> a -> b
$ Name
fld_nm
                          actual_arg_ty :: Type
actual_arg_ty = (() :: Constraint) => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst Type
arg_ty
                          rhs :: LocatedA (HsExpr GhcRn)
rhs = HsFieldBind fld (LocatedA (HsExpr GhcRn))
-> LocatedA (HsExpr GhcRn)
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind fld (LocatedA (HsExpr GhcRn))
rbind
                    ; (TcCoercionR
_co, Type
actual_arg_ty) <- (() :: Constraint) =>
FixedRuntimeRepContext -> Type -> TcM (TcCoercionR, Type)
FixedRuntimeRepContext -> Type -> TcM (TcCoercionR, Type)
hasFixedRuntimeRep (Name -> HsExpr GhcRn -> FixedRuntimeRepContext
FRRRecordUpdate Name
fld_nm (LocatedA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LocatedA (HsExpr GhcRn)
rhs)) Type
actual_arg_ty
                      -- We get a better error message by doing a (redundant) representation-polymorphism check here,
                      -- rather than delaying until the typechecker typechecks the let-bindings,
                      -- because the let-bound Ids have internal names.
                      -- (As we will typecheck the let-bindings later, we can drop this coercion here.)
                      -- See RepPolyRecordUpdate test.
                    ; Name
nm <- OccName -> SrcSpan -> TcM Name
newNameAt OccName
nm_occ SrcSpan
generatedSrcSpan
                    ; let id :: TyCoVar
id = (() :: Constraint) => Name -> Type -> Type -> TyCoVar
Name -> Type -> Type -> TyCoVar
mkLocalId Name
nm Type
m Type
actual_arg_ty
                      -- NB: create fresh names to avoid any accidental shadowing
                      -- occurring in the RHS expressions when creating the let bindings:
                      --
                      --  let x1 = e1; x2 = e2; ...
                    ; (Name, (TyCoVar, LocatedA (HsExpr GhcRn)))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Name, (TyCoVar, LocatedA (HsExpr GhcRn)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
fld_nm, (TyCoVar
id, LocatedA (HsExpr GhcRn)
rhs))
                    }
             arg_ty_env :: NameEnv (Scaled Type)
arg_ty_env = [(Name, Scaled Type)] -> NameEnv (Scaled Type)
forall a. [(Name, a)] -> NameEnv a
mkNameEnv
                        ([(Name, Scaled Type)] -> NameEnv (Scaled Type))
-> [(Name, Scaled Type)] -> NameEnv (Scaled Type)
forall a b. (a -> b) -> a -> b
$ (FieldLabel -> Scaled Type -> (Name, Scaled Type))
-> [FieldLabel] -> [Scaled Type] -> [(Name, Scaled Type)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ FieldLabel
lbl Scaled Type
arg_ty -> (FieldLabel -> Name
flSelector FieldLabel
lbl, Scaled Type
arg_ty))
                            (ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
relevant_con)
                            [Scaled Type]
arg_tys

       ; [(Name, (TyCoVar, LocatedA (HsExpr GhcRn)))]
upd_ids <- (Name
 -> GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
         (LocatedA (HsExpr GhcRn)))
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (Name, (TyCoVar, LocatedA (HsExpr GhcRn))))
-> [Name]
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
         (LocatedA (HsExpr GhcRn)))]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [(Name, (TyCoVar, LocatedA (HsExpr GhcRn)))]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Name
-> LHsFieldBind
     GhcTc
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
     (LHsExpr GhcRn)
-> TcM (Name, (TyCoVar, LHsExpr GhcRn))
Name
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
        (LocatedA (HsExpr GhcRn)))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Name, (TyCoVar, LocatedA (HsExpr GhcRn)))
forall fld.
Name
-> LHsFieldBind GhcTc fld (LHsExpr GhcRn)
-> TcM (Name, (TyCoVar, LHsExpr GhcRn))
mk_upd_id [Name]
upd_fld_names [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
      (LocatedA (HsExpr GhcRn)))]
rbinds
       ; let updEnv :: UniqMap Name (Id, LHsExpr GhcRn)
             updEnv :: UniqMap Name (TyCoVar, LHsExpr GhcRn)
updEnv = [(Name, (TyCoVar, LHsExpr GhcRn))]
-> UniqMap Name (TyCoVar, LHsExpr GhcRn)
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap ([(Name, (TyCoVar, LHsExpr GhcRn))]
 -> UniqMap Name (TyCoVar, LHsExpr GhcRn))
-> [(Name, (TyCoVar, LHsExpr GhcRn))]
-> UniqMap Name (TyCoVar, LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ [(Name, (TyCoVar, LHsExpr GhcRn))]
[(Name, (TyCoVar, LocatedA (HsExpr GhcRn)))]
upd_ids

             make_pat :: ConLike -> LMatch GhcRn (LHsExpr GhcRn)
             -- As explained in Note [Record Updates], to desugar
             --
             --   e { x=e1, y=e2 }
             --
             -- we generate a case statement, with an equation for
             -- each constructor of the record. For example, for
             -- the constructor
             --
             --   T1 :: { x :: Int, y :: Bool, z :: Char } -> T p q
             --
             -- we let-bind x' = e1, y' = e2 and generate the equation:
             --
             --   T1 _ _ z -> T1 x' y' z
             make_pat :: ConLike -> LMatch GhcRn (LHsExpr GhcRn)
make_pat ConLike
conLike = HsMatchContext GhcRn
-> [LPat GhcRn]
-> LocatedA (HsExpr GhcRn)
-> LMatch GhcRn (LocatedA (HsExpr GhcRn))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA,
 Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns) =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch HsMatchContext GhcRn
forall p. HsMatchContext p
CaseAlt [LPat GhcRn
pat] LocatedA (HsExpr GhcRn)
rhs
               where
                 ([GenLocated SrcSpanAnnA (Pat GhcRn)]
lhs_con_pats, [LocatedA (HsExpr GhcRn)]
rhs_con_args)
                    = (Int
 -> FieldLabel
 -> (GenLocated SrcSpanAnnA (Pat GhcRn), LocatedA (HsExpr GhcRn)))
-> [Int]
-> [FieldLabel]
-> ([GenLocated SrcSpanAnnA (Pat GhcRn)],
    [LocatedA (HsExpr GhcRn)])
forall a b c d. (a -> b -> (c, d)) -> [a] -> [b] -> ([c], [d])
zipWithAndUnzip Int -> FieldLabel -> (LPat GhcRn, LHsExpr GhcRn)
Int
-> FieldLabel
-> (GenLocated SrcSpanAnnA (Pat GhcRn), LocatedA (HsExpr GhcRn))
mk_con_arg [Int
1..] [FieldLabel]
con_fields
                 pat :: LPat GhcRn
pat = Name -> [LPat GhcRn] -> LPat GhcRn
genSimpleConPat Name
con [LPat GhcRn]
[GenLocated SrcSpanAnnA (Pat GhcRn)]
lhs_con_pats
                 rhs :: LocatedA (HsExpr GhcRn)
rhs = HsExpr GhcRn -> LocatedA (HsExpr GhcRn)
forall a an. a -> LocatedAn an a
wrapGenSpan (HsExpr GhcRn -> LocatedA (HsExpr GhcRn))
-> HsExpr GhcRn -> LocatedA (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
genHsApps Name
con [LHsExpr GhcRn]
[LocatedA (HsExpr GhcRn)]
rhs_con_args
                 con :: Name
con = ConLike -> Name
conLikeName ConLike
conLike
                 con_fields :: [FieldLabel]
con_fields = ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
conLike

             mk_con_arg :: Int
                        -> FieldLabel
                        -> ( LPat GhcRn
                              -- LHS constructor pattern argument
                           , LHsExpr GhcRn )
                              -- RHS constructor argument
             mk_con_arg :: Int -> FieldLabel -> (LPat GhcRn, LHsExpr GhcRn)
mk_con_arg Int
i FieldLabel
fld_lbl =
               -- The following generates the pattern matches of the desugared `case` expression.
               -- For fields being updated (for example `x`, `y` in T1 and T4 in Note [Record Updates]),
               -- wildcards are used to avoid creating unused variables.
               case UniqMap Name (TyCoVar, LocatedA (HsExpr GhcRn))
-> Name -> Maybe (TyCoVar, LocatedA (HsExpr GhcRn))
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UniqMap Name (TyCoVar, LHsExpr GhcRn)
UniqMap Name (TyCoVar, LocatedA (HsExpr GhcRn))
updEnv (Name -> Maybe (TyCoVar, LocatedA (HsExpr GhcRn)))
-> Name -> Maybe (TyCoVar, LocatedA (HsExpr GhcRn))
forall a b. (a -> b) -> a -> b
$ FieldLabel -> Name
flSelector FieldLabel
fld_lbl of
                 -- Field is being updated: LHS = wildcard pattern, RHS = appropriate let-bound Id.
                 Just (TyCoVar
upd_id, LocatedA (HsExpr GhcRn)
_) -> (LPat GhcRn
genWildPat, Name -> LHsExpr GhcRn
genLHsVar (TyCoVar -> Name
idName TyCoVar
upd_id))
                 -- Field is not being updated: LHS = variable pattern, RHS = that same variable.
                 Maybe (TyCoVar, LocatedA (HsExpr GhcRn))
_  -> let fld_nm :: Name
fld_nm = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Int -> Unique
mkBuiltinUnique Int
i)
                                      (FastString -> OccName
mkVarOccFS (FieldLabelString -> FastString
field_label (FieldLabelString -> FastString) -> FieldLabelString -> FastString
forall a b. (a -> b) -> a -> b
$ FieldLabel -> FieldLabelString
flLabel FieldLabel
fld_lbl))
                                      SrcSpan
generatedSrcSpan
                       in (Name -> LPat GhcRn
genVarPat Name
fld_nm, Name -> LHsExpr GhcRn
genLHsVar Name
fld_nm)

       -- STEP 4
       -- Desugar to HsCase, as per note [Record Updates]
       ; let ds_expr :: HsExpr GhcRn
             ds_expr :: HsExpr GhcRn
ds_expr = XLet GhcRn
-> LHsToken "let" GhcRn
-> HsLocalBinds GhcRn
-> LHsToken "in" GhcRn
-> LHsExpr GhcRn
-> HsExpr GhcRn
forall p.
XLet p
-> LHsToken "let" p
-> HsLocalBinds p
-> LHsToken "in" p
-> LHsExpr p
-> HsExpr p
HsLet XLet GhcRn
NoExtField
noExtField LHsToken "let" GhcRn
GenLocated TokenLocation (HsToken "let")
forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok)
noHsTok HsLocalBinds GhcRn
let_binds LHsToken "in" GhcRn
GenLocated TokenLocation (HsToken "in")
forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok)
noHsTok (SrcSpanAnnA -> HsExpr GhcRn -> LocatedA (HsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
forall {ann}. SrcAnn ann
gen HsExpr GhcRn
case_expr)

             case_expr :: HsExpr GhcRn
             case_expr :: HsExpr GhcRn
case_expr = XCase GhcRn
-> LHsExpr GhcRn
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> HsExpr GhcRn
forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase XCase GhcRn
NoExtField
noExtField LHsExpr GhcRn
record_expr (Origin
-> LocatedL [LocatedA (Match GhcRn (LocatedA (HsExpr GhcRn)))]
-> MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
     [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
Generated ([LocatedA (Match GhcRn (LocatedA (HsExpr GhcRn)))]
-> LocatedL [LocatedA (Match GhcRn (LocatedA (HsExpr GhcRn)))]
forall a an. a -> LocatedAn an a
wrapGenSpan [LMatch GhcRn (LHsExpr GhcRn)]
[LocatedA (Match GhcRn (LocatedA (HsExpr GhcRn)))]
matches))
             matches :: [LMatch GhcRn (LHsExpr GhcRn)]
             matches :: [LMatch GhcRn (LHsExpr GhcRn)]
matches = (ConLike -> LocatedA (Match GhcRn (LocatedA (HsExpr GhcRn))))
-> [ConLike] -> [LocatedA (Match GhcRn (LocatedA (HsExpr GhcRn)))]
forall a b. (a -> b) -> [a] -> [b]
map ConLike -> LMatch GhcRn (LHsExpr GhcRn)
ConLike -> LocatedA (Match GhcRn (LocatedA (HsExpr GhcRn)))
make_pat [ConLike]
relevant_cons

             let_binds :: HsLocalBindsLR GhcRn GhcRn
             let_binds :: HsLocalBinds GhcRn
let_binds = XHsValBinds GhcRn GhcRn
-> HsValBindsLR GhcRn GhcRn -> HsLocalBinds GhcRn
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcRn GhcRn
EpAnn AnnList
forall a. EpAnn a
noAnn (HsValBindsLR GhcRn GhcRn -> HsLocalBinds GhcRn)
-> HsValBindsLR GhcRn GhcRn -> HsLocalBinds GhcRn
forall a b. (a -> b) -> a -> b
$ XXValBindsLR GhcRn GhcRn -> HsValBindsLR GhcRn GhcRn
forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
XValBindsLR
                       (XXValBindsLR GhcRn GhcRn -> HsValBindsLR GhcRn GhcRn)
-> XXValBindsLR GhcRn GhcRn -> HsValBindsLR GhcRn GhcRn
forall a b. (a -> b) -> a -> b
$ [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> NHsValBindsLR GhcRn
forall idL.
[(RecFlag, LHsBinds idL)] -> [LSig GhcRn] -> NHsValBindsLR idL
NValBinds [(RecFlag, LHsBinds GhcRn)]
upd_ids_lhs (((Name, (TyCoVar, LocatedA (HsExpr GhcRn)))
 -> GenLocated SrcSpanAnnA (Sig GhcRn))
-> [(Name, (TyCoVar, LocatedA (HsExpr GhcRn)))]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (Name, (TyCoVar, LHsExpr GhcRn)) -> LSig GhcRn
(Name, (TyCoVar, LocatedA (HsExpr GhcRn)))
-> GenLocated SrcSpanAnnA (Sig GhcRn)
mk_idSig [(Name, (TyCoVar, LocatedA (HsExpr GhcRn)))]
upd_ids)
             upd_ids_lhs :: [(RecFlag, LHsBindsLR GhcRn GhcRn)]
             upd_ids_lhs :: [(RecFlag, LHsBinds GhcRn)]
upd_ids_lhs = [ (RecFlag
NonRecursive, LHsBind GhcRn -> LHsBinds GhcRn
forall a. a -> Bag a
unitBag (LHsBind GhcRn -> LHsBinds GhcRn)
-> LHsBind GhcRn -> LHsBinds GhcRn
forall a b. (a -> b) -> a -> b
$ Name -> [LPat GhcRn] -> LHsExpr GhcRn -> LHsBind GhcRn
genSimpleFunBind (TyCoVar -> Name
idName TyCoVar
id) [] LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
rhs)
                           | (Name
_, (TyCoVar
id, LocatedA (HsExpr GhcRn)
rhs)) <- [(Name, (TyCoVar, LocatedA (HsExpr GhcRn)))]
upd_ids ]
             mk_idSig :: (Name, (Id, LHsExpr GhcRn)) -> LSig GhcRn
             mk_idSig :: (Name, (TyCoVar, LHsExpr GhcRn)) -> LSig GhcRn
mk_idSig (Name
_, (TyCoVar
id, LHsExpr GhcRn
_)) = SrcSpanAnnA -> Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
forall {ann}. SrcAnn ann
gen (Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn))
-> Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall a b. (a -> b) -> a -> b
$ XXSig GhcRn -> Sig GhcRn
forall pass. XXSig pass -> Sig pass
XSig (XXSig GhcRn -> Sig GhcRn) -> XXSig GhcRn -> Sig GhcRn
forall a b. (a -> b) -> a -> b
$ TyCoVar -> IdSig
IdSig TyCoVar
id
               -- We let-bind variables using 'IdSig' in order to accept
               -- record updates involving higher-rank types.
               -- See Wrinkle [Using IdSig] in Note [Record Updates].
             gen :: SrcAnn ann
gen = SrcSpan -> SrcAnn ann
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
generatedSrcSpan

        ; String -> SDoc -> TcRn ()
traceTc String
"desugarRecordUpd" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
            [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"relevant_con:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
relevant_con
                 , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"res_ty:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty
                 , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ds_res_ty:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ds_res_ty
                 ]

        ; let cons :: SDoc
cons = [ConLike] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [ConLike]
relevant_cons
              err_lines :: [SDoc]
err_lines =
                (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In a record update at field" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Name] -> SDoc
forall a. [a] -> SDoc
plural [Name]
upd_fld_names SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Name] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [Name]
upd_fld_names SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
:)
                ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ case ConLike
relevant_con of
                     RealDataCon DataCon
con ->
                        [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"with type constructor" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DataCon -> TyCon
dataConTyCon DataCon
con))
                        , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"data constructor" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ConLike] -> SDoc
forall a. [a] -> SDoc
plural [ConLike]
relevant_cons SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
cons ]
                     PatSynCon {} ->
                        [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"with pattern synonym" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ConLike] -> SDoc
forall a. [a] -> SDoc
plural [ConLike]
relevant_cons SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
cons ]
                [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ if [TyCoVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
ex_tvs
                   then []
                   else [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"existential variable" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [TyCoVar] -> SDoc
forall a. [a] -> SDoc
plural [TyCoVar]
ex_tvs SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TyCoVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [TyCoVar]
ex_tvs ]
              err_ctxt :: SDoc
err_ctxt = [SDoc] -> SDoc
make_lines_msg [SDoc]
err_lines

        ; (HsExpr GhcRn, Type, SDoc) -> TcM (HsExpr GhcRn, Type, SDoc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn
ds_expr, Type
ds_res_ty, SDoc
err_ctxt) } } }

-- | Pretty-print a collection of lines, adding commas at the end of each line,
-- and adding "and" to the start of the last line.
make_lines_msg :: [SDoc] -> SDoc
make_lines_msg :: [SDoc] -> SDoc
make_lines_msg []      = SDoc
forall doc. IsOutput doc => doc
empty
make_lines_msg [SDoc
last]  = SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SDoc
last SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
dot
make_lines_msg [SDoc
l1,SDoc
l2] = SDoc
l1 SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"and" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
l2 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
dot
make_lines_msg (SDoc
l:[SDoc]
ls)  = SDoc
l SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
make_lines_msg [SDoc]
ls

{- *********************************************************************
*                                                                      *
                 Record bindings
*                                                                      *
********************************************************************* -}

-- Disambiguate the fields in a record update.
-- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head
disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType
                 -> [LHsRecUpdField GhcRn] -> ExpRhoType
                 -> TcM [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds :: LHsExpr GhcRn
-> Type
-> [LHsRecUpdField GhcRn]
-> ExpRhoType
-> TcM
     [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds LHsExpr GhcRn
record_expr Type
record_rho [LHsRecUpdField GhcRn]
rbnds ExpRhoType
res_ty
    -- Are all the fields unambiguous?
  = case (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
      (LocatedA (HsExpr GhcRn)))
 -> Maybe
      (GenLocated
         SrcSpanAnnA
         (HsFieldBind
            (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
            (LocatedA (HsExpr GhcRn))),
       Name))
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
         (LocatedA (HsExpr GhcRn)))]
-> Maybe
     [(GenLocated
         SrcSpanAnnA
         (HsFieldBind
            (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
            (LocatedA (HsExpr GhcRn))),
       Name)]
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 LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn, Name)
GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
     (LocatedA (HsExpr GhcRn)))
-> Maybe
     (GenLocated
        SrcSpanAnnA
        (HsFieldBind
           (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
           (LocatedA (HsExpr GhcRn))),
      Name)
isUnambiguous [LHsRecUpdField GhcRn]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
      (LocatedA (HsExpr GhcRn)))]
rbnds of
                     -- If so, just skip to looking up the Ids
                     -- Always the case if DuplicateRecordFields is off
      Just [(GenLocated
    SrcSpanAnnA
    (HsFieldBind
       (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
       (LocatedA (HsExpr GhcRn))),
  Name)]
rbnds' -> ((GenLocated
    SrcSpanAnnA
    (HsFieldBind
       (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
       (LocatedA (HsExpr GhcRn))),
  Name)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated
         SrcSpanAnnA
         (HsFieldBind
            (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
            (LocatedA (HsExpr GhcRn)))))
-> [(GenLocated
       SrcSpanAnnA
       (HsFieldBind
          (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
          (LocatedA (HsExpr GhcRn))),
     Name)]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [GenLocated
        SrcSpanAnnA
        (HsFieldBind
           (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
           (LocatedA (HsExpr GhcRn)))]
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 (LHsRecUpdField GhcRn, Name)
-> TcM
     (LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
(GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
      (LocatedA (HsExpr GhcRn))),
 Name)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated
        SrcSpanAnnA
        (HsFieldBind
           (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
           (LocatedA (HsExpr GhcRn))))
lookupSelector [(GenLocated
    SrcSpanAnnA
    (HsFieldBind
       (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
       (LocatedA (HsExpr GhcRn))),
  Name)]
rbnds'
      Maybe
  [(GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
         (LocatedA (HsExpr GhcRn))),
    Name)]
Nothing     -> -- If not, try to identify a single parent
        do { FamInstEnvs
fam_inst_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
             -- Look up the possible parents for each field
           ; [(GenLocated
    SrcSpanAnnA
    (HsFieldBind
       (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
       (LocatedA (HsExpr GhcRn))),
  [(RecSelParent, GlobalRdrElt)])]
rbnds_with_parents <- TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
IOEnv
  (Env TcGblEnv TcLclEnv)
  [(GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
         (LocatedA (HsExpr GhcRn))),
    [(RecSelParent, GlobalRdrElt)])]
getUpdFieldsParents
           ; let possible_parents :: [[RecSelParent]]
possible_parents = ((GenLocated
    SrcSpanAnnA
    (HsFieldBind
       (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
       (LocatedA (HsExpr GhcRn))),
  [(RecSelParent, GlobalRdrElt)])
 -> [RecSelParent])
-> [(GenLocated
       SrcSpanAnnA
       (HsFieldBind
          (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
          (LocatedA (HsExpr GhcRn))),
     [(RecSelParent, GlobalRdrElt)])]
-> [[RecSelParent]]
forall a b. (a -> b) -> [a] -> [b]
map (((RecSelParent, GlobalRdrElt) -> RecSelParent)
-> [(RecSelParent, GlobalRdrElt)] -> [RecSelParent]
forall a b. (a -> b) -> [a] -> [b]
map (RecSelParent, GlobalRdrElt) -> RecSelParent
forall a b. (a, b) -> a
fst ([(RecSelParent, GlobalRdrElt)] -> [RecSelParent])
-> ((GenLocated
       SrcSpanAnnA
       (HsFieldBind
          (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
          (LocatedA (HsExpr GhcRn))),
     [(RecSelParent, GlobalRdrElt)])
    -> [(RecSelParent, GlobalRdrElt)])
-> (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
         (LocatedA (HsExpr GhcRn))),
    [(RecSelParent, GlobalRdrElt)])
-> [RecSelParent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
      (LocatedA (HsExpr GhcRn))),
 [(RecSelParent, GlobalRdrElt)])
-> [(RecSelParent, GlobalRdrElt)]
forall a b. (a, b) -> b
snd) [(GenLocated
    SrcSpanAnnA
    (HsFieldBind
       (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
       (LocatedA (HsExpr GhcRn))),
  [(RecSelParent, GlobalRdrElt)])]
rbnds_with_parents
             -- Identify a single parent
           ; RecSelParent
p <- FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
identifyParent FamInstEnvs
fam_inst_envs [[RecSelParent]]
possible_parents
             -- Pick the right selector with that parent for each field
           ; IOEnv
  (Env TcGblEnv TcLclEnv)
  [GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
        (LocatedA (HsExpr GhcRn)))]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [GenLocated
        SrcSpanAnnA
        (HsFieldBind
           (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
           (LocatedA (HsExpr GhcRn)))]
forall r. TcM r -> TcM r
checkNoErrs (IOEnv
   (Env TcGblEnv TcLclEnv)
   [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
         (LocatedA (HsExpr GhcRn)))]
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      [GenLocated
         SrcSpanAnnA
         (HsFieldBind
            (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
            (LocatedA (HsExpr GhcRn)))])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [GenLocated
        SrcSpanAnnA
        (HsFieldBind
           (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
           (LocatedA (HsExpr GhcRn)))]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [GenLocated
        SrcSpanAnnA
        (HsFieldBind
           (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
           (LocatedA (HsExpr GhcRn)))]
forall a b. (a -> b) -> a -> b
$ ((GenLocated
    SrcSpanAnnA
    (HsFieldBind
       (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
       (LocatedA (HsExpr GhcRn))),
  [(RecSelParent, GlobalRdrElt)])
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated
         SrcSpanAnnA
         (HsFieldBind
            (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
            (LocatedA (HsExpr GhcRn)))))
-> [(GenLocated
       SrcSpanAnnA
       (HsFieldBind
          (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
          (LocatedA (HsExpr GhcRn))),
     [(RecSelParent, GlobalRdrElt)])]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [GenLocated
        SrcSpanAnnA
        (HsFieldBind
           (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
           (LocatedA (HsExpr GhcRn)))]
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 (RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> TcM
     (LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
pickParent RecSelParent
p) [(GenLocated
    SrcSpanAnnA
    (HsFieldBind
       (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
       (LocatedA (HsExpr GhcRn))),
  [(RecSelParent, GlobalRdrElt)])]
rbnds_with_parents }
  where
    -- Extract the selector name of a field update if it is unambiguous
    isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)
    isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn, Name)
isUnambiguous LHsRecUpdField GhcRn
x = case GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn)
-> AmbiguousFieldOcc GhcRn
forall l e. GenLocated l e -> e
unLoc (HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
  (LocatedA (HsExpr GhcRn))
-> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS (GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
     (LocatedA (HsExpr GhcRn)))
-> HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
     (LocatedA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc LHsRecUpdField GhcRn
GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
     (LocatedA (HsExpr GhcRn)))
x)) of
                        Unambiguous XUnambiguous GhcRn
sel_name XRec GhcRn RdrName
_ -> (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
      (LocatedA (HsExpr GhcRn))),
 Name)
-> Maybe
     (GenLocated
        SrcSpanAnnA
        (HsFieldBind
           (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
           (LocatedA (HsExpr GhcRn))),
      Name)
forall a. a -> Maybe a
Just (LHsRecUpdField GhcRn
GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
     (LocatedA (HsExpr GhcRn)))
x, XUnambiguous GhcRn
Name
sel_name)
                        Ambiguous{}            -> Maybe (LHsRecUpdField GhcRn, Name)
Maybe
  (GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
        (LocatedA (HsExpr GhcRn))),
   Name)
forall a. Maybe a
Nothing

    -- Look up the possible parents and selector GREs for each field
    getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn
                                , [(RecSelParent, GlobalRdrElt)])]
    getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
getUpdFieldsParents
      = ([[(RecSelParent, GlobalRdrElt)]]
 -> [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])])
-> IOEnv (Env TcGblEnv TcLclEnv) [[(RecSelParent, GlobalRdrElt)]]
-> TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
      (LocatedA (HsExpr GhcRn)))]
-> [[(RecSelParent, GlobalRdrElt)]]
-> [(GenLocated
       SrcSpanAnnA
       (HsFieldBind
          (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
          (LocatedA (HsExpr GhcRn))),
     [(RecSelParent, GlobalRdrElt)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [LHsRecUpdField GhcRn]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
      (LocatedA (HsExpr GhcRn)))]
rbnds) (IOEnv (Env TcGblEnv TcLclEnv) [[(RecSelParent, GlobalRdrElt)]]
 -> TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])])
-> IOEnv (Env TcGblEnv TcLclEnv) [[(RecSelParent, GlobalRdrElt)]]
-> TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
forall a b. (a -> b) -> a -> b
$ (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
      (LocatedA (HsExpr GhcRn)))
 -> IOEnv (Env TcGblEnv TcLclEnv) [(RecSelParent, GlobalRdrElt)])
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
         (LocatedA (HsExpr GhcRn)))]
-> IOEnv (Env TcGblEnv TcLclEnv) [[(RecSelParent, GlobalRdrElt)]]
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
          (Bool
-> RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) [(RecSelParent, GlobalRdrElt)]
lookupParents Bool
False (RdrName
 -> IOEnv (Env TcGblEnv TcLclEnv) [(RecSelParent, GlobalRdrElt)])
-> (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
         (LocatedA (HsExpr GhcRn)))
    -> RdrName)
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
        (LocatedA (HsExpr GhcRn)))
-> IOEnv (Env TcGblEnv TcLclEnv) [(RecSelParent, GlobalRdrElt)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan RdrName -> RdrName)
-> (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
         (LocatedA (HsExpr GhcRn)))
    -> GenLocated SrcSpan RdrName)
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
        (LocatedA (HsExpr GhcRn)))
-> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecUpdField GhcRn -> GenLocated SrcSpan RdrName
HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
  (LocatedA (HsExpr GhcRn))
-> GenLocated SrcSpan RdrName
forall (p :: Pass).
HsRecUpdField (GhcPass p) -> GenLocated SrcSpan RdrName
hsRecUpdFieldRdr (HsFieldBind
   (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
   (LocatedA (HsExpr GhcRn))
 -> GenLocated SrcSpan RdrName)
-> (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
         (LocatedA (HsExpr GhcRn)))
    -> HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
         (LocatedA (HsExpr GhcRn)))
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
        (LocatedA (HsExpr GhcRn)))
-> GenLocated SrcSpan RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
     (LocatedA (HsExpr GhcRn)))
-> HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
     (LocatedA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc)
          [LHsRecUpdField GhcRn]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
      (LocatedA (HsExpr GhcRn)))]
rbnds

    -- Given a the lists of possible parents for each field,
    -- identify a single parent
    identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
    identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
identifyParent FamInstEnvs
fam_inst_envs [[RecSelParent]]
possible_parents
      = case ([RecSelParent] -> [RecSelParent] -> [RecSelParent])
-> [[RecSelParent]] -> [RecSelParent]
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 [RecSelParent] -> [RecSelParent] -> [RecSelParent]
forall a. Eq a => [a] -> [a] -> [a]
intersect [[RecSelParent]]
possible_parents of
        -- No parents for all fields: record update is ill-typed
        []  -> TcRnMessage -> TcM RecSelParent
forall a. TcRnMessage -> TcM a
failWithTc ([LHsRecUpdField GhcRn] -> TcRnMessage
TcRnNoPossibleParentForFields [LHsRecUpdField GhcRn]
rbnds)

        -- Exactly one datatype with all the fields: use that
        [RecSelParent
p] -> RecSelParent -> TcM RecSelParent
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return RecSelParent
p

        -- Multiple possible parents: try harder to disambiguate
        -- Can we get a parent TyCon from the pushed-in type?
        RecSelParent
_:[RecSelParent]
_ | Just TyCon
p <- FamInstEnvs -> ExpRhoType -> Maybe TyCon
tyConOfET FamInstEnvs
fam_inst_envs ExpRhoType
res_ty ->
              do { TyCon -> TcRn ()
reportAmbiguousField TyCon
p
                 ; RecSelParent -> TcM RecSelParent
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> RecSelParent
RecSelData TyCon
p) }

        -- Does the expression being updated have a type signature?
        -- If so, try to extract a parent TyCon from it
            | Just {} <- HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (LocatedA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
record_expr)
            , Just TyCon
tc <- FamInstEnvs -> Type -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs Type
record_rho
            -> do { TyCon -> TcRn ()
reportAmbiguousField TyCon
tc
                  ; RecSelParent -> TcM RecSelParent
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> RecSelParent
RecSelData TyCon
tc) }

        -- Nothing else we can try...
        [RecSelParent]
_ -> TcRnMessage -> TcM RecSelParent
forall a. TcRnMessage -> TcM a
failWithTc ([LHsRecUpdField GhcRn] -> TcRnMessage
TcRnBadOverloadedRecordUpdate [LHsRecUpdField GhcRn]
rbnds)

    -- Make a field unambiguous by choosing the given parent.
    -- Emits an error if the field cannot have that parent,
    -- e.g. if the user writes
    --     r { x = e } :: T
    -- where T does not have field x.
    pickParent :: RecSelParent
               -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
               -> TcM (LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
    pickParent :: RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> TcM
     (LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
pickParent RecSelParent
p (LHsRecUpdField GhcRn
upd, [(RecSelParent, GlobalRdrElt)]
xs)
      = case RecSelParent
-> [(RecSelParent, GlobalRdrElt)] -> Maybe GlobalRdrElt
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup RecSelParent
p [(RecSelParent, GlobalRdrElt)]
xs of
                      -- Phew! The parent is valid for this field.
                      -- Previously ambiguous fields must be marked as
                      -- used now that we know which one is meant, but
                      -- unambiguous ones shouldn't be recorded again
                      -- (giving duplicate deprecation warnings).
          Just GlobalRdrElt
gre -> do { Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(RecSelParent, GlobalRdrElt)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(RecSelParent, GlobalRdrElt)] -> [(RecSelParent, GlobalRdrElt)]
forall a. HasCallStack => [a] -> [a]
tail [(RecSelParent, GlobalRdrElt)]
xs)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
                             let L SrcAnn NoEpAnns
loc AmbiguousFieldOcc GhcRn
_ = HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
  (LocatedA (HsExpr GhcRn))
-> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS (GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
     (LocatedA (HsExpr GhcRn)))
-> HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
     (LocatedA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc LHsRecUpdField GhcRn
GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
     (LocatedA (HsExpr GhcRn)))
upd)
                             SrcAnn NoEpAnns -> TcRn () -> TcRn ()
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcAnn NoEpAnns
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Bool -> GlobalRdrElt -> TcRn ()
addUsedGRE Bool
True GlobalRdrElt
gre
                         ; (LHsRecUpdField GhcRn, Name)
-> TcM
     (LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector (LHsRecUpdField GhcRn
upd, GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre) }
                      -- The field doesn't belong to this parent, so report
                      -- an error but keep going through all the fields
          Maybe GlobalRdrElt
Nothing  -> do { TcRnMessage -> TcRn ()
addErrTc (RecSelParent -> RdrName -> TcRnMessage
fieldNotInType RecSelParent
p
                                      (GenLocated SrcSpan RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc (HsRecUpdField GhcRn -> GenLocated SrcSpan RdrName
forall (p :: Pass).
HsRecUpdField (GhcPass p) -> GenLocated SrcSpan RdrName
hsRecUpdFieldRdr (GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
     (LocatedA (HsExpr GhcRn)))
-> HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
     (LocatedA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc LHsRecUpdField GhcRn
GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
     (LocatedA (HsExpr GhcRn)))
upd))))
                         ; (LHsRecUpdField GhcRn, Name)
-> TcM
     (LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector (LHsRecUpdField GhcRn
upd, GlobalRdrElt -> Name
greMangledName ((RecSelParent, GlobalRdrElt) -> GlobalRdrElt
forall a b. (a, b) -> b
snd ([(RecSelParent, GlobalRdrElt)] -> (RecSelParent, GlobalRdrElt)
forall a. HasCallStack => [a] -> a
head [(RecSelParent, GlobalRdrElt)]
xs))) }

    -- Given a (field update, selector name) pair, look up the
    -- selector to give a field update with an unambiguous Id
    lookupSelector :: (LHsRecUpdField GhcRn, Name)
                 -> TcM (LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
    lookupSelector :: (LHsRecUpdField GhcRn, Name)
-> TcM
     (LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector (L SrcSpanAnnA
l HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
  (LocatedA (HsExpr GhcRn))
upd, Name
n)
      = do { TyCoVar
i <- Name -> TcM TyCoVar
tcLookupId Name
n
           ; let L SrcAnn NoEpAnns
loc AmbiguousFieldOcc GhcRn
af = HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
  (LocatedA (HsExpr GhcRn))
-> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
  (LocatedA (HsExpr GhcRn))
upd
                 lbl :: RdrName
lbl      = AmbiguousFieldOcc GhcRn -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc AmbiguousFieldOcc GhcRn
af
           ; GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
     (LocatedA (HsExpr GhcRn)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated
        SrcSpanAnnA
        (HsFieldBind
           (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
           (LocatedA (HsExpr GhcRn))))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
      (LocatedA (HsExpr GhcRn)))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated
         SrcSpanAnnA
         (HsFieldBind
            (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
            (LocatedA (HsExpr GhcRn)))))
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
        (LocatedA (HsExpr GhcRn)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated
        SrcSpanAnnA
        (HsFieldBind
           (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
           (LocatedA (HsExpr GhcRn))))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
     (LocatedA (HsExpr GhcRn))
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
        (LocatedA (HsExpr GhcRn)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsFieldBind
               { hfbAnn :: XHsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
hfbAnn = HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
  (LocatedA (HsExpr GhcRn))
-> XHsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
forall lhs rhs. HsFieldBind lhs rhs -> XHsFieldBind lhs
hfbAnn HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
  (LocatedA (HsExpr GhcRn))
upd
               , hfbLHS :: GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc)
hfbLHS
                       = SrcAnn NoEpAnns
-> AmbiguousFieldOcc GhcTc
-> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcAnn NoEpAnns -> SrcAnn NoEpAnns
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcAnn NoEpAnns
loc) (XUnambiguous GhcTc -> XRec GhcTc RdrName -> AmbiguousFieldOcc GhcTc
forall pass.
XUnambiguous pass -> XRec pass RdrName -> AmbiguousFieldOcc pass
Unambiguous XUnambiguous GhcTc
TyCoVar
i (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcAnn NoEpAnns -> SrcSpanAnnN
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcAnn NoEpAnns
loc) RdrName
lbl))
               , hfbRHS :: LocatedA (HsExpr GhcRn)
hfbRHS = HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
  (LocatedA (HsExpr GhcRn))
-> LocatedA (HsExpr GhcRn)
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
  (LocatedA (HsExpr GhcRn))
upd
               , hfbPun :: Bool
hfbPun = HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
  (LocatedA (HsExpr GhcRn))
-> Bool
forall lhs rhs. HsFieldBind lhs rhs -> Bool
hfbPun HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
  (LocatedA (HsExpr GhcRn))
upd
               }
           }

    -- See Note [Deprecating ambiguous fields] in GHC.Tc.Gen.Head
    reportAmbiguousField :: TyCon -> TcM ()
    reportAmbiguousField :: TyCon -> TcRn ()
reportAmbiguousField TyCon
parent_type =
        SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
addDiagnostic (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ HsExpr GhcRn -> TyCon -> TcRnMessage
TcRnAmbiguousField HsExpr GhcRn
rupd TyCon
parent_type
      where
        rupd :: HsExpr GhcRn
rupd = RecordUpd { rupd_expr :: LHsExpr GhcRn
rupd_expr = LHsExpr GhcRn
record_expr, rupd_flds :: Either [LHsRecUpdField GhcRn] [LHsRecUpdProj GhcRn]
rupd_flds = [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
      (LocatedA (HsExpr GhcRn)))]
-> Either
     [GenLocated
        SrcSpanAnnA
        (HsFieldBind
           (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
           (LocatedA (HsExpr GhcRn)))]
     [GenLocated
        SrcSpanAnnA
        (HsFieldBind
           (GenLocated (SrcAnn NoEpAnns) (FieldLabelStrings GhcRn))
           (LocatedA (HsExpr GhcRn)))]
forall a b. a -> Either a b
Left [LHsRecUpdField GhcRn]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
      (LocatedA (HsExpr GhcRn)))]
rbnds, rupd_ext :: XRecordUpd GhcRn
rupd_ext = XRecordUpd GhcRn
NoExtField
noExtField }
        loc :: SrcSpan
loc  = GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
     (LocatedA (HsExpr GhcRn)))
-> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA ([GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
      (LocatedA (HsExpr GhcRn)))]
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
        (LocatedA (HsExpr GhcRn)))
forall a. HasCallStack => [a] -> a
head [LHsRecUpdField GhcRn]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
      (LocatedA (HsExpr GhcRn)))]
rbnds)

{-
Game plan for record bindings
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1. Find the TyCon for the bindings, from the first field label.

2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.

For each binding field = value

3. Instantiate the field type (from the field label) using the type
   envt from step 2.

4  Type check the value using tcCheckPolyExprNC (in tcRecordField),
   passing the field type as the expected argument type.

This extends OK when the field types are universally quantified.
-}

tcRecordBinds
        :: ConLike
        -> [TcType]     -- Expected type for each field
        -> HsRecordBinds GhcRn
        -> TcM (HsRecordBinds GhcTc)

tcRecordBinds :: ConLike
-> [Type] -> HsRecordBinds GhcRn -> TcM (HsRecordBinds GhcTc)
tcRecordBinds ConLike
con_like [Type]
arg_tys (HsRecFields [LHsRecField GhcRn (LHsExpr GhcRn)]
rbinds Maybe (XRec GhcRn RecFieldsDotDot)
dd)
  = do  { [Maybe
   (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
         (GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
mb_binds <- (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
      (LocatedA (HsExpr GhcRn)))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Maybe
         (GenLocated
            SrcSpanAnnA
            (HsFieldBind
               (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
               (GenLocated SrcSpanAnnA (HsExpr GhcTc))))))
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
         (LocatedA (HsExpr GhcRn)))]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [Maybe
        (GenLocated
           SrcSpanAnnA
           (HsFieldBind
              (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
              (GenLocated SrcSpanAnnA (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 LHsRecField GhcRn (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
     (LocatedA (HsExpr GhcRn)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe
        (GenLocated
           SrcSpanAnnA
           (HsFieldBind
              (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
              (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
do_bind [LHsRecField GhcRn (LHsExpr GhcRn)]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
      (LocatedA (HsExpr GhcRn)))]
rbinds
        ; HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsRecField GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> Maybe (XRec GhcTc RecFieldsDotDot)
-> HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall p arg.
[LHsRecField p arg]
-> Maybe (XRec p RecFieldsDotDot) -> HsRecFields p arg
HsRecFields ([Maybe
   (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
         (GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
         (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall a. [Maybe a] -> [a]
catMaybes [Maybe
   (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
         (GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
mb_binds) Maybe (XRec GhcRn RecFieldsDotDot)
Maybe (XRec GhcTc RecFieldsDotDot)
dd) }
  where
    fields :: [Name]
fields = (FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector ([FieldLabel] -> [Name]) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con_like
    flds_w_tys :: [(Name, Type)]
flds_w_tys = String -> [Name] -> [Type] -> [(Name, Type)]
forall a b. (() :: Constraint) => String -> [a] -> [b] -> [(a, b)]
zipEqual String
"tcRecordBinds" [Name]
fields [Type]
arg_tys

    do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
            -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
    do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
do_bind (L SrcSpanAnnA
l fld :: HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
  (LocatedA (HsExpr GhcRn))
fld@(HsFieldBind { hfbLHS :: forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS = GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)
f
                                 , hfbRHS :: forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS = LocatedA (HsExpr GhcRn)
rhs }))

      = do { Maybe
  (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc),
   GenLocated SrcSpanAnnA (HsExpr GhcTc))
mb <- ConLike
-> [(Name, Type)]
-> LFieldOcc GhcRn
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, Type)]
flds_w_tys LFieldOcc GhcRn
GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)
f LHsExpr GhcRn
LocatedA (HsExpr GhcRn)
rhs
           ; case Maybe
  (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc),
   GenLocated SrcSpanAnnA (HsExpr GhcTc))
mb of
               Maybe
  (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc),
   GenLocated SrcSpanAnnA (HsExpr GhcTc))
Nothing         -> Maybe
  (GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
        (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe
        (GenLocated
           SrcSpanAnnA
           (HsFieldBind
              (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
              (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
  (GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
        (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a. Maybe a
Nothing
               -- Just (f', rhs') -> return (Just (L l (fld { hfbLHS = f'
               --                                            , hfbRHS = rhs' }))) }
               Just (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc)
f', GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs') -> Maybe
  (GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
        (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe
        (GenLocated
           SrcSpanAnnA
           (HsFieldBind
              (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
              (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
     (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> Maybe
     (GenLocated
        SrcSpanAnnA
        (HsFieldBind
           (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
           (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a. a -> Maybe a
Just (SrcSpanAnnA
-> HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
     (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
        (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsFieldBind
                                                     { hfbAnn :: XHsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc))
hfbAnn = HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
  (LocatedA (HsExpr GhcRn))
-> XHsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
forall lhs rhs. HsFieldBind lhs rhs -> XHsFieldBind lhs
hfbAnn HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
  (LocatedA (HsExpr GhcRn))
fld
                                                     , hfbLHS :: GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc)
hfbLHS = GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc)
f'
                                                     , hfbRHS :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
hfbRHS = GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs'
                                                     , hfbPun :: Bool
hfbPun = HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
  (LocatedA (HsExpr GhcRn))
-> Bool
forall lhs rhs. HsFieldBind lhs rhs -> Bool
hfbPun HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
  (LocatedA (HsExpr GhcRn))
fld}))) }


tcRecordField :: ConLike -> Assoc Name Type
              -> LFieldOcc GhcRn -> LHsExpr GhcRn
              -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField :: ConLike
-> [(Name, Type)]
-> LFieldOcc GhcRn
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, Type)]
flds_w_tys (L SrcAnn NoEpAnns
loc (FieldOcc XCFieldOcc GhcRn
sel_name XRec GhcRn RdrName
lbl)) LHsExpr GhcRn
rhs
  | Just Type
field_ty <- [(Name, Type)] -> Name -> Maybe Type
forall a b. Eq a => Assoc a b -> a -> Maybe b
assocMaybe [(Name, Type)]
flds_w_tys XCFieldOcc GhcRn
Name
sel_name
      = SDoc
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (FieldLabelString -> SDoc
fieldCtxt FieldLabelString
field_lbl) (TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
 -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)))
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
        do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs' <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
rhs Type
field_ty
           ; (() :: Constraint) => FixedRuntimeRepContext -> Type -> TcRn ()
FixedRuntimeRepContext -> Type -> TcRn ()
hasFixedRuntimeRep_syntactic (RdrName -> HsExpr GhcTc -> FixedRuntimeRepContext
FRRRecordCon (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc XRec GhcRn RdrName
GenLocated SrcSpanAnnN RdrName
lbl) (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs'))
                Type
field_ty
           ; let field_id :: TyCoVar
field_id = OccName -> Unique -> Type -> Type -> SrcSpan -> TyCoVar
mkUserLocal (Name -> OccName
nameOccName XCFieldOcc GhcRn
Name
sel_name)
                                        (Name -> Unique
nameUnique XCFieldOcc GhcRn
Name
sel_name)
                                        Type
ManyTy Type
field_ty (SrcAnn NoEpAnns -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcAnn NoEpAnns
loc)
                -- Yuk: the field_id has the *unique* of the selector Id
                --          (so we can find it easily)
                --      but is a LocalId with the appropriate type of the RHS
                --          (so the desugarer knows the type of local binder to make)
           ; Maybe
  (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc),
   GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe
        (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc),
         GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc),
 GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> Maybe
     (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc),
      GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> Maybe a
Just (SrcAnn NoEpAnns
-> FieldOcc GhcTc -> GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
loc (XCFieldOcc GhcTc -> XRec GhcTc RdrName -> FieldOcc GhcTc
forall pass. XCFieldOcc pass -> XRec pass RdrName -> FieldOcc pass
FieldOcc XCFieldOcc GhcTc
TyCoVar
field_id XRec GhcRn RdrName
XRec GhcTc RdrName
lbl), GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs')) }
      | Bool
otherwise
      = do { TcRnMessage -> TcRn ()
addErrTc (Name -> FieldLabelString -> TcRnMessage
badFieldConErr (ConLike -> Name
forall a. NamedThing a => a -> Name
getName ConLike
con_like) FieldLabelString
field_lbl)
           ; Maybe
  (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc),
   GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe
        (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc),
         GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
  (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc),
   GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. Maybe a
Nothing }
  where
        field_lbl :: FieldLabelString
field_lbl = FastString -> FieldLabelString
FieldLabelString (FastString -> FieldLabelString) -> FastString -> FieldLabelString
forall a b. (a -> b) -> a -> b
$ OccName -> FastString
occNameFS (OccName -> FastString) -> OccName -> FastString
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc XRec GhcRn RdrName
GenLocated SrcSpanAnnN RdrName
lbl)


checkMissingFields ::  ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM ()
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled Type] -> TcRn ()
checkMissingFields ConLike
con_like HsRecordBinds GhcRn
rbinds [Scaled Type]
arg_tys
  | [FieldLabel] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
field_labels   -- Not declared as a record;
                        -- But C{} is still valid if no strict fields
  = if (HsImplBang -> Bool) -> [HsImplBang] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any HsImplBang -> Bool
isBanged [HsImplBang]
field_strs then
        -- Illegal if any arg is strict
        TcRnMessage -> TcRn ()
addErrTc (ConLike -> [(FieldLabelString, Type)] -> TcRnMessage
TcRnMissingStrictFields ConLike
con_like [])
    else do
        Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([HsImplBang] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [HsImplBang]
field_strs Bool -> Bool -> Bool
&& [FieldLabel] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
field_labels) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
          let msg :: TcRnMessage
msg = ConLike -> [(FieldLabelString, Type)] -> TcRnMessage
TcRnMissingFields ConLike
con_like []
          (Bool -> TcRnMessage -> TcRn ()
diagnosticTc Bool
True TcRnMessage
msg)

  | Bool
otherwise = do              -- A record
    Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(FieldLabelString, Type)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, Type)]
missing_s_fields) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
        [(FieldLabelString, Type)]
fs <- [(FieldLabelString, Type)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(FieldLabelString, Type)]
forall {t :: * -> *} {a}.
Traversable t =>
t (a, Type) -> IOEnv (Env TcGblEnv TcLclEnv) (t (a, Type))
zonk_fields [(FieldLabelString, Type)]
missing_s_fields
        -- It is an error to omit a strict field, because
        -- we can't substitute it with (error "Missing field f")
        TcRnMessage -> TcRn ()
addErrTc (ConLike -> [(FieldLabelString, Type)] -> TcRnMessage
TcRnMissingStrictFields ConLike
con_like [(FieldLabelString, Type)]
fs)

    Bool
warn <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnMissingFields
    Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
warn Bool -> Bool -> Bool
&& [(FieldLabelString, Type)] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [(FieldLabelString, Type)]
missing_ns_fields) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
        [(FieldLabelString, Type)]
fs <- [(FieldLabelString, Type)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(FieldLabelString, Type)]
forall {t :: * -> *} {a}.
Traversable t =>
t (a, Type) -> IOEnv (Env TcGblEnv TcLclEnv) (t (a, Type))
zonk_fields [(FieldLabelString, Type)]
missing_ns_fields
        -- It is not an error (though we may want) to omit a
        -- lazy field, because we can always use
        -- (error "Missing field f") instead.
        let msg :: TcRnMessage
msg = ConLike -> [(FieldLabelString, Type)] -> TcRnMessage
TcRnMissingFields ConLike
con_like [(FieldLabelString, Type)]
fs
        Bool -> TcRnMessage -> TcRn ()
diagnosticTc Bool
True TcRnMessage
msg

  where
    -- we zonk the fields to get better types in error messages (#18869)
    zonk_fields :: t (a, Type) -> IOEnv (Env TcGblEnv TcLclEnv) (t (a, Type))
zonk_fields t (a, Type)
fs = t (a, Type)
-> ((a, Type) -> IOEnv (Env TcGblEnv TcLclEnv) (a, Type))
-> IOEnv (Env TcGblEnv TcLclEnv) (t (a, Type))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM t (a, Type)
fs (((a, Type) -> IOEnv (Env TcGblEnv TcLclEnv) (a, Type))
 -> IOEnv (Env TcGblEnv TcLclEnv) (t (a, Type)))
-> ((a, Type) -> IOEnv (Env TcGblEnv TcLclEnv) (a, Type))
-> IOEnv (Env TcGblEnv TcLclEnv) (t (a, Type))
forall a b. (a -> b) -> a -> b
$ \(a
str,Type
ty) -> do
        Type
ty' <- Type -> TcM Type
zonkTcType Type
ty
        (a, Type) -> IOEnv (Env TcGblEnv TcLclEnv) (a, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
str,Type
ty')
    missing_s_fields :: [(FieldLabelString, Type)]
missing_s_fields
        = [ (FieldLabel -> FieldLabelString
flLabel FieldLabel
fl, Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
ty) | (FieldLabel
fl,HsImplBang
str,Scaled Type
ty) <- [(FieldLabel, HsImplBang, Scaled Type)]
field_info,
                 HsImplBang -> Bool
isBanged HsImplBang
str,
                 Bool -> Bool
not (FieldLabel
fl FieldLabel -> [Name] -> Bool
forall {t :: * -> *}. Foldable t => FieldLabel -> t Name -> Bool
`elemField` [XCFieldOcc GhcRn]
[Name]
field_names_used)
          ]
    missing_ns_fields :: [(FieldLabelString, Type)]
missing_ns_fields
        = [ (FieldLabel -> FieldLabelString
flLabel FieldLabel
fl, Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
ty) | (FieldLabel
fl,HsImplBang
str,Scaled Type
ty) <- [(FieldLabel, HsImplBang, Scaled Type)]
field_info,
                 Bool -> Bool
not (HsImplBang -> Bool
isBanged HsImplBang
str),
                 Bool -> Bool
not (FieldLabel
fl FieldLabel -> [Name] -> Bool
forall {t :: * -> *}. Foldable t => FieldLabel -> t Name -> Bool
`elemField` [XCFieldOcc GhcRn]
[Name]
field_names_used)
          ]

    field_names_used :: [XCFieldOcc GhcRn]
field_names_used = HsRecFields GhcRn (LocatedA (HsExpr GhcRn)) -> [XCFieldOcc GhcRn]
forall p arg. UnXRec p => HsRecFields p arg -> [XCFieldOcc p]
hsRecFields HsRecordBinds GhcRn
HsRecFields GhcRn (LocatedA (HsExpr GhcRn))
rbinds
    field_labels :: [FieldLabel]
field_labels     = ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con_like

    field_info :: [(FieldLabel, HsImplBang, Scaled Type)]
field_info = [FieldLabel]
-> [HsImplBang]
-> [Scaled Type]
-> [(FieldLabel, HsImplBang, Scaled Type)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [FieldLabel]
field_labels [HsImplBang]
field_strs [Scaled Type]
arg_tys

    field_strs :: [HsImplBang]
field_strs = ConLike -> [HsImplBang]
conLikeImplBangs ConLike
con_like

    FieldLabel
fl elemField :: FieldLabel -> t Name -> Bool
`elemField` t Name
flds = (Name -> Bool) -> t Name -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ Name
fl' -> FieldLabel -> Name
flSelector FieldLabel
fl Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
fl') t Name
flds

{-
************************************************************************
*                                                                      *
\subsection{Errors and contexts}
*                                                                      *
************************************************************************

Boring and alphabetical:
-}

fieldCtxt :: FieldLabelString -> SDoc
fieldCtxt :: FieldLabelString -> SDoc
fieldCtxt FieldLabelString
field_name
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (FieldLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FieldLabelString
field_name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"field of a record"

badFieldsUpd
  :: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
               -- Field names that don't belong to a single datacon
  -> [ConLike] -- Data cons of the type which the first field name belongs to
  -> TcRnMessage
badFieldsUpd :: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike] -> TcRnMessage
badFieldsUpd [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds [ConLike]
data_cons
  = [FieldLabelString] -> TcRnMessage
TcRnNoConstructorHasAllFields [FieldLabelString]
conflictingFields
          -- See Note [Finding the conflicting fields]
  where
    -- A (preferably small) set of fields such that no constructor contains
    -- all of them.  See Note [Finding the conflicting fields]
    conflictingFields :: [FieldLabelString]
conflictingFields = case [(FieldLabelString, [Bool])]
nonMembers of
        -- nonMember belongs to a different type.
        (FieldLabelString
nonMember, [Bool]
_) : [(FieldLabelString, [Bool])]
_ -> [FieldLabelString
aMember, FieldLabelString
nonMember]
        [] -> let
            -- All of rbinds belong to one type. In this case, repeatedly add
            -- a field to the set until no constructor contains the set.

            -- Each field, together with a list indicating which constructors
            -- have all the fields so far.
            growingSets :: [(FieldLabelString, [Bool])]
            growingSets :: [(FieldLabelString, [Bool])]
growingSets = ((FieldLabelString, [Bool])
 -> (FieldLabelString, [Bool]) -> (FieldLabelString, [Bool]))
-> [(FieldLabelString, [Bool])] -> [(FieldLabelString, [Bool])]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 (FieldLabelString, [Bool])
-> (FieldLabelString, [Bool]) -> (FieldLabelString, [Bool])
forall {a} {a}. (a, [Bool]) -> (a, [Bool]) -> (a, [Bool])
combine [(FieldLabelString, [Bool])]
membership
            combine :: (a, [Bool]) -> (a, [Bool]) -> (a, [Bool])
combine (a
_, [Bool]
setMem) (a
field, [Bool]
fldMem)
              = (a
field, (Bool -> Bool -> Bool) -> [Bool] -> [Bool] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Bool -> Bool
(&&) [Bool]
setMem [Bool]
fldMem)
            in
            -- Fields that don't change the membership status of the set
            -- are redundant and can be dropped.
            (NonEmpty (FieldLabelString, [Bool]) -> FieldLabelString)
-> [NonEmpty (FieldLabelString, [Bool])] -> [FieldLabelString]
forall a b. (a -> b) -> [a] -> [b]
map ((FieldLabelString, [Bool]) -> FieldLabelString
forall a b. (a, b) -> a
fst ((FieldLabelString, [Bool]) -> FieldLabelString)
-> (NonEmpty (FieldLabelString, [Bool])
    -> (FieldLabelString, [Bool]))
-> NonEmpty (FieldLabelString, [Bool])
-> FieldLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (FieldLabelString, [Bool]) -> (FieldLabelString, [Bool])
forall a. NonEmpty a -> a
NE.head) ([NonEmpty (FieldLabelString, [Bool])] -> [FieldLabelString])
-> [NonEmpty (FieldLabelString, [Bool])] -> [FieldLabelString]
forall a b. (a -> b) -> a -> b
$ ((FieldLabelString, [Bool]) -> [Bool])
-> [(FieldLabelString, [Bool])]
-> [NonEmpty (FieldLabelString, [Bool])]
forall (f :: * -> *) b a.
(Foldable f, Eq b) =>
(a -> b) -> f a -> [NonEmpty a]
NE.groupWith (FieldLabelString, [Bool]) -> [Bool]
forall a b. (a, b) -> b
snd [(FieldLabelString, [Bool])]
growingSets

    aMember :: FieldLabelString
aMember = Bool
-> ((FieldLabelString, [Bool]) -> FieldLabelString)
-> (FieldLabelString, [Bool])
-> FieldLabelString
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([(FieldLabelString, [Bool])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, [Bool])]
members) ) (FieldLabelString, [Bool]) -> FieldLabelString
forall a b. (a, b) -> a
fst ([(FieldLabelString, [Bool])] -> (FieldLabelString, [Bool])
forall a. HasCallStack => [a] -> a
head [(FieldLabelString, [Bool])]
members)
    ([(FieldLabelString, [Bool])]
members, [(FieldLabelString, [Bool])]
nonMembers) = ((FieldLabelString, [Bool]) -> Bool)
-> [(FieldLabelString, [Bool])]
-> ([(FieldLabelString, [Bool])], [(FieldLabelString, [Bool])])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool)
-> ((FieldLabelString, [Bool]) -> [Bool])
-> (FieldLabelString, [Bool])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldLabelString, [Bool]) -> [Bool]
forall a b. (a, b) -> b
snd) [(FieldLabelString, [Bool])]
membership

    -- For each field, which constructors contain the field?
    membership :: [(FieldLabelString, [Bool])]
    membership :: [(FieldLabelString, [Bool])]
membership = [(FieldLabelString, [Bool])] -> [(FieldLabelString, [Bool])]
forall {a}. [(a, [Bool])] -> [(a, [Bool])]
sortMembership ([(FieldLabelString, [Bool])] -> [(FieldLabelString, [Bool])])
-> [(FieldLabelString, [Bool])] -> [(FieldLabelString, [Bool])]
forall a b. (a -> b) -> a -> b
$
        (FieldLabelString -> (FieldLabelString, [Bool]))
-> [FieldLabelString] -> [(FieldLabelString, [Bool])]
forall a b. (a -> b) -> [a] -> [b]
map (\FieldLabelString
fld -> (FieldLabelString
fld, (UniqSet FieldLabelString -> Bool)
-> [UniqSet FieldLabelString] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (FieldLabelString
fld FieldLabelString -> UniqSet FieldLabelString -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet`) [UniqSet FieldLabelString]
fieldLabelSets)) ([FieldLabelString] -> [(FieldLabelString, [Bool])])
-> [FieldLabelString] -> [(FieldLabelString, [Bool])]
forall a b. (a -> b) -> a -> b
$
          (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
      (LocatedA (HsExpr GhcRn)))
 -> FieldLabelString)
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
         (LocatedA (HsExpr GhcRn)))]
-> [FieldLabelString]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> FieldLabelString
FieldLabelString (FastString -> FieldLabelString)
-> (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
         (LocatedA (HsExpr GhcRn)))
    -> FastString)
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
        (LocatedA (HsExpr GhcRn)))
-> FieldLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> FastString
occNameFS (OccName -> FastString)
-> (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
         (LocatedA (HsExpr GhcRn)))
    -> OccName)
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
        (LocatedA (HsExpr GhcRn)))
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> OccName)
-> (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
         (LocatedA (HsExpr GhcRn)))
    -> RdrName)
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
        (LocatedA (HsExpr GhcRn)))
-> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AmbiguousFieldOcc GhcTc -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc (AmbiguousFieldOcc GhcTc -> RdrName)
-> (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
         (LocatedA (HsExpr GhcRn)))
    -> AmbiguousFieldOcc GhcTc)
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
        (LocatedA (HsExpr GhcRn)))
-> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc)
-> AmbiguousFieldOcc GhcTc
forall l e. GenLocated l e -> e
unLoc (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc)
 -> AmbiguousFieldOcc GhcTc)
-> (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
         (LocatedA (HsExpr GhcRn)))
    -> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
        (LocatedA (HsExpr GhcRn)))
-> AmbiguousFieldOcc GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
  (LocatedA (HsExpr GhcRn))
-> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS (HsFieldBind
   (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
   (LocatedA (HsExpr GhcRn))
 -> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
-> (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
         (LocatedA (HsExpr GhcRn)))
    -> HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
         (LocatedA (HsExpr GhcRn)))
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
        (LocatedA (HsExpr GhcRn)))
-> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
     (LocatedA (HsExpr GhcRn)))
-> HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
     (LocatedA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc) [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
      (LocatedA (HsExpr GhcRn)))]
rbinds

    fieldLabelSets :: [UniqSet FieldLabelString]
    fieldLabelSets :: [UniqSet FieldLabelString]
fieldLabelSets = (ConLike -> UniqSet FieldLabelString)
-> [ConLike] -> [UniqSet FieldLabelString]
forall a b. (a -> b) -> [a] -> [b]
map ([FieldLabelString] -> UniqSet FieldLabelString
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet ([FieldLabelString] -> UniqSet FieldLabelString)
-> (ConLike -> [FieldLabelString])
-> ConLike
-> UniqSet FieldLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldLabel -> FieldLabelString)
-> [FieldLabel] -> [FieldLabelString]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> FieldLabelString
flLabel ([FieldLabel] -> [FieldLabelString])
-> (ConLike -> [FieldLabel]) -> ConLike -> [FieldLabelString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConLike -> [FieldLabel]
conLikeFieldLabels) [ConLike]
data_cons

    -- Sort in order of increasing number of True, so that a smaller
    -- conflicting set can be found.
    sortMembership :: [(a, [Bool])] -> [(a, [Bool])]
sortMembership =
      ((Int, (a, [Bool])) -> (a, [Bool]))
-> [(Int, (a, [Bool]))] -> [(a, [Bool])]
forall a b. (a -> b) -> [a] -> [b]
map (Int, (a, [Bool])) -> (a, [Bool])
forall a b. (a, b) -> b
snd ([(Int, (a, [Bool]))] -> [(a, [Bool])])
-> ([(a, [Bool])] -> [(Int, (a, [Bool]))])
-> [(a, [Bool])]
-> [(a, [Bool])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ((Int, (a, [Bool])) -> (Int, (a, [Bool])) -> Ordering)
-> [(Int, (a, [Bool]))] -> [(Int, (a, [Bool]))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Int, (a, [Bool])) -> Int)
-> (Int, (a, [Bool]))
-> (Int, (a, [Bool]))
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, (a, [Bool])) -> Int
forall a b. (a, b) -> a
fst) ([(Int, (a, [Bool]))] -> [(Int, (a, [Bool]))])
-> ([(a, [Bool])] -> [(Int, (a, [Bool]))])
-> [(a, [Bool])]
-> [(Int, (a, [Bool]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ((a, [Bool]) -> (Int, (a, [Bool])))
-> [(a, [Bool])] -> [(Int, (a, [Bool]))]
forall a b. (a -> b) -> [a] -> [b]
map (\ item :: (a, [Bool])
item@(a
_, [Bool]
membershipRow) -> ([Bool] -> Int
countTrue [Bool]
membershipRow, (a, [Bool])
item))

    countTrue :: [Bool] -> Int
countTrue = (Bool -> Bool) -> [Bool] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Bool -> Bool
forall a. a -> a
id

{-
Note [Finding the conflicting fields]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have
  data A = A {a0, a1 :: Int}
         | B {b0, b1 :: Int}
and we see a record update
  x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 }
Then we'd like to find the smallest subset of fields that no
constructor has all of.  Here, say, {a0,b0}, or {a0,b1}, etc.
We don't really want to report that no constructor has all of
{a0,a1,b0,b1}, because when there are hundreds of fields it's
hard to see what was really wrong.

We may need more than two fields, though; eg
  data T = A { x,y :: Int, v::Int }
          | B { y,z :: Int, v::Int }
          | C { z,x :: Int, v::Int }
with update
   r { x=e1, y=e2, z=e3 }, we

Finding the smallest subset is hard, so the code here makes
a decent stab, no more.  See #7989.
-}

mixedSelectors :: [Id] -> [Id] -> TcRnMessage
mixedSelectors :: [TyCoVar] -> [TyCoVar] -> TcRnMessage
mixedSelectors data_sels :: [TyCoVar]
data_sels@(TyCoVar
dc_rep_id:[TyCoVar]
_) pat_syn_sels :: [TyCoVar]
pat_syn_sels@(TyCoVar
ps_rep_id:[TyCoVar]
_)
  = Name -> [TyCoVar] -> Name -> [TyCoVar] -> TcRnMessage
TcRnMixedSelectors (TyCon -> Name
tyConName TyCon
rep_dc) [TyCoVar]
data_sels (PatSyn -> Name
patSynName PatSyn
rep_ps) [TyCoVar]
pat_syn_sels
  where
    RecSelPatSyn PatSyn
rep_ps = TyCoVar -> RecSelParent
recordSelectorTyCon TyCoVar
ps_rep_id
    RecSelData TyCon
rep_dc = TyCoVar -> RecSelParent
recordSelectorTyCon TyCoVar
dc_rep_id
mixedSelectors [TyCoVar]
_ [TyCoVar]
_ = String -> TcRnMessage
forall a. HasCallStack => String -> a
panic String
"GHC.Tc.Gen.Expr: mixedSelectors emptylists"

{-
************************************************************************
*                                                                      *
\subsection{Static Pointers}
*                                                                      *
************************************************************************
-}

-- | Checks if the given name is closed and emits an error if not.
--
-- See Note [Not-closed error messages].
checkClosedInStaticForm :: Name -> TcM ()
checkClosedInStaticForm :: Name -> TcRn ()
checkClosedInStaticForm Name
name = do
    TcTypeEnv
type_env <- TcM TcTypeEnv
getLclTypeEnv
    case TcTypeEnv -> Name -> Maybe NotClosedReason
checkClosed TcTypeEnv
type_env Name
name of
      Maybe NotClosedReason
Nothing -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just NotClosedReason
reason -> TcRnMessage -> TcRn ()
addErrTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Name -> NotClosedReason -> TcRnMessage
explain Name
name NotClosedReason
reason
  where
    -- See Note [Checking closedness].
    checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
    checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
checkClosed TcTypeEnv
type_env Name
n = TcTypeEnv -> UniqSet Name -> Name -> Maybe NotClosedReason
checkLoop TcTypeEnv
type_env (Name -> UniqSet Name
unitNameSet Name
n) Name
n

    checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason
    checkLoop :: TcTypeEnv -> UniqSet Name -> Name -> Maybe NotClosedReason
checkLoop TcTypeEnv
type_env UniqSet Name
visited Name
n =
      -- The @visited@ set is an accumulating parameter that contains the set of
      -- visited nodes, so we avoid repeating cycles in the traversal.
      case TcTypeEnv -> Name -> Maybe TcTyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcTypeEnv
type_env Name
n of
        Just (ATcId { tct_id :: TcTyThing -> TyCoVar
tct_id = TyCoVar
tcid, tct_info :: TcTyThing -> IdBindingInfo
tct_info = IdBindingInfo
info }) -> case IdBindingInfo
info of
          IdBindingInfo
ClosedLet   -> Maybe NotClosedReason
forall a. Maybe a
Nothing
          IdBindingInfo
NotLetBound -> NotClosedReason -> Maybe NotClosedReason
forall a. a -> Maybe a
Just NotClosedReason
NotLetBoundReason
          NonClosedLet UniqSet Name
fvs Bool
type_closed -> [NotClosedReason] -> Maybe NotClosedReason
forall a. [a] -> Maybe a
listToMaybe ([NotClosedReason] -> Maybe NotClosedReason)
-> [NotClosedReason] -> Maybe NotClosedReason
forall a b. (a -> b) -> a -> b
$
            -- Look for a non-closed variable in fvs
            [ Name -> NotClosedReason -> NotClosedReason
NotClosed Name
n' NotClosedReason
reason
            | Name
n' <- UniqSet Name -> [Name]
nameSetElemsStable UniqSet Name
fvs
            , Bool -> Bool
not (Name -> UniqSet Name -> Bool
elemNameSet Name
n' UniqSet Name
visited)
            , Just NotClosedReason
reason <- [TcTypeEnv -> UniqSet Name -> Name -> Maybe NotClosedReason
checkLoop TcTypeEnv
type_env (UniqSet Name -> Name -> UniqSet Name
extendNameSet UniqSet Name
visited Name
n') Name
n']
            ] [NotClosedReason] -> [NotClosedReason] -> [NotClosedReason]
forall a. [a] -> [a] -> [a]
++
            if Bool
type_closed then
              []
            else
              -- We consider non-let-bound variables easier to figure out than
              -- non-closed types, so we report non-closed types to the user
              -- only if we cannot spot the former.
              [ VarSet -> NotClosedReason
NotTypeClosed (VarSet -> NotClosedReason) -> VarSet -> NotClosedReason
forall a b. (a -> b) -> a -> b
$ Type -> VarSet
tyCoVarsOfType (TyCoVar -> Type
idType TyCoVar
tcid) ]
        -- The binding is closed.
        Maybe TcTyThing
_ -> Maybe NotClosedReason
forall a. Maybe a
Nothing

    -- Converts a reason into a human-readable sentence.
    --
    -- @explain name reason@ starts with
    --
    -- "<name> is used in a static form but it is not closed because it"
    --
    -- and then follows a list of causes. For each id in the path, the text
    --
    -- "uses <id> which"
    --
    -- is appended, yielding something like
    --
    -- "uses <id> which uses <id1> which uses <id2> which"
    --
    -- until the end of the path is reached, which is reported as either
    --
    -- "is not let-bound"
    --
    -- when the final node is not let-bound, or
    --
    -- "has a non-closed type because it contains the type variables:
    -- v1, v2, v3"
    --
    -- when the final node has a non-closed type.
    --
    explain :: Name -> NotClosedReason -> TcRnMessage
    explain :: Name -> NotClosedReason -> TcRnMessage
explain = Name -> NotClosedReason -> TcRnMessage
TcRnStaticFormNotClosed

-- Note [Not-closed error messages]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- When variables in a static form are not closed, we go through the trouble
-- of explaining why they aren't.
--
-- Thus, the following program
--
-- > {-# LANGUAGE StaticPointers #-}
-- > module M where
-- >
-- > f x = static g
-- >   where
-- >     g = h
-- >     h = x
--
-- produces the error
--
--    'g' is used in a static form but it is not closed because it
--    uses 'h' which uses 'x' which is not let-bound.
--
-- And a program like
--
-- > {-# LANGUAGE StaticPointers #-}
-- > module M where
-- >
-- > import Data.Typeable
-- > import GHC.StaticPtr
-- >
-- > f :: Typeable a => a -> StaticPtr TypeRep
-- > f x = const (static (g undefined)) (h x)
-- >   where
-- >     g = h
-- >     h = typeOf
--
-- produces the error
--
--    'g' is used in a static form but it is not closed because it
--    uses 'h' which has a non-closed type because it contains the
--    type variables: 'a'
--

-- Note [Checking closedness]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- @checkClosed@ checks if a binding is closed and returns a reason if it is
-- not.
--
-- The bindings define a graph where the nodes are ids, and there is an edge
-- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free
-- variables.
--
-- When @n@ is not closed, it has to exist in the graph some node reachable
-- from @n@ that it is not a let-bound variable or that it has a non-closed
-- type. Thus, the "reason" is a path from @n@ to this offending node.
--
-- When @n@ is not closed, we traverse the graph reachable from @n@ to build
-- the reason.
--