{-# LANGUAGE CPP                 #-}
{-# 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,
         addAmbiguousNameErr,
         getFixedTyVars ) where

#include "HsVersions.h"

import GHC.Prelude

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

import GHC.Hs
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.Core.Multiplicity
import GHC.Core.UsageEnv
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.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.Gen.Pat
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.Tc.Types.Evidence
import GHC.Types.Var.Set
import GHC.Builtin.Types
import GHC.Builtin.Names
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.Data.FastString
import Control.Monad
import GHC.Core.Class(classTyCon)
import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )

import Data.Function
import Data.List (partition, sortBy, groupBy, intersect)

{-
************************************************************************
*                                                                      *
\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 -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr   LHsExpr GhcRn
expr TcType
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExpr   LHsExpr GhcRn
expr (TcType -> ExpRhoType
mkCheckExpType TcType
res_ty)
tcCheckPolyExprNC :: LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
expr TcType
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyLExprNC LHsExpr GhcRn
expr (TcType -> ExpRhoType
mkCheckExpType TcType
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 (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 (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 -> TcType -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr   LHsExpr GhcRn
expr TcType
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr   LHsExpr GhcRn
expr (TcType -> ExpRhoType
mkCheckExpType TcType
res_ty)
tcCheckMonoExprNC :: LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
expr TcType
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr GhcRn
expr (TcType -> ExpRhoType
mkCheckExpType TcType
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 (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 (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, TcType)
tcInferRho (L SrcSpanAnnA
loc HsExpr GhcRn
expr)
  = SrcSpanAnnA
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc   (TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType))
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a b. (a -> b) -> a -> b
$  -- Set location /first/; see GHC.Tc.Utils.Monad
    HsExpr GhcRn
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
expr (TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType))
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a b. (a -> b) -> a -> b
$  -- Note [Error contexts in generated code]
    do { (HsExpr GhcTc
expr', TcType
rho) <- (ExpRhoType -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc, TcType)
forall a. (ExpRhoType -> TcM a) -> TcM (a, TcType)
tcInfer (HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr)
       ; (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcType)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcType)
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', TcType
rho) }

tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
tcInferRhoNC (L SrcSpanAnnA
loc HsExpr GhcRn
expr)
  = SrcSpanAnnA
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType))
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a b. (a -> b) -> a -> b
$
    do { (HsExpr GhcTc
expr', TcType
rho) <- (ExpRhoType -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc, TcType)
forall a. (ExpRhoType -> TcM a) -> TcM (a, TcType)
tcInfer (HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr)
       ; (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcType)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcType)
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', TcType
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)
tcSkolemiseET 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 (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 appplications, 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)
--   - HsRecFld      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@(HsRecFld {})           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 (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
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
_ OccName
occ) ExpRhoType
res_ty
  = do { TcType
ty <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty    -- Allow Int# etc (#12531)
       ; HoleExprRef
her <- OccName -> TcType -> TcM HoleExprRef
emitNewExprHole OccName
occ TcType
ty
       ; UsageEnv -> TcRn ()
tcEmitBindingUsage UsageEnv
bottomUE   -- Holes fit any usage environment
                                       -- (#18491)
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XUnboundVar GhcTc -> OccName -> HsExpr GhcTc
forall p. XUnboundVar p -> OccName -> HsExpr p
HsUnboundVar XUnboundVar GhcTc
HoleExprRef
her OccName
occ) }

tcExpr e :: HsExpr GhcRn
e@(HsLit XLitE GhcRn
x HsLit GhcRn
lit) ExpRhoType
res_ty
  = do { let lit_ty :: TcType
lit_ty = HsLit GhcRn -> TcType
forall (p :: Pass). HsLit (GhcPass p) -> TcType
hsLitType HsLit GhcRn
lit
       ; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> 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)) TcType
lit_ty ExpRhoType
res_ty }

tcExpr (HsPar XPar GhcRn
x LHsExpr GhcRn
expr) 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 (m :: * -> *) a. Monad m => a -> m a
return (XPar GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcRn
XPar GhcTc
x GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
expr') }

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 (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) GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr 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
-> ([TcType]
    -> [TcType]
    -> IOEnv
         (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
NegateOrigin SyntaxExpr GhcRn
SyntaxExprRn
neg_expr [SyntaxOpType
SynAny] ExpRhoType
res_ty (([TcType]
  -> [TcType]
  -> IOEnv
       (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
 -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), SyntaxExprTc))
-> ([TcType]
    -> [TcType]
    -> IOEnv
         (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
               \[TcType
arg_ty] [TcType
arg_mult] ->
               TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
arg_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
expr TcType
arg_ty
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
expr' SyntaxExpr GhcTc
SyntaxExprTc
neg_expr') }

tcExpr e :: HsExpr GhcRn
e@(HsIPVar XIPVar GhcRn
_ HsIPName
x) ExpRhoType
res_ty
  = do {   {- Implicit parameters must have a *tau-type* not a
              type scheme.  We enforce this by creating a fresh
              type variable as its type.  (Because res_ty may not
              be a tau-type.) -}
         TcType
ip_ty <- TcM TcType
newOpenFlexiTyVarTy
       ; let ip_name :: TcType
ip_name = FieldLabelString -> TcType
mkStrLitTy (HsIPName -> FieldLabelString
hsIPNameFS HsIPName
x)
       ; Class
ipClass <- Name -> TcM Class
tcLookupClass Name
ipClassName
       ; Var
ip_var <- CtOrigin -> TcType -> TcM Var
emitWantedEvVar CtOrigin
origin (Class -> [TcType] -> TcType
mkClassPred Class
ipClass [TcType
ip_name, TcType
ip_ty])
       ; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
e
                   (Class -> TcType -> TcType -> HsExpr GhcTc -> HsExpr GhcTc
fromDict Class
ipClass TcType
ip_name TcType
ip_ty (XVar GhcTc -> LIdP GhcTc -> HsExpr GhcTc
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (Var -> LocatedAn NameAnn Var
forall a an. a -> LocatedAn an a
noLocA Var
ip_var)))
                   TcType
ip_ty ExpRhoType
res_ty }
  where
  -- Coerces a dictionary for `IP "x" t` into `t`.
  fromDict :: Class -> TcType -> TcType -> HsExpr GhcTc -> HsExpr GhcTc
fromDict Class
ipClass TcType
x TcType
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
$
                          TcType -> TcCoercionR
unwrapIP (TcType -> TcCoercionR) -> TcType -> TcCoercionR
forall a b. (a -> b) -> a -> b
$ Class -> [TcType] -> TcType
mkClassPred Class
ipClass [TcType
x,TcType
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') <- SDoc
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchLambda SDoc
herald TcMatchCtxt HsExpr
match_ctxt MatchGroup GhcRn (LHsExpr GhcRn)
match ExpRhoType
res_ty
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
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 NoExtField
XLam GhcTc
noExtField MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
MatchGroup GhcTc (LHsExpr GhcTc)
match')) }
  where
    match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
forall p. HsMatchContext p
LambdaExpr, mc_body :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> ExpRhoType
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mc_body = GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> ExpRhoType
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody }
    herald :: SDoc
herald = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The lambda expression" SDoc -> SDoc -> SDoc
<+>
                   SDoc -> SDoc
quotes (Depth -> SDoc -> SDoc
pprSetDepth (Int -> Depth
PartWay Int
1) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                           MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
MatchGroup (GhcPass idR) body -> SDoc
pprMatches MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
MatchGroup GhcRn (LHsExpr GhcRn)
match),
                        -- The pprSetDepth makes the abstraction print briefly
                   String -> SDoc
text String
"has"]

tcExpr e :: HsExpr GhcRn
e@(HsLamCase XLamCase GhcRn
x MatchGroup GhcRn (LHsExpr GhcRn)
matches) ExpRhoType
res_ty
  = do { (HsWrapper
wrap, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches')
           <- SDoc
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchLambda SDoc
msg TcMatchCtxt HsExpr
match_ctxt MatchGroup GhcRn (LHsExpr GhcRn)
matches ExpRhoType
res_ty
           -- The laziness annotation is because we don't want to fail here
           -- if there are multiple arguments
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
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 -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall p. XLamCase p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase XLamCase GhcRn
XLamCase GhcTc
x MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
MatchGroup GhcTc (LHsExpr GhcTc)
matches') }
  where
    msg :: SDoc
msg = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The function" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e)
              , String -> SDoc
text String
"requires"]
    match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
forall p. HsMatchContext p
CaseAlt, mc_body :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> ExpRhoType
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mc_body = GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> ExpRhoType
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody }



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

-- Explict 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  { TcType
res_ty <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty
        ; (TcCoercionR
coi, TcType
elt_ty) <- TcType -> TcM (TcCoercionR, TcType)
matchExpectedListTy TcType
res_ty
        ; let tc_elt :: GenLocated SrcSpanAnnA (HsExpr GhcRn) -> TcM (LHsExpr GhcTc)
tc_elt GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr = LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr GenLocated SrcSpanAnnA (HsExpr GhcRn)
LHsExpr GhcRn
expr TcType
elt_ty
        ; [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
exprs' <- (GenLocated SrcSpanAnnA (HsExpr GhcRn)
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> [GenLocated SrcSpanAnnA (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)
mapM GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
GenLocated SrcSpanAnnA (HsExpr GhcRn) -> TcM (LHsExpr GhcTc)
tc_elt [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
[LHsExpr GhcRn]
exprs
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
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 TcType
XExplicitList GhcTc
elt_ty [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
[LHsExpr 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 (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
       ; TcType
res_ty <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty
       ; (TcCoercionR
coi, [TcType]
arg_tys) <- TyCon -> TcType -> TcM (TcCoercionR, [TcType])
matchExpectedTyConApp TyCon
tup_tc TcType
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' :: [TcType]
arg_tys' = case Boxity
boxity of Boxity
Unboxed -> Int -> [TcType] -> [TcType]
forall a. Int -> [a] -> [a]
drop Int
arity [TcType]
arg_tys
                                       Boxity
Boxed   -> [TcType]
arg_tys
       ; [HsTupArg GhcTc]
tup_args1 <- [HsTupArg GhcRn] -> [TcType] -> TcM [HsTupArg GhcTc]
tcTupArgs [HsTupArg GhcRn]
tup_args [TcType]
arg_tys'
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
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 (t :: * -> *) a. Foldable t => t a -> Int
length [HsTupArg GhcRn]
tup_args

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

       -- Handle tuple sections where
       ; [HsTupArg GhcTc]
tup_args1 <- [HsTupArg GhcRn] -> [TcType] -> TcM [HsTupArg GhcTc]
tcTupArgs [HsTupArg GhcRn]
tup_args [TcType]
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 TcType]
missing_tys = [TcType -> TcType -> Scaled TcType
forall a. TcType -> a -> Scaled a
Scaled TcType
mult TcType
ty | (Missing (Scaled TcType
mult TcType
_), TcType
ty) <- [HsTupArg GhcTc] -> [TcType] -> [(HsTupArg GhcTc, TcType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [HsTupArg GhcTc]
tup_args1 [TcType]
arg_tys]

             -- See Note [Linear fields generalization] in GHC.Tc.Gen.App
             act_res_ty :: TcType
act_res_ty
                 = [Scaled TcType] -> TcType -> TcType
mkVisFunTys [Scaled TcType]
missing_tys (Boxity -> [TcType] -> TcType
mkTupleTy1 Boxity
boxity [TcType]
arg_tys)
                   -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make

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

       ; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' TcType
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
       ; TcType
res_ty <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty
       ; (TcCoercionR
coi, [TcType]
arg_tys) <- TyCon -> TcType -> TcM (TcCoercionR, [TcType])
matchExpectedTyConApp TyCon
sum_tc TcType
res_ty
       ; -- Drop levity vars, we don't care about them here
         let arg_tys' :: [TcType]
arg_tys' = Int -> [TcType] -> [TcType]
forall a. Int -> [a] -> [a]
drop Int
arity [TcType]
arg_tys
       ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr ([TcType]
arg_tys' [TcType] -> Int -> TcType
forall a. Outputable a => [a] -> Int -> a
`getNth` (Int
alt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
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 [TcType]
XExplicitSum GhcTc
arg_tys' Int
alt Int
arity GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
expr' ) }


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

tcExpr (HsLet XLet GhcRn
x HsLocalBinds GhcRn
binds 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 (m :: * -> *) a. Monad m => a -> m a
return (XLet GhcTc -> HsLocalBinds GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XLet p -> HsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet XLet GhcRn
XLet GhcTc
x HsLocalBinds GhcTc
binds' GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr 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
          TcType
mult <- TcType -> TcM TcType
newFlexiTyVarTy TcType
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', TcType
scrut_ty) <- TcType
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
mult (TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType))
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
tcInferRho LHsExpr GhcRn
scrut

        ; String -> SDoc -> TcRn ()
traceTc String
"HsCase" (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
scrut_ty)
        ; MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches' <- TcMatchCtxt HsExpr
-> Scaled TcType
-> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> ExpRhoType
-> TcM (MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall (body :: * -> *).
AnnoBody body =>
TcMatchCtxt body
-> Scaled TcType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> ExpRhoType
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatchesCase TcMatchCtxt HsExpr
match_ctxt (TcType -> TcType -> Scaled TcType
forall a. TcType -> a -> Scaled a
Scaled TcType
mult TcType
scrut_ty) MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
MatchGroup GhcRn (LHsExpr GhcRn)
matches ExpRhoType
res_ty
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
scrut' MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
MatchGroup GhcTc (LHsExpr GhcTc)
matches') }
 where
    match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
forall p. HsMatchContext p
CaseAlt,
                      mc_body :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> ExpRhoType
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mc_body = GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> ExpRhoType
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr 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 -> TcType -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
pred TcType
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 (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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
pred' GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
b1' GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
b2') }

tcExpr (HsMultiIf XMultiIf GhcRn
_ [LGRHS GhcRn (LHsExpr GhcRn)]
alts) ExpRhoType
res_ty
  = do { [Located (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
alts' <- (Located (GRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Located (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> [Located (GRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [Located (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((GRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
 -> TcM (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> Located (GRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Located (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM ((GRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
  -> TcM (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
 -> Located (GRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Located (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> (GRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
    -> TcM (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> Located (GRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Located (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a b. (a -> b) -> a -> b
$ TcMatchCtxt HsExpr
-> ExpRhoType
-> GRHS GhcRn (GenLocated SrcSpanAnnA (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) [Located (GRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
[LGRHS GhcRn (LHsExpr GhcRn)]
alts
       ; TcType
res_ty <- ExpRhoType -> TcM TcType
readExpType ExpRhoType
res_ty
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
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 TcType
XMultiIf GhcTc
res_ty [Located (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
[LGRHS GhcTc (LHsExpr GhcTc)]
alts') }
  where match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
forall p. HsMatchContext p
IfAlt, mc_body :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> ExpRhoType
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mc_body = GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> ExpRhoType
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody }

tcExpr (HsDo XDo GhcRn
_ HsStmtContext (HsDoRn GhcRn)
do_or_lc XRec GhcRn [ExprLStmt GhcRn]
stmts) ExpRhoType
res_ty
  = HsStmtContext GhcRn
-> LocatedL [ExprLStmt GhcRn] -> ExpRhoType -> TcM (HsExpr GhcTc)
tcDoStmts HsStmtContext GhcRn
HsStmtContext (HsDoRn GhcRn)
do_or_lc LocatedL [ExprLStmt GhcRn]
XRec GhcRn [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 SrcSpan (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 (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 GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
pat' GenLocated SrcSpan (HsCmdTop GhcTc)
LHsCmdTop 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  { TcType
res_ty          <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty
        ; (TcCoercionR
co, (TcType
p_ty, TcType
expr_ty)) <- TcType -> TcM (TcCoercionR, (TcType, TcType))
matchExpectedAppTy TcType
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
text String
"In the body of a static form:")
                             Int
2 (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsExpr GhcRn)
LHsExpr GhcRn
expr)
                       ) (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
            LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
expr TcType
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 UniqSet Name
XStatic GhcRn
fvs

        -- Require the type of the argument to be Typeable.
        -- The evidence is not used, but asking the constraint ensures that
        -- the current implementation is as restrictive as future versions
        -- of the StaticPointers extension.
        ; Class
typeableClass <- Name -> TcM Class
tcLookupClass Name
typeableClassName
        ; Var
_ <- CtOrigin -> TcType -> TcM Var
emitWantedEvVar CtOrigin
StaticOrigin (TcType -> TcM Var) -> TcType -> TcM Var
forall a b. (a -> b) -> a -> b
$
                  TyCon -> [TcType] -> TcType
mkTyConApp (Class -> TyCon
classTyCon Class
typeableClass)
                             [TcType
liftedTypeKind, TcType
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 -> [TcType] -> TcM (HsExpr GhcTc)
newMethodFromName CtOrigin
StaticOrigin Name
fromStaticPtrName
                                             [TcType
p_ty]
        ; let wrap :: HsWrapper
wrap = [TcType] -> HsWrapper
mkWpTyApps [TcType
expr_ty]
        ; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
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 EpAnnCO
XApp GhcTc
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
XStatic GhcTc
fvs GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr 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, TcType
con_sigma) <- Name -> TcM (HsExpr GhcTc, TcType)
tcInferId Name
con_name
        ; (HsWrapper
con_wrap, TcType
con_tau)   <- CtOrigin -> TcType -> TcM (HsWrapper, TcType)
topInstantiate CtOrigin
orig TcType
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 TcType]
arg_tys, TcType
actual_res_ty) = Int -> TcType -> Either Int ([Scaled TcType], TcType)
tcSplitFunTysN Int
arity TcType
con_tau

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

        ; HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rbinds' <- ConLike
-> [TcType] -> HsRecordBinds GhcRn -> TcM (HsRecordBinds GhcTc)
tcRecordBinds ConLike
con_like ((Scaled TcType -> TcType) -> [Scaled TcType] -> [TcType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcType -> TcType
forall a. Scaled a -> a
scaledThing [Scaled TcType]
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 = HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
HsRecordBinds GhcTc
rbinds' }

        ; HsExpr GhcTc
ret <- HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' TcType
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 TcType] -> TcRn ()
checkMissingFields ConLike
con_like HsRecordBinds GhcRn
rbinds [Scaled TcType]
arg_tys

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

{-
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"

-}

-- 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
  = ASSERT( notNull rbnds )
    do  { -- STEP -2: typecheck the record_expr, the record to be updated
          (GenLocated SrcSpanAnnA (HsExpr GhcTc)
record_expr', TcType
record_rho) <- TcType
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
Many (TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType))
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
tcInferRho LHsExpr GhcRn
record_expr
            -- 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, or 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
   (HsRecField'
      (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
rbinds <- LHsExpr GhcRn
-> TcType
-> [LHsRecUpdField GhcRn]
-> ExpRhoType
-> TcM
     [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds LHsExpr GhcRn
record_expr TcType
record_rho [LHsRecUpdField GhcRn]
rbnds ExpRhoType
res_ty
        ; let upd_flds :: [AmbiguousFieldOcc GhcTc]
upd_flds = (GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
 -> AmbiguousFieldOcc GhcTc)
-> [GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> [AmbiguousFieldOcc GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
-> AmbiguousFieldOcc GhcTc
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
 -> AmbiguousFieldOcc GhcTc)
-> (GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
    -> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
-> GenLocated
     SrcSpanAnnA
     (HsRecField'
        (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> AmbiguousFieldOcc GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecField'
  (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (HsRecField'
   (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
 -> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
-> (GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
    -> HsRecField'
         (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> GenLocated
     SrcSpanAnnA
     (HsRecField'
        (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  SrcSpanAnnA
  (HsRecField'
     (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> HsRecField'
     (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc) [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
rbinds
              upd_fld_occs :: [FieldLabelString]
upd_fld_occs = (AmbiguousFieldOcc GhcTc -> FieldLabelString)
-> [AmbiguousFieldOcc GhcTc] -> [FieldLabelString]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> FieldLabelString
occNameFS (OccName -> FieldLabelString)
-> (AmbiguousFieldOcc GhcTc -> OccName)
-> AmbiguousFieldOcc GhcTc
-> FieldLabelString
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 :: [Var]
sel_ids      = (AmbiguousFieldOcc GhcTc -> Var)
-> [AmbiguousFieldOcc GhcTc] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map AmbiguousFieldOcc GhcTc -> Var
selectorAmbiguousFieldOcc [AmbiguousFieldOcc GhcTc]
upd_flds
        -- 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
$ SDoc -> TcRn ()
addErrTc (Name -> SDoc
notSelector Name
fld_name)
                         | GenLocated
  SrcSpanAnnA
  (HsRecField'
     (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
fld <- [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
rbinds,
                           -- Excludes class ops
                           let L SrcSpan
loc Var
sel_id = HsRecField'
  (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated SrcSpan Var
forall arg.
HsRecField' (AmbiguousFieldOcc GhcTc) arg -> GenLocated SrcSpan Var
hsRecUpdFieldId (GenLocated
  SrcSpanAnnA
  (HsRecField'
     (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> HsRecField'
     (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc GenLocated
  SrcSpanAnnA
  (HsRecField'
     (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
fld),
                           Bool -> Bool
not (Var -> Bool
isRecordSelector Var
sel_id),
                           let fld_name :: Name
fld_name = Var -> Name
idName Var
sel_id ]
        ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([TcRn ()] -> 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)
sequence [TcRn ()]
bad_guys IOEnv (Env TcGblEnv TcLclEnv) [()] -> TcRn () -> TcRn ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TcRn ()
forall env a. IOEnv env a
failM)
        -- See note [Mixed Record Selectors]
        ; let ([Var]
data_sels, [Var]
pat_syn_sels) =
                (Var -> Bool) -> [Var] -> ([Var], [Var])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Var -> Bool
isDataConRecordSelector [Var]
sel_ids
        ; MASSERT( all isPatSynRecordSelector pat_syn_sels )
        ; Bool -> SDoc -> TcRn ()
checkTc ( [Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
data_sels Bool -> Bool -> Bool
|| [Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
pat_syn_sels )
                  ( [Var] -> [Var] -> SDoc
mixedSelectors [Var]
data_sels [Var]
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)
              Var
sel_id : [Var]
_  = [Var]
sel_ids

              mtycon :: Maybe TyCon
              mtycon :: Maybe TyCon
mtycon = case Var -> IdDetails
idDetails Var
sel_id of
                          RecSelId (RecSelData TyCon
tycon) Bool
_ -> TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tycon
                          IdDetails
_ -> Maybe TyCon
forall a. Maybe a
Nothing

              con_likes :: [ConLike]
              con_likes :: [ConLike]
con_likes = case Var -> IdDetails
idDetails Var
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. 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
        ; Bool -> SDoc -> TcRn ()
checkTc (Bool -> Bool
not ([ConLike] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConLike]
relevant_cons)) ([LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike] -> SDoc
badFieldsUpd [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
[LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds [ConLike]
con_likes)

        -- Take apart a representative constructor
        ; let con1 :: ConLike
con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
              ([Var]
con1_tvs, [Var]
_, [EqSpec]
_, [TcType]
_prov_theta, [TcType]
req_theta, [Scaled TcType]
scaled_con1_arg_tys, TcType
_)
                 = ConLike
-> ([Var], [Var], [EqSpec], [TcType], [TcType], [Scaled TcType],
    TcType)
conLikeFullSig ConLike
con1
              con1_arg_tys :: [TcType]
con1_arg_tys = (Scaled TcType -> TcType) -> [Scaled TcType] -> [TcType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcType -> TcType
forall a. Scaled a -> a
scaledThing [Scaled TcType]
scaled_con1_arg_tys
                -- We can safely drop the fields' multiplicities because
                -- they are currently always 1: there is no syntax for record
                -- fields with other multiplicities yet. This way we don't need
                -- to handle it in the rest of the function
              con1_flds :: [FieldLabelString]
con1_flds   = (FieldLabel -> FieldLabelString)
-> [FieldLabel] -> [FieldLabelString]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> FieldLabelString
flLabel ([FieldLabel] -> [FieldLabelString])
-> [FieldLabel] -> [FieldLabelString]
forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con1
              con1_tv_tys :: [TcType]
con1_tv_tys = [Var] -> [TcType]
mkTyVarTys [Var]
con1_tvs
              con1_res_ty :: TcType
con1_res_ty = case Maybe TyCon
mtycon of
                              Just TyCon
tc -> TyCon -> [TcType] -> TcType
mkFamilyTyConApp TyCon
tc [TcType]
con1_tv_tys
                              Maybe TyCon
Nothing -> ConLike -> [TcType] -> TcType
conLikeResTy ConLike
con1 [TcType]
con1_tv_tys

        -- Check that we're not dealing with a unidirectional pattern
        -- synonym
        ; Bool -> SDoc -> TcRn ()
checkTc (ConLike -> Bool
conLikeHasBuilder ConLike
con1) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
          Name -> SDoc
forall a. Outputable a => a -> SDoc
nonBidirectionalErr (ConLike -> Name
conLikeName ConLike
con1)

        -- STEP 3    Note [Criteria for update]
        -- Check that each updated field is polymorphic; that is, its type
        -- mentions only the universally-quantified variables of the data con
        ; let flds1_w_tys :: [(FieldLabelString, TcType)]
flds1_w_tys  = String
-> [FieldLabelString] -> [TcType] -> [(FieldLabelString, TcType)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"tcExpr:RecConUpd" [FieldLabelString]
con1_flds [TcType]
con1_arg_tys
              bad_upd_flds :: [(FieldLabelString, TcType)]
bad_upd_flds = ((FieldLabelString, TcType) -> Bool)
-> [(FieldLabelString, TcType)] -> [(FieldLabelString, TcType)]
forall a. (a -> Bool) -> [a] -> [a]
filter (FieldLabelString, TcType) -> Bool
bad_fld [(FieldLabelString, TcType)]
flds1_w_tys
              con1_tv_set :: VarSet
con1_tv_set  = [Var] -> VarSet
mkVarSet [Var]
con1_tvs
              bad_fld :: (FieldLabelString, TcType) -> Bool
bad_fld (FieldLabelString
fld, TcType
ty) = FieldLabelString
fld FieldLabelString -> [FieldLabelString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FieldLabelString]
upd_fld_occs Bool -> Bool -> Bool
&&
                                      Bool -> Bool
not (TcType -> VarSet
tyCoVarsOfType TcType
ty VarSet -> VarSet -> Bool
`subVarSet` VarSet
con1_tv_set)
        ; Bool -> SDoc -> TcRn ()
checkTc ([(FieldLabelString, TcType)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, TcType)]
bad_upd_flds) ([(FieldLabelString, TcType)] -> SDoc
badFieldTypes [(FieldLabelString, TcType)]
bad_upd_flds)

        -- STEP 4  Note [Type of a record update]
        -- Figure out types for the scrutinee and result
        -- Both are of form (T a b c), with fresh type variables, but with
        -- common variables where the scrutinee and result must have the same type
        -- These are variables that appear in *any* arg of *any* of the
        -- relevant constructors *except* in the updated fields
        --
        ; let fixed_tvs :: VarSet
fixed_tvs = [FieldLabelString] -> [Var] -> [ConLike] -> VarSet
getFixedTyVars [FieldLabelString]
upd_fld_occs [Var]
con1_tvs [ConLike]
relevant_cons
              is_fixed_tv :: Var -> Bool
is_fixed_tv Var
tv = Var
tv Var -> VarSet -> Bool
`elemVarSet` VarSet
fixed_tvs

              mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType)
              -- Deals with instantiation of kind variables
              --   c.f. GHC.Tc.Utils.TcMType.newMetaTyVars
              mk_inst_ty :: TCvSubst -> (Var, TcType) -> TcM (TCvSubst, TcType)
mk_inst_ty TCvSubst
subst (Var
tv, TcType
result_inst_ty)
                | Var -> Bool
is_fixed_tv Var
tv   -- Same as result type
                = (TCvSubst, TcType) -> TcM (TCvSubst, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst -> Var -> TcType -> TCvSubst
extendTvSubst TCvSubst
subst Var
tv TcType
result_inst_ty, TcType
result_inst_ty)
                | Bool
otherwise        -- Fresh type, of correct kind
                = do { (TCvSubst
subst', Var
new_tv) <- TCvSubst -> Var -> TcM (TCvSubst, Var)
newMetaTyVarX TCvSubst
subst Var
tv
                     ; (TCvSubst, TcType) -> TcM (TCvSubst, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst', Var -> TcType
mkTyVarTy Var
new_tv) }

        ; (TCvSubst
result_subst, [Var]
con1_tvs') <- [Var] -> TcM (TCvSubst, [Var])
newMetaTyVars [Var]
con1_tvs
        ; let result_inst_tys :: [TcType]
result_inst_tys = [Var] -> [TcType]
mkTyVarTys [Var]
con1_tvs'
              init_subst :: TCvSubst
init_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (TCvSubst -> InScopeSet
getTCvInScope TCvSubst
result_subst)

        ; (TCvSubst
scrut_subst, [TcType]
scrut_inst_tys) <- (TCvSubst -> (Var, TcType) -> TcM (TCvSubst, TcType))
-> TCvSubst
-> [(Var, TcType)]
-> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, [TcType])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM TCvSubst -> (Var, TcType) -> TcM (TCvSubst, TcType)
mk_inst_ty TCvSubst
init_subst
                                                      ([Var]
con1_tvs [Var] -> [TcType] -> [(Var, TcType)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TcType]
result_inst_tys)

        ; let rec_res_ty :: TcType
rec_res_ty    = HasCallStack => TCvSubst -> TcType -> TcType
TCvSubst -> TcType -> TcType
TcType.substTy TCvSubst
result_subst TcType
con1_res_ty
              scrut_ty :: TcType
scrut_ty      = HasCallStack => TCvSubst -> TcType -> TcType
TCvSubst -> TcType -> TcType
TcType.substTy TCvSubst
scrut_subst  TcType
con1_res_ty
              con1_arg_tys' :: [TcType]
con1_arg_tys' = (TcType -> TcType) -> [TcType] -> [TcType]
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => TCvSubst -> TcType -> TcType
TCvSubst -> TcType -> TcType
TcType.substTy TCvSubst
result_subst) [TcType]
con1_arg_tys

        ; TcCoercionR
co_scrut <- Maybe SDoc -> TcType -> TcType -> TcM TcCoercionR
unifyType (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsExpr GhcRn)
LHsExpr GhcRn
record_expr)) TcType
record_rho TcType
scrut_ty
                -- NB: normal unification is OK here (as opposed to subsumption),
                -- because for this to work out, both record_rho and scrut_ty have
                -- to be normal datatypes -- no contravariant stuff can go on

        -- STEP 5
        -- Typecheck the bindings
        ; [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
rbinds'      <- ConLike
-> [TcType]
-> [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTc]
tcRecordUpd ConLike
con1 [TcType]
con1_arg_tys' [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
[LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds

        -- STEP 6: Deal with the stupid theta
        ; let theta' :: [TcType]
theta' = TCvSubst -> [TcType] -> [TcType]
substThetaUnchecked TCvSubst
scrut_subst (ConLike -> [TcType]
conLikeStupidTheta ConLike
con1)
        ; CtOrigin -> [TcType] -> TcRn ()
instStupidTheta CtOrigin
RecordUpdOrigin [TcType]
theta'

        -- Step 7: make a cast for the scrutinee, in the
        --         case that it's from a data family
        ; let fam_co :: HsWrapper   -- RepT t1 .. tn ~R scrut_ty
              fam_co :: HsWrapper
fam_co | Just TyCon
tycon <- Maybe TyCon
mtycon
                     , Just CoAxiom Unbranched
co_con <- TyCon -> Maybe (CoAxiom Unbranched)
tyConFamilyCoercion_maybe TyCon
tycon
                     = TcCoercionR -> HsWrapper
mkWpCastR (CoAxiom Unbranched -> [TcType] -> [TcCoercionR] -> TcCoercionR
mkTcUnbranchedAxInstCo CoAxiom Unbranched
co_con [TcType]
scrut_inst_tys [])
                     | Bool
otherwise
                     = HsWrapper
idHsWrapper

        -- Step 8: Check that the req constraints are satisfied
        -- For normal data constructors req_theta is empty but we must do
        -- this check for pattern synonyms.
        ; let req_theta' :: [TcType]
req_theta' = TCvSubst -> [TcType] -> [TcType]
substThetaUnchecked TCvSubst
scrut_subst [TcType]
req_theta
        ; HsWrapper
req_wrap <- CtOrigin -> [TcType] -> TcM HsWrapper
instCallConstraints CtOrigin
RecordUpdOrigin [TcType]
req_theta'

        -- Phew!
        ; let upd_tc :: RecordUpdTc
upd_tc = RecordUpdTc { rupd_cons :: [ConLike]
rupd_cons = [ConLike]
relevant_cons
                                   , rupd_in_tys :: [TcType]
rupd_in_tys = [TcType]
scrut_inst_tys
                                   , rupd_out_tys :: [TcType]
rupd_out_tys = [TcType]
result_inst_tys
                                   , rupd_wrap :: HsWrapper
rupd_wrap = HsWrapper
req_wrap }
              expr' :: HsExpr GhcTc
expr' = RecordUpd { rupd_expr :: LHsExpr GhcTc
rupd_expr = HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
fam_co (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
                                                TcCoercionR -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrapCo TcCoercionR
co_scrut GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
record_expr'
                                , rupd_flds :: Either [LHsRecUpdField GhcTc] [LHsRecUpdProj GhcTc]
rupd_flds = [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> Either
     [GenLocated
        SrcSpanAnnA
        (HsRecField'
           (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
     [GenLocated
        SrcSpanAnnA
        (HsRecField'
           (FieldLabelStrings GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall a b. a -> Either a b
Left [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
rbinds'
                                , rupd_ext :: XRecordUpd GhcTc
rupd_ext = XRecordUpd GhcTc
RecordUpdTc
upd_tc }

        ; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
expr HsExpr GhcTc
expr' TcType
rec_res_ty ExpRhoType
res_ty }
tcExpr (RecordUpd {}) ExpRhoType
_ = String -> TcM (HsExpr GhcTc)
forall a. String -> a
panic String
"GHC.Tc.Gen.Expr: tcExpr: The impossible happened!"


{-
************************************************************************
*                                                                      *
        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
_ Located (HsFieldLabel GhcRn)
_) ExpRhoType
_ = String -> TcM (HsExpr GhcTc)
forall a. String -> a
panic String
"GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented"
tcExpr (HsProjection XProjection GhcRn
_ NonEmpty (Located (HsFieldLabel GhcRn))
_) ExpRhoType
_ = String -> TcM (HsExpr GhcTc)
forall a. String -> a
panic String
"GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented"

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

-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceExpr'.
-- 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 (HsSpliceE XSpliceE GhcRn
_ (HsSpliced XSpliced GhcRn
_ ThModFinalizers
mod_finalizers (HsSplicedExpr HsExpr GhcRn
expr)))
       ExpRhoType
res_ty
  = do ThModFinalizers -> TcRn ()
addModFinalizersWithLclEnv ThModFinalizers
mod_finalizers
       HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpRhoType
res_ty
tcExpr (HsSpliceE XSpliceE GhcRn
_ HsSplice GhcRn
splice)          ExpRhoType
res_ty = HsSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcSpliceExpr HsSplice GhcRn
splice ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsBracket XBracket GhcRn
_ HsBracket GhcRn
brack)         ExpRhoType
res_ty = HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcTypedBracket HsExpr GhcRn
e HsBracket GhcRn
brack ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsRnBracketOut XRnBracketOut GhcRn
_ HsBracket (HsBracketRn GhcRn)
brack [PendingRnSplice' GhcRn]
ps) ExpRhoType
res_ty = HsExpr GhcRn
-> HsBracket GhcRn
-> [PendingRnSplice]
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcUntypedBracket HsExpr GhcRn
e HsBracket GhcRn
HsBracket (HsBracketRn GhcRn)
brack [PendingRnSplice' GhcRn]
[PendingRnSplice]
ps ExpRhoType
res_ty

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

tcExpr (HsConLikeOut {})   ExpRhoType
ty = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:HsConLikeOut" (ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
ty)
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)
tcExpr (HsTcBracketOut {}) ExpRhoType
ty = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:HsTcBracketOut"    (ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
ty)
tcExpr (HsTick {})         ExpRhoType
ty = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:HsTick"    (ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
ty)
tcExpr (HsBinTick {})      ExpRhoType
ty = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:HsBinTick"    (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, TcType
elt_mult, TcType
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, TcType, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
       ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <-TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr TcType
elt_ty
       ; HsExpr GhcTc
enum_from <- CtOrigin -> Name -> [TcType] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
                              Name
enumFromName [TcType
elt_ty]
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
expr') }

tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromThen LHsExpr GhcRn
expr1 LHsExpr GhcRn
expr2) ExpRhoType
res_ty
  = do { (HsWrapper
wrap, TcType
elt_mult, TcType
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, TcType, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
       ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' <- TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 TcType
elt_ty
       ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2' <- TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 TcType
elt_ty
       ; HsExpr GhcTc
enum_from_then <- CtOrigin -> Name -> [TcType] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
                              Name
enumFromThenName [TcType
elt_ty]
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
expr1' GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
expr2') }

tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromTo LHsExpr GhcRn
expr1 LHsExpr GhcRn
expr2) ExpRhoType
res_ty
  = do { (HsWrapper
wrap, TcType
elt_mult, TcType
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, TcType, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
       ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' <- TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 TcType
elt_ty
       ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2' <- TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 TcType
elt_ty
       ; HsExpr GhcTc
enum_from_to <- CtOrigin -> Name -> [TcType] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
                              Name
enumFromToName [TcType
elt_ty]
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
expr1' GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr 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, TcType
elt_mult, TcType
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, TcType, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
        ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr1' <- TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 TcType
elt_ty
        ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr2' <- TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 TcType
elt_ty
        ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr3' <- TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr3 TcType
elt_ty
        ; HsExpr GhcTc
eft <- CtOrigin -> Name -> [TcType] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
                              Name
enumFromThenToName [TcType
elt_ty]
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
expr1' GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
expr2' GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
expr3') }

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

----------------
tcTupArgs :: [HsTupArg GhcRn] -> [TcSigmaType] -> TcM [HsTupArg GhcTc]
tcTupArgs :: [HsTupArg GhcRn] -> [TcType] -> TcM [HsTupArg GhcTc]
tcTupArgs [HsTupArg GhcRn]
args [TcType]
tys
  = do MASSERT( equalLength args tys )
       Int -> TcRn ()
checkTupSize ([HsTupArg GhcRn] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsTupArg GhcRn]
args)
       ((HsTupArg GhcRn, TcType)
 -> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc))
-> [(HsTupArg GhcRn, TcType)] -> TcM [HsTupArg GhcTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsTupArg GhcRn, TcType)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
go ([HsTupArg GhcRn]
args [HsTupArg GhcRn] -> [TcType] -> [(HsTupArg GhcRn, TcType)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TcType]
tys)
  where
    go :: (HsTupArg GhcRn, TcType)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
go (Missing {},     TcType
arg_ty) = do { TcType
mult <- TcType -> TcM TcType
newFlexiTyVarTy TcType
multiplicityTy
                                     ; HsTupArg GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XMissing GhcTc -> HsTupArg GhcTc
forall id. XMissing id -> HsTupArg id
Missing (TcType -> TcType -> Scaled TcType
forall a. TcType -> a -> Scaled a
Scaled TcType
mult TcType
arg_ty)) }
    go (Present XPresent GhcRn
x LHsExpr GhcRn
expr, TcType
arg_ty) = do { GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr TcType
arg_ty
                                     ; HsTupArg GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr 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
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
orig SyntaxExprRn
expr [SyntaxOpType]
arg_tys ExpRhoType
res_ty
  = CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType] -> [TcType] -> 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
              -> ([TcSigmaType] -> [Mult] -> TcM a)
              -> TcM (a, SyntaxExprTc)
tcSyntaxOpGen :: forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen CtOrigin
orig (SyntaxExprRn HsExpr GhcRn
op) [SyntaxOpType]
arg_tys SyntaxOpType
res_ty [TcType] -> [TcType] -> TcM a
thing_inside
  = do { (HsExpr GhcTc
expr, TcType
sigma) <- (HsExpr GhcRn, AppCtxt)
-> [HsExprArg 'TcpRn] -> Maybe TcType -> TcM (HsExpr GhcTc, TcType)
tcInferAppHead (HsExpr GhcRn
op, HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
op Int
0 SrcSpan
noSrcSpan) [] Maybe TcType
forall a. Maybe a
Nothing
             -- 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
$$ HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr SDoc -> SDoc -> SDoc
$$ TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
sigma)
       ; (a
result, HsWrapper
expr_wrap, [HsWrapper]
arg_wraps, HsWrapper
res_wrap)
           <- CtOrigin
-> TcType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall a.
CtOrigin
-> TcType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig TcType
sigma [SyntaxOpType]
arg_tys SyntaxOpType
res_ty (([TcType] -> [TcType] -> TcM a)
 -> TcM (a, HsWrapper, [HsWrapper], HsWrapper))
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall a b. (a -> b) -> a -> b
$
              [TcType] -> [TcType] -> 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
$$ HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr SDoc -> SDoc -> SDoc
$$ TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
sigma )
       ; (a, SyntaxExprTc) -> TcM (a, SyntaxExprTc)
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
_ [TcType] -> [TcType] -> TcM a
_ = String -> TcM (a, SyntaxExprTc)
forall a. 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
          -> TcSigmaType
          -> SyntaxOpType                -- ^ shape it is expected to have
          -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments
          -> TcM (a, HsWrapper)
           -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
tcSynArgE :: forall a.
CtOrigin
-> TcType
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig TcType
sigma_ty SyntaxOpType
syn_ty [TcType] -> [TcType] -> TcM a
thing_inside
  = do { (HsWrapper
skol_wrap, (a
result, HsWrapper
ty_wrapper))
           <- UserTypeCtxt
-> TcType
-> (TcType -> TcM (a, HsWrapper))
-> TcM (HsWrapper, (a, HsWrapper))
forall result.
UserTypeCtxt
-> TcType -> (TcType -> TcM result) -> TcM (HsWrapper, result)
tcSkolemise UserTypeCtxt
GenSigCtxt TcType
sigma_ty ((TcType -> TcM (a, HsWrapper)) -> TcM (HsWrapper, (a, HsWrapper)))
-> (TcType -> TcM (a, HsWrapper))
-> TcM (HsWrapper, (a, HsWrapper))
forall a b. (a -> b) -> a -> b
$ \ TcType
rho_ty ->
              TcType -> SyntaxOpType -> TcM (a, HsWrapper)
go TcType
rho_ty SyntaxOpType
syn_ty
       ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
skol_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
ty_wrapper) }
    where
    go :: TcType -> SyntaxOpType -> TcM (a, HsWrapper)
go TcType
rho_ty SyntaxOpType
SynAny
      = do { a
result <- [TcType] -> [TcType] -> TcM a
thing_inside [TcType
rho_ty] []
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }

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

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

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

                         -- another nested arrow is too much for now,
                         -- but I bet we'll never need this
                     ; MASSERT2( case arg_shape of
                                   SynFun {} -> False;
                                   _         -> True
                               , text "Too many nested arrows in SyntaxOpType" $$
                                 pprCtOrigin orig )

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

           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return ( a
result
                    , HsWrapper
match_wrapper HsWrapper -> HsWrapper -> HsWrapper
<.>
                      HsWrapper
-> HsWrapper -> Scaled TcType -> TcType -> SDoc -> HsWrapper
mkWpFun (HsWrapper
arg_wrapper2 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
arg_wrapper1) HsWrapper
res_wrapper
                              (TcType -> TcType -> Scaled TcType
forall a. TcType -> a -> Scaled a
Scaled TcType
op_mult TcType
arg_ty) TcType
res_ty SDoc
doc ) }
      where
        herald :: SDoc
herald = String -> SDoc
text String
"This rebindable syntax expects a function with"
        doc :: SDoc
doc = String -> SDoc
text String
"When checking a rebindable syntax operator arising from" SDoc -> SDoc -> SDoc
<+> CtOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr CtOrigin
orig

    go TcType
rho_ty (SynType ExpRhoType
the_ty)
      = do { HsWrapper
wrap   <- CtOrigin -> UserTypeCtxt -> ExpRhoType -> TcType -> TcM HsWrapper
tcSubTypePat CtOrigin
orig UserTypeCtxt
GenSigCtxt ExpRhoType
the_ty TcType
rho_ty
           ; a
result <- [TcType] -> [TcType] -> TcM a
thing_inside [] []
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
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
          -> TcSigmaType
          -> [SyntaxOpType]              -- ^ argument shapes
          -> SyntaxOpType                -- ^ result shape
          -> ([TcSigmaType] -> [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
-> TcType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig TcType
sigma_ty [SyntaxOpType]
arg_shapes SyntaxOpType
res_shape [TcType] -> [TcType] -> TcM a
thing_inside
  = do { (HsWrapper
match_wrapper, [Scaled TcType]
arg_tys, TcType
res_ty)
           <- SDoc
-> CtOrigin
-> Maybe SDoc
-> Int
-> TcType
-> TcM (HsWrapper, [Scaled TcType], TcType)
matchActualFunTysRho SDoc
herald CtOrigin
orig Maybe SDoc
forall a. Maybe a
Nothing
                                   ([SyntaxOpType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SyntaxOpType]
arg_shapes) TcType
sigma_ty
              -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
       ; ((a
result, HsWrapper
res_wrapper), [HsWrapper]
arg_wrappers)
           <- [TcType]
-> [SyntaxOpType]
-> ([TcType] -> [TcType] -> TcM (a, HsWrapper))
-> TcM ((a, HsWrapper), [HsWrapper])
forall a.
[TcType]
-> [SyntaxOpType]
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e ((Scaled TcType -> TcType) -> [Scaled TcType] -> [TcType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcType -> TcType
forall a. Scaled a -> a
scaledThing [Scaled TcType]
arg_tys) [SyntaxOpType]
arg_shapes (([TcType] -> [TcType] -> TcM (a, HsWrapper))
 -> TcM ((a, HsWrapper), [HsWrapper]))
-> ([TcType] -> [TcType] -> TcM (a, HsWrapper))
-> TcM ((a, HsWrapper), [HsWrapper])
forall a b. (a -> b) -> a -> b
$ \ [TcType]
arg_results [TcType]
arg_res_mults ->
              TcType -> SyntaxOpType -> ([TcType] -> TcM a) -> TcM (a, HsWrapper)
forall a.
TcType -> SyntaxOpType -> ([TcType] -> TcM a) -> TcM (a, HsWrapper)
tc_syn_arg    TcType
res_ty  SyntaxOpType
res_shape  (([TcType] -> TcM a) -> TcM (a, HsWrapper))
-> ([TcType] -> TcM a) -> TcM (a, HsWrapper)
forall a b. (a -> b) -> a -> b
$ \ [TcType]
res_results ->
              [TcType] -> [TcType] -> TcM a
thing_inside ([TcType]
arg_results [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
res_results) ((Scaled TcType -> TcType) -> [Scaled TcType] -> [TcType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcType -> TcType
forall a. Scaled a -> TcType
scaledMult [Scaled TcType]
arg_tys [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
arg_res_mults)
       ; (a, HsWrapper, [HsWrapper], HsWrapper)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
match_wrapper, [HsWrapper]
arg_wrappers, HsWrapper
res_wrapper) }
  where
    herald :: SDoc
herald = String -> SDoc
text String
"This rebindable syntax expects a function with"

    tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]
                  -> ([TcSigmaType] -> [Mult] -> TcM a)
                  -> TcM (a, [HsWrapper])
                    -- the wrappers are for arguments
    tc_syn_args_e :: forall a.
[TcType]
-> [SyntaxOpType]
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e (TcType
arg_ty : [TcType]
arg_tys) (SyntaxOpType
arg_shape : [SyntaxOpType]
arg_shapes) [TcType] -> [TcType] -> TcM a
thing_inside
      = do { ((a
result, [HsWrapper]
arg_wraps), HsWrapper
arg_wrap)
               <- CtOrigin
-> TcType
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM (a, [HsWrapper]))
-> TcM ((a, [HsWrapper]), HsWrapper)
forall a.
CtOrigin
-> TcType
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE     CtOrigin
orig TcType
arg_ty  SyntaxOpType
arg_shape  (([TcType] -> [TcType] -> TcM (a, [HsWrapper]))
 -> TcM ((a, [HsWrapper]), HsWrapper))
-> ([TcType] -> [TcType] -> TcM (a, [HsWrapper]))
-> TcM ((a, [HsWrapper]), HsWrapper)
forall a b. (a -> b) -> a -> b
$ \ [TcType]
arg1_results [TcType]
arg1_mults ->
                  [TcType]
-> [SyntaxOpType]
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, [HsWrapper])
forall a.
[TcType]
-> [SyntaxOpType]
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e      [TcType]
arg_tys [SyntaxOpType]
arg_shapes (([TcType] -> [TcType] -> TcM a) -> TcM (a, [HsWrapper]))
-> ([TcType] -> [TcType] -> TcM a) -> TcM (a, [HsWrapper])
forall a b. (a -> b) -> a -> b
$ \ [TcType]
args_results [TcType]
args_mults ->
                  [TcType] -> [TcType] -> TcM a
thing_inside ([TcType]
arg1_results [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
args_results) ([TcType]
arg1_mults [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
args_mults)
           ; (a, [HsWrapper]) -> TcM (a, [HsWrapper])
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 [TcType]
_ [SyntaxOpType]
_ [TcType] -> [TcType] -> TcM a
thing_inside = (, []) (a -> (a, [HsWrapper])) -> TcM a -> TcM (a, [HsWrapper])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TcType] -> [TcType] -> TcM a
thing_inside [] []

    tc_syn_arg :: TcSigmaType -> SyntaxOpType
               -> ([TcSigmaType] -> TcM a)
               -> TcM (a, HsWrapper)
                  -- the wrapper applies to the overall result
    tc_syn_arg :: forall a.
TcType -> SyntaxOpType -> ([TcType] -> TcM a) -> TcM (a, HsWrapper)
tc_syn_arg TcType
res_ty SyntaxOpType
SynAny [TcType] -> TcM a
thing_inside
      = do { a
result <- [TcType] -> TcM a
thing_inside [TcType
res_ty]
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }
    tc_syn_arg TcType
res_ty SyntaxOpType
SynRho [TcType] -> TcM a
thing_inside
      = do { (HsWrapper
inst_wrap, TcType
rho_ty) <- CtOrigin -> TcType -> TcM (HsWrapper, TcType)
topInstantiate CtOrigin
orig TcType
res_ty
               -- inst_wrap :: res_ty "->" rho_ty
           ; a
result <- [TcType] -> TcM a
thing_inside [TcType
rho_ty]
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
inst_wrap) }
    tc_syn_arg TcType
res_ty SyntaxOpType
SynList [TcType] -> TcM a
thing_inside
      = do { (HsWrapper
inst_wrap, TcType
rho_ty) <- CtOrigin -> TcType -> TcM (HsWrapper, TcType)
topInstantiate CtOrigin
orig TcType
res_ty
               -- inst_wrap :: res_ty "->" rho_ty
           ; (TcCoercionR
list_co, TcType
elt_ty)   <- TcType -> TcM (TcCoercionR, TcType)
matchExpectedListTy TcType
rho_ty
               -- list_co :: [elt_ty] ~N rho_ty
           ; a
result <- [TcType] -> TcM a
thing_inside [TcType
elt_ty]
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, TcCoercionR -> HsWrapper
mkWpCastN (TcCoercionR -> TcCoercionR
mkTcSymCo TcCoercionR
list_co) HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
inst_wrap) }
    tc_syn_arg TcType
_ (SynFun {}) [TcType] -> 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 TcType
res_ty (SynType ExpRhoType
the_ty) [TcType] -> TcM a
thing_inside
      = do { HsWrapper
wrap   <- CtOrigin -> UserTypeCtxt -> TcType -> ExpRhoType -> TcM HsWrapper
tcSubType CtOrigin
orig UserTypeCtxt
GenSigCtxt TcType
res_ty ExpRhoType
the_ty
           ; a
result <- [TcType] -> TcM a
thing_inside []
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
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.
-}

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

getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet
-- These tyvars must not change across the updates
getFixedTyVars :: [FieldLabelString] -> [Var] -> [ConLike] -> VarSet
getFixedTyVars [FieldLabelString]
upd_fld_occs [Var]
univ_tvs [ConLike]
cons
      = [Var] -> VarSet
mkVarSet [Var
tv1 | ConLike
con <- [ConLike]
cons
                      , let ([Var]
u_tvs, [Var]
_, [EqSpec]
eqspec, [TcType]
prov_theta
                             , [TcType]
req_theta, [Scaled TcType]
arg_tys, TcType
_)
                              = ConLike
-> ([Var], [Var], [EqSpec], [TcType], [TcType], [Scaled TcType],
    TcType)
conLikeFullSig ConLike
con
                            theta :: [TcType]
theta = [EqSpec] -> [TcType]
eqSpecPreds [EqSpec]
eqspec
                                     [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
prov_theta
                                     [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
req_theta
                            flds :: [FieldLabel]
flds = ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con
                            fixed_tvs :: VarSet
fixed_tvs = [TcType] -> VarSet
exactTyCoVarsOfTypes ((Scaled TcType -> TcType) -> [Scaled TcType] -> [TcType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcType -> TcType
forall a. Scaled a -> a
scaledThing [Scaled TcType]
fixed_tys)
                                    -- fixed_tys: See Note [Type of a record update]
                                        VarSet -> VarSet -> VarSet
`unionVarSet` [TcType] -> VarSet
tyCoVarsOfTypes [TcType]
theta
                                    -- Universally-quantified tyvars that
                                    -- appear in any of the *implicit*
                                    -- arguments to the constructor are fixed
                                    -- See Note [Implicit type sharing]

                            fixed_tys :: [Scaled TcType]
fixed_tys = [Scaled TcType
ty | (FieldLabel
fl, Scaled TcType
ty) <- [FieldLabel] -> [Scaled TcType] -> [(FieldLabel, Scaled TcType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FieldLabel]
flds [Scaled TcType]
arg_tys
                                            , Bool -> Bool
not (FieldLabel -> FieldLabelString
flLabel FieldLabel
fl FieldLabelString -> [FieldLabelString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FieldLabelString]
upd_fld_occs)]
                      , (Var
tv1,Var
tv) <- [Var]
univ_tvs [Var] -> [Var] -> [(Var, Var)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Var]
u_tvs
                      , Var
tv Var -> VarSet -> Bool
`elemVarSet` VarSet
fixed_tvs ]

-- 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 [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds :: LHsExpr GhcRn
-> TcType
-> [LHsRecUpdField GhcRn]
-> ExpRhoType
-> TcM
     [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds LHsExpr GhcRn
record_expr TcType
record_rho [LHsRecUpdField GhcRn]
rbnds ExpRhoType
res_ty
    -- Are all the fields unambiguous?
  = case (GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
 -> Maybe
      (GenLocated
         SrcSpanAnnA
         (HsRecField'
            (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
       Name))
-> [GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> Maybe
     [(GenLocated
         SrcSpanAnnA
         (HsRecField'
            (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
       Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated
  SrcSpanAnnA
  (HsRecField'
     (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> Maybe
     (GenLocated
        SrcSpanAnnA
        (HsRecField'
           (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
      Name)
LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn, Name)
isUnambiguous [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
[LHsRecUpdField GhcRn]
rbnds of
                     -- If so, just skip to looking up the Ids
                     -- Always the case if DuplicateRecordFields is off
      Just [(GenLocated
    SrcSpanAnnA
    (HsRecField'
       (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
  Name)]
rbnds' -> ((GenLocated
    SrcSpanAnnA
    (HsRecField'
       (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
  Name)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated
         SrcSpanAnnA
         (HsRecField'
            (AmbiguousFieldOcc GhcTc)
            (GenLocated SrcSpanAnnA (HsExpr GhcRn)))))
-> [(GenLocated
       SrcSpanAnnA
       (HsRecField'
          (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
     Name)]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [GenLocated
        SrcSpanAnnA
        (HsRecField'
           (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
 Name)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated
        SrcSpanAnnA
        (HsRecField'
           (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(LHsRecUpdField GhcRn, Name)
-> TcM
     (LHsRecField' GhcRn (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector [(GenLocated
    SrcSpanAnnA
    (HsRecField'
       (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
  Name)]
rbnds'
      Maybe
  [(GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (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
    (HsRecField'
       (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
  [(RecSelParent, GlobalRdrElt)])]
rbnds_with_parents <- IOEnv
  (Env TcGblEnv TcLclEnv)
  [(GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
    [(RecSelParent, GlobalRdrElt)])]
TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
getUpdFieldsParents
           ; let possible_parents :: [[RecSelParent]]
possible_parents = ((GenLocated
    SrcSpanAnnA
    (HsRecField'
       (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
  [(RecSelParent, GlobalRdrElt)])
 -> [RecSelParent])
-> [(GenLocated
       SrcSpanAnnA
       (HsRecField'
          (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (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
       (HsRecField'
          (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
     [(RecSelParent, GlobalRdrElt)])
    -> [(RecSelParent, GlobalRdrElt)])
-> (GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
    [(RecSelParent, GlobalRdrElt)])
-> [RecSelParent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
 [(RecSelParent, GlobalRdrElt)])
-> [(RecSelParent, GlobalRdrElt)]
forall a b. (a, b) -> b
snd) [(GenLocated
    SrcSpanAnnA
    (HsRecField'
       (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (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
     (HsRecField'
        (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [GenLocated
        SrcSpanAnnA
        (HsRecField'
           (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
forall r. TcM r -> TcM r
checkNoErrs (IOEnv
   (Env TcGblEnv TcLclEnv)
   [GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      [GenLocated
         SrcSpanAnnA
         (HsRecField'
            (AmbiguousFieldOcc GhcTc)
            (GenLocated SrcSpanAnnA (HsExpr GhcRn)))])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [GenLocated
        SrcSpanAnnA
        (HsRecField'
           (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [GenLocated
        SrcSpanAnnA
        (HsRecField'
           (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
forall a b. (a -> b) -> a -> b
$ ((GenLocated
    SrcSpanAnnA
    (HsRecField'
       (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
  [(RecSelParent, GlobalRdrElt)])
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated
         SrcSpanAnnA
         (HsRecField'
            (AmbiguousFieldOcc GhcTc)
            (GenLocated SrcSpanAnnA (HsExpr GhcRn)))))
-> [(GenLocated
       SrcSpanAnnA
       (HsRecField'
          (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
     [(RecSelParent, GlobalRdrElt)])]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [GenLocated
        SrcSpanAnnA
        (HsRecField'
           (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> TcM
     (LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
pickParent RecSelParent
p) [(GenLocated
    SrcSpanAnnA
    (HsRecField'
       (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (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 Located (AmbiguousFieldOcc GhcRn) -> AmbiguousFieldOcc GhcRn
forall l e. GenLocated l e -> e
unLoc (HsRecField'
  (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Located (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (GenLocated
  SrcSpanAnnA
  (HsRecField'
     (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> HsRecField'
     (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc GenLocated
  SrcSpanAnnA
  (HsRecField'
     (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
LHsRecUpdField GhcRn
x)) of
                        Unambiguous XUnambiguous GhcRn
sel_name LocatedN RdrName
_ -> (GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
 Name)
-> Maybe
     (GenLocated
        SrcSpanAnnA
        (HsRecField'
           (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
      Name)
forall a. a -> Maybe a
Just (GenLocated
  SrcSpanAnnA
  (HsRecField'
     (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
LHsRecUpdField GhcRn
x, Name
XUnambiguous GhcRn
sel_name)
                        Ambiguous{}            -> Maybe (LHsRecUpdField 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> [[(RecSelParent, GlobalRdrElt)]]
-> [(GenLocated
       SrcSpanAnnA
       (HsRecField'
          (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
     [(RecSelParent, GlobalRdrElt)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
[LHsRecUpdField 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
   (HsRecField'
      (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
 -> IOEnv (Env TcGblEnv TcLclEnv) [(RecSelParent, GlobalRdrElt)])
-> [GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (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)
mapM
          (Bool
-> RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) [(RecSelParent, GlobalRdrElt)]
lookupParents Bool
False (RdrName
 -> IOEnv (Env TcGblEnv TcLclEnv) [(RecSelParent, GlobalRdrElt)])
-> (GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
    -> RdrName)
-> GenLocated
     SrcSpanAnnA
     (HsRecField'
        (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (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
      (HsRecField'
         (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
    -> GenLocated SrcSpan RdrName)
-> GenLocated
     SrcSpanAnnA
     (HsRecField'
        (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecField'
  (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated SrcSpan RdrName
forall (p :: Pass).
HsRecUpdField (GhcPass p) -> GenLocated SrcSpan RdrName
hsRecUpdFieldRdr (HsRecField'
   (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
 -> GenLocated SrcSpan RdrName)
-> (GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
    -> HsRecField'
         (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> GenLocated
     SrcSpanAnnA
     (HsRecField'
        (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> GenLocated SrcSpan RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  SrcSpanAnnA
  (HsRecField'
     (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> HsRecField'
     (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc)
          [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
[LHsRecUpdField 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 (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
        []  -> SDoc -> TcM RecSelParent
forall a. SDoc -> TcM a
failWithTc ([LHsRecUpdField GhcRn] -> SDoc
noPossibleParents [LHsRecUpdField GhcRn]
rbnds)

        -- Exactly one datatype with all the fields: use that
        [RecSelParent
p] -> RecSelParent -> TcM RecSelParent
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 (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 (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsExpr GhcRn)
LHsExpr GhcRn
record_expr)
            , Just TyCon
tc <- FamInstEnvs -> TcType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs TcType
record_rho
            -> do { TyCon -> TcRn ()
reportAmbiguousField TyCon
tc
                  ; RecSelParent -> TcM RecSelParent
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> RecSelParent
RecSelData TyCon
tc) }

        -- Nothing else we can try...
        [RecSelParent]
_ -> SDoc -> TcM RecSelParent
forall a. SDoc -> TcM a
failWithTc SDoc
badOverloadedUpdate

    -- 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 (LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
    pickParent :: RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> TcM
     (LHsRecField' GhcTc (AmbiguousFieldOcc 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 (t :: * -> *) a. Foldable t => t a -> Bool
null ([(RecSelParent, GlobalRdrElt)] -> [(RecSelParent, GlobalRdrElt)]
forall a. [a] -> [a]
tail [(RecSelParent, GlobalRdrElt)]
xs)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
                             let L SrcSpan
loc AmbiguousFieldOcc GhcRn
_ = HsRecField'
  (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Located (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (GenLocated
  SrcSpanAnnA
  (HsRecField'
     (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> HsRecField'
     (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc GenLocated
  SrcSpanAnnA
  (HsRecField'
     (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
LHsRecUpdField GhcRn
upd)
                             SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Bool -> GlobalRdrElt -> TcRn ()
addUsedGRE Bool
True GlobalRdrElt
gre
                         ; (LHsRecUpdField GhcRn, Name)
-> TcM
     (LHsRecField' GhcRn (AmbiguousFieldOcc 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 { SDoc -> TcRn ()
addErrTc (RecSelParent -> RdrName -> SDoc
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
  (HsRecField'
     (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> HsRecField'
     (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc GenLocated
  SrcSpanAnnA
  (HsRecField'
     (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
LHsRecUpdField GhcRn
upd))))
                         ; (LHsRecUpdField GhcRn, Name)
-> TcM
     (LHsRecField' GhcRn (AmbiguousFieldOcc 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. [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 (LHsRecField' GhcRn (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
    lookupSelector :: (LHsRecUpdField GhcRn, Name)
-> TcM
     (LHsRecField' GhcRn (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector (L SrcSpanAnnA
l HsRecField'
  (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
upd, Name
n)
      = do { Var
i <- Name -> TcM Var
tcLookupId Name
n
           ; let L SrcSpan
loc AmbiguousFieldOcc GhcRn
af = HsRecField'
  (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Located (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl HsRecField'
  (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
upd
                 lbl :: RdrName
lbl      = AmbiguousFieldOcc GhcRn -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc AmbiguousFieldOcc GhcRn
af
           -- ; return $ L l upd { hsRecFieldLbl
           --                = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl)) }
           ; GenLocated
  SrcSpanAnnA
  (HsRecField'
     (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated
        SrcSpanAnnA
        (HsRecField'
           (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated
         SrcSpanAnnA
         (HsRecField'
            (AmbiguousFieldOcc GhcTc)
            (GenLocated SrcSpanAnnA (HsExpr GhcRn)))))
-> GenLocated
     SrcSpanAnnA
     (HsRecField'
        (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated
        SrcSpanAnnA
        (HsRecField'
           (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsRecField'
     (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated
     SrcSpanAnnA
     (HsRecField'
        (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsRecField
               { hsRecFieldAnn :: XHsRecField (AmbiguousFieldOcc GhcTc)
hsRecFieldAnn = HsRecField'
  (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> XHsRecField (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> XHsRecField id
hsRecFieldAnn HsRecField'
  (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
upd
               , hsRecFieldLbl :: GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
hsRecFieldLbl
                       = SrcSpan
-> AmbiguousFieldOcc GhcTc
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XUnambiguous GhcTc -> LocatedN RdrName -> AmbiguousFieldOcc GhcTc
forall pass.
XUnambiguous pass -> LocatedN RdrName -> AmbiguousFieldOcc pass
Unambiguous Var
XUnambiguous GhcTc
i (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
lbl))
               , hsRecFieldArg :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
hsRecFieldArg = HsRecField'
  (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall id arg. HsRecField' id arg -> arg
hsRecFieldArg HsRecField'
  (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
upd
               , hsRecPun :: Bool
hsRecPun = HsRecField'
  (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Bool
forall id arg. HsRecField' id arg -> Bool
hsRecPun HsRecField'
  (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (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
$ WarningFlag -> Bool -> SDoc -> TcRn ()
warnIfFlag WarningFlag
Opt_WarnAmbiguousFields Bool
True (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
          [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"The record update" SDoc -> SDoc -> SDoc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
rupd
                   SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"with type" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
parent_type
                   SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is ambiguous."
               , String -> SDoc
text String
"This will not be supported by -XDuplicateRecordFields in future releases of GHC."
               ]
      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
   (HsRecField'
      (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> Either
     [GenLocated
        SrcSpanAnnA
        (HsRecField'
           (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
     [GenLocated
        SrcSpanAnnA
        (HsRecField'
           (FieldLabelStrings GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
forall a b. a -> Either a b
Left [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
[LHsRecUpdField GhcRn]
rbnds, rupd_ext :: XRecordUpd GhcRn
rupd_ext = NoExtField
XRecordUpd GhcRn
noExtField }
        loc :: SrcSpan
loc  = GenLocated
  SrcSpanAnnA
  (HsRecField'
     (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA ([GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> GenLocated
     SrcSpanAnnA
     (HsRecField'
        (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall a. [a] -> a
head [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
[LHsRecUpdField 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
-> [TcType] -> HsRecordBinds GhcRn -> TcM (HsRecordBinds GhcTc)
tcRecordBinds ConLike
con_like [TcType]
arg_tys (HsRecFields [LHsRecField GhcRn (LHsExpr GhcRn)]
rbinds Maybe (Located Int)
dd)
  = do  { [Maybe
   (GenLocated
      SrcSpanAnnA
      (HsRecField'
         (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
mb_binds <- (GenLocated
   SrcSpanAnnA
   (HsRecField'
      (FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Maybe
         (GenLocated
            SrcSpanAnnA
            (HsRecField'
               (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))))))
-> [GenLocated
      SrcSpanAnnA
      (HsRecField'
         (FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [Maybe
        (GenLocated
           SrcSpanAnnA
           (HsRecField'
              (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated
  SrcSpanAnnA
  (HsRecField'
     (FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe
        (GenLocated
           SrcSpanAnnA
           (HsRecField'
              (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
LHsRecField GhcRn (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
do_bind [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
[LHsRecField GhcRn (LHsExpr GhcRn)]
rbinds
        ; HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsRecField GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> Maybe (Located Int)
-> HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields ([Maybe
   (GenLocated
      SrcSpanAnnA
      (HsRecField'
         (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
-> [GenLocated
      SrcSpanAnnA
      (HsRecField'
         (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall a. [Maybe a] -> [a]
catMaybes [Maybe
   (GenLocated
      SrcSpanAnnA
      (HsRecField'
         (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
mb_binds) Maybe (Located Int)
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, TcType)]
flds_w_tys = String -> [Name] -> [TcType] -> [(Name, TcType)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"tcRecordBinds" [Name]
fields [TcType]
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 :: HsRecField'
  (FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
fld@(HsRecField { hsRecFieldLbl :: forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl = Located (FieldOcc GhcRn)
f
                                 , hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs }))

      = do { Maybe
  (Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc))
mb <- ConLike
-> [(Name, TcType)]
-> LFieldOcc GhcRn
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, TcType)]
flds_w_tys Located (FieldOcc GhcRn)
LFieldOcc GhcRn
f GenLocated SrcSpanAnnA (HsExpr GhcRn)
LHsExpr GhcRn
rhs
           ; case Maybe
  (Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc))
mb of
               Maybe
  (Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc))
Nothing         -> Maybe
  (GenLocated
     SrcSpanAnnA
     (HsRecField'
        (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe
        (GenLocated
           SrcSpanAnnA
           (HsRecField'
              (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
  (GenLocated
     SrcSpanAnnA
     (HsRecField'
        (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a. Maybe a
Nothing
               -- Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f'
               --                                            , hsRecFieldArg = rhs' }))) }
               Just (Located (FieldOcc GhcTc)
f', GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs') -> Maybe
  (GenLocated
     SrcSpanAnnA
     (HsRecField'
        (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe
        (GenLocated
           SrcSpanAnnA
           (HsRecField'
              (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
  SrcSpanAnnA
  (HsRecField'
     (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> Maybe
     (GenLocated
        SrcSpanAnnA
        (HsRecField'
           (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a. a -> Maybe a
Just (SrcSpanAnnA
-> HsRecField'
     (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
     SrcSpanAnnA
     (HsRecField'
        (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsRecField
                                                     { hsRecFieldAnn :: XHsRecField (FieldOcc GhcTc)
hsRecFieldAnn = HsRecField'
  (FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> XHsRecField (FieldOcc GhcRn)
forall id arg. HsRecField' id arg -> XHsRecField id
hsRecFieldAnn HsRecField'
  (FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
fld
                                                     , hsRecFieldLbl :: Located (FieldOcc GhcTc)
hsRecFieldLbl = Located (FieldOcc GhcTc)
f'
                                                     , hsRecFieldArg :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
hsRecFieldArg = GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs'
                                                     , hsRecPun :: Bool
hsRecPun = HsRecField'
  (FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Bool
forall id arg. HsRecField' id arg -> Bool
hsRecPun HsRecField'
  (FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
fld}))) }

tcRecordUpd
        :: ConLike
        -> [TcType]     -- Expected type for each field
        -> [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
        -> TcM [LHsRecUpdField GhcTc]

tcRecordUpd :: ConLike
-> [TcType]
-> [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTc]
tcRecordUpd ConLike
con_like [TcType]
arg_tys [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds = ([Maybe
    (GenLocated
       SrcSpanAnnA
       (HsRecField'
          (AmbiguousFieldOcc GhcTc)
          (GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
 -> [LHsRecUpdField GhcTc])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [Maybe
        (GenLocated
           SrcSpanAnnA
           (HsRecField'
              (AmbiguousFieldOcc GhcTc)
              (GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
-> TcM [LHsRecUpdField GhcTc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe
   (GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcTc)
         (GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
-> [LHsRecUpdField GhcTc]
forall a. [Maybe a] -> [a]
catMaybes (IOEnv
   (Env TcGblEnv TcLclEnv)
   [Maybe
      (GenLocated
         SrcSpanAnnA
         (HsRecField'
            (AmbiguousFieldOcc GhcTc)
            (GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
 -> TcM [LHsRecUpdField GhcTc])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [Maybe
        (GenLocated
           SrcSpanAnnA
           (HsRecField'
              (AmbiguousFieldOcc GhcTc)
              (GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
-> TcM [LHsRecUpdField GhcTc]
forall a b. (a -> b) -> a -> b
$ (GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Maybe
         (GenLocated
            SrcSpanAnnA
            (HsRecField'
               (AmbiguousFieldOcc GhcTc)
               (GenLocated SrcSpanAnnA (HsExpr GhcTc))))))
-> [GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [Maybe
        (GenLocated
           SrcSpanAnnA
           (HsRecField'
              (AmbiguousFieldOcc GhcTc)
              (GenLocated SrcSpanAnnA (HsExpr GhcTc))))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated
  SrcSpanAnnA
  (HsRecField'
     (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe
        (GenLocated
           SrcSpanAnnA
           (HsRecField'
              (AmbiguousFieldOcc GhcTc)
              (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecUpdField GhcTc))
do_bind [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
[LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds
  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, TcType)]
flds_w_tys = String -> [Name] -> [TcType] -> [(Name, TcType)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"tcRecordUpd" [Name]
fields [TcType]
arg_tys

    do_bind :: LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
            -> TcM (Maybe (LHsRecUpdField GhcTc))
    do_bind :: LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecUpdField GhcTc))
do_bind (L SrcSpanAnnA
l fld :: HsRecField'
  (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
fld@(HsRecField { hsRecFieldLbl :: forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl = L SrcSpan
loc AmbiguousFieldOcc GhcTc
af
                                 , hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs }))
      = do { let lbl :: RdrName
lbl = AmbiguousFieldOcc GhcTc -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc AmbiguousFieldOcc GhcTc
af
                 sel_id :: Var
sel_id = AmbiguousFieldOcc GhcTc -> Var
selectorAmbiguousFieldOcc AmbiguousFieldOcc GhcTc
af
                 f :: Located (FieldOcc GhcRn)
f = SrcSpan -> FieldOcc GhcRn -> Located (FieldOcc GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XCFieldOcc GhcRn -> LocatedN RdrName -> FieldOcc GhcRn
forall pass. XCFieldOcc pass -> LocatedN RdrName -> FieldOcc pass
FieldOcc (Var -> Name
idName Var
sel_id) (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
lbl))
           ; Maybe
  (Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc))
mb <- ConLike
-> [(Name, TcType)]
-> LFieldOcc GhcRn
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, TcType)]
flds_w_tys Located (FieldOcc GhcRn)
LFieldOcc GhcRn
f GenLocated SrcSpanAnnA (HsExpr GhcRn)
LHsExpr GhcRn
rhs
           ; case Maybe
  (Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc))
mb of
               Maybe
  (Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc))
Nothing         -> Maybe
  (GenLocated
     SrcSpanAnnA
     (HsRecField'
        (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe
        (GenLocated
           SrcSpanAnnA
           (HsRecField'
              (AmbiguousFieldOcc GhcTc)
              (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
  (GenLocated
     SrcSpanAnnA
     (HsRecField'
        (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a. Maybe a
Nothing
               Just (Located (FieldOcc GhcTc)
f', GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs') ->
                 Maybe
  (GenLocated
     SrcSpanAnnA
     (HsRecField'
        (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe
        (GenLocated
           SrcSpanAnnA
           (HsRecField'
              (AmbiguousFieldOcc GhcTc)
              (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
  SrcSpanAnnA
  (HsRecField'
     (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> Maybe
     (GenLocated
        SrcSpanAnnA
        (HsRecField'
           (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a. a -> Maybe a
Just
                         (SrcSpanAnnA
-> HsRecField'
     (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
     SrcSpanAnnA
     (HsRecField'
        (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsRecField'
  (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
fld { hsRecFieldLbl :: GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
hsRecFieldLbl
                                      = SrcSpan
-> AmbiguousFieldOcc GhcTc
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XUnambiguous GhcTc -> LocatedN RdrName -> AmbiguousFieldOcc GhcTc
forall pass.
XUnambiguous pass -> LocatedN RdrName -> AmbiguousFieldOcc pass
Unambiguous
                                               (FieldOcc GhcTc -> XCFieldOcc GhcTc
forall pass. FieldOcc pass -> XCFieldOcc pass
extFieldOcc (Located (FieldOcc GhcTc) -> FieldOcc GhcTc
forall l e. GenLocated l e -> e
unLoc Located (FieldOcc GhcTc)
f'))
                                               (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
lbl))
                                   , hsRecFieldArg :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
hsRecFieldArg = GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs' }))) }

tcRecordField :: ConLike -> Assoc Name Type
              -> LFieldOcc GhcRn -> LHsExpr GhcRn
              -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField :: ConLike
-> [(Name, TcType)]
-> LFieldOcc GhcRn
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, TcType)]
flds_w_tys (L SrcSpan
loc (FieldOcc XCFieldOcc GhcRn
sel_name LocatedN RdrName
lbl)) LHsExpr GhcRn
rhs
  | Just TcType
field_ty <- [(Name, TcType)] -> Name -> Maybe TcType
forall a b. Eq a => Assoc a b -> a -> Maybe b
assocMaybe [(Name, TcType)]
flds_w_tys Name
XCFieldOcc GhcRn
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 -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
rhs TcType
field_ty
           ; let field_id :: Var
field_id = OccName -> Unique -> TcType -> TcType -> SrcSpan -> Var
mkUserLocal (Name -> OccName
nameOccName Name
XCFieldOcc GhcRn
sel_name)
                                        (Name -> Unique
nameUnique Name
XCFieldOcc GhcRn
sel_name)
                                        TcType
Many TcType
field_ty SrcSpan
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
  (Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe
        (Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> Maybe
     (Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> Maybe a
Just (SrcSpan -> FieldOcc GhcTc -> Located (FieldOcc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XCFieldOcc GhcTc -> LocatedN RdrName -> FieldOcc GhcTc
forall pass. XCFieldOcc pass -> LocatedN RdrName -> FieldOcc pass
FieldOcc Var
XCFieldOcc GhcTc
field_id LocatedN RdrName
lbl), GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs')) }
      | Bool
otherwise
      = do { SDoc -> TcRn ()
addErrTc (ConLike -> FieldLabelString -> SDoc
badFieldCon ConLike
con_like FieldLabelString
field_lbl)
           ; Maybe
  (Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe
        (Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
  (Located (FieldOcc GhcTc), GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. Maybe a
Nothing }
  where
        field_lbl :: FieldLabelString
field_lbl = OccName -> FieldLabelString
occNameFS (OccName -> FieldLabelString) -> OccName -> FieldLabelString
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
lbl)


checkMissingFields ::  ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM ()
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcRn ()
checkMissingFields ConLike
con_like HsRecordBinds GhcRn
rbinds [Scaled TcType]
arg_tys
  | [FieldLabel] -> 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
        SDoc -> TcRn ()
addErrTc (ConLike -> [(FieldLabelString, TcType)] -> SDoc
missingStrictFields ConLike
con_like [])
    else do
        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
&& [HsImplBang] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [HsImplBang]
field_strs Bool -> Bool -> Bool
&& [FieldLabel] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
field_labels)
             (WarnReason -> Bool -> SDoc -> TcRn ()
warnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingFields) Bool
True
                 (ConLike -> [(FieldLabelString, TcType)] -> SDoc
missingFields ConLike
con_like []))

  | Bool
otherwise = do              -- A record
    Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(FieldLabelString, TcType)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, TcType)]
missing_s_fields) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
        [(FieldLabelString, TcType)]
fs <- [(FieldLabelString, TcType)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(FieldLabelString, TcType)]
forall {t :: * -> *} {a}.
Traversable t =>
t (a, TcType) -> IOEnv (Env TcGblEnv TcLclEnv) (t (a, TcType))
zonk_fields [(FieldLabelString, TcType)]
missing_s_fields
        -- It is an error to omit a strict field, because
        -- we can't substitute it with (error "Missing field f")
        SDoc -> TcRn ()
addErrTc (ConLike -> [(FieldLabelString, TcType)] -> SDoc
missingStrictFields ConLike
con_like [(FieldLabelString, TcType)]
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, TcType)] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [(FieldLabelString, TcType)]
missing_ns_fields) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
        [(FieldLabelString, TcType)]
fs <- [(FieldLabelString, TcType)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(FieldLabelString, TcType)]
forall {t :: * -> *} {a}.
Traversable t =>
t (a, TcType) -> IOEnv (Env TcGblEnv TcLclEnv) (t (a, TcType))
zonk_fields [(FieldLabelString, TcType)]
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.
        WarnReason -> Bool -> SDoc -> TcRn ()
warnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingFields) Bool
True
             (ConLike -> [(FieldLabelString, TcType)] -> SDoc
missingFields ConLike
con_like [(FieldLabelString, TcType)]
fs)

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

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

    field_info :: [(FieldLabel, HsImplBang, Scaled TcType)]
field_info = [FieldLabel]
-> [HsImplBang]
-> [Scaled TcType]
-> [(FieldLabel, HsImplBang, Scaled TcType)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [FieldLabel]
field_labels [HsImplBang]
field_strs [Scaled TcType]
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
text String
"In the" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (FieldLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FieldLabelString
field_name) SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"field of a record")

badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc
badFieldTypes :: [(FieldLabelString, TcType)] -> SDoc
badFieldTypes [(FieldLabelString, TcType)]
prs
  = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Record update for insufficiently polymorphic field"
                         SDoc -> SDoc -> SDoc
<> [(FieldLabelString, TcType)] -> SDoc
forall a. [a] -> SDoc
plural [(FieldLabelString, TcType)]
prs SDoc -> SDoc -> SDoc
<> SDoc
colon)
       Int
2 ([SDoc] -> SDoc
vcat [ FieldLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FieldLabelString
f SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty | (FieldLabelString
f,TcType
ty) <- [(FieldLabelString, TcType)]
prs ])

badFieldsUpd
  :: [LHsRecField' GhcTc (AmbiguousFieldOcc 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
  -> SDoc
badFieldsUpd :: [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike] -> SDoc
badFieldsUpd [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds [ConLike]
data_cons
  = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"No constructor has all these fields:")
       Int
2 ([FieldLabelString] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [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.
            ([(FieldLabelString, [Bool])] -> FieldLabelString)
-> [[(FieldLabelString, [Bool])]] -> [FieldLabelString]
forall a b. (a -> b) -> [a] -> [b]
map ((FieldLabelString, [Bool]) -> FieldLabelString
forall a b. (a, b) -> a
fst ((FieldLabelString, [Bool]) -> FieldLabelString)
-> ([(FieldLabelString, [Bool])] -> (FieldLabelString, [Bool]))
-> [(FieldLabelString, [Bool])]
-> FieldLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FieldLabelString, [Bool])] -> (FieldLabelString, [Bool])
forall a. [a] -> a
head) ([[(FieldLabelString, [Bool])]] -> [FieldLabelString])
-> [[(FieldLabelString, [Bool])]] -> [FieldLabelString]
forall a b. (a -> b) -> a -> b
$ ((FieldLabelString, [Bool]) -> (FieldLabelString, [Bool]) -> Bool)
-> [(FieldLabelString, [Bool])] -> [[(FieldLabelString, [Bool])]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ([Bool] -> [Bool] -> Bool
forall a. Eq a => a -> a -> Bool
(==) ([Bool] -> [Bool] -> Bool)
-> ((FieldLabelString, [Bool]) -> [Bool])
-> (FieldLabelString, [Bool])
-> (FieldLabelString, [Bool])
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (FieldLabelString, [Bool]) -> [Bool]
forall a b. (a, b) -> b
snd) [(FieldLabelString, [Bool])]
growingSets

    aMember :: FieldLabelString
aMember = ASSERT( not (null members) ) fst (head 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
   (HsRecField'
      (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
 -> FieldLabelString)
-> [GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> [FieldLabelString]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> FieldLabelString
occNameFS (OccName -> FieldLabelString)
-> (GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
    -> OccName)
-> GenLocated
     SrcSpanAnnA
     (HsRecField'
        (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> FieldLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> OccName)
-> (GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
    -> RdrName)
-> GenLocated
     SrcSpanAnnA
     (HsRecField'
        (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (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
      (HsRecField'
         (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
    -> AmbiguousFieldOcc GhcTc)
-> GenLocated
     SrcSpanAnnA
     (HsRecField'
        (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
-> AmbiguousFieldOcc GhcTc
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
 -> AmbiguousFieldOcc GhcTc)
-> (GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
    -> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
-> GenLocated
     SrcSpanAnnA
     (HsRecField'
        (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> AmbiguousFieldOcc GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecField'
  (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (HsRecField'
   (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
 -> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
-> (GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
    -> HsRecField'
         (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> GenLocated
     SrcSpanAnnA
     (HsRecField'
        (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  SrcSpanAnnA
  (HsRecField'
     (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> HsRecField'
     (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc) [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
[LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr 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] -> SDoc
mixedSelectors :: [Var] -> [Var] -> SDoc
mixedSelectors data_sels :: [Var]
data_sels@(Var
dc_rep_id:[Var]
_) pat_syn_sels :: [Var]
pat_syn_sels@(Var
ps_rep_id:[Var]
_)
  = PtrString -> SDoc
ptext
      (String -> PtrString
sLit String
"Cannot use a mixture of pattern synonym and record selectors") SDoc -> SDoc -> SDoc
$$
    String -> SDoc
text String
"Record selectors defined by"
      SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Name
tyConName TyCon
rep_dc))
      SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
":"
      SDoc -> SDoc -> SDoc
<+> (Var -> SDoc) -> [Var] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
data_sels SDoc -> SDoc -> SDoc
$$
    String -> SDoc
text String
"Pattern synonym selectors defined by"
      SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (PatSyn -> Name
patSynName PatSyn
rep_ps))
      SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
":"
      SDoc -> SDoc -> SDoc
<+> (Var -> SDoc) -> [Var] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
pat_syn_sels
  where
    RecSelPatSyn PatSyn
rep_ps = Var -> RecSelParent
recordSelectorTyCon Var
ps_rep_id
    RecSelData TyCon
rep_dc = Var -> RecSelParent
recordSelectorTyCon Var
dc_rep_id
mixedSelectors [Var]
_ [Var]
_ = String -> SDoc
forall a. String -> a
panic String
"GHC.Tc.Gen.Expr: mixedSelectors emptylists"


missingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc
missingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc
missingStrictFields ConLike
con [(FieldLabelString, TcType)]
fields
  = [SDoc] -> SDoc
vcat [SDoc
header, Int -> SDoc -> SDoc
nest Int
2 SDoc
rest]
  where
    pprField :: (a, a) -> SDoc
pprField (a
f,a
ty) = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
f SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
ty
    rest :: SDoc
rest | [(FieldLabelString, TcType)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, TcType)]
fields = SDoc
Outputable.empty  -- Happens for non-record constructors
                                           -- with strict fields
         | Bool
otherwise   = [SDoc] -> SDoc
vcat (((FieldLabelString, TcType) -> SDoc)
-> [(FieldLabelString, TcType)] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldLabelString, TcType) -> SDoc
forall {a} {a}. (Outputable a, Outputable a) => (a, a) -> SDoc
pprField [(FieldLabelString, TcType)]
fields)

    header :: SDoc
header = String -> SDoc
text String
"Constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
con) SDoc -> SDoc -> SDoc
<+>
             String -> SDoc
text String
"does not have the required strict field(s)" SDoc -> SDoc -> SDoc
<>
             if [(FieldLabelString, TcType)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, TcType)]
fields then SDoc
Outputable.empty else SDoc
colon

missingFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc
missingFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc
missingFields ConLike
con [(FieldLabelString, TcType)]
fields
  = [SDoc] -> SDoc
vcat [SDoc
header, Int -> SDoc -> SDoc
nest Int
2 SDoc
rest]
  where
    pprField :: (a, a) -> SDoc
pprField (a
f,a
ty) = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
f SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
ty
    rest :: SDoc
rest | [(FieldLabelString, TcType)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, TcType)]
fields = SDoc
Outputable.empty
         | Bool
otherwise   = [SDoc] -> SDoc
vcat (((FieldLabelString, TcType) -> SDoc)
-> [(FieldLabelString, TcType)] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldLabelString, TcType) -> SDoc
forall {a} {a}. (Outputable a, Outputable a) => (a, a) -> SDoc
pprField [(FieldLabelString, TcType)]
fields)
    header :: SDoc
header = String -> SDoc
text String
"Fields of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
con) SDoc -> SDoc -> SDoc
<+>
             String -> SDoc
text String
"not initialised" SDoc -> SDoc -> SDoc
<>
             if [(FieldLabelString, TcType)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, TcType)]
fields then SDoc
Outputable.empty else SDoc
colon

-- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args))

noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc
noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc
noPossibleParents [LHsRecUpdField GhcRn]
rbinds
  = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"No type has all these fields:")
       Int
2 ([Located (AmbiguousFieldOcc GhcRn)] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [Located (AmbiguousFieldOcc GhcRn)]
fields)
  where
    fields :: [Located (AmbiguousFieldOcc GhcRn)]
fields = (GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
 -> Located (AmbiguousFieldOcc GhcRn))
-> [GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> [Located (AmbiguousFieldOcc GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (HsRecField'
  (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> Located (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (HsRecField'
   (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
 -> Located (AmbiguousFieldOcc GhcRn))
-> (GenLocated
      SrcSpanAnnA
      (HsRecField'
         (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
    -> HsRecField'
         (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> GenLocated
     SrcSpanAnnA
     (HsRecField'
        (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> Located (AmbiguousFieldOcc GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  SrcSpanAnnA
  (HsRecField'
     (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> HsRecField'
     (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc) [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
[LHsRecUpdField GhcRn]
rbinds

badOverloadedUpdate :: SDoc
badOverloadedUpdate :: SDoc
badOverloadedUpdate = String -> SDoc
text String
"Record update is ambiguous, and requires a type signature"

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

-- | A data type to describe why a variable is not closed.
data NotClosedReason = NotLetBoundReason
                     | NotTypeClosed VarSet
                     | NotClosed Name NotClosedReason

-- | 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 (m :: * -> *) a. Monad m => a -> m a
return ()
      Just NotClosedReason
reason -> SDoc -> TcRn ()
addErrTc (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Name -> NotClosedReason -> SDoc
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 -> Var
tct_id = Var
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
$ TcType -> VarSet
tyCoVarsOfType (Var -> TcType
idType Var
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 -> SDoc
    explain :: Name -> NotClosedReason -> SDoc
explain Name
name NotClosedReason
reason =
      SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is used in a static form but it is not closed"
                        SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"because it"
                        SDoc -> SDoc -> SDoc
$$
                        [SDoc] -> SDoc
sep (NotClosedReason -> [SDoc]
causes NotClosedReason
reason)

    causes :: NotClosedReason -> [SDoc]
    causes :: NotClosedReason -> [SDoc]
causes NotClosedReason
NotLetBoundReason = [String -> SDoc
text String
"is not let-bound."]
    causes (NotTypeClosed VarSet
vs) =
      [ String -> SDoc
text String
"has a non-closed type because it contains the"
      , String -> SDoc
text String
"type variables:" SDoc -> SDoc -> SDoc
<+>
        VarSet -> ([Var] -> SDoc) -> SDoc
pprVarSet VarSet
vs ([SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> ([Var] -> [SDoc]) -> [Var] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> [SDoc]) -> ([Var] -> [SDoc]) -> [Var] -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var -> SDoc) -> [Var] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> SDoc
quotes (SDoc -> SDoc) -> (Var -> SDoc) -> Var -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr))
      ]
    causes (NotClosed Name
n NotClosedReason
reason) =
      let msg :: SDoc
msg = String -> SDoc
text String
"uses" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"which"
       in case NotClosedReason
reason of
            NotClosed Name
_ NotClosedReason
_ -> SDoc
msg SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: NotClosedReason -> [SDoc]
causes NotClosedReason
reason
            NotClosedReason
_   -> let ([SDoc]
xs0, [SDoc]
xs1) = Int -> [SDoc] -> ([SDoc], [SDoc])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
1 ([SDoc] -> ([SDoc], [SDoc])) -> [SDoc] -> ([SDoc], [SDoc])
forall a b. (a -> b) -> a -> b
$ NotClosedReason -> [SDoc]
causes NotClosedReason
reason
                    in (SDoc -> SDoc) -> [SDoc] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SDoc
msg SDoc -> SDoc -> SDoc
<+>) [SDoc]
xs0 [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
xs1

-- 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.
--