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

\section[TcExpr]{Typecheck an expression}
-}

{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}

module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC,
                tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC,
                tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
                tcCheckId,
                addExprErrCtxt,
                getFixedTyVars ) where

#include "HsVersions.h"

import GhcPrelude

import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
import THNames( liftStringName, liftName )

import HsSyn
import TcHsSyn
import TcRnMonad
import TcUnify
import BasicTypes
import Inst
import TcBinds          ( chooseInferredQuantifiers, tcLocalBinds )
import TcSigs           ( tcUserTypeSig, tcInstSig )
import TcSimplify       ( simplifyInfer, InferMode(..) )
import FamInst          ( tcGetFamInstEnvs, tcLookupDataFamInst )
import FamInstEnv       ( FamInstEnvs )
import RnEnv            ( addUsedGRE )
import RnUtils          ( addNameClashErrRn, unknownSubordinateErr )
import TcEnv
import TcArrows
import TcMatches
import TcHsType
import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr )
import TcPat
import TcMType
import TcType
import Id
import IdInfo
import ConLike
import DataCon
import PatSyn
import Name
import NameEnv
import NameSet
import RdrName
import TyCon
import TyCoRep
import Type
import TcEvidence
import VarSet
import MkId( seqId )
import TysWiredIn
import TysPrim( intPrimTy, mkTemplateTyVars, tYPE )
import PrimOp( tagToEnumKey )
import PrelNames
import DynFlags
import SrcLoc
import Util
import VarEnv  ( emptyTidyEnv, mkInScopeSet )
import ListSetOps
import Maybes
import Outputable
import FastString
import Control.Monad
import Class(classTyCon)
import UniqSet ( nonDetEltsUniqSet )
import qualified GHC.LanguageExtensions as LangExt

import Data.Function
import Data.List
import qualified Data.Set as Set

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

tcPolyExpr, tcPolyExprNC
  :: LHsExpr GhcRn         -- Expression to type check
  -> TcSigmaType           -- Expected type (could be a polytype)
  -> TcM (LHsExpr GhcTcId) -- Generalised expr with expected type

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

tcPolyExpr :: LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr   expr :: LHsExpr GhcRn
expr res_ty :: TcSigmaType
res_ty = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tc_poly_expr LHsExpr GhcRn
expr (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
res_ty)
tcPolyExprNC :: LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExprNC expr :: LHsExpr GhcRn
expr res_ty :: TcSigmaType
res_ty = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tc_poly_expr_nc LHsExpr GhcRn
expr (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
res_ty)

-- these versions take an ExpType
tc_poly_expr, tc_poly_expr_nc :: LHsExpr GhcRn -> ExpSigmaType
                              -> TcM (LHsExpr GhcTcId)
tc_poly_expr :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tc_poly_expr expr :: LHsExpr GhcRn
expr res_ty :: ExpSigmaType
res_ty
  = LHsExpr GhcRn -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a. LHsExpr GhcRn -> TcM a -> TcM a
addExprErrCtxt LHsExpr GhcRn
expr (TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
    do { String -> SDoc -> TcRn ()
traceTc "tcPolyExpr" (ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
res_ty); LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tc_poly_expr_nc LHsExpr GhcRn
expr ExpSigmaType
res_ty }

tc_poly_expr_nc :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tc_poly_expr_nc (L loc :: SrcSpan
loc expr :: HsExpr GhcRn
expr) res_ty :: ExpSigmaType
res_ty
  = SrcSpan -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
    do { String -> SDoc -> TcRn ()
traceTc "tcPolyExprNC" (ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
res_ty)
       ; (wrap :: HsWrapper
wrap, expr' :: HsExpr GhcTcId
expr')
           <- UserTypeCtxt
-> ExpSigmaType
-> (ExpSigmaType -> TcM (HsExpr GhcTcId))
-> TcM (HsWrapper, HsExpr GhcTcId)
forall result.
UserTypeCtxt
-> ExpSigmaType
-> (ExpSigmaType -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemiseET UserTypeCtxt
GenSigCtxt ExpSigmaType
res_ty ((ExpSigmaType -> TcM (HsExpr GhcTcId))
 -> TcM (HsWrapper, HsExpr GhcTcId))
-> (ExpSigmaType -> TcM (HsExpr GhcTcId))
-> TcM (HsWrapper, HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ \ res_ty :: ExpSigmaType
res_ty ->
              HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcExpr HsExpr GhcRn
expr ExpSigmaType
res_ty
       ; LHsExpr GhcTcId -> TcM (LHsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcTcId -> TcM (LHsExpr GhcTcId))
-> LHsExpr GhcTcId -> TcM (LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap HsExpr GhcTcId
expr') }

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

tcMonoExpr :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr expr :: LHsExpr GhcRn
expr res_ty :: ExpSigmaType
res_ty
  = SDoc -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsExpr GhcRn -> SDoc
exprCtxt LHsExpr GhcRn
expr) (TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
    LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC LHsExpr GhcRn
expr ExpSigmaType
res_ty

tcMonoExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC (L loc :: SrcSpan
loc expr :: HsExpr GhcRn
expr) res_ty :: ExpSigmaType
res_ty
  = SrcSpan -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
    do  { HsExpr GhcTcId
expr' <- HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcExpr HsExpr GhcRn
expr ExpSigmaType
res_ty
        ; LHsExpr GhcTcId -> TcM (LHsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsExpr GhcTcId
expr') }

---------------
tcInferSigma, tcInferSigmaNC :: LHsExpr GhcRn -> TcM ( LHsExpr GhcTcId
                                                    , TcSigmaType )
-- Infer a *sigma*-type.
tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferSigma expr :: LHsExpr GhcRn
expr = SDoc
-> TcM (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsExpr GhcRn -> SDoc
exprCtxt LHsExpr GhcRn
expr) (LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferSigmaNC LHsExpr GhcRn
expr)

tcInferSigmaNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferSigmaNC (L loc :: SrcSpan
loc expr :: HsExpr GhcRn
expr)
  = SrcSpan
-> TcM (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTcId, TcSigmaType)
 -> TcM (LHsExpr GhcTcId, TcSigmaType))
-> TcM (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall a b. (a -> b) -> a -> b
$
    do { (expr' :: HsExpr GhcTcId
expr', sigma :: TcSigmaType
sigma) <- (ExpSigmaType -> TcM (HsExpr GhcTcId))
-> TcM (HsExpr GhcTcId, TcSigmaType)
forall a. (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
tcInferNoInst (HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcExpr HsExpr GhcRn
expr)
       ; (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsExpr GhcTcId
expr', TcSigmaType
sigma) }

tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcRhoType)
-- Infer a *rho*-type. The return type is always (shallowly) instantiated.
tcInferRho :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferRho expr :: LHsExpr GhcRn
expr = SDoc
-> TcM (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsExpr GhcRn -> SDoc
exprCtxt LHsExpr GhcRn
expr) (LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferRhoNC LHsExpr GhcRn
expr)

tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferRhoNC expr :: LHsExpr GhcRn
expr
  = do { (expr' :: LHsExpr GhcTcId
expr', sigma :: TcSigmaType
sigma) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferSigmaNC LHsExpr GhcRn
expr
       ; (wrap :: HsWrapper
wrap, rho :: TcSigmaType
rho) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate (LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
expr) TcSigmaType
sigma
       ; (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
wrap LHsExpr GhcTcId
expr', TcSigmaType
rho) }


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

NB: The res_ty is always deeply skolemised.
-}

tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
tcExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcExpr (HsVar _ (L _ name :: IdP GhcRn
name))   res_ty :: ExpSigmaType
res_ty = Name -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcCheckId Name
IdP GhcRn
name ExpSigmaType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsUnboundVar _ uv :: UnboundVar
uv)  res_ty :: ExpSigmaType
res_ty = HsExpr GhcRn -> UnboundVar -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcUnboundId HsExpr GhcRn
e UnboundVar
uv ExpSigmaType
res_ty

tcExpr e :: HsExpr GhcRn
e@(HsApp {})     res_ty :: ExpSigmaType
res_ty = HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcApp1 HsExpr GhcRn
e ExpSigmaType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsAppType {}) res_ty :: ExpSigmaType
res_ty = HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcApp1 HsExpr GhcRn
e ExpSigmaType
res_ty

tcExpr e :: HsExpr GhcRn
e@(HsLit x :: XLitE GhcRn
x lit :: HsLit GhcRn
lit) res_ty :: ExpSigmaType
res_ty
  = do { let lit_ty :: TcSigmaType
lit_ty = HsLit GhcRn -> TcSigmaType
forall (p :: Pass). HsLit (GhcPass p) -> TcSigmaType
hsLitType HsLit GhcRn
lit
       ; HsExpr GhcRn
-> HsExpr GhcTcId
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
tcWrapResult HsExpr GhcRn
e (XLitE GhcTcId -> HsLit GhcTcId -> HsExpr GhcTcId
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcRn
XLitE GhcTcId
x (HsLit GhcRn -> HsLit GhcTcId
forall a b. ConvertIdX a b => HsLit a -> HsLit b
convertLit HsLit GhcRn
lit)) TcSigmaType
lit_ty ExpSigmaType
res_ty }

tcExpr (HsPar x :: XPar GhcRn
x expr :: LHsExpr GhcRn
expr) res_ty :: ExpSigmaType
res_ty = do { LHsExpr GhcTcId
expr' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC LHsExpr GhcRn
expr ExpSigmaType
res_ty
                                  ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XPar GhcTcId -> LHsExpr GhcTcId -> HsExpr GhcTcId
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcRn
XPar GhcTcId
x LHsExpr GhcTcId
expr') }

tcExpr (HsSCC x :: XSCC GhcRn
x src :: SourceText
src lbl :: StringLiteral
lbl expr :: LHsExpr GhcRn
expr) res_ty :: ExpSigmaType
res_ty
  = do { LHsExpr GhcTcId
expr' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
expr ExpSigmaType
res_ty
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XSCC GhcTcId
-> SourceText -> StringLiteral -> LHsExpr GhcTcId -> HsExpr GhcTcId
forall p.
XSCC p -> SourceText -> StringLiteral -> LHsExpr p -> HsExpr p
HsSCC XSCC GhcRn
XSCC GhcTcId
x SourceText
src StringLiteral
lbl LHsExpr GhcTcId
expr') }

tcExpr (HsTickPragma x :: XTickPragma GhcRn
x src :: SourceText
src info :: (StringLiteral, (Int, Int), (Int, Int))
info srcInfo :: ((SourceText, SourceText), (SourceText, SourceText))
srcInfo expr :: LHsExpr GhcRn
expr) res_ty :: ExpSigmaType
res_ty
  = do { LHsExpr GhcTcId
expr' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
expr ExpSigmaType
res_ty
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XTickPragma GhcTcId
-> SourceText
-> (StringLiteral, (Int, Int), (Int, Int))
-> ((SourceText, SourceText), (SourceText, SourceText))
-> LHsExpr GhcTcId
-> HsExpr GhcTcId
forall p.
XTickPragma p
-> SourceText
-> (StringLiteral, (Int, Int), (Int, Int))
-> ((SourceText, SourceText), (SourceText, SourceText))
-> LHsExpr p
-> HsExpr p
HsTickPragma XTickPragma GhcRn
XTickPragma GhcTcId
x SourceText
src (StringLiteral, (Int, Int), (Int, Int))
info ((SourceText, SourceText), (SourceText, SourceText))
srcInfo LHsExpr GhcTcId
expr') }

tcExpr (HsCoreAnn x :: XCoreAnn GhcRn
x src :: SourceText
src lbl :: StringLiteral
lbl expr :: LHsExpr GhcRn
expr) res_ty :: ExpSigmaType
res_ty
  = do  { LHsExpr GhcTcId
expr' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
expr ExpSigmaType
res_ty
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCoreAnn GhcTcId
-> SourceText -> StringLiteral -> LHsExpr GhcTcId -> HsExpr GhcTcId
forall p.
XCoreAnn p -> SourceText -> StringLiteral -> LHsExpr p -> HsExpr p
HsCoreAnn XCoreAnn GhcRn
XCoreAnn GhcTcId
x SourceText
src StringLiteral
lbl LHsExpr GhcTcId
expr') }

tcExpr (HsOverLit x :: XOverLitE GhcRn
x lit :: HsOverLit GhcRn
lit) res_ty :: ExpSigmaType
res_ty
  = do  { HsOverLit GhcTcId
lit' <- HsOverLit GhcRn -> ExpSigmaType -> TcM (HsOverLit GhcTcId)
newOverloadedLit HsOverLit GhcRn
lit ExpSigmaType
res_ty
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XOverLitE GhcTcId -> HsOverLit GhcTcId -> HsExpr GhcTcId
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcRn
XOverLitE GhcTcId
x HsOverLit GhcTcId
lit') }

tcExpr (NegApp x :: XNegApp GhcRn
x expr :: LHsExpr GhcRn
expr neg_expr :: SyntaxExpr GhcRn
neg_expr) res_ty :: ExpSigmaType
res_ty
  = do  { (expr' :: LHsExpr GhcTcId
expr', neg_expr' :: SyntaxExpr GhcTcId
neg_expr')
            <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId, SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
NegateOrigin SyntaxExpr GhcRn
neg_expr [SyntaxOpType
SynAny] ExpSigmaType
res_ty (([TcSigmaType] -> TcM (LHsExpr GhcTcId))
 -> TcM (LHsExpr GhcTcId, SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId, SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
               \[arg_ty :: TcSigmaType
arg_ty] ->
               LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
expr (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
arg_ty)
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XNegApp GhcTcId
-> LHsExpr GhcTcId -> SyntaxExpr GhcTcId -> HsExpr GhcTcId
forall p. XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p
NegApp XNegApp GhcRn
XNegApp GhcTcId
x LHsExpr GhcTcId
expr' SyntaxExpr GhcTcId
neg_expr') }

tcExpr e :: HsExpr GhcRn
e@(HsIPVar _ x :: HsIPName
x) res_ty :: ExpSigmaType
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.) -}
         TcSigmaType
ip_ty <- TcM TcSigmaType
newOpenFlexiTyVarTy
       ; let ip_name :: TcSigmaType
ip_name = FastString -> TcSigmaType
mkStrLitTy (HsIPName -> FastString
hsIPNameFS HsIPName
x)
       ; Class
ipClass <- Name -> TcM Class
tcLookupClass Name
ipClassName
       ; EvVar
ip_var <- CtOrigin -> TcSigmaType -> TcM EvVar
emitWantedEvVar CtOrigin
origin (Class -> [TcSigmaType] -> TcSigmaType
mkClassPred Class
ipClass [TcSigmaType
ip_name, TcSigmaType
ip_ty])
       ; HsExpr GhcRn
-> HsExpr GhcTcId
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
tcWrapResult HsExpr GhcRn
e
                   (Class
-> TcSigmaType -> TcSigmaType -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
Class
-> TcSigmaType
-> TcSigmaType
-> HsExpr (GhcPass id)
-> HsExpr (GhcPass id)
fromDict Class
ipClass TcSigmaType
ip_name TcSigmaType
ip_ty (XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExt
noExt (SrcSpanLess (Located EvVar) -> Located EvVar
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located EvVar)
EvVar
ip_var)))
                   TcSigmaType
ip_ty ExpSigmaType
res_ty }
  where
  -- Coerces a dictionary for `IP "x" t` into `t`.
  fromDict :: Class
-> TcSigmaType
-> TcSigmaType
-> HsExpr (GhcPass id)
-> HsExpr (GhcPass id)
fromDict ipClass :: Class
ipClass x :: TcSigmaType
x ty :: TcSigmaType
ty = HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap (HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id))
-> HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsWrapper
mkWpCastR (TcCoercionR -> HsWrapper) -> TcCoercionR -> HsWrapper
forall a b. (a -> b) -> a -> b
$
                          TcSigmaType -> TcCoercionR
unwrapIP (TcSigmaType -> TcCoercionR) -> TcSigmaType -> TcCoercionR
forall a b. (a -> b) -> a -> b
$ Class -> [TcSigmaType] -> TcSigmaType
mkClassPred Class
ipClass [TcSigmaType
x,TcSigmaType
ty]
  origin :: CtOrigin
origin = HsIPName -> CtOrigin
IPOccOrigin HsIPName
x

tcExpr e :: HsExpr GhcRn
e@(HsOverLabel _ mb_fromLabel :: Maybe (IdP GhcRn)
mb_fromLabel l :: FastString
l) res_ty :: ExpSigmaType
res_ty
  = do { -- See Note [Type-checking overloaded labels]
         SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
       ; case Maybe (IdP GhcRn)
mb_fromLabel of
           Just fromLabel :: IdP GhcRn
fromLabel -> HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcExpr (SrcSpan -> Name -> HsExpr GhcRn
applyFromLabel SrcSpan
loc Name
IdP GhcRn
fromLabel) ExpSigmaType
res_ty
           Nothing -> do { Class
isLabelClass <- Name -> TcM Class
tcLookupClass Name
isLabelClassName
                         ; TcSigmaType
alpha <- TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind
                         ; let pred :: TcSigmaType
pred = Class -> [TcSigmaType] -> TcSigmaType
mkClassPred Class
isLabelClass [TcSigmaType
lbl, TcSigmaType
alpha]
                         ; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
                         ; EvVar
var <- CtOrigin -> TcSigmaType -> TcM EvVar
emitWantedEvVar CtOrigin
origin TcSigmaType
pred
                         ; HsExpr GhcRn
-> HsExpr GhcTcId
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
tcWrapResult HsExpr GhcRn
e
                                       (TcSigmaType -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
TcSigmaType -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
fromDict TcSigmaType
pred (XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExt
noExt (SrcSpan -> EvVar -> Located EvVar
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc EvVar
var)))
                                        TcSigmaType
alpha ExpSigmaType
res_ty } }
  where
  -- Coerces a dictionary for `IsLabel "x" t` into `t`,
  -- or `HasField "x" r a into `r -> a`.
  fromDict :: TcSigmaType -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
fromDict pred :: TcSigmaType
pred = HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap (HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id))
-> HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsWrapper
mkWpCastR (TcCoercionR -> HsWrapper) -> TcCoercionR -> HsWrapper
forall a b. (a -> b) -> a -> b
$ TcSigmaType -> TcCoercionR
unwrapIP TcSigmaType
pred
  origin :: CtOrigin
origin = FastString -> CtOrigin
OverLabelOrigin FastString
l
  lbl :: TcSigmaType
lbl = FastString -> TcSigmaType
mkStrLitTy FastString
l

  applyFromLabel :: SrcSpan -> Name -> HsExpr GhcRn
applyFromLabel loc :: SrcSpan
loc fromLabel :: Name
fromLabel =
    XAppTypeE GhcRn
-> LHsExpr GhcRn -> LHsWcType (NoGhcTc GhcRn) -> HsExpr GhcRn
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE GhcRn
NoExt
noExt
         (SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XVar GhcRn -> GenLocated SrcSpan (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcRn
NoExt
noExt (SrcSpan -> Name -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Name
fromLabel)))
         (GenLocated SrcSpan (HsType GhcRn)
-> HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
forall thing. thing -> HsWildCardBndrs GhcRn thing
mkEmptyWildCardBndrs (SrcSpan -> HsType GhcRn -> GenLocated SrcSpan (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XTyLit GhcRn -> HsTyLit -> HsType GhcRn
forall pass. XTyLit pass -> HsTyLit -> HsType pass
HsTyLit XTyLit GhcRn
NoExt
noExt (SourceText -> FastString -> HsTyLit
HsStrTy SourceText
NoSourceText FastString
l))))

tcExpr (HsLam x :: XLam GhcRn
x match :: MatchGroup GhcRn (LHsExpr GhcRn)
match) res_ty :: ExpSigmaType
res_ty
  = do  { (match' :: MatchGroup GhcTcId (LHsExpr GhcTcId)
match', wrap :: HsWrapper
wrap) <- SDoc
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
tcMatchLambda SDoc
herald TcMatchCtxt HsExpr
match_ctxt MatchGroup GhcRn (LHsExpr GhcRn)
match ExpSigmaType
res_ty
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (XLam GhcTcId
-> MatchGroup GhcTcId (LHsExpr GhcTcId) -> HsExpr GhcTcId
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcRn
XLam GhcTcId
x MatchGroup GhcTcId (LHsExpr GhcTcId)
match')) }
  where
    match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext Name
-> (Located (body GhcRn)
    -> ExpSigmaType -> TcM (Located (body GhcTcId)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext Name
mc_what = HsMatchContext Name
forall id. HsMatchContext id
LambdaExpr, mc_body :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
mc_body = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcBody }
    herald :: SDoc
herald = [SDoc] -> SDoc
sep [ String -> SDoc
text "The lambda expression" SDoc -> SDoc -> SDoc
<+>
                   SDoc -> SDoc
quotes (Depth -> SDoc -> SDoc
pprSetDepth (Int -> Depth
PartWay 1) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                           MatchGroup GhcRn (LHsExpr GhcRn) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId (GhcPass idR), Outputable body) =>
MatchGroup (GhcPass idR) body -> SDoc
pprMatches MatchGroup GhcRn (LHsExpr GhcRn)
match),
                        -- The pprSetDepth makes the abstraction print briefly
                   String -> SDoc
text "has"]

tcExpr e :: HsExpr GhcRn
e@(HsLamCase x :: XLamCase GhcRn
x matches :: MatchGroup GhcRn (LHsExpr GhcRn)
matches) res_ty :: ExpSigmaType
res_ty
  = do { (matches' :: MatchGroup GhcTcId (LHsExpr GhcTcId)
matches', wrap :: HsWrapper
wrap)
           <- SDoc
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
tcMatchLambda SDoc
msg TcMatchCtxt HsExpr
match_ctxt MatchGroup GhcRn (LHsExpr GhcRn)
matches ExpSigmaType
res_ty
           -- The laziness annotation is because we don't want to fail here
           -- if there are multiple arguments
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$ XLamCase GhcTcId
-> MatchGroup GhcTcId (LHsExpr GhcTcId) -> HsExpr GhcTcId
forall p. XLamCase p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase XLamCase GhcRn
XLamCase GhcTcId
x MatchGroup GhcTcId (LHsExpr GhcTcId)
matches') }
  where
    msg :: SDoc
msg = [SDoc] -> SDoc
sep [ String -> SDoc
text "The function" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e)
              , String -> SDoc
text "requires"]
    match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext Name
-> (Located (body GhcRn)
    -> ExpSigmaType -> TcM (Located (body GhcTcId)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext Name
mc_what = HsMatchContext Name
forall id. HsMatchContext id
CaseAlt, mc_body :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
mc_body = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcBody }

tcExpr e :: HsExpr GhcRn
e@(ExprWithTySig _ expr :: LHsExpr GhcRn
expr sig_ty :: LHsSigWcType (NoGhcTc GhcRn)
sig_ty) res_ty :: ExpSigmaType
res_ty
  = do { let loc :: SrcSpan
loc = GenLocated SrcSpan (HsType GhcRn) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LHsSigWcType GhcRn -> GenLocated SrcSpan (HsType GhcRn)
forall pass. LHsSigWcType pass -> LHsType pass
hsSigWcType LHsSigWcType (NoGhcTc GhcRn)
LHsSigWcType GhcRn
sig_ty)
       ; TcIdSigInfo
sig_info <- TcM TcIdSigInfo -> TcM TcIdSigInfo
forall r. TcM r -> TcM r
checkNoErrs (TcM TcIdSigInfo -> TcM TcIdSigInfo)
-> TcM TcIdSigInfo -> TcM TcIdSigInfo
forall a b. (a -> b) -> a -> b
$  -- Avoid error cascade
                     SrcSpan -> LHsSigWcType GhcRn -> Maybe Name -> TcM TcIdSigInfo
tcUserTypeSig SrcSpan
loc LHsSigWcType (NoGhcTc GhcRn)
LHsSigWcType GhcRn
sig_ty Maybe Name
forall a. Maybe a
Nothing
       ; (expr' :: LHsExpr GhcTcId
expr', poly_ty :: TcSigmaType
poly_ty) <- LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcExprSig LHsExpr GhcRn
expr TcIdSigInfo
sig_info
       ; let expr'' :: HsExpr GhcTcId
expr'' = XExprWithTySig GhcTcId
-> LHsExpr GhcTcId
-> LHsSigWcType (NoGhcTc GhcTcId)
-> HsExpr GhcTcId
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig XExprWithTySig GhcTcId
NoExt
noExt LHsExpr GhcTcId
expr' LHsSigWcType (NoGhcTc GhcRn)
LHsSigWcType (NoGhcTc GhcTcId)
sig_ty
       ; HsExpr GhcRn
-> HsExpr GhcTcId
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
tcWrapResult HsExpr GhcRn
e HsExpr GhcTcId
expr'' TcSigmaType
poly_ty ExpSigmaType
res_ty }

{-
Note [Type-checking overloaded labels]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Recall that we have

  module GHC.OverloadedLabels where
    class IsLabel (x :: Symbol) a where
      fromLabel :: a

We translate `#foo` to `fromLabel @"foo"`, where we use

 * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not
 * `GHC.OverloadedLabels.fromLabel`.

In the `RebindableSyntax` case, the renamer will have filled in the
first field of `HsOverLabel` with the `fromLabel` function to use, and
we simply apply it to the appropriate visible type argument.

In the `OverloadedLabels` case, when we see an overloaded label like
`#foo`, we generate a fresh variable `alpha` for the type and emit an
`IsLabel "foo" alpha` constraint.  Because the `IsLabel` class has a
single method, it is represented by a newtype, so we can coerce
`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters).

-}


{-
************************************************************************
*                                                                      *
                Infix operators and sections
*                                                                      *
************************************************************************

Note [Left sections]
~~~~~~~~~~~~~~~~~~~~
Left sections, like (4 *), are equivalent to
        \ x -> (*) 4 x,
or, if PostfixOperators is enabled, just
        (*) 4
With PostfixOperators we don't actually require the function to take
two arguments at all.  For example, (x `not`) means (not x); you get
postfix operators!  Not Haskell 98, but it's less work and kind of
useful.

Note [Typing rule for ($)]
~~~~~~~~~~~~~~~~~~~~~~~~~~
People write
   runST $ blah
so much, where
   runST :: (forall s. ST s a) -> a
that I have finally given in and written a special type-checking
rule just for saturated applications of ($).
  * Infer the type of the first argument
  * Decompose it; should be of form (arg2_ty -> res_ty),
       where arg2_ty might be a polytype
  * Use arg2_ty to typecheck arg2

Note [Typing rule for seq]
~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to allow
       x `seq` (# p,q #)
which suggests this type for seq:
   seq :: forall (a:*) (b:Open). a -> b -> b,
with (b:Open) meaning that be can be instantiated with an unboxed
tuple.  The trouble is that this might accept a partially-applied
'seq', and I'm just not certain that would work.  I'm only sure it's
only going to work when it's fully applied, so it turns into
    case x of _ -> (# p,q #)

So it seems more uniform to treat 'seq' as if it was a language
construct.

See also Note [seqId magic] in MkId
-}

tcExpr expr :: HsExpr GhcRn
expr@(OpApp fix :: XOpApp GhcRn
fix arg1 :: LHsExpr GhcRn
arg1 op :: LHsExpr GhcRn
op arg2 :: LHsExpr GhcRn
arg2) res_ty :: ExpSigmaType
res_ty
  | (L loc :: SrcSpan
loc (HsVar _ (L lv :: SrcSpan
lv op_name :: IdP GhcRn
op_name))) <- LHsExpr GhcRn
op
  , Name
IdP GhcRn
op_name Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
seqIdKey           -- Note [Typing rule for seq]
  = do { TcSigmaType
arg1_ty <- TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind
       ; let arg2_exp_ty :: ExpSigmaType
arg2_exp_ty = ExpSigmaType
res_ty
       ; LHsExpr GhcTcId
arg1' <- LHsExpr GhcRn
-> LHsExpr GhcRn -> TcSigmaType -> Int -> TcM (LHsExpr GhcTcId)
tcArg LHsExpr GhcRn
op LHsExpr GhcRn
arg1 TcSigmaType
arg1_ty 1
       ; LHsExpr GhcTcId
arg2' <- SDoc -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsExpr GhcRn -> LHsExpr GhcRn -> Int -> SDoc
forall fun arg.
(Outputable fun, Outputable arg) =>
fun -> arg -> Int -> SDoc
funAppCtxt LHsExpr GhcRn
op LHsExpr GhcRn
arg2 2) (TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                  LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tc_poly_expr_nc LHsExpr GhcRn
arg2 ExpSigmaType
arg2_exp_ty
       ; TcSigmaType
arg2_ty <- ExpSigmaType -> TcM TcSigmaType
readExpType ExpSigmaType
arg2_exp_ty
       ; EvVar
op_id <- Name -> TcM EvVar
tcLookupId Name
IdP GhcRn
op_name
       ; let op' :: LHsExpr GhcTcId
op' = SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap ([TcSigmaType] -> HsWrapper
mkWpTyApps [TcSigmaType
arg1_ty, TcSigmaType
arg2_ty])
                                   (XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExt
noExt (SrcSpan -> EvVar -> Located EvVar
forall l e. l -> e -> GenLocated l e
L SrcSpan
lv EvVar
op_id)))
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ XOpApp GhcTcId
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> HsExpr GhcTcId
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcRn
XOpApp GhcTcId
fix LHsExpr GhcTcId
arg1' LHsExpr GhcTcId
op' LHsExpr GhcTcId
arg2' }

  | (L loc :: SrcSpan
loc (HsVar _ (L lv :: SrcSpan
lv op_name :: IdP GhcRn
op_name))) <- LHsExpr GhcRn
op
  , Name
IdP GhcRn
op_name Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
dollarIdKey        -- Note [Typing rule for ($)]
  = do { String -> SDoc -> TcRn ()
traceTc "Application rule" (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
op)
       ; (arg1' :: LHsExpr GhcTcId
arg1', arg1_ty :: TcSigmaType
arg1_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferSigma LHsExpr GhcRn
arg1

       ; let doc :: SDoc
doc   = String -> SDoc
text "The first argument of ($) takes"
             orig1 :: CtOrigin
orig1 = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
arg1
       ; (wrap_arg1 :: HsWrapper
wrap_arg1, [arg2_sigma :: TcSigmaType
arg2_sigma], op_res_ty :: TcSigmaType
op_res_ty) <-
           SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> Int
-> TcSigmaType
-> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
matchActualFunTys SDoc
doc CtOrigin
orig1 (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
arg1)) 1 TcSigmaType
arg1_ty

         -- We have (arg1 $ arg2)
         -- So: arg1_ty = arg2_ty -> op_res_ty
         -- where arg2_sigma maybe polymorphic; that's the point

       ; LHsExpr GhcTcId
arg2'  <- LHsExpr GhcRn
-> LHsExpr GhcRn -> TcSigmaType -> Int -> TcM (LHsExpr GhcTcId)
tcArg LHsExpr GhcRn
op LHsExpr GhcRn
arg2 TcSigmaType
arg2_sigma 2

       -- Make sure that the argument type has kind '*'
       --   ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b
       -- Eg we do not want to allow  (D#  $  4.0#)   Trac #5570
       --    (which gives a seg fault)
       --
       -- The *result* type can have any kind (Trac #8739),
       -- so we don't need to check anything for that
       ; TcCoercionR
_ <- Maybe (HsType GhcRn)
-> TcSigmaType -> TcSigmaType -> TcM TcCoercionR
unifyKind (HsType GhcRn -> Maybe (HsType GhcRn)
forall a. a -> Maybe a
Just (XXType GhcRn -> HsType GhcRn
forall pass. XXType pass -> HsType pass
XHsType (XXType GhcRn -> HsType GhcRn) -> XXType GhcRn -> HsType GhcRn
forall a b. (a -> b) -> a -> b
$ TcSigmaType -> NewHsTypeX
NHsCoreTy TcSigmaType
arg2_sigma))
                        (HasDebugCallStack => TcSigmaType -> TcSigmaType
TcSigmaType -> TcSigmaType
tcTypeKind TcSigmaType
arg2_sigma) TcSigmaType
liftedTypeKind
           -- ignore the evidence. arg2_sigma must have type * or #,
           -- because we know arg2_sigma -> or_res_ty is well-kinded
           -- (because otherwise matchActualFunTys would fail)
           -- There's no possibility here of, say, a kind family reducing to *.

       ; HsWrapper
wrap_res <- CtOrigin
-> Maybe (HsExpr GhcRn)
-> TcSigmaType
-> ExpSigmaType
-> TcM HsWrapper
tcSubTypeHR CtOrigin
orig1 (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
expr) TcSigmaType
op_res_ty ExpSigmaType
res_ty
                       -- op_res -> res

       ; EvVar
op_id  <- Name -> TcM EvVar
tcLookupId Name
IdP GhcRn
op_name
       ; TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
readExpType ExpSigmaType
res_ty
       ; let op' :: LHsExpr GhcTcId
op' = SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap ([TcSigmaType] -> HsWrapper
mkWpTyApps [ HasDebugCallStack => TcSigmaType -> TcSigmaType
TcSigmaType -> TcSigmaType
getRuntimeRep TcSigmaType
res_ty
                                               , TcSigmaType
arg2_sigma
                                               , TcSigmaType
res_ty])
                                   (XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExt
noExt (SrcSpan -> EvVar -> Located EvVar
forall l e. l -> e -> GenLocated l e
L SrcSpan
lv EvVar
op_id)))
             -- arg1' :: arg1_ty
             -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty)
             -- wrap_res :: op_res_ty "->" res_ty
             -- op' :: (a2_ty -> res_ty) -> a2_ty -> res_ty

             -- wrap1 :: arg1_ty "->" (arg2_sigma -> res_ty)
             wrap1 :: HsWrapper
wrap1 = HsWrapper
-> HsWrapper -> TcSigmaType -> TcSigmaType -> SDoc -> HsWrapper
mkWpFun HsWrapper
idHsWrapper HsWrapper
wrap_res TcSigmaType
arg2_sigma TcSigmaType
res_ty SDoc
doc
                     HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap_arg1
             doc :: SDoc
doc = String -> SDoc
text "When looking at the argument to ($)"

       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XOpApp GhcTcId
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> HsExpr GhcTcId
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcRn
XOpApp GhcTcId
fix (HsWrapper -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
wrap1 LHsExpr GhcTcId
arg1') LHsExpr GhcTcId
op' LHsExpr GhcTcId
arg2') }

  | (L loc :: SrcSpan
loc (HsRecFld _ (Ambiguous _ lbl :: Located RdrName
lbl))) <- LHsExpr GhcRn
op
  , Just sig_ty :: LHsSigWcType GhcRn
sig_ty <- HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
arg1)
    -- See Note [Disambiguating record fields]
  = do { TcSigmaType
sig_tc_ty <- UserTypeCtxt -> LHsSigWcType GhcRn -> TcM TcSigmaType
tcHsSigWcType UserTypeCtxt
ExprSigCtxt LHsSigWcType GhcRn
sig_ty
       ; Name
sel_name <- Located RdrName -> TcSigmaType -> TcM Name
disambiguateSelector Located RdrName
lbl TcSigmaType
sig_tc_ty
       ; let op' :: LHsExpr GhcRn
op' = SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XRecFld GhcRn -> AmbiguousFieldOcc GhcRn -> HsExpr GhcRn
forall p. XRecFld p -> AmbiguousFieldOcc p -> HsExpr p
HsRecFld XRecFld GhcRn
NoExt
noExt (XUnambiguous GhcRn -> Located RdrName -> AmbiguousFieldOcc GhcRn
forall pass.
XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Unambiguous Name
XUnambiguous GhcRn
sel_name Located RdrName
lbl))
       ; HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcExpr (XOpApp GhcRn
-> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcRn
fix LHsExpr GhcRn
arg1 LHsExpr GhcRn
op' LHsExpr GhcRn
arg2) ExpSigmaType
res_ty
       }

  | Bool
otherwise
  = do { String -> SDoc -> TcRn ()
traceTc "Non Application rule" (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
op)
       ; (wrap :: HsWrapper
wrap, op' :: LHsExpr GhcTcId
op', [HsValArg arg1' :: LHsExpr GhcTcId
arg1', HsValArg arg2' :: LHsExpr GhcTcId
arg2'])
           <- Maybe SDoc
-> LHsExpr GhcRn
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcApp (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> SDoc
mk_op_msg LHsExpr GhcRn
op)
                     LHsExpr GhcRn
op [LHsExpr GhcRn -> LHsExprArgIn
forall tm ty. tm -> HsArg tm ty
HsValArg LHsExpr GhcRn
arg1, LHsExpr GhcRn -> LHsExprArgIn
forall tm ty. tm -> HsArg tm ty
HsValArg LHsExpr GhcRn
arg2] ExpSigmaType
res_ty
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$ XOpApp GhcTcId
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> HsExpr GhcTcId
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcRn
XOpApp GhcTcId
fix LHsExpr GhcTcId
arg1' LHsExpr GhcTcId
op' LHsExpr GhcTcId
arg2') }

-- Right sections, equivalent to \ x -> x `op` expr, or
--      \ x -> op x expr

tcExpr expr :: HsExpr GhcRn
expr@(SectionR x :: XSectionR GhcRn
x op :: LHsExpr GhcRn
op arg2 :: LHsExpr GhcRn
arg2) res_ty :: ExpSigmaType
res_ty
  = do { (op' :: LHsExpr GhcTcId
op', op_ty :: TcSigmaType
op_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferFun LHsExpr GhcRn
op
       ; (wrap_fun :: HsWrapper
wrap_fun, [arg1_ty :: TcSigmaType
arg1_ty, arg2_ty :: TcSigmaType
arg2_ty], op_res_ty :: TcSigmaType
op_res_ty)
                  <- SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> Int
-> TcSigmaType
-> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
matchActualFunTys (LHsExpr GhcRn -> SDoc
mk_op_msg LHsExpr GhcRn
op) CtOrigin
fn_orig (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
op)) 2 TcSigmaType
op_ty
       ; HsWrapper
wrap_res <- CtOrigin
-> Maybe (HsExpr GhcRn)
-> TcSigmaType
-> ExpSigmaType
-> TcM HsWrapper
tcSubTypeHR CtOrigin
SectionOrigin (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
expr)
                                 (TcSigmaType -> TcSigmaType -> TcSigmaType
mkFunTy TcSigmaType
arg1_ty TcSigmaType
op_res_ty) ExpSigmaType
res_ty
       ; LHsExpr GhcTcId
arg2' <- LHsExpr GhcRn
-> LHsExpr GhcRn -> TcSigmaType -> Int -> TcM (LHsExpr GhcTcId)
tcArg LHsExpr GhcRn
op LHsExpr GhcRn
arg2 TcSigmaType
arg2_ty 2
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap_res (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$
                  XSectionR GhcTcId
-> LHsExpr GhcTcId -> LHsExpr GhcTcId -> HsExpr GhcTcId
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR XSectionR GhcRn
XSectionR GhcTcId
x (HsWrapper -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
wrap_fun LHsExpr GhcTcId
op') LHsExpr GhcTcId
arg2' ) }
  where
    fn_orig :: CtOrigin
fn_orig = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
op
    -- It's important to use the origin of 'op', so that call-stacks
    -- come out right; they are driven by the OccurrenceOf CtOrigin
    -- See Trac #13285

tcExpr expr :: HsExpr GhcRn
expr@(SectionL x :: XSectionL GhcRn
x arg1 :: LHsExpr GhcRn
arg1 op :: LHsExpr GhcRn
op) res_ty :: ExpSigmaType
res_ty
  = do { (op' :: LHsExpr GhcTcId
op', op_ty :: TcSigmaType
op_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferFun LHsExpr GhcRn
op
       ; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags      -- Note [Left sections]
       ; let n_reqd_args :: Int
n_reqd_args | Extension -> DynFlags -> Bool
xopt Extension
LangExt.PostfixOperators DynFlags
dflags = 1
                         | Bool
otherwise                            = 2

       ; (wrap_fn :: HsWrapper
wrap_fn, (arg1_ty :: TcSigmaType
arg1_ty:arg_tys :: [TcSigmaType]
arg_tys), op_res_ty :: TcSigmaType
op_res_ty)
           <- SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> Int
-> TcSigmaType
-> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
matchActualFunTys (LHsExpr GhcRn -> SDoc
mk_op_msg LHsExpr GhcRn
op) CtOrigin
fn_orig (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
op))
                                Int
n_reqd_args TcSigmaType
op_ty
       ; HsWrapper
wrap_res <- CtOrigin
-> Maybe (HsExpr GhcRn)
-> TcSigmaType
-> ExpSigmaType
-> TcM HsWrapper
tcSubTypeHR CtOrigin
SectionOrigin (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
expr)
                                 ([TcSigmaType] -> TcSigmaType -> TcSigmaType
mkFunTys [TcSigmaType]
arg_tys TcSigmaType
op_res_ty) ExpSigmaType
res_ty
       ; LHsExpr GhcTcId
arg1' <- LHsExpr GhcRn
-> LHsExpr GhcRn -> TcSigmaType -> Int -> TcM (LHsExpr GhcTcId)
tcArg LHsExpr GhcRn
op LHsExpr GhcRn
arg1 TcSigmaType
arg1_ty 1
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap_res (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$
                  XSectionL GhcTcId
-> LHsExpr GhcTcId -> LHsExpr GhcTcId -> HsExpr GhcTcId
forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL XSectionL GhcRn
XSectionL GhcTcId
x LHsExpr GhcTcId
arg1' (HsWrapper -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
wrap_fn LHsExpr GhcTcId
op') ) }
  where
    fn_orig :: CtOrigin
fn_orig = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
op
    -- It's important to use the origin of 'op', so that call-stacks
    -- come out right; they are driven by the OccurrenceOf CtOrigin
    -- See Trac #13285

tcExpr expr :: HsExpr GhcRn
expr@(ExplicitTuple x :: XExplicitTuple GhcRn
x tup_args :: [LHsTupArg GhcRn]
tup_args boxity :: Boxity
boxity) res_ty :: ExpSigmaType
res_ty
  | (LHsTupArg GhcRn -> Bool) -> [LHsTupArg GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LHsTupArg GhcRn -> Bool
forall id. LHsTupArg id -> Bool
tupArgPresent [LHsTupArg GhcRn]
tup_args
  = do { let arity :: Int
arity  = [LHsTupArg GhcRn] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsTupArg GhcRn]
tup_args
             tup_tc :: TyCon
tup_tc = Boxity -> Int -> TyCon
tupleTyCon Boxity
boxity Int
arity
       ; TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
res_ty
       ; (coi :: TcCoercionR
coi, arg_tys :: [TcSigmaType]
arg_tys) <- TyCon -> TcSigmaType -> TcM (TcCoercionR, [TcSigmaType])
matchExpectedTyConApp TyCon
tup_tc TcSigmaType
res_ty
                           -- Unboxed tuples have RuntimeRep vars, which we
                           -- don't care about here
                           -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
       ; let arg_tys' :: [TcSigmaType]
arg_tys' = case Boxity
boxity of Unboxed -> Int -> [TcSigmaType] -> [TcSigmaType]
forall a. Int -> [a] -> [a]
drop Int
arity [TcSigmaType]
arg_tys
                                       Boxed   -> [TcSigmaType]
arg_tys
       ; [LHsTupArg GhcTcId]
tup_args1 <- [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTcId]
tcTupArgs [LHsTupArg GhcRn]
tup_args [TcSigmaType]
arg_tys'
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
TcCoercionR -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrapCo TcCoercionR
coi (XExplicitTuple GhcTcId
-> [LHsTupArg GhcTcId] -> Boxity -> HsExpr GhcTcId
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcRn
XExplicitTuple GhcTcId
x [LHsTupArg GhcTcId]
tup_args1 Boxity
boxity) }

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

       ; [TcSigmaType]
arg_tys <- case Boxity
boxity of
           { Boxed   -> Int -> TcSigmaType -> TcM [TcSigmaType]
newFlexiTyVarTys Int
arity TcSigmaType
liftedTypeKind
           ; Unboxed -> Int -> TcM TcSigmaType -> TcM [TcSigmaType]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
arity TcM TcSigmaType
newOpenFlexiTyVarTy }
       ; let actual_res_ty :: TcSigmaType
actual_res_ty
                 = [TcSigmaType] -> TcSigmaType -> TcSigmaType
mkFunTys [TcSigmaType
ty | (ty :: TcSigmaType
ty, (L _ (Missing _))) <- [TcSigmaType]
arg_tys [TcSigmaType]
-> [LHsTupArg GhcRn] -> [(TcSigmaType, LHsTupArg GhcRn)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [LHsTupArg GhcRn]
tup_args]
                            (Boxity -> [TcSigmaType] -> TcSigmaType
mkTupleTy Boxity
boxity [TcSigmaType]
arg_tys)

       ; HsWrapper
wrap <- CtOrigin
-> Maybe (HsExpr GhcRn)
-> TcSigmaType
-> ExpSigmaType
-> TcM HsWrapper
tcSubTypeHR (String -> CtOrigin
Shouldn'tHappenOrigin "ExpTuple")
                             (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
expr)
                             TcSigmaType
actual_res_ty ExpSigmaType
res_ty

       -- Handle tuple sections where
       ; [LHsTupArg GhcTcId]
tup_args1 <- [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTcId]
tcTupArgs [LHsTupArg GhcRn]
tup_args [TcSigmaType]
arg_tys

       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (XExplicitTuple GhcTcId
-> [LHsTupArg GhcTcId] -> Boxity -> HsExpr GhcTcId
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcRn
XExplicitTuple GhcTcId
x [LHsTupArg GhcTcId]
tup_args1 Boxity
boxity) }

tcExpr (ExplicitSum _ alt :: Int
alt arity :: Int
arity expr :: LHsExpr GhcRn
expr) res_ty :: ExpSigmaType
res_ty
  = do { let sum_tc :: TyCon
sum_tc = Int -> TyCon
sumTyCon Int
arity
       ; TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
res_ty
       ; (coi :: TcCoercionR
coi, arg_tys :: [TcSigmaType]
arg_tys) <- TyCon -> TcSigmaType -> TcM (TcCoercionR, [TcSigmaType])
matchExpectedTyConApp TyCon
sum_tc TcSigmaType
res_ty
       ; -- Drop levity vars, we don't care about them here
         let arg_tys' :: [TcSigmaType]
arg_tys' = Int -> [TcSigmaType] -> [TcSigmaType]
forall a. Int -> [a] -> [a]
drop Int
arity [TcSigmaType]
arg_tys
       ; LHsExpr GhcTcId
expr' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
expr ([TcSigmaType]
arg_tys' [TcSigmaType] -> Int -> TcSigmaType
forall a. Outputable a => [a] -> Int -> a
`getNth` (Int
alt Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1))
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
TcCoercionR -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrapCo TcCoercionR
coi (XExplicitSum GhcTcId
-> Int -> Int -> LHsExpr GhcTcId -> HsExpr GhcTcId
forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum [TcSigmaType]
XExplicitSum GhcTcId
arg_tys' Int
alt Int
arity LHsExpr GhcTcId
expr' ) }

tcExpr (ExplicitList _ witness :: Maybe (SyntaxExpr GhcRn)
witness exprs :: [LHsExpr GhcRn]
exprs) res_ty :: ExpSigmaType
res_ty
  = case Maybe (SyntaxExpr GhcRn)
witness of
      Nothing   -> do  { TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
res_ty
                       ; (coi :: TcCoercionR
coi, elt_ty :: TcSigmaType
elt_ty) <- TcSigmaType -> TcM (TcCoercionR, TcSigmaType)
matchExpectedListTy TcSigmaType
res_ty
                       ; [LHsExpr GhcTcId]
exprs' <- (LHsExpr GhcRn -> TcM (LHsExpr GhcTcId))
-> [LHsExpr GhcRn]
-> IOEnv (Env TcGblEnv TcLclEnv) [LHsExpr GhcTcId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcSigmaType -> LHsExpr GhcRn -> TcM (LHsExpr GhcTcId)
tc_elt TcSigmaType
elt_ty) [LHsExpr GhcRn]
exprs
                       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                         TcCoercionR -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
TcCoercionR -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrapCo TcCoercionR
coi (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcTcId
-> Maybe (SyntaxExpr GhcTcId)
-> [LHsExpr GhcTcId]
-> HsExpr GhcTcId
forall p.
XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p
ExplicitList TcSigmaType
XExplicitList GhcTcId
elt_ty Maybe (SyntaxExpr GhcTcId)
forall a. Maybe a
Nothing [LHsExpr GhcTcId]
exprs' }

      Just fln :: SyntaxExpr GhcRn
fln -> do { ((exprs' :: [LHsExpr GhcTcId]
exprs', elt_ty :: TcSigmaType
elt_ty), fln' :: SyntaxExpr GhcTcId
fln')
                         <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM ([LHsExpr GhcTcId], TcSigmaType))
-> TcM (([LHsExpr GhcTcId], TcSigmaType), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
ListOrigin SyntaxExpr GhcRn
fln
                                       [TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
intTy, SyntaxOpType
SynList] ExpSigmaType
res_ty (([TcSigmaType] -> TcM ([LHsExpr GhcTcId], TcSigmaType))
 -> TcM (([LHsExpr GhcTcId], TcSigmaType), SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcM ([LHsExpr GhcTcId], TcSigmaType))
-> TcM (([LHsExpr GhcTcId], TcSigmaType), SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                            \ [elt_ty :: TcSigmaType
elt_ty] ->
                            do { [LHsExpr GhcTcId]
exprs' <-
                                    (LHsExpr GhcRn -> TcM (LHsExpr GhcTcId))
-> [LHsExpr GhcRn]
-> IOEnv (Env TcGblEnv TcLclEnv) [LHsExpr GhcTcId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcSigmaType -> LHsExpr GhcRn -> TcM (LHsExpr GhcTcId)
tc_elt TcSigmaType
elt_ty) [LHsExpr GhcRn]
exprs
                               ; ([LHsExpr GhcTcId], TcSigmaType)
-> TcM ([LHsExpr GhcTcId], TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsExpr GhcTcId]
exprs', TcSigmaType
elt_ty) }

                     ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcTcId
-> Maybe (SyntaxExpr GhcTcId)
-> [LHsExpr GhcTcId]
-> HsExpr GhcTcId
forall p.
XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p
ExplicitList TcSigmaType
XExplicitList GhcTcId
elt_ty (SyntaxExpr GhcTcId -> Maybe (SyntaxExpr GhcTcId)
forall a. a -> Maybe a
Just SyntaxExpr GhcTcId
fln') [LHsExpr GhcTcId]
exprs' }
     where tc_elt :: TcSigmaType -> LHsExpr GhcRn -> TcM (LHsExpr GhcTcId)
tc_elt elt_ty :: TcSigmaType
elt_ty expr :: LHsExpr GhcRn
expr = LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
expr TcSigmaType
elt_ty

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

tcExpr (HsLet x :: XLet GhcRn
x (L l :: SrcSpan
l binds :: HsLocalBinds GhcRn
binds) expr :: LHsExpr GhcRn
expr) res_ty :: ExpSigmaType
res_ty
  = do  { (binds' :: HsLocalBinds GhcTcId
binds', expr' :: LHsExpr GhcTcId
expr') <- HsLocalBinds GhcRn
-> TcM (LHsExpr GhcTcId)
-> TcM (HsLocalBinds GhcTcId, LHsExpr GhcTcId)
forall thing.
HsLocalBinds GhcRn
-> TcM thing -> TcM (HsLocalBinds GhcTcId, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (TcM (LHsExpr GhcTcId)
 -> TcM (HsLocalBinds GhcTcId, LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId)
-> TcM (HsLocalBinds GhcTcId, LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                             LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
expr ExpSigmaType
res_ty
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XLet GhcTcId
-> LHsLocalBinds GhcTcId -> LHsExpr GhcTcId -> HsExpr GhcTcId
forall p. XLet p -> LHsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet XLet GhcRn
XLet GhcTcId
x (SrcSpan -> HsLocalBinds GhcTcId -> LHsLocalBinds GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsLocalBinds GhcTcId
binds') LHsExpr GhcTcId
expr') }

tcExpr (HsCase x :: XCase GhcRn
x scrut :: LHsExpr GhcRn
scrut matches :: MatchGroup GhcRn (LHsExpr GhcRn)
matches) res_ty :: ExpSigmaType
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
          (scrut' :: LHsExpr GhcTcId
scrut', scrut_ty :: TcSigmaType
scrut_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferRho LHsExpr GhcRn
scrut

        ; String -> SDoc -> TcRn ()
traceTc "HsCase" (TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
scrut_ty)
        ; MatchGroup GhcTcId (LHsExpr GhcTcId)
matches' <- TcMatchCtxt HsExpr
-> TcSigmaType
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId))
forall (body :: * -> *).
Outputable (body GhcRn) =>
TcMatchCtxt body
-> TcSigmaType
-> MatchGroup GhcRn (Located (body GhcRn))
-> ExpSigmaType
-> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
tcMatchesCase TcMatchCtxt HsExpr
match_ctxt TcSigmaType
scrut_ty MatchGroup GhcRn (LHsExpr GhcRn)
matches ExpSigmaType
res_ty
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCase GhcTcId
-> LHsExpr GhcTcId
-> MatchGroup GhcTcId (LHsExpr GhcTcId)
-> HsExpr GhcTcId
forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase XCase GhcRn
XCase GhcTcId
x LHsExpr GhcTcId
scrut' MatchGroup GhcTcId (LHsExpr GhcTcId)
matches') }
 where
    match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext Name
-> (Located (body GhcRn)
    -> ExpSigmaType -> TcM (Located (body GhcTcId)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext Name
mc_what = HsMatchContext Name
forall id. HsMatchContext id
CaseAlt,
                      mc_body :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
mc_body = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcBody }

tcExpr (HsIf x :: XIf GhcRn
x Nothing pred :: LHsExpr GhcRn
pred b1 :: LHsExpr GhcRn
b1 b2 :: LHsExpr GhcRn
b2) res_ty :: ExpSigmaType
res_ty    -- Ordinary 'if'
  = do { LHsExpr GhcTcId
pred' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
pred (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
boolTy)
       ; ExpSigmaType
res_ty <- ExpSigmaType -> TcM ExpSigmaType
tauifyExpType ExpSigmaType
res_ty
           -- Just like Note [Case branches must never infer a non-tau type]
           -- in TcMatches (See #10619)

       ; LHsExpr GhcTcId
b1' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
b1 ExpSigmaType
res_ty
       ; LHsExpr GhcTcId
b2' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
b2 ExpSigmaType
res_ty
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XIf GhcTcId
-> Maybe (SyntaxExpr GhcTcId)
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> HsExpr GhcTcId
forall p.
XIf p
-> Maybe (SyntaxExpr p)
-> LHsExpr p
-> LHsExpr p
-> LHsExpr p
-> HsExpr p
HsIf XIf GhcRn
XIf GhcTcId
x Maybe (SyntaxExpr GhcTcId)
forall a. Maybe a
Nothing LHsExpr GhcTcId
pred' LHsExpr GhcTcId
b1' LHsExpr GhcTcId
b2') }

tcExpr (HsIf x :: XIf GhcRn
x (Just fun :: SyntaxExpr GhcRn
fun) pred :: LHsExpr GhcRn
pred b1 :: LHsExpr GhcRn
b1 b2 :: LHsExpr GhcRn
b2) res_ty :: ExpSigmaType
res_ty
  = do { ((pred' :: LHsExpr GhcTcId
pred', b1' :: LHsExpr GhcTcId
b1', b2' :: LHsExpr GhcTcId
b2'), fun' :: SyntaxExpr GhcTcId
fun')
           <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType]
    -> TcM (LHsExpr GhcTcId, LHsExpr GhcTcId, LHsExpr GhcTcId))
-> TcM
     ((LHsExpr GhcTcId, LHsExpr GhcTcId, LHsExpr GhcTcId),
      SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
IfOrigin SyntaxExpr GhcRn
fun [SyntaxOpType
SynAny, SyntaxOpType
SynAny, SyntaxOpType
SynAny] ExpSigmaType
res_ty (([TcSigmaType]
  -> TcM (LHsExpr GhcTcId, LHsExpr GhcTcId, LHsExpr GhcTcId))
 -> TcM
      ((LHsExpr GhcTcId, LHsExpr GhcTcId, LHsExpr GhcTcId),
       SyntaxExpr GhcTcId))
-> ([TcSigmaType]
    -> TcM (LHsExpr GhcTcId, LHsExpr GhcTcId, LHsExpr GhcTcId))
-> TcM
     ((LHsExpr GhcTcId, LHsExpr GhcTcId, LHsExpr GhcTcId),
      SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
              \ [pred_ty :: TcSigmaType
pred_ty, b1_ty :: TcSigmaType
b1_ty, b2_ty :: TcSigmaType
b2_ty] ->
              do { LHsExpr GhcTcId
pred' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
pred TcSigmaType
pred_ty
                 ; LHsExpr GhcTcId
b1'   <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
b1   TcSigmaType
b1_ty
                 ; LHsExpr GhcTcId
b2'   <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
b2   TcSigmaType
b2_ty
                 ; (LHsExpr GhcTcId, LHsExpr GhcTcId, LHsExpr GhcTcId)
-> TcM (LHsExpr GhcTcId, LHsExpr GhcTcId, LHsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcTcId
pred', LHsExpr GhcTcId
b1', LHsExpr GhcTcId
b2') }
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XIf GhcTcId
-> Maybe (SyntaxExpr GhcTcId)
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> HsExpr GhcTcId
forall p.
XIf p
-> Maybe (SyntaxExpr p)
-> LHsExpr p
-> LHsExpr p
-> LHsExpr p
-> HsExpr p
HsIf XIf GhcRn
XIf GhcTcId
x (SyntaxExpr GhcTcId -> Maybe (SyntaxExpr GhcTcId)
forall a. a -> Maybe a
Just SyntaxExpr GhcTcId
fun') LHsExpr GhcTcId
pred' LHsExpr GhcTcId
b1' LHsExpr GhcTcId
b2') }

tcExpr (HsMultiIf _ alts :: [LGRHS GhcRn (LHsExpr GhcRn)]
alts) res_ty :: ExpSigmaType
res_ty
  = do { ExpSigmaType
res_ty <- if [LGRHS GhcRn (LHsExpr GhcRn)] -> Bool
forall a. [a] -> Bool
isSingleton [LGRHS GhcRn (LHsExpr GhcRn)]
alts
                   then ExpSigmaType -> TcM ExpSigmaType
forall (m :: * -> *) a. Monad m => a -> m a
return ExpSigmaType
res_ty
                   else ExpSigmaType -> TcM ExpSigmaType
tauifyExpType ExpSigmaType
res_ty
             -- Just like TcMatches
             -- Note [Case branches must never infer a non-tau type]

       ; [LGRHS GhcTcId (LHsExpr GhcTcId)]
alts' <- (LGRHS GhcRn (LHsExpr GhcRn)
 -> IOEnv (Env TcGblEnv TcLclEnv) (LGRHS GhcTcId (LHsExpr GhcTcId)))
-> [LGRHS GhcRn (LHsExpr GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [LGRHS GhcTcId (LHsExpr GhcTcId)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (LGRHS GhcRn (LHsExpr GhcRn))
 -> TcM (SrcSpanLess (LGRHS GhcTcId (LHsExpr GhcTcId))))
-> LGRHS GhcRn (LHsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (LGRHS GhcTcId (LHsExpr GhcTcId))
forall a b.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b
wrapLocM ((SrcSpanLess (LGRHS GhcRn (LHsExpr GhcRn))
  -> TcM (SrcSpanLess (LGRHS GhcTcId (LHsExpr GhcTcId))))
 -> LGRHS GhcRn (LHsExpr GhcRn)
 -> IOEnv (Env TcGblEnv TcLclEnv) (LGRHS GhcTcId (LHsExpr GhcTcId)))
-> (SrcSpanLess (LGRHS GhcRn (LHsExpr GhcRn))
    -> TcM (SrcSpanLess (LGRHS GhcTcId (LHsExpr GhcTcId))))
-> LGRHS GhcRn (LHsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (LGRHS GhcTcId (LHsExpr GhcTcId))
forall a b. (a -> b) -> a -> b
$ TcMatchCtxt HsExpr
-> ExpSigmaType
-> GRHS GhcRn (LHsExpr GhcRn)
-> TcM (GRHS GhcTcId (LHsExpr GhcTcId))
forall (body :: * -> *).
TcMatchCtxt body
-> ExpSigmaType
-> GRHS GhcRn (Located (body GhcRn))
-> TcM (GRHS GhcTcId (Located (body GhcTcId)))
tcGRHS TcMatchCtxt HsExpr
match_ctxt ExpSigmaType
res_ty) [LGRHS GhcRn (LHsExpr GhcRn)]
alts
       ; TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
readExpType ExpSigmaType
res_ty
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XMultiIf GhcTcId
-> [LGRHS GhcTcId (LHsExpr GhcTcId)] -> HsExpr GhcTcId
forall p. XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p
HsMultiIf TcSigmaType
XMultiIf GhcTcId
res_ty [LGRHS GhcTcId (LHsExpr GhcTcId)]
alts') }
  where match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext Name
-> (Located (body GhcRn)
    -> ExpSigmaType -> TcM (Located (body GhcTcId)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext Name
mc_what = HsMatchContext Name
forall id. HsMatchContext id
IfAlt, mc_body :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
mc_body = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcBody }

tcExpr (HsDo _ do_or_lc :: HsStmtContext Name
do_or_lc stmts :: Located [ExprLStmt GhcRn]
stmts) res_ty :: ExpSigmaType
res_ty
  = do { HsExpr GhcTcId
expr' <- HsStmtContext Name
-> Located [ExprLStmt GhcRn]
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
tcDoStmts HsStmtContext Name
do_or_lc Located [ExprLStmt GhcRn]
stmts ExpSigmaType
res_ty
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTcId
expr' }

tcExpr (HsProc x :: XProc GhcRn
x pat :: LPat GhcRn
pat cmd :: LHsCmdTop GhcRn
cmd) res_ty :: ExpSigmaType
res_ty
  = do  { (pat' :: OutPat GhcTcId
pat', cmd' :: LHsCmdTop GhcTcId
cmd', coi :: TcCoercionR
coi) <- LPat GhcRn
-> LHsCmdTop GhcRn
-> ExpSigmaType
-> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercionR)
tcProc LPat GhcRn
pat LHsCmdTop GhcRn
cmd ExpSigmaType
res_ty
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
TcCoercionR -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrapCo TcCoercionR
coi (XProc GhcTcId
-> OutPat GhcTcId -> LHsCmdTop GhcTcId -> HsExpr GhcTcId
forall p. XProc p -> LPat p -> LHsCmdTop p -> HsExpr p
HsProc XProc GhcRn
XProc GhcTcId
x OutPat GhcTcId
pat' LHsCmdTop GhcTcId
cmd') }

-- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.
-- See Note [Grand plan for static forms] in 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 fvs :: XStatic GhcRn
fvs expr :: LHsExpr GhcRn
expr) res_ty :: ExpSigmaType
res_ty
  = do  { TcSigmaType
res_ty          <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
res_ty
        ; (co :: TcCoercionR
co, (p_ty :: TcSigmaType
p_ty, expr_ty :: TcSigmaType
expr_ty)) <- TcSigmaType -> TcM (TcCoercionR, (TcSigmaType, TcSigmaType))
matchExpectedAppTy TcSigmaType
res_ty
        ; (expr' :: LHsExpr GhcTcId
expr', lie :: WantedConstraints
lie)    <- TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId, WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId, WantedConstraints))
-> TcM (LHsExpr GhcTcId)
-> TcM (LHsExpr GhcTcId, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
            SDoc -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "In the body of a static form:")
                             2 (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
expr)
                       ) (TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
            LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExprNC LHsExpr GhcRn
expr TcSigmaType
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
        ; EvVar
_ <- CtOrigin -> TcSigmaType -> TcM EvVar
emitWantedEvVar CtOrigin
StaticOrigin (TcSigmaType -> TcM EvVar) -> TcSigmaType -> TcM EvVar
forall a b. (a -> b) -> a -> b
$
                  TyCon -> [TcSigmaType] -> TcSigmaType
mkTyConApp (Class -> TyCon
classTyCon Class
typeableClass)
                             [TcSigmaType
liftedTypeKind, TcSigmaType
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 GhcTcId
fromStaticPtr <- CtOrigin -> Name -> TcSigmaType -> TcM (HsExpr GhcTcId)
newMethodFromName CtOrigin
StaticOrigin Name
fromStaticPtrName TcSigmaType
p_ty
        ; let wrap :: HsWrapper
wrap = [TcSigmaType] -> HsWrapper
mkWpTyApps [TcSigmaType
expr_ty]
        ; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
TcCoercionR -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrapCo TcCoercionR
co (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$ XApp GhcTcId
-> LHsExpr GhcTcId -> LHsExpr GhcTcId -> HsExpr GhcTcId
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTcId
NoExt
noExt
                                         (SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsExpr GhcTcId -> LHsExpr GhcTcId)
-> HsExpr GhcTcId -> LHsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap HsExpr GhcTcId
fromStaticPtr)
                                         (SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XStatic GhcTcId -> LHsExpr GhcTcId -> HsExpr GhcTcId
forall p. XStatic p -> LHsExpr p -> HsExpr p
HsStatic XStatic GhcRn
XStatic GhcTcId
fvs LHsExpr GhcTcId
expr'))
        }

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

tcExpr expr :: HsExpr GhcRn
expr@(RecordCon { rcon_con_name :: forall p. HsExpr p -> Located (IdP p)
rcon_con_name = L loc :: SrcSpan
loc con_name :: IdP GhcRn
con_name
                       , rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcRn
rbinds }) res_ty :: ExpSigmaType
res_ty
  = do  { ConLike
con_like <- Name -> TcM ConLike
tcLookupConLike Name
IdP GhcRn
con_name

        -- Check for missing fields
        ; ConLike -> HsRecordBinds GhcRn -> TcRn ()
checkMissingFields ConLike
con_like HsRecordBinds GhcRn
rbinds

        ; (con_expr :: HsExpr GhcTcId
con_expr, con_sigma :: TcSigmaType
con_sigma) <- Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferId Name
IdP GhcRn
con_name
        ; (con_wrap :: HsWrapper
con_wrap, con_tau :: TcSigmaType
con_tau) <-
            CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate (Name -> CtOrigin
OccurrenceOf Name
IdP GhcRn
con_name) TcSigmaType
con_sigma
              -- a shallow instantiation should really be enough for
              -- a data constructor.
        ; let arity :: Int
arity = ConLike -> Int
conLikeArity ConLike
con_like
              Right (arg_tys :: [TcSigmaType]
arg_tys, actual_res_ty :: TcSigmaType
actual_res_ty) = Int -> TcSigmaType -> Either Int ([TcSigmaType], TcSigmaType)
tcSplitFunTysN Int
arity TcSigmaType
con_tau
        ; case ConLike -> Maybe EvVar
conLikeWrapId_maybe ConLike
con_like of
               Nothing -> Name -> TcM (HsExpr GhcTcId)
forall name a. Outputable name => name -> TcM a
nonBidirectionalErr (ConLike -> Name
conLikeName ConLike
con_like)
               Just con_id :: EvVar
con_id -> do {
                  HsWrapper
res_wrap <- CtOrigin
-> Maybe (HsExpr GhcRn)
-> TcSigmaType
-> ExpSigmaType
-> TcM HsWrapper
tcSubTypeHR (String -> CtOrigin
Shouldn'tHappenOrigin "RecordCon")
                                          (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
expr) TcSigmaType
actual_res_ty ExpSigmaType
res_ty
                ; HsRecordBinds GhcTcId
rbinds' <- ConLike
-> [TcSigmaType]
-> HsRecordBinds GhcRn
-> TcM (HsRecordBinds GhcTcId)
tcRecordBinds ConLike
con_like [TcSigmaType]
arg_tys HsRecordBinds GhcRn
rbinds
                ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                  HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
res_wrap (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$
                  RecordCon :: forall p.
XRecordCon p -> Located (IdP p) -> HsRecordBinds p -> HsExpr p
RecordCon { rcon_ext :: XRecordCon GhcTcId
rcon_ext = RecordConTc :: ConLike -> HsExpr GhcTcId -> RecordConTc
RecordConTc
                                 { rcon_con_like :: ConLike
rcon_con_like = ConLike
con_like
                                 , rcon_con_expr :: HsExpr GhcTcId
rcon_con_expr = HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
con_wrap HsExpr GhcTcId
con_expr }
                            , rcon_con_name :: Located (IdP GhcTcId)
rcon_con_name = SrcSpan -> EvVar -> Located EvVar
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc EvVar
con_id
                            , rcon_flds :: HsRecordBinds GhcTcId
rcon_flds = HsRecordBinds GhcTcId
rbinds' } } }

{-
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 Trac #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 TcTyClsDecls), 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"

-}

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 -> [LHsRecUpdField p]
rupd_flds = [LHsRecUpdField GhcRn]
rbnds }) res_ty :: ExpSigmaType
res_ty
  = ASSERT( notNull rbnds )
    do  { -- STEP -2: typecheck the record_expr, the record to be updated
          (record_expr' :: LHsExpr GhcTcId
record_expr', record_rho :: TcSigmaType
record_rho) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferRho LHsExpr GhcRn
record_expr

        -- STEP -1  See Note [Disambiguating record fields]
        -- After this we know that rbinds is unambiguous
        ; [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
rbinds <- LHsExpr GhcRn
-> TcSigmaType
-> [LHsRecUpdField GhcRn]
-> ExpSigmaType
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
disambiguateRecordBinds LHsExpr GhcRn
record_expr TcSigmaType
record_rho [LHsRecUpdField GhcRn]
rbnds ExpSigmaType
res_ty
        ; let upd_flds :: [AmbiguousFieldOcc GhcTcId]
upd_flds = (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
 -> AmbiguousFieldOcc GhcTcId)
-> [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
-> [AmbiguousFieldOcc GhcTcId]
forall a b. (a -> b) -> [a] -> [b]
map (Located (AmbiguousFieldOcc GhcTcId) -> AmbiguousFieldOcc GhcTcId
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located (AmbiguousFieldOcc GhcTcId) -> AmbiguousFieldOcc GhcTcId)
-> (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
    -> Located (AmbiguousFieldOcc GhcTcId))
-> LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> AmbiguousFieldOcc GhcTcId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> Located (AmbiguousFieldOcc GhcTcId)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
 -> Located (AmbiguousFieldOcc GhcTcId))
-> (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
    -> HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
-> LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> Located (AmbiguousFieldOcc GhcTcId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
rbinds
              upd_fld_occs :: [FastString]
upd_fld_occs = (AmbiguousFieldOcc GhcTcId -> FastString)
-> [AmbiguousFieldOcc GhcTcId] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> FastString
occNameFS (OccName -> FastString)
-> (AmbiguousFieldOcc GhcTcId -> OccName)
-> AmbiguousFieldOcc GhcTcId
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> OccName)
-> (AmbiguousFieldOcc GhcTcId -> RdrName)
-> AmbiguousFieldOcc GhcTcId
-> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AmbiguousFieldOcc GhcTcId -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc) [AmbiguousFieldOcc GhcTcId]
upd_flds
              sel_ids :: [EvVar]
sel_ids      = (AmbiguousFieldOcc GhcTcId -> EvVar)
-> [AmbiguousFieldOcc GhcTcId] -> [EvVar]
forall a b. (a -> b) -> [a] -> [b]
map AmbiguousFieldOcc GhcTcId -> EvVar
selectorAmbiguousFieldOcc [AmbiguousFieldOcc GhcTcId]
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)
                         | LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
fld <- [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
rbinds,
                           -- Excludes class ops
                           let L loc :: SrcSpan
loc sel_id :: EvVar
sel_id = HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> Located EvVar
forall arg.
HsRecField' (AmbiguousFieldOcc GhcTcId) arg -> Located EvVar
hsRecUpdFieldId (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> SrcSpanLess
     (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
fld),
                           Bool -> Bool
not (EvVar -> Bool
isRecordSelector EvVar
sel_id),
                           let fld_name :: Name
fld_name = EvVar -> Name
idName EvVar
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 (data_sels :: [EvVar]
data_sels, pat_syn_sels :: [EvVar]
pat_syn_sels) =
                (EvVar -> Bool) -> [EvVar] -> ([EvVar], [EvVar])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition EvVar -> Bool
isDataConRecordSelector [EvVar]
sel_ids
        ; MASSERT( all isPatSynRecordSelector pat_syn_sels )
        ; Bool -> SDoc -> TcRn ()
checkTc ( [EvVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvVar]
data_sels Bool -> Bool -> Bool
|| [EvVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvVar]
pat_syn_sels )
                  ( [EvVar] -> [EvVar] -> SDoc
mixedSelectors [EvVar]
data_sels [EvVar]
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)
              sel_id :: EvVar
sel_id : _  = [EvVar]
sel_ids

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

              con_likes :: [ConLike]
              con_likes :: [ConLike]
con_likes = case EvVar -> IdDetails
idDetails EvVar
sel_id of
                             RecSelId (RecSelData tc :: TyCon
tc) _
                                -> (DataCon -> ConLike) -> [DataCon] -> [ConLike]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> ConLike
RealDataCon (TyCon -> [DataCon]
tyConDataCons TyCon
tc)
                             RecSelId (RecSelPatSyn ps :: PatSyn
ps) _
                                -> [PatSyn -> ConLike
PatSynCon PatSyn
ps]
                             _  -> String -> [ConLike]
forall a. String -> a
panic "tcRecordUpd"
                -- NB: for a data type family, the tycon is the instance tycon

              relevant_cons :: [ConLike]
relevant_cons = [ConLike] -> [FastString] -> [ConLike]
conLikesWithFields [ConLike]
con_likes [FastString]
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' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
-> [ConLike] -> SDoc
badFieldsUpd [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
rbinds [ConLike]
con_likes)

        -- Take apart a representative constructor
        ; let con1 :: ConLike
con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
              (con1_tvs :: [EvVar]
con1_tvs, _, _, _prov_theta :: [TcSigmaType]
_prov_theta, req_theta :: [TcSigmaType]
req_theta, con1_arg_tys :: [TcSigmaType]
con1_arg_tys, _)
                 = ConLike
-> ([EvVar], [EvVar], [EqSpec], [TcSigmaType], [TcSigmaType],
    [TcSigmaType], TcSigmaType)
conLikeFullSig ConLike
con1
              con1_flds :: [FastString]
con1_flds   = (FieldLbl Name -> FastString) -> [FieldLbl Name] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map FieldLbl Name -> FastString
forall a. FieldLbl a -> FastString
flLabel ([FieldLbl Name] -> [FastString])
-> [FieldLbl Name] -> [FastString]
forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLbl Name]
conLikeFieldLabels ConLike
con1
              con1_tv_tys :: [TcSigmaType]
con1_tv_tys = [EvVar] -> [TcSigmaType]
mkTyVarTys [EvVar]
con1_tvs
              con1_res_ty :: TcSigmaType
con1_res_ty = case Maybe TyCon
mtycon of
                              Just tc :: TyCon
tc -> TyCon -> [TcSigmaType] -> TcSigmaType
mkFamilyTyConApp TyCon
tc [TcSigmaType]
con1_tv_tys
                              Nothing -> ConLike -> [TcSigmaType] -> TcSigmaType
conLikeResTy ConLike
con1 [TcSigmaType]
con1_tv_tys

        -- Check that we're not dealing with a unidirectional pattern
        -- synonym
        ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe EvVar -> Bool
forall a. Maybe a -> Bool
isJust (Maybe EvVar -> Bool) -> Maybe EvVar -> Bool
forall a b. (a -> b) -> a -> b
$ ConLike -> Maybe EvVar
conLikeWrapId_maybe ConLike
con1)
                  (Name -> TcRn ()
forall name a. Outputable name => name -> TcM a
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 :: [(FastString, TcSigmaType)]
flds1_w_tys  = String
-> [FastString] -> [TcSigmaType] -> [(FastString, TcSigmaType)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual "tcExpr:RecConUpd" [FastString]
con1_flds [TcSigmaType]
con1_arg_tys
              bad_upd_flds :: [(FastString, TcSigmaType)]
bad_upd_flds = ((FastString, TcSigmaType) -> Bool)
-> [(FastString, TcSigmaType)] -> [(FastString, TcSigmaType)]
forall a. (a -> Bool) -> [a] -> [a]
filter (FastString, TcSigmaType) -> Bool
bad_fld [(FastString, TcSigmaType)]
flds1_w_tys
              con1_tv_set :: VarSet
con1_tv_set  = [EvVar] -> VarSet
mkVarSet [EvVar]
con1_tvs
              bad_fld :: (FastString, TcSigmaType) -> Bool
bad_fld (fld :: FastString
fld, ty :: TcSigmaType
ty) = FastString
fld FastString -> [FastString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FastString]
upd_fld_occs Bool -> Bool -> Bool
&&
                                      Bool -> Bool
not (TcSigmaType -> VarSet
tyCoVarsOfType TcSigmaType
ty VarSet -> VarSet -> Bool
`subVarSet` VarSet
con1_tv_set)
        ; Bool -> SDoc -> TcRn ()
checkTc ([(FastString, TcSigmaType)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FastString, TcSigmaType)]
bad_upd_flds) ([(FastString, TcSigmaType)] -> SDoc
badFieldTypes [(FastString, TcSigmaType)]
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 = [FastString] -> [EvVar] -> [ConLike] -> VarSet
getFixedTyVars [FastString]
upd_fld_occs [EvVar]
con1_tvs [ConLike]
relevant_cons
              is_fixed_tv :: EvVar -> Bool
is_fixed_tv tv :: EvVar
tv = EvVar
tv EvVar -> VarSet -> Bool
`elemVarSet` VarSet
fixed_tvs

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

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

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

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

        ; HsWrapper
wrap_res <- CtOrigin
-> Maybe (HsExpr GhcRn)
-> TcSigmaType
-> ExpSigmaType
-> TcM HsWrapper
tcSubTypeHR (HsExpr GhcRn -> CtOrigin
exprCtOrigin HsExpr GhcRn
expr)
                                  (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
expr) TcSigmaType
rec_res_ty ExpSigmaType
res_ty
        ; TcCoercionR
co_scrut <- Maybe (HsExpr GhcRn)
-> TcSigmaType -> TcSigmaType -> TcM TcCoercionR
unifyType (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
record_expr)) TcSigmaType
record_rho TcSigmaType
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
        ; [LHsRecUpdField GhcTcId]
rbinds'      <- ConLike
-> [TcSigmaType]
-> [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTcId]
tcRecordUpd ConLike
con1 [TcSigmaType]
con1_arg_tys' [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
rbinds

        -- STEP 6: Deal with the stupid theta
        ; let theta' :: [TcSigmaType]
theta' = TCvSubst -> [TcSigmaType] -> [TcSigmaType]
substThetaUnchecked TCvSubst
scrut_subst (ConLike -> [TcSigmaType]
conLikeStupidTheta ConLike
con1)
        ; CtOrigin -> [TcSigmaType] -> TcRn ()
instStupidTheta CtOrigin
RecordUpdOrigin [TcSigmaType]
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
tycon <- Maybe TyCon
mtycon
                     , Just co_con :: CoAxiom Unbranched
co_con <- TyCon -> Maybe (CoAxiom Unbranched)
tyConFamilyCoercion_maybe TyCon
tycon
                     = TcCoercionR -> HsWrapper
mkWpCastR (CoAxiom Unbranched -> [TcSigmaType] -> [TcCoercionR] -> TcCoercionR
mkTcUnbranchedAxInstCo CoAxiom Unbranched
co_con [TcSigmaType]
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' :: [TcSigmaType]
req_theta' = TCvSubst -> [TcSigmaType] -> [TcSigmaType]
substThetaUnchecked TCvSubst
scrut_subst [TcSigmaType]
req_theta
        ; HsWrapper
req_wrap <- CtOrigin -> [TcSigmaType] -> TcM HsWrapper
instCallConstraints CtOrigin
RecordUpdOrigin [TcSigmaType]
req_theta'

        -- Phew!
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
          HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap_res (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$
          RecordUpd :: forall p.
XRecordUpd p -> LHsExpr p -> [LHsRecUpdField p] -> HsExpr p
RecordUpd { rupd_expr :: LHsExpr GhcTcId
rupd_expr
                          = HsWrapper -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
fam_co (TcCoercionR -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
TcCoercionR -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrapCo TcCoercionR
co_scrut LHsExpr GhcTcId
record_expr')
                    , rupd_flds :: [LHsRecUpdField GhcTcId]
rupd_flds = [LHsRecUpdField GhcTcId]
rbinds'
                    , rupd_ext :: XRecordUpd GhcTcId
rupd_ext = RecordUpdTc :: [ConLike]
-> [TcSigmaType] -> [TcSigmaType] -> HsWrapper -> RecordUpdTc
RecordUpdTc
                        { rupd_cons :: [ConLike]
rupd_cons = [ConLike]
relevant_cons
                        , rupd_in_tys :: [TcSigmaType]
rupd_in_tys = [TcSigmaType]
scrut_inst_tys
                        , rupd_out_tys :: [TcSigmaType]
rupd_out_tys = [TcSigmaType]
result_inst_tys
                        , rupd_wrap :: HsWrapper
rupd_wrap = HsWrapper
req_wrap }} }

tcExpr e :: HsExpr GhcRn
e@(HsRecFld _ f :: AmbiguousFieldOcc GhcRn
f) res_ty :: ExpSigmaType
res_ty
    = HsExpr GhcRn
-> AmbiguousFieldOcc GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcCheckRecSelId HsExpr GhcRn
e AmbiguousFieldOcc GhcRn
f ExpSigmaType
res_ty

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

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

tcExpr (ArithSeq _ witness :: Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq) res_ty :: ExpSigmaType
res_ty
  = Maybe (SyntaxExpr GhcRn)
-> ArithSeqInfo GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness ArithSeqInfo GhcRn
seq ExpSigmaType
res_ty

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

-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceExpr'.
-- Here we get rid of it and add the finalizers to the global environment.
--
-- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers :: ThModFinalizers
mod_finalizers (HsSplicedExpr expr :: HsExpr GhcRn
expr)))
       res_ty :: ExpSigmaType
res_ty
  = do ThModFinalizers -> TcRn ()
addModFinalizersWithLclEnv ThModFinalizers
mod_finalizers
       HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcExpr HsExpr GhcRn
expr ExpSigmaType
res_ty
tcExpr (HsSpliceE _ splice :: HsSplice GhcRn
splice)          res_ty :: ExpSigmaType
res_ty
  = HsSplice GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcSpliceExpr HsSplice GhcRn
splice ExpSigmaType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsBracket _ brack :: HsBracket GhcRn
brack)         res_ty :: ExpSigmaType
res_ty
  = HsExpr GhcRn
-> HsBracket GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcTypedBracket HsExpr GhcRn
e HsBracket GhcRn
brack ExpSigmaType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsRnBracketOut _ brack :: HsBracket GhcRn
brack ps :: [PendingRnSplice]
ps) res_ty :: ExpSigmaType
res_ty
  = HsExpr GhcRn
-> HsBracket GhcRn
-> [PendingRnSplice]
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
tcUntypedBracket HsExpr GhcRn
e HsBracket GhcRn
brack [PendingRnSplice]
ps ExpSigmaType
res_ty

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

tcExpr other :: HsExpr GhcRn
other _ = String -> SDoc -> TcM (HsExpr GhcTcId)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tcMonoExpr" (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
other)
  -- Include ArrForm, ArrApp, which shouldn't appear at all
  -- Also HsTcBracketOut, HsQuasiQuoteE

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

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

tcArithSeq :: Maybe (SyntaxExpr GhcRn)
-> ArithSeqInfo GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcArithSeq witness :: Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(From expr :: LHsExpr GhcRn
expr) res_ty :: ExpSigmaType
res_ty
  = do { (wrap :: HsWrapper
wrap, elt_ty :: TcSigmaType
elt_ty, wit' :: Maybe (SyntaxExpr GhcTcId)
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpSigmaType
-> TcM (HsWrapper, TcSigmaType, Maybe (SyntaxExpr GhcTcId))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpSigmaType
res_ty
       ; LHsExpr GhcTcId
expr' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
expr TcSigmaType
elt_ty
       ; HsExpr GhcTcId
enum_from <- CtOrigin -> Name -> TcSigmaType -> TcM (HsExpr GhcTcId)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
                              Name
enumFromName TcSigmaType
elt_ty
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$
         XArithSeq GhcTcId
-> Maybe (SyntaxExpr GhcTcId)
-> ArithSeqInfo GhcTcId
-> HsExpr GhcTcId
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcTcId
HsExpr GhcTcId
enum_from Maybe (SyntaxExpr GhcTcId)
wit' (LHsExpr GhcTcId -> ArithSeqInfo GhcTcId
forall id. LHsExpr id -> ArithSeqInfo id
From LHsExpr GhcTcId
expr') }

tcArithSeq witness :: Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromThen expr1 :: LHsExpr GhcRn
expr1 expr2 :: LHsExpr GhcRn
expr2) res_ty :: ExpSigmaType
res_ty
  = do { (wrap :: HsWrapper
wrap, elt_ty :: TcSigmaType
elt_ty, wit' :: Maybe (SyntaxExpr GhcTcId)
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpSigmaType
-> TcM (HsWrapper, TcSigmaType, Maybe (SyntaxExpr GhcTcId))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpSigmaType
res_ty
       ; LHsExpr GhcTcId
expr1' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
expr1 TcSigmaType
elt_ty
       ; LHsExpr GhcTcId
expr2' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
expr2 TcSigmaType
elt_ty
       ; HsExpr GhcTcId
enum_from_then <- CtOrigin -> Name -> TcSigmaType -> TcM (HsExpr GhcTcId)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
                              Name
enumFromThenName TcSigmaType
elt_ty
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$
         XArithSeq GhcTcId
-> Maybe (SyntaxExpr GhcTcId)
-> ArithSeqInfo GhcTcId
-> HsExpr GhcTcId
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcTcId
HsExpr GhcTcId
enum_from_then Maybe (SyntaxExpr GhcTcId)
wit' (LHsExpr GhcTcId -> LHsExpr GhcTcId -> ArithSeqInfo GhcTcId
forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThen LHsExpr GhcTcId
expr1' LHsExpr GhcTcId
expr2') }

tcArithSeq witness :: Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromTo expr1 :: LHsExpr GhcRn
expr1 expr2 :: LHsExpr GhcRn
expr2) res_ty :: ExpSigmaType
res_ty
  = do { (wrap :: HsWrapper
wrap, elt_ty :: TcSigmaType
elt_ty, wit' :: Maybe (SyntaxExpr GhcTcId)
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpSigmaType
-> TcM (HsWrapper, TcSigmaType, Maybe (SyntaxExpr GhcTcId))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpSigmaType
res_ty
       ; LHsExpr GhcTcId
expr1' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
expr1 TcSigmaType
elt_ty
       ; LHsExpr GhcTcId
expr2' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
expr2 TcSigmaType
elt_ty
       ; HsExpr GhcTcId
enum_from_to <- CtOrigin -> Name -> TcSigmaType -> TcM (HsExpr GhcTcId)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
                              Name
enumFromToName TcSigmaType
elt_ty
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$
         XArithSeq GhcTcId
-> Maybe (SyntaxExpr GhcTcId)
-> ArithSeqInfo GhcTcId
-> HsExpr GhcTcId
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcTcId
HsExpr GhcTcId
enum_from_to Maybe (SyntaxExpr GhcTcId)
wit' (LHsExpr GhcTcId -> LHsExpr GhcTcId -> ArithSeqInfo GhcTcId
forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromTo LHsExpr GhcTcId
expr1' LHsExpr GhcTcId
expr2') }

tcArithSeq witness :: Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromThenTo expr1 :: LHsExpr GhcRn
expr1 expr2 :: LHsExpr GhcRn
expr2 expr3 :: LHsExpr GhcRn
expr3) res_ty :: ExpSigmaType
res_ty
  = do { (wrap :: HsWrapper
wrap, elt_ty :: TcSigmaType
elt_ty, wit' :: Maybe (SyntaxExpr GhcTcId)
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpSigmaType
-> TcM (HsWrapper, TcSigmaType, Maybe (SyntaxExpr GhcTcId))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpSigmaType
res_ty
        ; LHsExpr GhcTcId
expr1' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
expr1 TcSigmaType
elt_ty
        ; LHsExpr GhcTcId
expr2' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
expr2 TcSigmaType
elt_ty
        ; LHsExpr GhcTcId
expr3' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
expr3 TcSigmaType
elt_ty
        ; HsExpr GhcTcId
eft <- CtOrigin -> Name -> TcSigmaType -> TcM (HsExpr GhcTcId)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
                              Name
enumFromThenToName TcSigmaType
elt_ty
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$
          XArithSeq GhcTcId
-> Maybe (SyntaxExpr GhcTcId)
-> ArithSeqInfo GhcTcId
-> HsExpr GhcTcId
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcTcId
HsExpr GhcTcId
eft Maybe (SyntaxExpr GhcTcId)
wit' (LHsExpr GhcTcId
-> LHsExpr GhcTcId -> LHsExpr GhcTcId -> ArithSeqInfo GhcTcId
forall id.
LHsExpr id -> LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThenTo LHsExpr GhcTcId
expr1' LHsExpr GhcTcId
expr2' LHsExpr GhcTcId
expr3') }

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

{-
************************************************************************
*                                                                      *
                Applications
*                                                                      *
************************************************************************
-}

-- HsArg is defined in HsTypes.hs

wrapHsArgs :: (NoGhcTc (GhcPass id) ~ GhcRn)
           => LHsExpr (GhcPass id)
           -> [HsArg (LHsExpr (GhcPass id)) (LHsWcType GhcRn)]
           -> LHsExpr (GhcPass id)
wrapHsArgs :: LHsExpr (GhcPass id)
-> [HsArg
      (LHsExpr (GhcPass id))
      (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
-> LHsExpr (GhcPass id)
wrapHsArgs f :: LHsExpr (GhcPass id)
f []                     = LHsExpr (GhcPass id)
f
wrapHsArgs f :: LHsExpr (GhcPass id)
f (HsValArg  a :: LHsExpr (GhcPass id)
a : args :: [HsArg
   (LHsExpr (GhcPass id))
   (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
args)   = LHsExpr (GhcPass id)
-> [HsArg
      (LHsExpr (GhcPass id))
      (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
-> LHsExpr (GhcPass id)
forall (id :: Pass).
(NoGhcTc (GhcPass id) ~ GhcRn) =>
LHsExpr (GhcPass id)
-> [HsArg
      (LHsExpr (GhcPass id))
      (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
-> LHsExpr (GhcPass id)
wrapHsArgs (LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp LHsExpr (GhcPass id)
f LHsExpr (GhcPass id)
a)          [HsArg
   (LHsExpr (GhcPass id))
   (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
args
wrapHsArgs f :: LHsExpr (GhcPass id)
f (HsTypeArg _ t :: HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
t : args :: [HsArg
   (LHsExpr (GhcPass id))
   (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
args) = LHsExpr (GhcPass id)
-> [HsArg
      (LHsExpr (GhcPass id))
      (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
-> LHsExpr (GhcPass id)
forall (id :: Pass).
(NoGhcTc (GhcPass id) ~ GhcRn) =>
LHsExpr (GhcPass id)
-> [HsArg
      (LHsExpr (GhcPass id))
      (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
-> LHsExpr (GhcPass id)
wrapHsArgs (LHsExpr (GhcPass id)
-> HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
-> LHsExpr (GhcPass id)
forall (id :: Pass).
(NoGhcTc (GhcPass id) ~ GhcRn) =>
LHsExpr (GhcPass id)
-> HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
-> LHsExpr (GhcPass id)
mkHsAppType LHsExpr (GhcPass id)
f HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
t)      [HsArg
   (LHsExpr (GhcPass id))
   (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
args
wrapHsArgs f :: LHsExpr (GhcPass id)
f (HsArgPar sp :: SrcSpan
sp : args :: [HsArg
   (LHsExpr (GhcPass id))
   (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
args)   = LHsExpr (GhcPass id)
-> [HsArg
      (LHsExpr (GhcPass id))
      (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
-> LHsExpr (GhcPass id)
forall (id :: Pass).
(NoGhcTc (GhcPass id) ~ GhcRn) =>
LHsExpr (GhcPass id)
-> [HsArg
      (LHsExpr (GhcPass id))
      (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
-> LHsExpr (GhcPass id)
wrapHsArgs (SrcSpan -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id)
forall l e. l -> e -> GenLocated l e
L SrcSpan
sp (HsExpr (GhcPass id) -> LHsExpr (GhcPass id))
-> HsExpr (GhcPass id) -> LHsExpr (GhcPass id)
forall a b. (a -> b) -> a -> b
$ XPar (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar (GhcPass id)
NoExt
noExt LHsExpr (GhcPass id)
f) [HsArg
   (LHsExpr (GhcPass id))
   (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
args

isHsValArg :: HsArg tm ty -> Bool
isHsValArg :: HsArg tm ty -> Bool
isHsValArg (HsValArg {})  = Bool
True
isHsValArg (HsTypeArg {}) = Bool
False
isHsValArg (HsArgPar {})  = Bool
False

isArgPar :: HsArg tm ty -> Bool
isArgPar :: HsArg tm ty -> Bool
isArgPar (HsArgPar {})  = Bool
True
isArgPar (HsValArg {})  = Bool
False
isArgPar (HsTypeArg {}) = Bool
False

isArgPar_maybe :: HsArg a b -> Maybe (HsArg c d)
isArgPar_maybe :: HsArg a b -> Maybe (HsArg c d)
isArgPar_maybe (HsArgPar sp :: SrcSpan
sp) = HsArg c d -> Maybe (HsArg c d)
forall a. a -> Maybe a
Just (HsArg c d -> Maybe (HsArg c d)) -> HsArg c d -> Maybe (HsArg c d)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsArg c d
forall tm ty. SrcSpan -> HsArg tm ty
HsArgPar SrcSpan
sp
isArgPar_maybe _ = Maybe (HsArg c d)
forall a. Maybe a
Nothing

type LHsExprArgIn  = HsArg (LHsExpr GhcRn)   (LHsWcType GhcRn)
type LHsExprArgOut = HsArg (LHsExpr GhcTcId) (LHsWcType GhcRn)

tcApp1 :: HsExpr GhcRn  -- either HsApp or HsAppType
       -> ExpRhoType -> TcM (HsExpr GhcTcId)
tcApp1 :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcApp1 e :: HsExpr GhcRn
e res_ty :: ExpSigmaType
res_ty
  = do { (wrap :: HsWrapper
wrap, fun :: LHsExpr GhcTcId
fun, args :: [LHsExprArgOut]
args) <- Maybe SDoc
-> LHsExpr GhcRn
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcApp Maybe SDoc
forall a. Maybe a
Nothing (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsExpr GhcRn)
HsExpr GhcRn
e) [] ExpSigmaType
res_ty
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcTcId -> HsExpr GhcTcId
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LHsExpr GhcTcId -> HsExpr GhcTcId)
-> LHsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcTcId -> [LHsExprArgOut] -> LHsExpr GhcTcId
forall (id :: Pass).
(NoGhcTc (GhcPass id) ~ GhcRn) =>
LHsExpr (GhcPass id)
-> [HsArg
      (LHsExpr (GhcPass id))
      (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
-> LHsExpr (GhcPass id)
wrapHsArgs LHsExpr GhcTcId
fun [LHsExprArgOut]
args) }

tcApp :: Maybe SDoc  -- like "The function `f' is applied to"
                     -- or leave out to get exactly that message
      -> LHsExpr GhcRn -> [LHsExprArgIn] -- Function and args
      -> ExpRhoType -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
           -- (wrap, fun, args). For an ordinary function application,
           -- these should be assembled as (wrap (fun args)).
           -- But OpApp is slightly different, so that's why the caller
           -- must assemble

tcApp :: Maybe SDoc
-> LHsExpr GhcRn
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcApp m_herald :: Maybe SDoc
m_herald (L sp :: SrcSpan
sp (HsPar _ fun :: LHsExpr GhcRn
fun)) args :: [LHsExprArgIn]
args res_ty :: ExpSigmaType
res_ty
  = Maybe SDoc
-> LHsExpr GhcRn
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcApp Maybe SDoc
m_herald LHsExpr GhcRn
fun (SrcSpan -> LHsExprArgIn
forall tm ty. SrcSpan -> HsArg tm ty
HsArgPar SrcSpan
sp LHsExprArgIn -> [LHsExprArgIn] -> [LHsExprArgIn]
forall a. a -> [a] -> [a]
: [LHsExprArgIn]
args) ExpSigmaType
res_ty

tcApp m_herald :: Maybe SDoc
m_herald (L _ (HsApp _ fun :: LHsExpr GhcRn
fun arg1 :: LHsExpr GhcRn
arg1)) args :: [LHsExprArgIn]
args res_ty :: ExpSigmaType
res_ty
  = Maybe SDoc
-> LHsExpr GhcRn
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcApp Maybe SDoc
m_herald LHsExpr GhcRn
fun (LHsExpr GhcRn -> LHsExprArgIn
forall tm ty. tm -> HsArg tm ty
HsValArg LHsExpr GhcRn
arg1 LHsExprArgIn -> [LHsExprArgIn] -> [LHsExprArgIn]
forall a. a -> [a] -> [a]
: [LHsExprArgIn]
args) ExpSigmaType
res_ty

tcApp m_herald :: Maybe SDoc
m_herald (L _ (HsAppType _ fun :: LHsExpr GhcRn
fun ty1 :: LHsWcType (NoGhcTc GhcRn)
ty1)) args :: [LHsExprArgIn]
args res_ty :: ExpSigmaType
res_ty
  = Maybe SDoc
-> LHsExpr GhcRn
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcApp Maybe SDoc
m_herald LHsExpr GhcRn
fun (SrcSpan
-> HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
-> LHsExprArgIn
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
noSrcSpan LHsWcType (NoGhcTc GhcRn)
HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
ty1 LHsExprArgIn -> [LHsExprArgIn] -> [LHsExprArgIn]
forall a. a -> [a] -> [a]
: [LHsExprArgIn]
args) ExpSigmaType
res_ty

tcApp m_herald :: Maybe SDoc
m_herald fun :: LHsExpr GhcRn
fun@(L loc :: SrcSpan
loc (HsRecFld _ fld_lbl :: AmbiguousFieldOcc GhcRn
fld_lbl)) args :: [LHsExprArgIn]
args res_ty :: ExpSigmaType
res_ty
  | Ambiguous _ lbl :: Located RdrName
lbl        <- AmbiguousFieldOcc GhcRn
fld_lbl  -- Still ambiguous
  , HsValArg (L _ arg :: HsExpr GhcRn
arg) : _ <- (LHsExprArgIn -> Bool) -> [LHsExprArgIn] -> [LHsExprArgIn]
forall a. (a -> Bool) -> [a] -> [a]
filterOut LHsExprArgIn -> Bool
forall tm ty. HsArg tm ty -> Bool
isArgPar [LHsExprArgIn]
args -- A value arg is first
  , Just sig_ty :: LHsSigWcType GhcRn
sig_ty     <- HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig HsExpr GhcRn
arg  -- A type sig on the arg disambiguates
  = do { TcSigmaType
sig_tc_ty <- UserTypeCtxt -> LHsSigWcType GhcRn -> TcM TcSigmaType
tcHsSigWcType UserTypeCtxt
ExprSigCtxt LHsSigWcType GhcRn
sig_ty
       ; Name
sel_name  <- Located RdrName -> TcSigmaType -> TcM Name
disambiguateSelector Located RdrName
lbl TcSigmaType
sig_tc_ty
       ; (tc_fun :: HsExpr GhcTcId
tc_fun, fun_ty :: TcSigmaType
fun_ty) <- AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferRecSelId (XUnambiguous GhcRn -> Located RdrName -> AmbiguousFieldOcc GhcRn
forall pass.
XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Unambiguous Name
XUnambiguous GhcRn
sel_name Located RdrName
lbl)
       ; Maybe SDoc
-> LHsExpr GhcRn
-> LHsExpr GhcTcId
-> TcSigmaType
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcFunApp Maybe SDoc
m_herald LHsExpr GhcRn
fun (SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsExpr GhcTcId
tc_fun) TcSigmaType
fun_ty [LHsExprArgIn]
args ExpSigmaType
res_ty }

tcApp m_herald :: Maybe SDoc
m_herald fun :: LHsExpr GhcRn
fun@(L loc :: SrcSpan
loc (HsVar _ (L _ fun_id :: IdP GhcRn
fun_id))) args :: [LHsExprArgIn]
args res_ty :: ExpSigmaType
res_ty
  -- Special typing rule for tagToEnum#
  | Name
IdP GhcRn
fun_id Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tagToEnumKey
  , Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1
  = SrcSpan
-> Name
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcTagToEnum SrcSpan
loc Name
IdP GhcRn
fun_id [LHsExprArgIn]
args ExpSigmaType
res_ty

  -- Special typing rule for 'seq'
  -- In the saturated case, behave as if seq had type
  --    forall a (b::TYPE r). a -> b -> b
  -- for some type r.  See Note [Typing rule for seq]
  | Name
IdP GhcRn
fun_id Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
seqIdKey
  , Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2
  = do { TcSigmaType
rep <- TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
runtimeRepTy
       ; let [alpha :: EvVar
alpha, beta :: EvVar
beta] = [TcSigmaType] -> [EvVar]
mkTemplateTyVars [TcSigmaType
liftedTypeKind, TcSigmaType -> TcSigmaType
tYPE TcSigmaType
rep]
             seq_ty :: TcSigmaType
seq_ty = [EvVar] -> TcSigmaType -> TcSigmaType
mkSpecForAllTys [EvVar
alpha,EvVar
beta]
                      (EvVar -> TcSigmaType
mkTyVarTy EvVar
alpha TcSigmaType -> TcSigmaType -> TcSigmaType
`mkFunTy` EvVar -> TcSigmaType
mkTyVarTy EvVar
beta TcSigmaType -> TcSigmaType -> TcSigmaType
`mkFunTy` EvVar -> TcSigmaType
mkTyVarTy EvVar
beta)
             seq_fun :: LHsExpr GhcTcId
seq_fun = SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExt
noExt (SrcSpan -> EvVar -> Located EvVar
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc EvVar
seqId))
             -- seq_ty = forall (a:*) (b:TYPE r). a -> b -> b
             -- where 'r' is a meta type variable
        ; Maybe SDoc
-> LHsExpr GhcRn
-> LHsExpr GhcTcId
-> TcSigmaType
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcFunApp Maybe SDoc
m_herald LHsExpr GhcRn
fun LHsExpr GhcTcId
seq_fun TcSigmaType
seq_ty [LHsExprArgIn]
args ExpSigmaType
res_ty }
  where
    n_val_args :: Int
n_val_args = (LHsExprArgIn -> Bool) -> [LHsExprArgIn] -> Int
forall a. (a -> Bool) -> [a] -> Int
count LHsExprArgIn -> Bool
forall tm ty. HsArg tm ty -> Bool
isHsValArg [LHsExprArgIn]
args

tcApp _ (L loc :: SrcSpan
loc (ExplicitList _ Nothing [])) [HsTypeArg _ ty_arg :: HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
ty_arg] res_ty :: ExpSigmaType
res_ty
  -- See Note [Visible type application for the empty list constructor]
  = do { TcSigmaType
ty_arg' <- HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
-> TcSigmaType -> TcM TcSigmaType
tcHsTypeApp HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
ty_arg TcSigmaType
liftedTypeKind
       ; let list_ty :: TcSigmaType
list_ty = TyCon -> [TcSigmaType] -> TcSigmaType
TyConApp TyCon
listTyCon [TcSigmaType
ty_arg']
       ; HsWrapper
_ <- CtOrigin
-> UserTypeCtxt -> TcSigmaType -> ExpSigmaType -> TcM HsWrapper
tcSubTypeDS (Name -> CtOrigin
OccurrenceOf Name
nilDataConName) UserTypeCtxt
GenSigCtxt
                          TcSigmaType
list_ty ExpSigmaType
res_ty
       ; let expr :: LHsExpr GhcTcId
             expr :: LHsExpr GhcTcId
expr = SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsExpr GhcTcId -> LHsExpr GhcTcId)
-> HsExpr GhcTcId -> LHsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcTcId
-> Maybe (SyntaxExpr GhcTcId)
-> [LHsExpr GhcTcId]
-> HsExpr GhcTcId
forall p.
XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p
ExplicitList TcSigmaType
XExplicitList GhcTcId
ty_arg' Maybe (SyntaxExpr GhcTcId)
forall a. Maybe a
Nothing []
       ; (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
idHsWrapper, LHsExpr GhcTcId
expr, []) }

tcApp m_herald :: Maybe SDoc
m_herald fun :: LHsExpr GhcRn
fun args :: [LHsExprArgIn]
args res_ty :: ExpSigmaType
res_ty
  = do { (tc_fun :: LHsExpr GhcTcId
tc_fun, fun_ty :: TcSigmaType
fun_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferFun LHsExpr GhcRn
fun
       ; Maybe SDoc
-> LHsExpr GhcRn
-> LHsExpr GhcTcId
-> TcSigmaType
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcFunApp Maybe SDoc
m_herald LHsExpr GhcRn
fun LHsExpr GhcTcId
tc_fun TcSigmaType
fun_ty [LHsExprArgIn]
args ExpSigmaType
res_ty }

---------------------
tcFunApp :: Maybe SDoc  -- like "The function `f' is applied to"
                        -- or leave out to get exactly that message
         -> LHsExpr GhcRn                  -- Renamed function
         -> LHsExpr GhcTcId -> TcSigmaType -- Function and its type
         -> [LHsExprArgIn]                 -- Arguments
         -> ExpRhoType                     -- Overall result type
         -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
            -- (wrapper-for-result, fun, args)
            -- For an ordinary function application,
            -- these should be assembled as wrap_res[ fun args ]
            -- But OpApp is slightly different, so that's why the caller
            -- must assemble

-- tcFunApp deals with the general case;
-- the special cases are handled by tcApp
tcFunApp :: Maybe SDoc
-> LHsExpr GhcRn
-> LHsExpr GhcTcId
-> TcSigmaType
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcFunApp m_herald :: Maybe SDoc
m_herald rn_fun :: LHsExpr GhcRn
rn_fun tc_fun :: LHsExpr GhcTcId
tc_fun fun_sigma :: TcSigmaType
fun_sigma rn_args :: [LHsExprArgIn]
rn_args res_ty :: ExpSigmaType
res_ty
  = do { let orig :: CtOrigin
orig = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
rn_fun

       ; String -> SDoc -> TcRn ()
traceTc "tcFunApp" (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
rn_fun SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
fun_sigma SDoc -> SDoc -> SDoc
$$ [LHsExprArgIn] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsExprArgIn]
rn_args SDoc -> SDoc -> SDoc
$$ ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
res_ty)
       ; (wrap_fun :: HsWrapper
wrap_fun, tc_args :: [LHsExprArgOut]
tc_args, actual_res_ty :: TcSigmaType
actual_res_ty)
           <- LHsExpr GhcRn
-> TcSigmaType
-> CtOrigin
-> [LHsExprArgIn]
-> SDoc
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
tcArgs LHsExpr GhcRn
rn_fun TcSigmaType
fun_sigma CtOrigin
orig [LHsExprArgIn]
rn_args
                     (Maybe SDoc
m_herald Maybe SDoc -> SDoc -> SDoc
forall a. Maybe a -> a -> a
`orElse` LHsExpr GhcRn -> [LHsExprArgIn] -> SDoc
mk_app_msg LHsExpr GhcRn
rn_fun [LHsExprArgIn]
rn_args)

            -- this is just like tcWrapResult, but the types don't line
            -- up to call that function
       ; HsWrapper
wrap_res <- Bool
-> HsExpr GhcRn
-> TcSigmaType
-> ExpSigmaType
-> TcM HsWrapper
-> TcM HsWrapper
forall a.
Bool
-> HsExpr GhcRn -> TcSigmaType -> ExpSigmaType -> TcM a -> TcM a
addFunResCtxt Bool
True (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
rn_fun) TcSigmaType
actual_res_ty ExpSigmaType
res_ty (TcM HsWrapper -> TcM HsWrapper) -> TcM HsWrapper -> TcM HsWrapper
forall a b. (a -> b) -> a -> b
$
                     CtOrigin
-> UserTypeCtxt
-> Maybe (HsExpr GhcRn)
-> TcSigmaType
-> ExpSigmaType
-> TcM HsWrapper
tcSubTypeDS_NC_O CtOrigin
orig UserTypeCtxt
GenSigCtxt
                       (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (HsExpr GhcRn -> Maybe (HsExpr GhcRn))
-> HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> HsExpr GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LHsExpr GhcRn -> HsExpr GhcRn) -> LHsExpr GhcRn -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> [LHsExprArgIn] -> LHsExpr GhcRn
forall (id :: Pass).
(NoGhcTc (GhcPass id) ~ GhcRn) =>
LHsExpr (GhcPass id)
-> [HsArg
      (LHsExpr (GhcPass id))
      (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
-> LHsExpr (GhcPass id)
wrapHsArgs LHsExpr GhcRn
rn_fun [LHsExprArgIn]
rn_args)
                       TcSigmaType
actual_res_ty ExpSigmaType
res_ty

       ; (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
wrap_res, HsWrapper -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
wrap_fun LHsExpr GhcTcId
tc_fun, [LHsExprArgOut]
tc_args) }

mk_app_msg :: LHsExpr GhcRn -> [LHsExprArgIn] -> SDoc
mk_app_msg :: LHsExpr GhcRn -> [LHsExprArgIn] -> SDoc
mk_app_msg fun :: LHsExpr GhcRn
fun args :: [LHsExprArgIn]
args = [SDoc] -> SDoc
sep [ String -> SDoc
text "The" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
what SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
expr)
                          , String -> SDoc
text "is applied to"]
  where
    what :: String
what | [HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))]
type_app_args = "function"
         | Bool
otherwise          = "expression"
    -- Include visible type arguments (but not other arguments) in the herald.
    -- See Note [Herald for matchExpectedFunTys] in TcUnify.
    expr :: LHsExpr GhcRn
expr = LHsExpr GhcRn
-> [HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))]
-> LHsExpr GhcRn
mkHsAppTypes LHsExpr GhcRn
fun [HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))]
type_app_args
    type_app_args :: [HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))]
type_app_args = [HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
hs_ty | HsTypeArg _ hs_ty :: HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
hs_ty <- [LHsExprArgIn]
args]

mk_op_msg :: LHsExpr GhcRn -> SDoc
mk_op_msg :: LHsExpr GhcRn -> SDoc
mk_op_msg op :: LHsExpr GhcRn
op = String -> SDoc
text "The operator" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
op) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "takes"

{-
Note [Visible type application for the empty list constructor]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Getting the expression [] @Int to typecheck is slightly tricky since [] isn't
an ordinary data constructor. By default, when tcExpr typechecks a list
expression, it wraps the expression in a coercion, which gives it a type to the
effect of p[a]. It isn't until later zonking that the type becomes
forall a. [a], but that's too late for visible type application.

The workaround is to check for empty list expressions that have a visible type
argument in tcApp, and if so, directly typecheck [] @ty data constructor name.
This avoids the intermediate coercion and produces an expression of type [ty],
as one would intuitively expect.

Unfortunately, this workaround isn't terribly robust, since more involved
expressions such as (let in []) @Int won't work. Until a more elegant fix comes
along, however, this at least allows direct type application on [] to work,
which is better than before.
-}

----------------
tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
-- Infer type of a function
tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferFun (L loc :: SrcSpan
loc (HsVar _ (L _ name :: IdP GhcRn
name)))
  = do { (fun :: HsExpr GhcTcId
fun, ty :: TcSigmaType
ty) <- SrcSpan
-> TcM (HsExpr GhcTcId, TcSigmaType)
-> TcM (HsExpr GhcTcId, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferId Name
IdP GhcRn
name)
               -- Don't wrap a context around a plain Id
       ; (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsExpr GhcTcId
fun, TcSigmaType
ty) }

tcInferFun (L loc :: SrcSpan
loc (HsRecFld _ f :: AmbiguousFieldOcc GhcRn
f))
  = do { (fun :: HsExpr GhcTcId
fun, ty :: TcSigmaType
ty) <- SrcSpan
-> TcM (HsExpr GhcTcId, TcSigmaType)
-> TcM (HsExpr GhcTcId, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferRecSelId AmbiguousFieldOcc GhcRn
f)
               -- Don't wrap a context around a plain Id
       ; (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsExpr GhcTcId
fun, TcSigmaType
ty) }

tcInferFun fun :: LHsExpr GhcRn
fun
  = LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferSigma LHsExpr GhcRn
fun
      -- NB: tcInferSigma; see TcUnify
      -- Note [Deep instantiation of InferResult]


----------------
-- | Type-check the arguments to a function, possibly including visible type
-- applications
tcArgs :: LHsExpr GhcRn   -- ^ The function itself (for err msgs only)
       -> TcSigmaType    -- ^ the (uninstantiated) type of the function
       -> CtOrigin       -- ^ the origin for the function's type
       -> [LHsExprArgIn] -- ^ the args
       -> SDoc           -- ^ the herald for matchActualFunTys
       -> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
          -- ^ (a wrapper for the function, the tc'd args, result type)
tcArgs :: LHsExpr GhcRn
-> TcSigmaType
-> CtOrigin
-> [LHsExprArgIn]
-> SDoc
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
tcArgs fun :: LHsExpr GhcRn
fun orig_fun_ty :: TcSigmaType
orig_fun_ty fun_orig :: CtOrigin
fun_orig orig_args :: [LHsExprArgIn]
orig_args herald :: SDoc
herald
  = [TcSigmaType]
-> Int
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
go [] 1 TcSigmaType
orig_fun_ty [LHsExprArgIn]
orig_args
  where
    -- Don't count visible type arguments when determining how many arguments
    -- an expression is given in an arity mismatch error, since visible type
    -- arguments reported as a part of the expression herald itself.
    -- See Note [Herald for matchExpectedFunTys] in TcUnify.
    orig_expr_args_arity :: Int
orig_expr_args_arity = (LHsExprArgIn -> Bool) -> [LHsExprArgIn] -> Int
forall a. (a -> Bool) -> [a] -> Int
count LHsExprArgIn -> Bool
forall tm ty. HsArg tm ty -> Bool
isHsValArg [LHsExprArgIn]
orig_args

    go :: [TcSigmaType]
-> Int
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
go _ _ fun_ty :: TcSigmaType
fun_ty [] = (HsWrapper, [LHsExprArgOut], TcSigmaType)
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
idHsWrapper, [], TcSigmaType
fun_ty)

    go acc_args :: [TcSigmaType]
acc_args n :: Int
n fun_ty :: TcSigmaType
fun_ty (HsArgPar sp :: SrcSpan
sp : args :: [LHsExprArgIn]
args)
      = do { (inner_wrap :: HsWrapper
inner_wrap, args' :: [LHsExprArgOut]
args', res_ty :: TcSigmaType
res_ty) <- [TcSigmaType]
-> Int
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
go [TcSigmaType]
acc_args Int
n TcSigmaType
fun_ty [LHsExprArgIn]
args
           ; (HsWrapper, [LHsExprArgOut], TcSigmaType)
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
inner_wrap, SrcSpan -> LHsExprArgOut
forall tm ty. SrcSpan -> HsArg tm ty
HsArgPar SrcSpan
sp LHsExprArgOut -> [LHsExprArgOut] -> [LHsExprArgOut]
forall a. a -> [a] -> [a]
: [LHsExprArgOut]
args', TcSigmaType
res_ty)
           }

    go acc_args :: [TcSigmaType]
acc_args n :: Int
n fun_ty :: TcSigmaType
fun_ty (HsTypeArg l :: SrcSpan
l hs_ty_arg :: HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
hs_ty_arg : args :: [LHsExprArgIn]
args)
      = do { (wrap1 :: HsWrapper
wrap1, upsilon_ty :: TcSigmaType
upsilon_ty) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiateInferred CtOrigin
fun_orig TcSigmaType
fun_ty
               -- wrap1 :: fun_ty "->" upsilon_ty
           ; case TcSigmaType -> Maybe (TyVarBinder, TcSigmaType)
tcSplitForAllTy_maybe TcSigmaType
upsilon_ty of
               Just (tvb :: TyVarBinder
tvb, inner_ty :: TcSigmaType
inner_ty)
                 | TyVarBinder -> ArgFlag
forall tv argf. VarBndr tv argf -> argf
binderArgFlag TyVarBinder
tvb ArgFlag -> ArgFlag -> Bool
forall a. Eq a => a -> a -> Bool
== ArgFlag
Specified ->
                   -- It really can't be Inferred, because we've justn
                   -- instantiated those. But, oddly, it might just be Required.
                   -- See Note [Required quantifiers in the type of a term]
                 do { let tv :: EvVar
tv   = TyVarBinder -> EvVar
forall tv argf. VarBndr tv argf -> tv
binderVar TyVarBinder
tvb
                          kind :: TcSigmaType
kind = EvVar -> TcSigmaType
tyVarKind EvVar
tv
                    ; TcSigmaType
ty_arg <- HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
-> TcSigmaType -> TcM TcSigmaType
tcHsTypeApp HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
hs_ty_arg TcSigmaType
kind

                    ; TcSigmaType
inner_ty <- TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
inner_ty
                          -- See Note [Visible type application zonk]
                    ; let in_scope :: InScopeSet
in_scope  = VarSet -> InScopeSet
mkInScopeSet ([TcSigmaType] -> VarSet
tyCoVarsOfTypes [TcSigmaType
upsilon_ty, TcSigmaType
ty_arg])

                          insted_ty :: TcSigmaType
insted_ty = InScopeSet
-> [EvVar] -> [TcSigmaType] -> TcSigmaType -> TcSigmaType
substTyWithInScope InScopeSet
in_scope [EvVar
tv] [TcSigmaType
ty_arg] TcSigmaType
inner_ty
                                      -- NB: tv and ty_arg have the same kind, so this
                                      --     substitution is kind-respecting
                    ; String -> SDoc -> TcRn ()
traceTc "VTA" ([SDoc] -> SDoc
vcat [EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvVar
tv, TcSigmaType -> SDoc
debugPprType TcSigmaType
kind
                                          , TcSigmaType -> SDoc
debugPprType TcSigmaType
ty_arg
                                          , TcSigmaType -> SDoc
debugPprType (HasDebugCallStack => TcSigmaType -> TcSigmaType
TcSigmaType -> TcSigmaType
tcTypeKind TcSigmaType
ty_arg)
                                          , TcSigmaType -> SDoc
debugPprType TcSigmaType
inner_ty
                                          , TcSigmaType -> SDoc
debugPprType TcSigmaType
insted_ty ])

                    ; (inner_wrap :: HsWrapper
inner_wrap, args' :: [LHsExprArgOut]
args', res_ty :: TcSigmaType
res_ty)
                        <- [TcSigmaType]
-> Int
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
go [TcSigmaType]
acc_args (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) TcSigmaType
insted_ty [LHsExprArgIn]
args
                   -- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty
                    ; let inst_wrap :: HsWrapper
inst_wrap = [TcSigmaType] -> HsWrapper
mkWpTyApps [TcSigmaType
ty_arg]
                    ; (HsWrapper, [LHsExprArgOut], TcSigmaType)
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper
inner_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
inst_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap1
                             , SrcSpan
-> HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
-> LHsExprArgOut
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
l HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
hs_ty_arg LHsExprArgOut -> [LHsExprArgOut] -> [LHsExprArgOut]
forall a. a -> [a] -> [a]
: [LHsExprArgOut]
args'
                             , TcSigmaType
res_ty ) }
               _ -> TcSigmaType
-> HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
forall a b.
Outputable a =>
TcSigmaType -> a -> IOEnv (Env TcGblEnv TcLclEnv) b
ty_app_err TcSigmaType
upsilon_ty HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
hs_ty_arg }

    go acc_args :: [TcSigmaType]
acc_args n :: Int
n fun_ty :: TcSigmaType
fun_ty (HsValArg arg :: LHsExpr GhcRn
arg : args :: [LHsExprArgIn]
args)
      = do { (wrap :: HsWrapper
wrap, [arg_ty :: TcSigmaType
arg_ty], res_ty :: TcSigmaType
res_ty)
               <- SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> Int
-> TcSigmaType
-> [TcSigmaType]
-> Int
-> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
matchActualFunTysPart SDoc
herald CtOrigin
fun_orig (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
fun)) 1 TcSigmaType
fun_ty
                                        [TcSigmaType]
acc_args Int
orig_expr_args_arity
               -- wrap :: fun_ty "->" arg_ty -> res_ty
           ; LHsExpr GhcTcId
arg' <- LHsExpr GhcRn
-> LHsExpr GhcRn -> TcSigmaType -> Int -> TcM (LHsExpr GhcTcId)
tcArg LHsExpr GhcRn
fun LHsExpr GhcRn
arg TcSigmaType
arg_ty Int
n
           ; (inner_wrap :: HsWrapper
inner_wrap, args' :: [LHsExprArgOut]
args', inner_res_ty :: TcSigmaType
inner_res_ty)
               <- [TcSigmaType]
-> Int
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
go (TcSigmaType
arg_ty TcSigmaType -> [TcSigmaType] -> [TcSigmaType]
forall a. a -> [a] -> [a]
: [TcSigmaType]
acc_args) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) TcSigmaType
res_ty [LHsExprArgIn]
args
               -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty
           ; (HsWrapper, [LHsExprArgOut], TcSigmaType)
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper
-> HsWrapper -> TcSigmaType -> TcSigmaType -> SDoc -> HsWrapper
mkWpFun HsWrapper
idHsWrapper HsWrapper
inner_wrap TcSigmaType
arg_ty TcSigmaType
res_ty SDoc
doc HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap
                    , LHsExpr GhcTcId -> LHsExprArgOut
forall tm ty. tm -> HsArg tm ty
HsValArg LHsExpr GhcTcId
arg' LHsExprArgOut -> [LHsExprArgOut] -> [LHsExprArgOut]
forall a. a -> [a] -> [a]
: [LHsExprArgOut]
args'
                    , TcSigmaType
inner_res_ty ) }
      where
        doc :: SDoc
doc = String -> SDoc
text "When checking the" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakNth Int
n SDoc -> SDoc -> SDoc
<+>
              String -> SDoc
text "argument to" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
fun)

    ty_app_err :: TcSigmaType -> a -> IOEnv (Env TcGblEnv TcLclEnv) b
ty_app_err ty :: TcSigmaType
ty arg :: a
arg
      = do { (_, ty :: TcSigmaType
ty) <- TidyEnv -> TcSigmaType -> TcM (TidyEnv, TcSigmaType)
zonkTidyTcType TidyEnv
emptyTidyEnv TcSigmaType
ty
           ; SDoc -> IOEnv (Env TcGblEnv TcLclEnv) b
forall a. SDoc -> TcRn a
failWith (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) b)
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) b
forall a b. (a -> b) -> a -> b
$
               String -> SDoc
text "Cannot apply expression of type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
ty) SDoc -> SDoc -> SDoc
$$
               String -> SDoc
text "to a visible type argument" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
arg) }

{- Note [Required quantifiers in the type of a term]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (Trac #15859)

  data A k :: k -> Type      -- A      :: forall k -> k -> Type
  type KindOf (a :: k) = k   -- KindOf :: forall k. k -> Type
  a = (undefind :: KindOf A) @Int

With ImpredicativeTypes (thin ice, I know), we instantiate
KindOf at type (forall k -> k -> Type), so
  KindOf A = forall k -> k -> Type
whose first argument is Required

We want to reject this type application to Int, but in earlier
GHCs we had an ASSERT that Required could not occur here.

The ice is thin; c.f. Note [No Required TyCoBinder in terms]
in TyCoRep.

Note [Visible type application zonk]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg).

* tcHsTypeApp only guarantees that
    - ty_arg is zonked
    - kind(zonk(tv)) = kind(ty_arg)
  (checkExpectedKind zonks as it goes).

So we must zonk inner_ty as well, to guarantee consistency between zonk(tv)
and inner_ty.  Otherwise we can build an ill-kinded type.  An example was
Trac #14158, where we had:
   id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a
and we had the visible type application
  id @(->)

* We instantiated k := kappa, yielding
    forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a
* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *).
* That instantiated (->) as ((->) q1 q1), and unified kappa := q1,
  Here q1 :: RuntimeRep
* Now we substitute
     cat  :->  (->) q1 q1 :: TYPE q1 -> TYPE q1 -> *
  but we must first zonk the inner_ty to get
      forall (a :: TYPE q1). cat a a
  so that the result of substitution is well-kinded
  Failing to do so led to Trac #14158.
-}

----------------
tcArg :: LHsExpr GhcRn                   -- The function (for error messages)
      -> LHsExpr GhcRn                   -- Actual arguments
      -> TcRhoType                       -- expected arg type
      -> Int                             -- # of argument
      -> TcM (LHsExpr GhcTcId)           -- Resulting argument
tcArg :: LHsExpr GhcRn
-> LHsExpr GhcRn -> TcSigmaType -> Int -> TcM (LHsExpr GhcTcId)
tcArg fun :: LHsExpr GhcRn
fun arg :: LHsExpr GhcRn
arg ty :: TcSigmaType
ty arg_no :: Int
arg_no = SDoc -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsExpr GhcRn -> LHsExpr GhcRn -> Int -> SDoc
forall fun arg.
(Outputable fun, Outputable arg) =>
fun -> arg -> Int -> SDoc
funAppCtxt LHsExpr GhcRn
fun LHsExpr GhcRn
arg Int
arg_no) (TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                          LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExprNC LHsExpr GhcRn
arg TcSigmaType
ty

----------------
tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTcId]
tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTcId]
tcTupArgs args :: [LHsTupArg GhcRn]
args tys :: [TcSigmaType]
tys
  = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
  where
    go :: (GenLocated l (HsTupArg GhcRn), TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcTcId))
go (L l :: l
l (Missing {}),   arg_ty :: TcSigmaType
arg_ty) = GenLocated l (HsTupArg GhcTcId)
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
return (l -> HsTupArg GhcTcId -> GenLocated l (HsTupArg GhcTcId)
forall l e. l -> e -> GenLocated l e
L l
l (XMissing GhcTcId -> HsTupArg GhcTcId
forall id. XMissing id -> HsTupArg id
Missing TcSigmaType
XMissing GhcTcId
arg_ty))
    go (L l :: l
l (Present x :: XPresent GhcRn
x expr :: LHsExpr GhcRn
expr), arg_ty :: TcSigmaType
arg_ty) = do { LHsExpr GhcTcId
expr' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
expr TcSigmaType
arg_ty
                                           ; GenLocated l (HsTupArg GhcTcId)
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
return (l -> HsTupArg GhcTcId -> GenLocated l (HsTupArg GhcTcId)
forall l e. l -> e -> GenLocated l e
L l
l (XPresent GhcTcId -> LHsExpr GhcTcId -> HsTupArg GhcTcId
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcRn
XPresent GhcTcId
x LHsExpr GhcTcId
expr')) }
    go (L _ (XTupArg{}), _) = String
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcTcId))
forall a. String -> a
panic "tcTupArgs"

---------------------------
-- See TcType.SyntaxOpType also for commentary
tcSyntaxOp :: CtOrigin
           -> SyntaxExpr GhcRn
           -> [SyntaxOpType]           -- ^ shape of syntax operator arguments
           -> ExpRhoType               -- ^ overall result type
           -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments
           -> TcM (a, SyntaxExpr GhcTcId)
-- ^ Typecheck a syntax operator
-- The operator is a variable or a lambda at this stage (i.e. renamer
-- output)
tcSyntaxOp :: CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp orig :: CtOrigin
orig expr :: SyntaxExpr GhcRn
expr arg_tys :: [SyntaxOpType]
arg_tys res_ty :: ExpSigmaType
res_ty
  = CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOpGen CtOrigin
orig SyntaxExpr GhcRn
expr [SyntaxOpType]
arg_tys (ExpSigmaType -> SyntaxOpType
SynType ExpSigmaType
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
              -> SyntaxExpr GhcRn
              -> [SyntaxOpType]
              -> SyntaxOpType
              -> ([TcSigmaType] -> TcM a)
              -> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOpGen :: CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOpGen orig :: CtOrigin
orig op :: SyntaxExpr GhcRn
op arg_tys :: [SyntaxOpType]
arg_tys res_ty :: SyntaxOpType
res_ty thing_inside :: [TcSigmaType] -> TcM a
thing_inside
  = do { (expr :: LHsExpr GhcTcId
expr, sigma :: TcSigmaType
sigma) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferSigma (LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType))
-> LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn)
-> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ SyntaxExpr GhcRn -> HsExpr GhcRn
forall p. SyntaxExpr p -> HsExpr p
syn_expr SyntaxExpr GhcRn
op
       ; (result :: a
result, expr_wrap :: HsWrapper
expr_wrap, arg_wraps :: [HsWrapper]
arg_wraps, res_wrap :: HsWrapper
res_wrap)
           <- CtOrigin
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall a.
CtOrigin
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig TcSigmaType
sigma [SyntaxOpType]
arg_tys SyntaxOpType
res_ty (([TcSigmaType] -> TcM a)
 -> TcM (a, HsWrapper, [HsWrapper], HsWrapper))
-> ([TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall a b. (a -> b) -> a -> b
$
              [TcSigmaType] -> TcM a
thing_inside
       ; (a, SyntaxExpr GhcTcId) -> TcM (a, SyntaxExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, SyntaxExpr :: forall p. HsExpr p -> [HsWrapper] -> HsWrapper -> SyntaxExpr p
SyntaxExpr { syn_expr :: HsExpr GhcTcId
syn_expr = HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
expr_wrap (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcTcId -> SrcSpanLess (LHsExpr GhcTcId)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcTcId
expr
                                    , syn_arg_wraps :: [HsWrapper]
syn_arg_wraps = [HsWrapper]
arg_wraps
                                    , syn_res_wrap :: HsWrapper
syn_res_wrap  = HsWrapper
res_wrap }) }

{-
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] -> TcM a)    -- ^ check the arguments
          -> TcM (a, HsWrapper)
           -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
tcSynArgE :: CtOrigin
-> TcSigmaType
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE orig :: CtOrigin
orig sigma_ty :: TcSigmaType
sigma_ty syn_ty :: SyntaxOpType
syn_ty thing_inside :: [TcSigmaType] -> TcM a
thing_inside
  = do { (skol_wrap :: HsWrapper
skol_wrap, (result :: a
result, ty_wrapper :: HsWrapper
ty_wrapper))
           <- UserTypeCtxt
-> TcSigmaType
-> ([EvVar] -> TcSigmaType -> TcM (a, HsWrapper))
-> TcM (HsWrapper, (a, HsWrapper))
forall result.
UserTypeCtxt
-> TcSigmaType
-> ([EvVar] -> TcSigmaType -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemise UserTypeCtxt
GenSigCtxt TcSigmaType
sigma_ty (([EvVar] -> TcSigmaType -> TcM (a, HsWrapper))
 -> TcM (HsWrapper, (a, HsWrapper)))
-> ([EvVar] -> TcSigmaType -> TcM (a, HsWrapper))
-> TcM (HsWrapper, (a, HsWrapper))
forall a b. (a -> b) -> a -> b
$ \ _ rho_ty :: TcSigmaType
rho_ty ->
              TcSigmaType -> SyntaxOpType -> TcM (a, HsWrapper)
go TcSigmaType
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 :: TcSigmaType -> SyntaxOpType -> TcM (a, HsWrapper)
go rho_ty :: TcSigmaType
rho_ty SynAny
      = do { a
result <- [TcSigmaType] -> TcM a
thing_inside [TcSigmaType
rho_ty]
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }

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

    go rho_ty :: TcSigmaType
rho_ty SynList
      = do { (list_co :: TcCoercionR
list_co, elt_ty :: TcSigmaType
elt_ty) <- TcSigmaType -> TcM (TcCoercionR, TcSigmaType)
matchExpectedListTy TcSigmaType
rho_ty
           ; a
result <- [TcSigmaType] -> TcM a
thing_inside [TcSigmaType
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 rho_ty :: TcSigmaType
rho_ty (SynFun arg_shape :: SyntaxOpType
arg_shape res_shape :: SyntaxOpType
res_shape)
      = do { ( ( ( (result :: a
result, arg_ty :: TcSigmaType
arg_ty, res_ty :: TcSigmaType
res_ty)
                 , res_wrapper :: HsWrapper
res_wrapper )                   -- :: res_ty_out "->" res_ty
               , arg_wrapper1 :: HsWrapper
arg_wrapper1, [], arg_wrapper2 :: HsWrapper
arg_wrapper2 )  -- :: arg_ty "->" arg_ty_out
             , match_wrapper :: HsWrapper
match_wrapper )         -- :: (arg_ty -> res_ty) "->" rho_ty
               <- SDoc
-> Int
-> ExpSigmaType
-> ([ExpSigmaType]
    -> ExpSigmaType
    -> TcM
         (((a, TcSigmaType, TcSigmaType), HsWrapper), HsWrapper,
          [HsWrapper], HsWrapper))
-> TcM
     ((((a, TcSigmaType, TcSigmaType), HsWrapper), HsWrapper,
       [HsWrapper], HsWrapper),
      HsWrapper)
forall a.
SDoc
-> Int
-> ExpSigmaType
-> ([ExpSigmaType] -> ExpSigmaType -> TcM a)
-> TcM (a, HsWrapper)
matchExpectedFunTys SDoc
herald 1 (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
rho_ty) (([ExpSigmaType]
  -> ExpSigmaType
  -> TcM
       (((a, TcSigmaType, TcSigmaType), HsWrapper), HsWrapper,
        [HsWrapper], HsWrapper))
 -> TcM
      ((((a, TcSigmaType, TcSigmaType), HsWrapper), HsWrapper,
        [HsWrapper], HsWrapper),
       HsWrapper))
-> ([ExpSigmaType]
    -> ExpSigmaType
    -> TcM
         (((a, TcSigmaType, TcSigmaType), HsWrapper), HsWrapper,
          [HsWrapper], HsWrapper))
-> TcM
     ((((a, TcSigmaType, TcSigmaType), HsWrapper), HsWrapper,
       [HsWrapper], HsWrapper),
      HsWrapper)
forall a b. (a -> b) -> a -> b
$
                  \ [arg_ty :: ExpSigmaType
arg_ty] res_ty :: ExpSigmaType
res_ty ->
                  do { TcSigmaType
arg_tc_ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
arg_ty
                     ; TcSigmaType
res_tc_ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
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 )

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

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

    go rho_ty :: TcSigmaType
rho_ty (SynType the_ty :: ExpSigmaType
the_ty)
      = do { HsWrapper
wrap   <- CtOrigin
-> UserTypeCtxt -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
tcSubTypeET CtOrigin
orig UserTypeCtxt
GenSigCtxt ExpSigmaType
the_ty TcSigmaType
rho_ty
           ; a
result <- [TcSigmaType] -> 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] -> 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 :: CtOrigin
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA orig :: CtOrigin
orig sigma_ty :: TcSigmaType
sigma_ty arg_shapes :: [SyntaxOpType]
arg_shapes res_shape :: SyntaxOpType
res_shape thing_inside :: [TcSigmaType] -> TcM a
thing_inside
  = do { (match_wrapper :: HsWrapper
match_wrapper, arg_tys :: [TcSigmaType]
arg_tys, res_ty :: TcSigmaType
res_ty)
           <- SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> Int
-> TcSigmaType
-> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
matchActualFunTys SDoc
herald CtOrigin
orig Maybe (HsExpr GhcRn)
forall a. Maybe a
Nothing ([SyntaxOpType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SyntaxOpType]
arg_shapes) TcSigmaType
sigma_ty
              -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
       ; ((result :: a
result, res_wrapper :: HsWrapper
res_wrapper), arg_wrappers :: [HsWrapper]
arg_wrappers)
           <- [TcSigmaType]
-> [SyntaxOpType]
-> ([TcSigmaType] -> TcM (a, HsWrapper))
-> TcM ((a, HsWrapper), [HsWrapper])
forall a.
[TcSigmaType]
-> [SyntaxOpType]
-> ([TcSigmaType] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e [TcSigmaType]
arg_tys [SyntaxOpType]
arg_shapes (([TcSigmaType] -> TcM (a, HsWrapper))
 -> TcM ((a, HsWrapper), [HsWrapper]))
-> ([TcSigmaType] -> TcM (a, HsWrapper))
-> TcM ((a, HsWrapper), [HsWrapper])
forall a b. (a -> b) -> a -> b
$ \ arg_results :: [TcSigmaType]
arg_results ->
              TcSigmaType
-> SyntaxOpType -> ([TcSigmaType] -> TcM a) -> TcM (a, HsWrapper)
forall a.
TcSigmaType
-> SyntaxOpType -> ([TcSigmaType] -> TcM a) -> TcM (a, HsWrapper)
tc_syn_arg    TcSigmaType
res_ty  SyntaxOpType
res_shape  (([TcSigmaType] -> TcM a) -> TcM (a, HsWrapper))
-> ([TcSigmaType] -> TcM a) -> TcM (a, HsWrapper)
forall a b. (a -> b) -> a -> b
$ \ res_results :: [TcSigmaType]
res_results ->
              [TcSigmaType] -> TcM a
thing_inside ([TcSigmaType]
arg_results [TcSigmaType] -> [TcSigmaType] -> [TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [TcSigmaType]
res_results)
       ; (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 "This rebindable syntax expects a function with"

    tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]
                  -> ([TcSigmaType] -> TcM a)
                  -> TcM (a, [HsWrapper])
                    -- the wrappers are for arguments
    tc_syn_args_e :: [TcSigmaType]
-> [SyntaxOpType]
-> ([TcSigmaType] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e (arg_ty :: TcSigmaType
arg_ty : arg_tys :: [TcSigmaType]
arg_tys) (arg_shape :: SyntaxOpType
arg_shape : arg_shapes :: [SyntaxOpType]
arg_shapes) thing_inside :: [TcSigmaType] -> TcM a
thing_inside
      = do { ((result :: a
result, arg_wraps :: [HsWrapper]
arg_wraps), arg_wrap :: HsWrapper
arg_wrap)
               <- CtOrigin
-> TcSigmaType
-> SyntaxOpType
-> ([TcSigmaType] -> TcM (a, [HsWrapper]))
-> TcM ((a, [HsWrapper]), HsWrapper)
forall a.
CtOrigin
-> TcSigmaType
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE     CtOrigin
orig TcSigmaType
arg_ty  SyntaxOpType
arg_shape  (([TcSigmaType] -> TcM (a, [HsWrapper]))
 -> TcM ((a, [HsWrapper]), HsWrapper))
-> ([TcSigmaType] -> TcM (a, [HsWrapper]))
-> TcM ((a, [HsWrapper]), HsWrapper)
forall a b. (a -> b) -> a -> b
$ \ arg1_results :: [TcSigmaType]
arg1_results ->
                  [TcSigmaType]
-> [SyntaxOpType]
-> ([TcSigmaType] -> TcM a)
-> TcM (a, [HsWrapper])
forall a.
[TcSigmaType]
-> [SyntaxOpType]
-> ([TcSigmaType] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e      [TcSigmaType]
arg_tys [SyntaxOpType]
arg_shapes (([TcSigmaType] -> TcM a) -> TcM (a, [HsWrapper]))
-> ([TcSigmaType] -> TcM a) -> TcM (a, [HsWrapper])
forall a b. (a -> b) -> a -> b
$ \ args_results :: [TcSigmaType]
args_results ->
                  [TcSigmaType] -> TcM a
thing_inside ([TcSigmaType]
arg1_results [TcSigmaType] -> [TcSigmaType] -> [TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [TcSigmaType]
args_results)
           ; (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 _ _ thing_inside :: [TcSigmaType] -> TcM a
thing_inside = (, []) (a -> (a, [HsWrapper])) -> TcM a -> TcM (a, [HsWrapper])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TcSigmaType] -> 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 :: TcSigmaType
-> SyntaxOpType -> ([TcSigmaType] -> TcM a) -> TcM (a, HsWrapper)
tc_syn_arg res_ty :: TcSigmaType
res_ty SynAny thing_inside :: [TcSigmaType] -> TcM a
thing_inside
      = do { a
result <- [TcSigmaType] -> TcM a
thing_inside [TcSigmaType
res_ty]
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }
    tc_syn_arg res_ty :: TcSigmaType
res_ty SynRho thing_inside :: [TcSigmaType] -> TcM a
thing_inside
      = do { (inst_wrap :: HsWrapper
inst_wrap, rho_ty :: TcSigmaType
rho_ty) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
deeplyInstantiate CtOrigin
orig TcSigmaType
res_ty
               -- inst_wrap :: res_ty "->" rho_ty
           ; a
result <- [TcSigmaType] -> TcM a
thing_inside [TcSigmaType
rho_ty]
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
inst_wrap) }
    tc_syn_arg res_ty :: TcSigmaType
res_ty SynList thing_inside :: [TcSigmaType] -> TcM a
thing_inside
      = do { (inst_wrap :: HsWrapper
inst_wrap, rho_ty :: TcSigmaType
rho_ty) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate CtOrigin
orig TcSigmaType
res_ty
               -- inst_wrap :: res_ty "->" rho_ty
           ; (list_co :: TcCoercionR
list_co, elt_ty :: TcSigmaType
elt_ty)   <- TcSigmaType -> TcM (TcCoercionR, TcSigmaType)
matchExpectedListTy TcSigmaType
rho_ty
               -- list_co :: [elt_ty] ~N rho_ty
           ; a
result <- [TcSigmaType] -> TcM a
thing_inside [TcSigmaType
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 _ (SynFun {}) _
      = String -> SDoc -> TcM (a, HsWrapper)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tcSynArgA hits a SynFun" (CtOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr CtOrigin
orig)
    tc_syn_arg res_ty :: TcSigmaType
res_ty (SynType the_ty :: ExpSigmaType
the_ty) thing_inside :: [TcSigmaType] -> TcM a
thing_inside
      = do { HsWrapper
wrap   <- CtOrigin
-> UserTypeCtxt -> TcSigmaType -> ExpSigmaType -> TcM HsWrapper
tcSubTypeO CtOrigin
orig UserTypeCtxt
GenSigCtxt TcSigmaType
res_ty ExpSigmaType
the_ty
           ; a
result <- [TcSigmaType] -> 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.

************************************************************************
*                                                                      *
                Expressions with a type signature
                        expr :: type
*                                                                      *
********************************************************************* -}

tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTcId, TcType)
tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcExprSig expr :: LHsExpr GhcRn
expr (CompleteSig { sig_bndr :: TcIdSigInfo -> EvVar
sig_bndr = EvVar
poly_id, sig_loc :: TcIdSigInfo -> SrcSpan
sig_loc = SrcSpan
loc })
  = SrcSpan
-> TcM (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTcId, TcSigmaType)
 -> TcM (LHsExpr GhcTcId, TcSigmaType))
-> TcM (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall a b. (a -> b) -> a -> b
$   -- Sets the location for the implication constraint
    do { (tv_prs :: [(Name, EvVar)]
tv_prs, theta :: [TcSigmaType]
theta, tau :: TcSigmaType
tau) <- ([EvVar] -> TcM (TCvSubst, [EvVar]))
-> EvVar -> TcM ([(Name, EvVar)], [TcSigmaType], TcSigmaType)
tcInstType [EvVar] -> TcM (TCvSubst, [EvVar])
tcInstSkolTyVars EvVar
poly_id
       ; [EvVar]
given <- [TcSigmaType] -> TcM [EvVar]
newEvVars [TcSigmaType]
theta
       ; String -> SDoc -> TcRn ()
traceTc "tcExprSig: CompleteSig" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         [SDoc] -> SDoc
vcat [ String -> SDoc
text "poly_id:" SDoc -> SDoc -> SDoc
<+> EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvVar
poly_id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (EvVar -> TcSigmaType
idType EvVar
poly_id)
              , String -> SDoc
text "tv_prs:" SDoc -> SDoc -> SDoc
<+> [(Name, EvVar)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, EvVar)]
tv_prs ]

       ; let skol_info :: SkolemInfo
skol_info = UserTypeCtxt -> TcSigmaType -> [(Name, EvVar)] -> SkolemInfo
SigSkol UserTypeCtxt
ExprSigCtxt (EvVar -> TcSigmaType
idType EvVar
poly_id) [(Name, EvVar)]
tv_prs
             skol_tvs :: [EvVar]
skol_tvs  = ((Name, EvVar) -> EvVar) -> [(Name, EvVar)] -> [EvVar]
forall a b. (a -> b) -> [a] -> [b]
map (Name, EvVar) -> EvVar
forall a b. (a, b) -> b
snd [(Name, EvVar)]
tv_prs
       ; (ev_binds :: TcEvBinds
ev_binds, expr' :: LHsExpr GhcTcId
expr') <- SkolemInfo
-> [EvVar]
-> [EvVar]
-> TcM (LHsExpr GhcTcId)
-> TcM (TcEvBinds, LHsExpr GhcTcId)
forall result.
SkolemInfo
-> [EvVar] -> [EvVar] -> TcM result -> TcM (TcEvBinds, result)
checkConstraints SkolemInfo
skol_info [EvVar]
skol_tvs [EvVar]
given (TcM (LHsExpr GhcTcId) -> TcM (TcEvBinds, LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId) -> TcM (TcEvBinds, LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                              [(Name, EvVar)] -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall r. [(Name, EvVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, EvVar)]
tv_prs (TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                              LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExprNC LHsExpr GhcRn
expr TcSigmaType
tau

       ; let poly_wrap :: HsWrapper
poly_wrap = [EvVar] -> HsWrapper
mkWpTyLams   [EvVar]
skol_tvs
                         HsWrapper -> HsWrapper -> HsWrapper
<.> [EvVar] -> HsWrapper
mkWpLams [EvVar]
given
                         HsWrapper -> HsWrapper -> HsWrapper
<.> TcEvBinds -> HsWrapper
mkWpLet  TcEvBinds
ev_binds
       ; (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
poly_wrap LHsExpr GhcTcId
expr', EvVar -> TcSigmaType
idType EvVar
poly_id) }

tcExprSig expr :: LHsExpr GhcRn
expr sig :: TcIdSigInfo
sig@(PartialSig { psig_name :: TcIdSigInfo -> Name
psig_name = Name
name, sig_loc :: TcIdSigInfo -> SrcSpan
sig_loc = SrcSpan
loc })
  = SrcSpan
-> TcM (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTcId, TcSigmaType)
 -> TcM (LHsExpr GhcTcId, TcSigmaType))
-> TcM (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall a b. (a -> b) -> a -> b
$   -- Sets the location for the implication constraint
    do { (tclvl :: TcLevel
tclvl, wanted :: WantedConstraints
wanted, (expr' :: LHsExpr GhcTcId
expr', sig_inst :: TcIdSigInst
sig_inst))
             <- TcM (LHsExpr GhcTcId, TcIdSigInst)
-> TcM (TcLevel, WantedConstraints, (LHsExpr GhcTcId, TcIdSigInst))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints  (TcM (LHsExpr GhcTcId, TcIdSigInst)
 -> TcM
      (TcLevel, WantedConstraints, (LHsExpr GhcTcId, TcIdSigInst)))
-> TcM (LHsExpr GhcTcId, TcIdSigInst)
-> TcM (TcLevel, WantedConstraints, (LHsExpr GhcTcId, TcIdSigInst))
forall a b. (a -> b) -> a -> b
$
                do { TcIdSigInst
sig_inst <- TcIdSigInfo -> TcM TcIdSigInst
tcInstSig TcIdSigInfo
sig
                   ; LHsExpr GhcTcId
expr' <- [(Name, EvVar)] -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall r. [(Name, EvVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv (TcIdSigInst -> [(Name, EvVar)]
sig_inst_skols TcIdSigInst
sig_inst) (TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                              [(Name, EvVar)] -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall r. [(Name, EvVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv (TcIdSigInst -> [(Name, EvVar)]
sig_inst_wcs   TcIdSigInst
sig_inst) (TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                              LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExprNC LHsExpr GhcRn
expr (TcIdSigInst -> TcSigmaType
sig_inst_tau TcIdSigInst
sig_inst)
                   ; (LHsExpr GhcTcId, TcIdSigInst)
-> TcM (LHsExpr GhcTcId, TcIdSigInst)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcTcId
expr', TcIdSigInst
sig_inst) }
       -- See Note [Partial expression signatures]
       ; let tau :: TcSigmaType
tau = TcIdSigInst -> TcSigmaType
sig_inst_tau TcIdSigInst
sig_inst
             infer_mode :: InferMode
infer_mode | [TcSigmaType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TcIdSigInst -> [TcSigmaType]
sig_inst_theta TcIdSigInst
sig_inst)
                        , Maybe TcSigmaType -> Bool
forall a. Maybe a -> Bool
isNothing (TcIdSigInst -> Maybe TcSigmaType
sig_inst_wcx TcIdSigInst
sig_inst)
                        = InferMode
ApplyMR
                        | Bool
otherwise
                        = InferMode
NoRestrictions
       ; (qtvs :: [EvVar]
qtvs, givens :: [EvVar]
givens, ev_binds :: TcEvBinds
ev_binds, residual :: WantedConstraints
residual, _)
                 <- TcLevel
-> InferMode
-> [TcIdSigInst]
-> [(Name, TcSigmaType)]
-> WantedConstraints
-> TcM ([EvVar], [EvVar], TcEvBinds, WantedConstraints, Bool)
simplifyInfer TcLevel
tclvl InferMode
infer_mode [TcIdSigInst
sig_inst] [(Name
name, TcSigmaType
tau)] WantedConstraints
wanted
       ; WantedConstraints -> TcRn ()
emitConstraints WantedConstraints
residual

       ; TcSigmaType
tau <- TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
tau
       ; let inferred_theta :: [TcSigmaType]
inferred_theta = (EvVar -> TcSigmaType) -> [EvVar] -> [TcSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map EvVar -> TcSigmaType
evVarPred [EvVar]
givens
             tau_tvs :: VarSet
tau_tvs        = TcSigmaType -> VarSet
tyCoVarsOfType TcSigmaType
tau
       ; (binders :: [TyVarBinder]
binders, my_theta :: [TcSigmaType]
my_theta) <- [TcSigmaType]
-> VarSet
-> [EvVar]
-> Maybe TcIdSigInst
-> TcM ([TyVarBinder], [TcSigmaType])
chooseInferredQuantifiers [TcSigmaType]
inferred_theta
                                   VarSet
tau_tvs [EvVar]
qtvs (TcIdSigInst -> Maybe TcIdSigInst
forall a. a -> Maybe a
Just TcIdSigInst
sig_inst)
       ; let inferred_sigma :: TcSigmaType
inferred_sigma = [EvVar] -> [TcSigmaType] -> TcSigmaType -> TcSigmaType
mkInfSigmaTy [EvVar]
qtvs [TcSigmaType]
inferred_theta TcSigmaType
tau
             my_sigma :: TcSigmaType
my_sigma       = [TyVarBinder] -> TcSigmaType -> TcSigmaType
mkForAllTys [TyVarBinder]
binders ([TcSigmaType] -> TcSigmaType -> TcSigmaType
mkPhiTy  [TcSigmaType]
my_theta TcSigmaType
tau)
       ; HsWrapper
wrap <- if TcSigmaType
inferred_sigma TcSigmaType -> TcSigmaType -> Bool
`eqType` TcSigmaType
my_sigma -- NB: eqType ignores vis.
                 then HsWrapper -> TcM HsWrapper
forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
idHsWrapper  -- Fast path; also avoids complaint when we infer
                                          -- an ambiguous type and have AllowAmbiguousType
                                          -- e..g infer  x :: forall a. F a -> Int
                 else UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper
tcSubType_NC UserTypeCtxt
ExprSigCtxt TcSigmaType
inferred_sigma TcSigmaType
my_sigma

       ; String -> SDoc -> TcRn ()
traceTc "tcExpSig" ([EvVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [EvVar]
qtvs SDoc -> SDoc -> SDoc
$$ [EvVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [EvVar]
givens SDoc -> SDoc -> SDoc
$$ TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
inferred_sigma SDoc -> SDoc -> SDoc
$$ TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
my_sigma)
       ; let poly_wrap :: HsWrapper
poly_wrap = HsWrapper
wrap
                         HsWrapper -> HsWrapper -> HsWrapper
<.> [EvVar] -> HsWrapper
mkWpTyLams [EvVar]
qtvs
                         HsWrapper -> HsWrapper -> HsWrapper
<.> [EvVar] -> HsWrapper
mkWpLams [EvVar]
givens
                         HsWrapper -> HsWrapper -> HsWrapper
<.> TcEvBinds -> HsWrapper
mkWpLet  TcEvBinds
ev_binds
       ; (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
poly_wrap LHsExpr GhcTcId
expr', TcSigmaType
my_sigma) }


{- Note [Partial expression signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Partial type signatures on expressions are easy to get wrong.  But
here is a guiding principile
    e :: ty
should behave like
    let x :: ty
        x = e
    in x

So for partial signatures we apply the MR if no context is given.  So
   e :: IO _          apply the MR
   e :: _ => IO _     do not apply the MR
just like in TcBinds.decideGeneralisationPlan

This makes a difference (Trac #11670):
   peek :: Ptr a -> IO CLong
   peek ptr = peekElemOff undefined 0 :: _
from (peekElemOff undefined 0) we get
          type: IO w
   constraints: Storable w

We must NOT try to generalise over 'w' because the signature specifies
no constraints so we'll complain about not being able to solve
Storable w.  Instead, don't generalise; then _ gets instantiated to
CLong, as it should.
-}

{- *********************************************************************
*                                                                      *
                 tcInferId
*                                                                      *
********************************************************************* -}

tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId)
tcCheckId :: Name -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcCheckId name :: Name
name res_ty :: ExpSigmaType
res_ty
  = do { (expr :: HsExpr GhcTcId
expr, actual_res_ty :: TcSigmaType
actual_res_ty) <- Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferId Name
name
       ; String -> SDoc -> TcRn ()
traceTc "tcCheckId" ([SDoc] -> SDoc
vcat [Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name, TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
actual_res_ty, ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
res_ty])
       ; Bool
-> HsExpr GhcRn
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
-> TcM (HsExpr GhcTcId)
forall a.
Bool
-> HsExpr GhcRn -> TcSigmaType -> ExpSigmaType -> TcM a -> TcM a
addFunResCtxt Bool
False (XVar GhcRn -> GenLocated SrcSpan (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcRn
NoExt
noExt (SrcSpanLess (GenLocated SrcSpan Name) -> GenLocated SrcSpan Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc Name
SrcSpanLess (GenLocated SrcSpan Name)
name)) TcSigmaType
actual_res_ty ExpSigmaType
res_ty (TcM (HsExpr GhcTcId) -> TcM (HsExpr GhcTcId))
-> TcM (HsExpr GhcTcId) -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
         CtOrigin
-> HsExpr GhcRn
-> HsExpr GhcTcId
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
tcWrapResultO (Name -> CtOrigin
OccurrenceOf Name
name) (XVar GhcRn -> GenLocated SrcSpan (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcRn
NoExt
noExt (SrcSpanLess (GenLocated SrcSpan Name) -> GenLocated SrcSpan Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc Name
SrcSpanLess (GenLocated SrcSpan Name)
name)) HsExpr GhcTcId
expr
                                                          TcSigmaType
actual_res_ty ExpSigmaType
res_ty }

tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
tcCheckRecSelId :: HsExpr GhcRn
-> AmbiguousFieldOcc GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcCheckRecSelId rn_expr :: HsExpr GhcRn
rn_expr f :: AmbiguousFieldOcc GhcRn
f@(Unambiguous _ (L _ lbl :: RdrName
lbl)) res_ty :: ExpSigmaType
res_ty
  = do { (expr :: HsExpr GhcTcId
expr, actual_res_ty :: TcSigmaType
actual_res_ty) <- AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferRecSelId AmbiguousFieldOcc GhcRn
f
       ; Bool
-> HsExpr GhcRn
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
-> TcM (HsExpr GhcTcId)
forall a.
Bool
-> HsExpr GhcRn -> TcSigmaType -> ExpSigmaType -> TcM a -> TcM a
addFunResCtxt Bool
False (XRecFld GhcRn -> AmbiguousFieldOcc GhcRn -> HsExpr GhcRn
forall p. XRecFld p -> AmbiguousFieldOcc p -> HsExpr p
HsRecFld XRecFld GhcRn
NoExt
noExt AmbiguousFieldOcc GhcRn
f) TcSigmaType
actual_res_ty ExpSigmaType
res_ty (TcM (HsExpr GhcTcId) -> TcM (HsExpr GhcTcId))
-> TcM (HsExpr GhcTcId) -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
         CtOrigin
-> HsExpr GhcRn
-> HsExpr GhcTcId
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
tcWrapResultO (RdrName -> CtOrigin
OccurrenceOfRecSel RdrName
lbl) HsExpr GhcRn
rn_expr HsExpr GhcTcId
expr TcSigmaType
actual_res_ty ExpSigmaType
res_ty }
tcCheckRecSelId rn_expr :: HsExpr GhcRn
rn_expr (Ambiguous _ lbl :: Located RdrName
lbl) res_ty :: ExpSigmaType
res_ty
  = case TcSigmaType -> Maybe (TcSigmaType, TcSigmaType)
tcSplitFunTy_maybe (TcSigmaType -> Maybe (TcSigmaType, TcSigmaType))
-> Maybe TcSigmaType -> Maybe (TcSigmaType, TcSigmaType)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExpSigmaType -> Maybe TcSigmaType
checkingExpType_maybe ExpSigmaType
res_ty of
      Nothing       -> Located RdrName -> TcM (HsExpr GhcTcId)
forall a. Located RdrName -> TcM a
ambiguousSelector Located RdrName
lbl
      Just (arg :: TcSigmaType
arg, _) -> do { Name
sel_name <- Located RdrName -> TcSigmaType -> TcM Name
disambiguateSelector Located RdrName
lbl TcSigmaType
arg
                          ; HsExpr GhcRn
-> AmbiguousFieldOcc GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcCheckRecSelId HsExpr GhcRn
rn_expr (XUnambiguous GhcRn -> Located RdrName -> AmbiguousFieldOcc GhcRn
forall pass.
XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Unambiguous Name
XUnambiguous GhcRn
sel_name Located RdrName
lbl)
                                                    ExpSigmaType
res_ty }
tcCheckRecSelId _ (XAmbiguousFieldOcc _) _ = String -> TcM (HsExpr GhcTcId)
forall a. String -> a
panic "tcCheckRecSelId"

------------------------
tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType)
tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferRecSelId (Unambiguous sel :: XUnambiguous GhcRn
sel (L _ lbl :: RdrName
lbl))
  = do { (expr' :: HsExpr GhcTcId
expr', ty :: TcSigmaType
ty) <- RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tc_infer_id RdrName
lbl Name
XUnambiguous GhcRn
sel
       ; (HsExpr GhcTcId, TcSigmaType) -> TcM (HsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId
expr', TcSigmaType
ty) }
tcInferRecSelId (Ambiguous _ lbl :: Located RdrName
lbl)
  = Located RdrName -> TcM (HsExpr GhcTcId, TcSigmaType)
forall a. Located RdrName -> TcM a
ambiguousSelector Located RdrName
lbl
tcInferRecSelId (XAmbiguousFieldOcc _) = String -> TcM (HsExpr GhcTcId, TcSigmaType)
forall a. String -> a
panic "tcInferRecSelId"

------------------------
tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)
-- Look up an occurrence of an Id
-- Do not instantiate its type
tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferId id_name :: Name
id_name
  | Name
id_name Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tagToEnumKey
  = SDoc -> TcM (HsExpr GhcTcId, TcSigmaType)
forall a. SDoc -> TcRn a
failWithTc (String -> SDoc
text "tagToEnum# must appear applied to one argument")
        -- tcApp catches the case (tagToEnum# arg)

  | Name
id_name Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
assertIdKey
  = do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_IgnoreAsserts DynFlags
dflags
         then RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tc_infer_id (Name -> RdrName
nameRdrName Name
id_name) Name
id_name
         else Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tc_infer_assert Name
id_name }

  | Bool
otherwise
  = do { (expr :: HsExpr GhcTcId
expr, ty :: TcSigmaType
ty) <- RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tc_infer_id (Name -> RdrName
nameRdrName Name
id_name) Name
id_name
       ; String -> SDoc -> TcRn ()
traceTc "tcInferId" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
id_name SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
ty)
       ; (HsExpr GhcTcId, TcSigmaType) -> TcM (HsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId
expr, TcSigmaType
ty) }

tc_infer_assert :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)
-- Deal with an occurrence of 'assert'
-- See Note [Adding the implicit parameter to 'assert']
tc_infer_assert :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tc_infer_assert assert_name :: Name
assert_name
  = do { EvVar
assert_error_id <- Name -> TcM EvVar
tcLookupId Name
assertErrorName
       ; (wrap :: HsWrapper
wrap, id_rho :: TcSigmaType
id_rho) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate (Name -> CtOrigin
OccurrenceOf Name
assert_name)
                                          (EvVar -> TcSigmaType
idType EvVar
assert_error_id)
       ; (HsExpr GhcTcId, TcSigmaType) -> TcM (HsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExt
noExt (SrcSpanLess (Located EvVar) -> Located EvVar
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located EvVar)
EvVar
assert_error_id)), TcSigmaType
id_rho)
       }

tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tc_infer_id lbl :: RdrName
lbl id_name :: Name
id_name
 = do { TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup Name
id_name
      ; case TcTyThing
thing of
             ATcId { tct_id :: TcTyThing -> EvVar
tct_id = EvVar
id }
               -> do { EvVar -> TcRn ()
check_naughty EvVar
id        -- Note [Local record selectors]
                     ; EvVar -> TcRn ()
checkThLocalId EvVar
id
                     ; EvVar -> TcM (HsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) p.
(Monad m, XVar p ~ NoExt, IdP p ~ EvVar) =>
EvVar -> m (HsExpr p, TcSigmaType)
return_id EvVar
id }

             AGlobal (AnId id :: EvVar
id)
               -> do { EvVar -> TcRn ()
check_naughty EvVar
id
                     ; EvVar -> TcM (HsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) p.
(Monad m, XVar p ~ NoExt, IdP p ~ EvVar) =>
EvVar -> m (HsExpr p, TcSigmaType)
return_id EvVar
id }
                    -- A global cannot possibly be ill-staged
                    -- nor does it need the 'lifting' treatment
                    -- hence no checkTh stuff here

             AGlobal (AConLike cl :: ConLike
cl) -> case ConLike
cl of
                 RealDataCon con :: DataCon
con -> DataCon -> TcM (HsExpr GhcTcId, TcSigmaType)
return_data_con DataCon
con
                 PatSynCon ps :: PatSyn
ps    -> PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType)
tcPatSynBuilderOcc PatSyn
ps

             _ -> SDoc -> TcM (HsExpr GhcTcId, TcSigmaType)
forall a. SDoc -> TcRn a
failWithTc (SDoc -> TcM (HsExpr GhcTcId, TcSigmaType))
-> SDoc -> TcM (HsExpr GhcTcId, TcSigmaType)
forall a b. (a -> b) -> a -> b
$
                  TcTyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyThing
thing SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "used where a value identifier was expected" }
  where
    return_id :: EvVar -> m (HsExpr p, TcSigmaType)
return_id id :: EvVar
id = (HsExpr p, TcSigmaType) -> m (HsExpr p, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar p -> Located (IdP p) -> HsExpr p
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar p
NoExt
noExt (SrcSpanLess (Located (IdP p)) -> Located (IdP p)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located (IdP p))
EvVar
id), EvVar -> TcSigmaType
idType EvVar
id)

    return_data_con :: DataCon -> TcM (HsExpr GhcTcId, TcSigmaType)
return_data_con con :: DataCon
con
       -- For data constructors, must perform the stupid-theta check
      | [TcSigmaType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcSigmaType]
stupid_theta
      = (HsExpr GhcTcId, TcSigmaType) -> TcM (HsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (XConLikeOut GhcTcId -> ConLike -> HsExpr GhcTcId
forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut XConLikeOut GhcTcId
NoExt
noExt (DataCon -> ConLike
RealDataCon DataCon
con), TcSigmaType
con_ty)

      | Bool
otherwise
       -- See Note [Instantiating stupid theta]
      = do { let (tvs :: [EvVar]
tvs, theta :: [TcSigmaType]
theta, rho :: TcSigmaType
rho) = TcSigmaType -> ([EvVar], [TcSigmaType], TcSigmaType)
tcSplitSigmaTy TcSigmaType
con_ty
           ; (subst :: TCvSubst
subst, tvs' :: [EvVar]
tvs') <- [EvVar] -> TcM (TCvSubst, [EvVar])
newMetaTyVars [EvVar]
tvs
           ; let tys' :: [TcSigmaType]
tys'   = [EvVar] -> [TcSigmaType]
mkTyVarTys [EvVar]
tvs'
                 theta' :: [TcSigmaType]
theta' = HasCallStack => TCvSubst -> [TcSigmaType] -> [TcSigmaType]
TCvSubst -> [TcSigmaType] -> [TcSigmaType]
substTheta TCvSubst
subst [TcSigmaType]
theta
                 rho' :: TcSigmaType
rho'   = HasCallStack => TCvSubst -> TcSigmaType -> TcSigmaType
TCvSubst -> TcSigmaType -> TcSigmaType
substTy TCvSubst
subst TcSigmaType
rho
           ; HsWrapper
wrap <- CtOrigin -> [TcSigmaType] -> [TcSigmaType] -> TcM HsWrapper
instCall (Name -> CtOrigin
OccurrenceOf Name
id_name) [TcSigmaType]
tys' [TcSigmaType]
theta'
           ; DataCon -> [TcSigmaType] -> TcRn ()
addDataConStupidTheta DataCon
con [TcSigmaType]
tys'
           ; (HsExpr GhcTcId, TcSigmaType) -> TcM (HsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (XConLikeOut GhcTcId -> ConLike -> HsExpr GhcTcId
forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut XConLikeOut GhcTcId
NoExt
noExt (DataCon -> ConLike
RealDataCon DataCon
con))
                    , TcSigmaType
rho') }

      where
        con_ty :: TcSigmaType
con_ty         = DataCon -> TcSigmaType
dataConUserType DataCon
con
        stupid_theta :: [TcSigmaType]
stupid_theta   = DataCon -> [TcSigmaType]
dataConStupidTheta DataCon
con

    check_naughty :: EvVar -> TcRn ()
check_naughty id :: EvVar
id
      | EvVar -> Bool
isNaughtyRecordSelector EvVar
id = SDoc -> TcRn ()
forall a. SDoc -> TcRn a
failWithTc (RdrName -> SDoc
naughtyRecordSel RdrName
lbl)
      | Bool
otherwise                  = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


tcUnboundId :: HsExpr GhcRn -> UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId)
-- 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
--
-- We turn all of them into HsVar, since HsUnboundVar can't contain an
-- Id; and indeed the evidence for the CHoleCan does bind it, so it's
-- not unbound any more!
tcUnboundId :: HsExpr GhcRn -> UnboundVar -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcUnboundId rn_expr :: HsExpr GhcRn
rn_expr unbound :: UnboundVar
unbound res_ty :: ExpSigmaType
res_ty
 = do { TcSigmaType
ty <- TcM TcSigmaType
newOpenFlexiTyVarTy  -- Allow Int# etc (Trac #12531)
      ; let occ :: OccName
occ = UnboundVar -> OccName
unboundVarOcc UnboundVar
unbound
      ; Name
name <- OccName -> TcM Name
forall gbl lcl. OccName -> TcRnIf gbl lcl Name
newSysName OccName
occ
      ; let ev :: EvVar
ev = Name -> TcSigmaType -> EvVar
mkLocalId Name
name TcSigmaType
ty
      ; Ct
can <- Hole -> EvVar -> TcSigmaType -> TcM Ct
newHoleCt (UnboundVar -> Hole
ExprHole UnboundVar
unbound) EvVar
ev TcSigmaType
ty
      ; Ct -> TcRn ()
emitInsoluble Ct
can
      ; CtOrigin
-> HsExpr GhcRn
-> HsExpr GhcTcId
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
tcWrapResultO (OccName -> CtOrigin
UnboundOccurrenceOf OccName
occ) HsExpr GhcRn
rn_expr (XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExt
noExt (SrcSpanLess (Located EvVar) -> Located EvVar
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located EvVar)
EvVar
ev))
                                                                     TcSigmaType
ty ExpSigmaType
res_ty }


{-
Note [Adding the implicit parameter to 'assert']
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The typechecker transforms (assert e1 e2) to (assertError e1 e2).
This isn't really the Right Thing because there's no way to "undo"
if you want to see the original source code in the typechecker
output.  We'll have fix this in due course, when we care more about
being able to reconstruct the exact original program.

Note [tagToEnum#]
~~~~~~~~~~~~~~~~~
Nasty check to ensure that tagToEnum# is applied to a type that is an
enumeration TyCon.  Unification may refine the type later, but this
check won't see that, alas.  It's crude, because it relies on our
knowing *now* that the type is ok, which in turn relies on the
eager-unification part of the type checker pushing enough information
here.  In theory the Right Thing to do is to have a new form of
constraint but I definitely cannot face that!  And it works ok as-is.

Here's are two cases that should fail
        f :: forall a. a
        f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable

        g :: Int
        g = tagToEnum# 0        -- Int is not an enumeration

When data type families are involved it's a bit more complicated.
     data family F a
     data instance F [Int] = A | B | C
Then we want to generate something like
     tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]
Usually that coercion is hidden inside the wrappers for
constructors of F [Int] but here we have to do it explicitly.

It's all grotesquely complicated.

Note [Instantiating stupid theta]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Normally, when we infer the type of an Id, we don't instantiate,
because we wish to allow for visible type application later on.
But if a datacon has a stupid theta, we're a bit stuck. We need
to emit the stupid theta constraints with instantiated types. It's
difficult to defer this to the lazy instantiation, because a stupid
theta has no spot to put it in a type. So we just instantiate eagerly
in this case. Thus, users cannot use visible type application with
a data constructor sporting a stupid theta. I won't feel so bad for
the users that complain.

-}

tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType
            -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
-- tagToEnum# :: forall a. Int# -> a
-- See Note [tagToEnum#]   Urgh!
tcTagToEnum :: SrcSpan
-> Name
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcTagToEnum loc :: SrcSpan
loc fun_name :: Name
fun_name args :: [LHsExprArgIn]
args res_ty :: ExpSigmaType
res_ty
  = do { EvVar
fun <- Name -> TcM EvVar
tcLookupId Name
fun_name

       ; let pars1 :: [LHsExprArgOut]
pars1 = (LHsExprArgIn -> Maybe LHsExprArgOut)
-> [LHsExprArgIn] -> [LHsExprArgOut]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LHsExprArgIn -> Maybe LHsExprArgOut
forall a b c d. HsArg a b -> Maybe (HsArg c d)
isArgPar_maybe [LHsExprArgIn]
before
             pars2 :: [LHsExprArgOut]
pars2 = (LHsExprArgIn -> Maybe LHsExprArgOut)
-> [LHsExprArgIn] -> [LHsExprArgOut]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LHsExprArgIn -> Maybe LHsExprArgOut
forall a b c d. HsArg a b -> Maybe (HsArg c d)
isArgPar_maybe [LHsExprArgIn]
after
             -- args contains exactly one HsValArg
             (before :: [LHsExprArgIn]
before, _:after :: [LHsExprArgIn]
after) = (LHsExprArgIn -> Bool)
-> [LHsExprArgIn] -> ([LHsExprArgIn], [LHsExprArgIn])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break LHsExprArgIn -> Bool
forall tm ty. HsArg tm ty -> Bool
isHsValArg [LHsExprArgIn]
args

       ; LHsExpr GhcRn
arg <- case (LHsExprArgIn -> Bool) -> [LHsExprArgIn] -> [LHsExprArgIn]
forall a. (a -> Bool) -> [a] -> [a]
filterOut LHsExprArgIn -> Bool
forall tm ty. HsArg tm ty -> Bool
isArgPar [LHsExprArgIn]
args of
           [HsTypeArg _ hs_ty_arg :: HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
hs_ty_arg, HsValArg term_arg :: LHsExpr GhcRn
term_arg]
             -> do { TcSigmaType
ty_arg <- HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
-> TcSigmaType -> TcM TcSigmaType
tcHsTypeApp HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
hs_ty_arg TcSigmaType
liftedTypeKind
                   ; HsWrapper
_ <- CtOrigin
-> UserTypeCtxt -> TcSigmaType -> ExpSigmaType -> TcM HsWrapper
tcSubTypeDS (Name -> CtOrigin
OccurrenceOf Name
fun_name) UserTypeCtxt
GenSigCtxt TcSigmaType
ty_arg ExpSigmaType
res_ty
                     -- other than influencing res_ty, we just
                     -- don't care about a type arg passed in.
                     -- So drop the evidence.
                   ; LHsExpr GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcRn
term_arg }
           [HsValArg term_arg :: LHsExpr GhcRn
term_arg] -> do { TcSigmaType
_ <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
res_ty
                                     ; LHsExpr GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcRn
term_arg }
           _          -> String
-> [LHsExprArgIn] -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
forall a. String -> [LHsExprArgIn] -> TcM a
too_many_args "tagToEnum#" [LHsExprArgIn]
args

       ; TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
readExpType ExpSigmaType
res_ty
       ; TcSigmaType
ty'    <- TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
res_ty

       -- Check that the type is algebraic
       ; let mb_tc_app :: Maybe (TyCon, [TcSigmaType])
mb_tc_app = HasCallStack => TcSigmaType -> Maybe (TyCon, [TcSigmaType])
TcSigmaType -> Maybe (TyCon, [TcSigmaType])
tcSplitTyConApp_maybe TcSigmaType
ty'
             Just (tc :: TyCon
tc, tc_args :: [TcSigmaType]
tc_args) = Maybe (TyCon, [TcSigmaType])
mb_tc_app
       ; Bool -> SDoc -> TcRn ()
checkTc (Maybe (TyCon, [TcSigmaType]) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (TyCon, [TcSigmaType])
mb_tc_app)
                 (TcSigmaType -> SDoc -> SDoc
mk_error TcSigmaType
ty' SDoc
doc1)

       -- Look through any type family
       ; FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
       ; let (rep_tc :: TyCon
rep_tc, rep_args :: [TcSigmaType]
rep_args, coi :: TcCoercionR
coi)
               = FamInstEnvs
-> TyCon -> [TcSigmaType] -> (TyCon, [TcSigmaType], TcCoercionR)
tcLookupDataFamInst FamInstEnvs
fam_envs TyCon
tc [TcSigmaType]
tc_args
            -- coi :: tc tc_args ~R rep_tc rep_args

       ; Bool -> SDoc -> TcRn ()
checkTc (TyCon -> Bool
isEnumerationTyCon TyCon
rep_tc)
                 (TcSigmaType -> SDoc -> SDoc
mk_error TcSigmaType
ty' SDoc
doc2)

       ; LHsExpr GhcTcId
arg' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
arg (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
intPrimTy)
       ; let fun' :: LHsExpr GhcTcId
fun' = SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap (TcSigmaType -> HsWrapper
WpTyApp TcSigmaType
rep_ty) (XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExt
noExt (SrcSpan -> EvVar -> Located EvVar
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc EvVar
fun)))
             rep_ty :: TcSigmaType
rep_ty = TyCon -> [TcSigmaType] -> TcSigmaType
mkTyConApp TyCon
rep_tc [TcSigmaType]
rep_args
             out_args :: [LHsExprArgOut]
out_args = [[LHsExprArgOut]] -> [LHsExprArgOut]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ [LHsExprArgOut]
pars1
              , [LHsExpr GhcTcId -> LHsExprArgOut
forall tm ty. tm -> HsArg tm ty
HsValArg LHsExpr GhcTcId
arg']
              , [LHsExprArgOut]
pars2
              ]

       ; (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
forall (m :: * -> *) a. Monad m => a -> m a
return (TcCoercionR -> HsWrapper
mkWpCastR (TcCoercionR -> TcCoercionR
mkTcSymCo TcCoercionR
coi), LHsExpr GhcTcId
fun', [LHsExprArgOut]
out_args) }
                 -- coi is a Representational coercion
  where
    doc1 :: SDoc
doc1 = [SDoc] -> SDoc
vcat [ String -> SDoc
text "Specify the type by giving a type signature"
                , String -> SDoc
text "e.g. (tagToEnum# x) :: Bool" ]
    doc2 :: SDoc
doc2 = String -> SDoc
text "Result type must be an enumeration type"

    mk_error :: TcType -> SDoc -> SDoc
    mk_error :: TcSigmaType -> SDoc -> SDoc
mk_error ty :: TcSigmaType
ty what :: SDoc
what
      = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Bad call to tagToEnum#"
               SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "at type" SDoc -> SDoc -> SDoc
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
ty)
           2 SDoc
what

too_many_args :: String -> [LHsExprArgIn] -> TcM a
too_many_args :: String -> [LHsExprArgIn] -> TcM a
too_many_args fun :: String
fun args :: [LHsExprArgIn]
args
  = SDoc -> TcM a
forall a. SDoc -> TcRn a
failWith (SDoc -> TcM a) -> SDoc -> TcM a
forall a b. (a -> b) -> a -> b
$
    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Too many type arguments to" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
fun SDoc -> SDoc -> SDoc
<> SDoc
colon)
       2 ([SDoc] -> SDoc
sep ((LHsExprArgIn -> SDoc) -> [LHsExprArgIn] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map LHsExprArgIn -> SDoc
forall (p :: Pass) a pass l.
(OutputableBndr (IdP (GhcPass (NoGhcTcPass p))),
 OutputableBndr (NameOrRdrName (IdP (GhcPass (NoGhcTcPass p)))),
 OutputableBndr (IdP (GhcPass p)),
 OutputableBndr (NameOrRdrName (IdP (GhcPass p))), Outputable a,
 Outputable (XIPBinds (GhcPass p)),
 Outputable (XViaStrategy (GhcPass p)),
 Outputable (XIPBinds (GhcPass (NoGhcTcPass p))),
 Outputable (XViaStrategy (GhcPass (NoGhcTcPass p))),
 NoGhcTcPass p ~ NoGhcTcPass (NoGhcTcPass p)) =>
HsArg a (HsWildCardBndrs pass (GenLocated l (HsType (GhcPass p))))
-> SDoc
pp [LHsExprArgIn]
args))
  where
    pp :: HsArg a (HsWildCardBndrs pass (GenLocated l (HsType (GhcPass p))))
-> SDoc
pp (HsValArg e :: a
e)                             = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
e
    pp (HsTypeArg _ (HsWC { hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = L _ t :: HsType (GhcPass p)
t })) = HsType (GhcPass p) -> SDoc
forall (p :: Pass).
OutputableBndrId (GhcPass p) =>
HsType (GhcPass p) -> SDoc
pprHsType HsType (GhcPass p)
t
    pp (HsTypeArg _ (XHsWildCardBndrs _)) = String -> SDoc
forall a. String -> a
panic "too_many_args"
    pp (HsArgPar _) = SDoc
empty


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

checkThLocalId :: Id -> TcM ()
checkThLocalId :: EvVar -> TcRn ()
checkThLocalId id :: EvVar
id
  = do  { Maybe (TopLevelFlag, Int, ThStage)
mb_local_use <- Name -> TcRn (Maybe (TopLevelFlag, Int, ThStage))
getStageAndBindLevel (EvVar -> Name
idName EvVar
id)
        ; case Maybe (TopLevelFlag, Int, ThStage)
mb_local_use of
             Just (top_lvl :: TopLevelFlag
top_lvl, bind_lvl :: Int
bind_lvl, use_stage :: ThStage
use_stage)
                | ThStage -> Int
thLevel ThStage
use_stage Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
bind_lvl
                -> TopLevelFlag -> EvVar -> ThStage -> TcRn ()
checkCrossStageLifting TopLevelFlag
top_lvl EvVar
id ThStage
use_stage
             _  -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()   -- Not a locally-bound thing, or
                               -- no cross-stage link
    }

--------------------------------------
checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()
-- If we are inside typed brackets, and (use_lvl > bind_lvl)
-- we must check whether there's a cross-stage lift to do
-- Examples   \x -> [|| x ||]
--            [|| map ||]
-- There is no error-checking to do, because the renamer did that
--
-- This is similar to checkCrossStageLifting in RnSplice, but
-- this code is applied to *typed* brackets.

checkCrossStageLifting :: TopLevelFlag -> EvVar -> ThStage -> TcRn ()
checkCrossStageLifting top_lvl :: TopLevelFlag
top_lvl id :: EvVar
id (Brack _ (TcPending ps_var :: TcRef [PendingTcSplice]
ps_var lie_var :: TcRef WantedConstraints
lie_var))
  | TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
  = Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Bool
isExternalName Name
id_name) (Name -> TcRn ()
keepAlive Name
id_name)
    -- See Note [Keeping things alive for Template Haskell] in RnSplice

  | Bool
otherwise
  =     -- Nested identifiers, such as 'x' in
        -- E.g. \x -> [|| h x ||]
        -- We must behave as if the reference to x was
        --      h $(lift x)
        -- We use 'x' itself as the splice proxy, used by
        -- the desugarer to stitch it all back together.
        -- If 'x' occurs many times we may get many identical
        -- bindings of the same splice proxy, but that doesn't
        -- matter, although it's a mite untidy.
    do  { let id_ty :: TcSigmaType
id_ty = EvVar -> TcSigmaType
idType EvVar
id
        ; Bool -> SDoc -> TcRn ()
checkTc (TcSigmaType -> Bool
isTauTy TcSigmaType
id_ty) (EvVar -> SDoc
polySpliceErr EvVar
id)
               -- If x is polymorphic, its occurrence sites might
               -- have different instantiations, so we can't use plain
               -- 'x' as the splice proxy name.  I don't know how to
               -- solve this, and it's probably unimportant, so I'm
               -- just going to flag an error for now

        ; HsExpr GhcTcId
lift <- if TcSigmaType -> Bool
isStringTy TcSigmaType
id_ty then
                     do { EvVar
sid <- Name -> TcM EvVar
tcLookupId Name
THNames.liftStringName
                                     -- See Note [Lifting strings]
                        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExt
noExt (SrcSpanLess (Located EvVar) -> Located EvVar
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located EvVar)
EvVar
sid)) }
                  else
                     TcRef WantedConstraints
-> TcM (HsExpr GhcTcId) -> TcM (HsExpr GhcTcId)
forall a. TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar TcRef WantedConstraints
lie_var   (TcM (HsExpr GhcTcId) -> TcM (HsExpr GhcTcId))
-> TcM (HsExpr GhcTcId) -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                          -- Put the 'lift' constraint into the right LIE
                     CtOrigin -> Name -> TcSigmaType -> TcM (HsExpr GhcTcId)
newMethodFromName (Name -> CtOrigin
OccurrenceOf Name
id_name)
                                       Name
THNames.liftName TcSigmaType
id_ty

                   -- Update the pending splices
        ; [PendingTcSplice]
ps <- TcRef [PendingTcSplice]
-> IOEnv (Env TcGblEnv TcLclEnv) [PendingTcSplice]
forall a env. IORef a -> IOEnv env a
readMutVar TcRef [PendingTcSplice]
ps_var
        ; let pending_splice :: PendingTcSplice
pending_splice = Name -> LHsExpr GhcTcId -> PendingTcSplice
PendingTcSplice Name
id_name
                                 (LHsExpr GhcTcId -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (SrcSpanLess (LHsExpr GhcTcId) -> LHsExpr GhcTcId
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsExpr GhcTcId)
HsExpr GhcTcId
lift) (IdP GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar EvVar
IdP GhcTcId
id))
        ; TcRef [PendingTcSplice] -> [PendingTcSplice] -> TcRn ()
forall a env. IORef a -> a -> IOEnv env ()
writeMutVar TcRef [PendingTcSplice]
ps_var (PendingTcSplice
pending_splice PendingTcSplice -> [PendingTcSplice] -> [PendingTcSplice]
forall a. a -> [a] -> [a]
: [PendingTcSplice]
ps)

        ; () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
  where
    id_name :: Name
id_name = EvVar -> Name
idName EvVar
id

checkCrossStageLifting _ _ _ = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

polySpliceErr :: Id -> SDoc
polySpliceErr :: EvVar -> SDoc
polySpliceErr id :: EvVar
id
  = String -> SDoc
text "Can't splice the polymorphic local variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvVar
id)

{-
Note [Lifting strings]
~~~~~~~~~~~~~~~~~~~~~~
If we see $(... [| s |] ...) where s::String, we don't want to
generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
So this conditional short-circuits the lifting mechanism to generate
(liftString "xy") in that case.  I didn't want to use overlapping instances
for the Lift class in TH.Syntax, because that can lead to overlapping-instance
errors in a polymorphic situation.

If this check fails (which isn't impossible) we get another chance; see
Note [Converting strings] in Convert.hs

Local record selectors
~~~~~~~~~~~~~~~~~~~~~~
Record selectors for TyCons in this module are ordinary local bindings,
which show up as ATcIds rather than AGlobals.  So we need to check for
naughtiness in both branches.  c.f. TcTyClsBindings.mkAuxBinds.


************************************************************************
*                                                                      *
\subsection{Record bindings}
*                                                                      *
************************************************************************
-}

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

                            fixed_tys :: [TcSigmaType]
fixed_tys = [TcSigmaType
ty | (fl :: FieldLbl Name
fl, ty :: TcSigmaType
ty) <- [FieldLbl Name] -> [TcSigmaType] -> [(FieldLbl Name, TcSigmaType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FieldLbl Name]
flds [TcSigmaType]
arg_tys
                                            , Bool -> Bool
not (FieldLbl Name -> FastString
forall a. FieldLbl a -> FastString
flLabel FieldLbl Name
fl FastString -> [FastString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FastString]
upd_fld_occs)]
                      , (tv1 :: EvVar
tv1,tv :: EvVar
tv) <- [EvVar]
univ_tvs [EvVar] -> [EvVar] -> [(EvVar, EvVar)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [EvVar]
u_tvs
                      , EvVar
tv EvVar -> VarSet -> Bool
`elemVarSet` VarSet
fixed_tvs ]

{-
Note [Disambiguating record fields]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When the -XDuplicateRecordFields extension is used, and the renamer
encounters a record selector or update that it cannot immediately
disambiguate (because it involves fields that belong to multiple
datatypes), it will defer resolution of the ambiguity to the
typechecker.  In this case, the `Ambiguous` constructor of
`AmbiguousFieldOcc` is used.

Consider the following definitions:

        data S = MkS { foo :: Int }
        data T = MkT { foo :: Int, bar :: Int }
        data U = MkU { bar :: Int, baz :: Int }

When the renamer sees `foo` as a selector or an update, it will not
know which parent datatype is in use.

For selectors, there are two possible ways to disambiguate:

1. Check if the pushed-in type is a function whose domain is a
   datatype, for example:

       f s = (foo :: S -> Int) s

       g :: T -> Int
       g = foo

    This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`.

2. Check if the selector is applied to an argument that has a type
   signature, for example:

       h = foo (s :: S)

    This is checked by `tcApp`.


Updates are slightly more complex.  The `disambiguateRecordBinds`
function tries to determine the parent datatype in three ways:

1. Check for types that have all the fields being updated. For example:

        f x = x { foo = 3, bar = 2 }

   Here `f` must be updating `T` because neither `S` nor `U` have
   both fields. This may also discover that no possible type exists.
   For example the following will be rejected:

        f' x = x { foo = 3, baz = 3 }

2. Use the type being pushed in, if it is already a TyConApp. The
   following are valid updates to `T`:

        g :: T -> T
        g x = x { foo = 3 }

        g' x = x { foo = 3 } :: T

3. Use the type signature of the record expression, if it exists and
   is a TyConApp. Thus this is valid update to `T`:

        h x = (x :: T) { foo = 3 }


Note that we do not look up the types of variables being updated, and
no constraint-solving is performed, so for example the following will
be rejected as ambiguous:

     let bad (s :: S) = foo s

     let r :: T
         r = blah
     in r { foo = 3 }

     \r. (r { foo = 3 },  r :: T )

We could add further tests, of a more heuristic nature. For example,
rather than looking for an explicit signature, we could try to infer
the type of the argument to a selector or the record expression being
updated, in case we are lucky enough to get a TyConApp straight
away. However, it might be hard for programmers to predict whether a
particular update is sufficiently obvious for the signature to be
omitted. Moreover, this might change the behaviour of typechecker in
non-obvious ways.

See also Note [HsRecField and HsRecUpdField] in HsPat.
-}

-- Given a RdrName that refers to multiple record fields, and the type
-- of its argument, try to determine the name of the selector that is
-- meant.
disambiguateSelector :: Located RdrName -> Type -> TcM Name
disambiguateSelector :: Located RdrName -> TcSigmaType -> TcM Name
disambiguateSelector lr :: Located RdrName
lr@(L _ rdr :: RdrName
rdr) parent_type :: TcSigmaType
parent_type
 = do { FamInstEnvs
fam_inst_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
      ; case FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs TcSigmaType
parent_type of
          Nothing -> Located RdrName -> TcM Name
forall a. Located RdrName -> TcM a
ambiguousSelector Located RdrName
lr
          Just p :: TyCon
p  ->
            do { [(RecSelParent, GlobalRdrElt)]
xs <- RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents RdrName
rdr
               ; let parent :: RecSelParent
parent = TyCon -> RecSelParent
RecSelData TyCon
p
               ; case RecSelParent
-> [(RecSelParent, GlobalRdrElt)] -> Maybe GlobalRdrElt
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup RecSelParent
parent [(RecSelParent, GlobalRdrElt)]
xs of
                   Just gre :: GlobalRdrElt
gre -> do { Bool -> GlobalRdrElt -> TcRn ()
addUsedGRE Bool
True GlobalRdrElt
gre
                                  ; Name -> TcM Name
forall (m :: * -> *) a. Monad m => a -> m a
return (GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre) }
                   Nothing  -> SDoc -> TcM Name
forall a. SDoc -> TcRn a
failWithTc (RecSelParent -> RdrName -> SDoc
fieldNotInType RecSelParent
parent RdrName
rdr) } }

-- This field name really is ambiguous, so add a suitable "ambiguous
-- occurrence" error, then give up.
ambiguousSelector :: Located RdrName -> TcM a
ambiguousSelector :: Located RdrName -> TcM a
ambiguousSelector (L _ rdr :: RdrName
rdr)
  = do { GlobalRdrEnv
env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
       ; let gres :: [GlobalRdrElt]
gres = RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName RdrName
rdr GlobalRdrEnv
env
       ; [ErrCtxt] -> TcRn () -> TcRn ()
forall a. [ErrCtxt] -> TcM a -> TcM a
setErrCtxt [] (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ RdrName -> [GlobalRdrElt] -> TcRn ()
addNameClashErrRn RdrName
rdr [GlobalRdrElt]
gres
       ; TcM a
forall env a. IOEnv env a
failM }

-- Disambiguate the fields in a record update.
-- See Note [Disambiguating record fields]
disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType
                 -> [LHsRecUpdField GhcRn] -> ExpRhoType
                 -> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds :: LHsExpr GhcRn
-> TcSigmaType
-> [LHsRecUpdField GhcRn]
-> ExpSigmaType
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
disambiguateRecordBinds record_expr :: LHsExpr GhcRn
record_expr record_rho :: TcSigmaType
record_rho rbnds :: [LHsRecUpdField GhcRn]
rbnds res_ty :: ExpSigmaType
res_ty
    -- Are all the fields unambiguous?
  = case (LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn, Name))
-> [LHsRecUpdField GhcRn] -> Maybe [(LHsRecUpdField GhcRn, Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn, Name)
isUnambiguous [LHsRecUpdField GhcRn]
rbnds of
                     -- If so, just skip to looking up the Ids
                     -- Always the case if DuplicateRecordFields is off
      Just rbnds' :: [(LHsRecUpdField GhcRn, Name)]
rbnds' -> ((LHsRecUpdField GhcRn, Name)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)))
-> [(LHsRecUpdField GhcRn, Name)]
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (LHsRecUpdField GhcRn, Name)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
lookupSelector [(LHsRecUpdField GhcRn, Name)]
rbnds'
      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
           ; [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
rbnds_with_parents <- TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
getUpdFieldsParents
           ; let possible_parents :: [[RecSelParent]]
possible_parents = ((LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
 -> [RecSelParent])
-> [(LHsRecUpdField 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])
-> ((LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
    -> [(RecSelParent, GlobalRdrElt)])
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> [RecSelParent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> [(RecSelParent, GlobalRdrElt)]
forall a b. (a, b) -> b
snd) [(LHsRecUpdField 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
           ; TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
forall r. TcM r -> TcM r
checkNoErrs (TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
 -> TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)])
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
forall a b. (a -> b) -> a -> b
$ ((LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)))
-> [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
pickParent RecSelParent
p) [(LHsRecUpdField 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 x :: LHsRecUpdField GhcRn
x = case Located (AmbiguousFieldOcc GhcRn)
-> SrcSpanLess (Located (AmbiguousFieldOcc GhcRn))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (LHsRecUpdField GhcRn -> SrcSpanLess (LHsRecUpdField GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsRecUpdField GhcRn
x)) of
                        Unambiguous sel_name _ -> (LHsRecUpdField GhcRn, Name) -> Maybe (LHsRecUpdField GhcRn, Name)
forall a. a -> Maybe a
Just (LHsRecUpdField GhcRn
x, Name
XUnambiguous GhcRn
sel_name)
                        Ambiguous{}            -> Maybe (LHsRecUpdField GhcRn, Name)
forall a. Maybe a
Nothing
                        XAmbiguousFieldOcc{}   -> 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 ([LHsRecUpdField GhcRn]
-> [[(RecSelParent, GlobalRdrElt)]]
-> [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [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
$ (LHsRecUpdField GhcRn -> RnM [(RecSelParent, GlobalRdrElt)])
-> [LHsRecUpdField 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
          (RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents (RdrName -> RnM [(RecSelParent, GlobalRdrElt)])
-> (LHsRecUpdField GhcRn -> RdrName)
-> LHsRecUpdField GhcRn
-> RnM [(RecSelParent, GlobalRdrElt)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located RdrName -> RdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located RdrName -> RdrName)
-> (LHsRecUpdField GhcRn -> Located RdrName)
-> LHsRecUpdField GhcRn
-> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located RdrName
forall (p :: Pass). HsRecUpdField (GhcPass p) -> Located RdrName
hsRecUpdFieldRdr (HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
 -> Located RdrName)
-> (LHsRecUpdField GhcRn
    -> HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn))
-> LHsRecUpdField GhcRn
-> Located RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsRecUpdField GhcRn
-> HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc)
          [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 fam_inst_envs :: FamInstEnvs
fam_inst_envs possible_parents :: [[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 -> TcRn a
failWithTc ([LHsRecUpdField GhcRn] -> SDoc
noPossibleParents [LHsRecUpdField GhcRn]
rbnds)

        -- Exactly one datatype with all the fields: use that
        [p :: 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?
        _:_ | Just p :: TyCon
p <- FamInstEnvs -> ExpSigmaType -> Maybe TyCon
tyConOfET FamInstEnvs
fam_inst_envs ExpSigmaType
res_ty -> 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 (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
record_expr)
            , Just tc :: TyCon
tc <- FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs TcSigmaType
record_rho
            -> RecSelParent -> TcM RecSelParent
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> RecSelParent
RecSelData TyCon
tc)

        -- Nothing else we can try...
        _ -> SDoc -> TcM RecSelParent
forall a. SDoc -> TcRn 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' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
    pickParent :: RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
pickParent p :: RecSelParent
p (upd :: LHsRecUpdField GhcRn
upd, xs :: [(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 gre :: 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 loc :: SrcSpan
loc _ = HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (LHsRecUpdField GhcRn -> SrcSpanLess (LHsRecUpdField GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc 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)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
lookupSelector (LHsRecUpdField GhcRn
upd, GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre) }
                      -- The field doesn't belong to this parent, so report
                      -- an error but keep going through all the fields
          Nothing  -> do { SDoc -> TcRn ()
addErrTc (RecSelParent -> RdrName -> SDoc
fieldNotInType RecSelParent
p
                                      (Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located RdrName
forall (p :: Pass). HsRecUpdField (GhcPass p) -> Located RdrName
hsRecUpdFieldRdr (LHsRecUpdField GhcRn -> SrcSpanLess (LHsRecUpdField GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsRecUpdField GhcRn
upd))))
                         ; (LHsRecUpdField GhcRn, Name)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
lookupSelector (LHsRecUpdField GhcRn
upd, GlobalRdrElt -> Name
gre_name ((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' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
    lookupSelector :: (LHsRecUpdField GhcRn, Name)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
lookupSelector (L l :: SrcSpan
l upd :: HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
upd, n :: Name
n)
      = do { EvVar
i <- Name -> TcM EvVar
tcLookupId Name
n
           ; let L loc :: SrcSpan
loc af :: AmbiguousFieldOcc GhcRn
af = HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
upd
                 lbl :: RdrName
lbl      = AmbiguousFieldOcc GhcRn -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc AmbiguousFieldOcc GhcRn
af
           ; LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)))
-> LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
upd { hsRecFieldLbl :: Located (AmbiguousFieldOcc GhcTcId)
hsRecFieldLbl
                                  = SrcSpan
-> AmbiguousFieldOcc GhcTcId -> Located (AmbiguousFieldOcc GhcTcId)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XUnambiguous GhcTcId
-> Located RdrName -> AmbiguousFieldOcc GhcTcId
forall pass.
XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Unambiguous EvVar
XUnambiguous GhcTcId
i (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
lbl)) } }


-- Extract the outermost TyCon of a type, if there is one; for
-- data families this is the representation tycon (because that's
-- where the fields live).
tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf fam_inst_envs :: FamInstEnvs
fam_inst_envs ty0 :: TcSigmaType
ty0
  = case HasCallStack => TcSigmaType -> Maybe (TyCon, [TcSigmaType])
TcSigmaType -> Maybe (TyCon, [TcSigmaType])
tcSplitTyConApp_maybe TcSigmaType
ty of
      Just (tc :: TyCon
tc, tys :: [TcSigmaType]
tys) -> TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just ((TyCon, [TcSigmaType], TcCoercionR) -> TyCon
forall a b c. (a, b, c) -> a
fstOf3 (FamInstEnvs
-> TyCon -> [TcSigmaType] -> (TyCon, [TcSigmaType], TcCoercionR)
tcLookupDataFamInst FamInstEnvs
fam_inst_envs TyCon
tc [TcSigmaType]
tys))
      Nothing        -> Maybe TyCon
forall a. Maybe a
Nothing
  where
    (_, _, ty :: TcSigmaType
ty) = TcSigmaType -> ([EvVar], [TcSigmaType], TcSigmaType)
tcSplitSigmaTy TcSigmaType
ty0

-- Variant of tyConOf that works for ExpTypes
tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon
tyConOfET :: FamInstEnvs -> ExpSigmaType -> Maybe TyCon
tyConOfET fam_inst_envs :: FamInstEnvs
fam_inst_envs ty0 :: ExpSigmaType
ty0 = FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs (TcSigmaType -> Maybe TyCon) -> Maybe TcSigmaType -> Maybe TyCon
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExpSigmaType -> Maybe TcSigmaType
checkingExpType_maybe ExpSigmaType
ty0

-- For an ambiguous record field, find all the candidate record
-- selectors (as GlobalRdrElts) and their parents.
lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents rdr :: RdrName
rdr
  = do { GlobalRdrEnv
env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
       ; let gres :: [GlobalRdrElt]
gres = RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName RdrName
rdr GlobalRdrEnv
env
       ; (GlobalRdrElt
 -> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt))
-> [GlobalRdrElt] -> RnM [(RecSelParent, GlobalRdrElt)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GlobalRdrElt
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
lookupParent [GlobalRdrElt]
gres }
  where
    lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
    lookupParent :: GlobalRdrElt
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
lookupParent gre :: GlobalRdrElt
gre = do { EvVar
id <- Name -> TcM EvVar
tcLookupId (GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre)
                          ; if EvVar -> Bool
isRecordSelector EvVar
id
                              then (RecSelParent, GlobalRdrElt)
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
forall (m :: * -> *) a. Monad m => a -> m a
return (EvVar -> RecSelParent
recordSelectorTyCon EvVar
id, GlobalRdrElt
gre)
                              else SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
forall a. SDoc -> TcRn a
failWithTc (Name -> SDoc
notSelector (GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre)) }

-- A type signature on the argument of an ambiguous record selector or
-- the record expression in an update must be "obvious", i.e. the
-- outermost constructor ignoring parentheses.
obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (ExprWithTySig _ _ ty :: LHsSigWcType (NoGhcTc GhcRn)
ty) = LHsSigWcType GhcRn -> Maybe (LHsSigWcType GhcRn)
forall a. a -> Maybe a
Just LHsSigWcType (NoGhcTc GhcRn)
LHsSigWcType GhcRn
ty
obviousSig (HsPar _ p :: LHsExpr GhcRn
p)          = HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
p)
obviousSig _                    = Maybe (LHsSigWcType GhcRn)
forall a. Maybe a
Nothing


{-
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 tcArg, 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 GhcTcId)

tcRecordBinds :: ConLike
-> [TcSigmaType]
-> HsRecordBinds GhcRn
-> TcM (HsRecordBinds GhcTcId)
tcRecordBinds con_like :: ConLike
con_like arg_tys :: [TcSigmaType]
arg_tys (HsRecFields rbinds :: [LHsRecField GhcRn (LHsExpr GhcRn)]
rbinds dd :: Maybe Int
dd)
  = do  { [Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))]
mb_binds <- (LHsRecField GhcRn (LHsExpr GhcRn)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))))
-> [LHsRecField GhcRn (LHsExpr GhcRn)]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecField GhcRn (LHsExpr GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId)))
do_bind [LHsRecField GhcRn (LHsExpr GhcRn)]
rbinds
        ; HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsRecField GhcTcId (LHsExpr GhcTcId)]
-> Maybe Int -> HsRecordBinds GhcTcId
forall p arg. [LHsRecField p arg] -> Maybe Int -> HsRecFields p arg
HsRecFields ([Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))]
-> [LHsRecField GhcTcId (LHsExpr GhcTcId)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))]
mb_binds) Maybe Int
dd) }
  where
    fields :: [Name]
fields = (FieldLbl Name -> Name) -> [FieldLbl Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLbl Name -> Name
forall a. FieldLbl a -> a
flSelector ([FieldLbl Name] -> [Name]) -> [FieldLbl Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLbl Name]
conLikeFieldLabels ConLike
con_like
    flds_w_tys :: [(Name, TcSigmaType)]
flds_w_tys = String -> [Name] -> [TcSigmaType] -> [(Name, TcSigmaType)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual "tcRecordBinds" [Name]
fields [TcSigmaType]
arg_tys

    do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
            -> TcM (Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId)))
    do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId)))
do_bind (L l :: SrcSpan
l fld :: HsRecField GhcRn (LHsExpr 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 = LHsExpr GhcRn
rhs }))

      = do { Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId)
mb <- ConLike
-> [(Name, TcSigmaType)]
-> Located (FieldOcc GhcRn)
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
tcRecordField ConLike
con_like [(Name, TcSigmaType)]
flds_w_tys Located (FieldOcc GhcRn)
f LHsExpr GhcRn
rhs
           ; case Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId)
mb of
               Nothing         -> Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))
forall a. Maybe a
Nothing
               Just (f' :: LFieldOcc GhcTcId
f', rhs' :: LHsExpr GhcTcId
rhs') -> Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId)))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsRecField GhcTcId (LHsExpr GhcTcId)
-> Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))
forall a. a -> Maybe a
Just (SrcSpan
-> HsRecField' (FieldOcc GhcTcId) (LHsExpr GhcTcId)
-> LHsRecField GhcTcId (LHsExpr GhcTcId)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsRecField GhcRn (LHsExpr GhcRn)
fld { hsRecFieldLbl :: LFieldOcc GhcTcId
hsRecFieldLbl = LFieldOcc GhcTcId
f'
                                                          , hsRecFieldArg :: LHsExpr GhcTcId
hsRecFieldArg = LHsExpr GhcTcId
rhs' }))) }

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

tcRecordUpd :: ConLike
-> [TcSigmaType]
-> [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTcId]
tcRecordUpd con_like :: ConLike
con_like arg_tys :: [TcSigmaType]
arg_tys rbinds :: [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
rbinds = ([Maybe (LHsRecUpdField GhcTcId)] -> [LHsRecUpdField GhcTcId])
-> IOEnv (Env TcGblEnv TcLclEnv) [Maybe (LHsRecUpdField GhcTcId)]
-> TcM [LHsRecUpdField GhcTcId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (LHsRecUpdField GhcTcId)] -> [LHsRecUpdField GhcTcId]
forall a. [Maybe a] -> [a]
catMaybes (IOEnv (Env TcGblEnv TcLclEnv) [Maybe (LHsRecUpdField GhcTcId)]
 -> TcM [LHsRecUpdField GhcTcId])
-> IOEnv (Env TcGblEnv TcLclEnv) [Maybe (LHsRecUpdField GhcTcId)]
-> TcM [LHsRecUpdField GhcTcId]
forall a b. (a -> b) -> a -> b
$ (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsRecUpdField GhcTcId)))
-> [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [Maybe (LHsRecUpdField GhcTcId)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsRecUpdField GhcTcId))
do_bind [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
rbinds
  where
    fields :: [Name]
fields = (FieldLbl Name -> Name) -> [FieldLbl Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLbl Name -> Name
forall a. FieldLbl a -> a
flSelector ([FieldLbl Name] -> [Name]) -> [FieldLbl Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLbl Name]
conLikeFieldLabels ConLike
con_like
    flds_w_tys :: [(Name, TcSigmaType)]
flds_w_tys = String -> [Name] -> [TcSigmaType] -> [(Name, TcSigmaType)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual "tcRecordUpd" [Name]
fields [TcSigmaType]
arg_tys

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

tcRecordField :: ConLike -> Assoc Name Type
              -> LFieldOcc GhcRn -> LHsExpr GhcRn
              -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField :: ConLike
-> [(Name, TcSigmaType)]
-> Located (FieldOcc GhcRn)
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
tcRecordField con_like :: ConLike
con_like flds_w_tys :: [(Name, TcSigmaType)]
flds_w_tys (L loc :: SrcSpan
loc (FieldOcc sel_name :: XCFieldOcc GhcRn
sel_name lbl :: Located RdrName
lbl)) rhs :: LHsExpr GhcRn
rhs
  | Just field_ty :: TcSigmaType
field_ty <- [(Name, TcSigmaType)] -> Name -> Maybe TcSigmaType
forall a b. Eq a => Assoc a b -> a -> Maybe b
assocMaybe [(Name, TcSigmaType)]
flds_w_tys Name
XCFieldOcc GhcRn
sel_name
      = SDoc
-> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
-> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (FastString -> SDoc
fieldCtxt FastString
field_lbl) (TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
 -> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId)))
-> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
-> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
forall a b. (a -> b) -> a -> b
$
        do { LHsExpr GhcTcId
rhs' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExprNC LHsExpr GhcRn
rhs TcSigmaType
field_ty
           ; let field_id :: EvVar
field_id = OccName -> Unique -> TcSigmaType -> SrcSpan -> EvVar
mkUserLocal (Name -> OccName
nameOccName Name
XCFieldOcc GhcRn
sel_name)
                                        (Name -> Unique
nameUnique Name
XCFieldOcc GhcRn
sel_name)
                                        TcSigmaType
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 (LFieldOcc GhcTcId, LHsExpr GhcTcId)
-> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
return ((LFieldOcc GhcTcId, LHsExpr GhcTcId)
-> Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId)
forall a. a -> Maybe a
Just (SrcSpan -> FieldOcc GhcTcId -> LFieldOcc GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XCFieldOcc GhcTcId -> Located RdrName -> FieldOcc GhcTcId
forall pass. XCFieldOcc pass -> Located RdrName -> FieldOcc pass
FieldOcc EvVar
XCFieldOcc GhcTcId
field_id Located RdrName
lbl), LHsExpr GhcTcId
rhs')) }
      | Bool
otherwise
      = do { SDoc -> TcRn ()
addErrTc (ConLike -> FastString -> SDoc
badFieldCon ConLike
con_like FastString
field_lbl)
           ; Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId)
-> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId)
forall a. Maybe a
Nothing }
  where
        field_lbl :: FastString
field_lbl = OccName -> FastString
occNameFS (OccName -> FastString) -> OccName -> FastString
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc (Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located RdrName
lbl)
tcRecordField _ _ (L _ (XFieldOcc _)) _ = String -> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
forall a. String -> a
panic "tcRecordField"


checkMissingFields ::  ConLike -> HsRecordBinds GhcRn -> TcM ()
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcRn ()
checkMissingFields con_like :: ConLike
con_like rbinds :: HsRecordBinds GhcRn
rbinds
  | [FieldLbl Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLbl Name]
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 -> [FastString] -> 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 a. [a] -> Bool
notNull [HsImplBang]
field_strs Bool -> Bool -> Bool
&& [FieldLbl Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLbl Name]
field_labels)
             (WarnReason -> Bool -> SDoc -> TcRn ()
warnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingFields) Bool
True
                 (ConLike -> [FastString] -> SDoc
missingFields ConLike
con_like []))

  | Bool
otherwise = do              -- A record
    Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FastString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FastString]
missing_s_fields)
           (SDoc -> TcRn ()
addErrTc (ConLike -> [FastString] -> SDoc
missingStrictFields ConLike
con_like [FastString]
missing_s_fields))

    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
&& [FastString] -> Bool
forall a. [a] -> Bool
notNull [FastString]
missing_ns_fields)
         (WarnReason -> Bool -> SDoc -> TcRn ()
warnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingFields) Bool
True
             (ConLike -> [FastString] -> SDoc
missingFields ConLike
con_like [FastString]
missing_ns_fields))

  where
    missing_s_fields :: [FastString]
missing_s_fields
        = [ FieldLbl Name -> FastString
forall a. FieldLbl a -> FastString
flLabel FieldLbl Name
fl | (fl :: FieldLbl Name
fl, str :: HsImplBang
str) <- [(FieldLbl Name, HsImplBang)]
field_info,
                 HsImplBang -> Bool
isBanged HsImplBang
str,
                 Bool -> Bool
not (FieldLbl Name
fl FieldLbl Name -> [Name] -> Bool
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
FieldLbl a -> t a -> Bool
`elemField` [Name]
[XCFieldOcc GhcRn]
field_names_used)
          ]
    missing_ns_fields :: [FastString]
missing_ns_fields
        = [ FieldLbl Name -> FastString
forall a. FieldLbl a -> FastString
flLabel FieldLbl Name
fl | (fl :: FieldLbl Name
fl, str :: HsImplBang
str) <- [(FieldLbl Name, HsImplBang)]
field_info,
                 Bool -> Bool
not (HsImplBang -> Bool
isBanged HsImplBang
str),
                 Bool -> Bool
not (FieldLbl Name
fl FieldLbl Name -> [Name] -> Bool
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
FieldLbl a -> t a -> Bool
`elemField` [Name]
[XCFieldOcc GhcRn]
field_names_used)
          ]

    field_names_used :: [XCFieldOcc GhcRn]
field_names_used = HsRecordBinds GhcRn -> [XCFieldOcc GhcRn]
forall p arg. HsRecFields p arg -> [XCFieldOcc p]
hsRecFields HsRecordBinds GhcRn
rbinds
    field_labels :: [FieldLbl Name]
field_labels     = ConLike -> [FieldLbl Name]
conLikeFieldLabels ConLike
con_like

    field_info :: [(FieldLbl Name, HsImplBang)]
field_info = String
-> [FieldLbl Name] -> [HsImplBang] -> [(FieldLbl Name, HsImplBang)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual "missingFields"
                          [FieldLbl Name]
field_labels
                          [HsImplBang]
field_strs

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

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

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

Boring and alphabetical:
-}

addExprErrCtxt :: LHsExpr GhcRn -> TcM a -> TcM a
addExprErrCtxt :: LHsExpr GhcRn -> TcM a -> TcM a
addExprErrCtxt expr :: LHsExpr GhcRn
expr = SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsExpr GhcRn -> SDoc
exprCtxt LHsExpr GhcRn
expr)

exprCtxt :: LHsExpr GhcRn -> SDoc
exprCtxt :: LHsExpr GhcRn -> SDoc
exprCtxt expr :: LHsExpr GhcRn
expr
  = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "In the expression:") 2 (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
expr)

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

addFunResCtxt :: Bool  -- There is at least one argument
              -> HsExpr GhcRn -> TcType -> ExpRhoType
              -> TcM a -> TcM a
-- When we have a mis-match in the return type of a function
-- try to give a helpful message about too many/few arguments
--
-- Used for naked variables too; but with has_args = False
addFunResCtxt :: Bool
-> HsExpr GhcRn -> TcSigmaType -> ExpSigmaType -> TcM a -> TcM a
addFunResCtxt has_args :: Bool
has_args fun :: HsExpr GhcRn
fun fun_res_ty :: TcSigmaType
fun_res_ty env_ty :: ExpSigmaType
env_ty
  = (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addLandmarkErrCtxtM (\env :: TidyEnv
env -> (TidyEnv
env, ) (SDoc -> (TidyEnv, SDoc))
-> IOEnv (Env TcGblEnv TcLclEnv) SDoc -> TcM (TidyEnv, SDoc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) SDoc
mk_msg)
      -- NB: use a landmark error context, so that an empty context
      -- doesn't suppress some more useful context
  where
    mk_msg :: IOEnv (Env TcGblEnv TcLclEnv) SDoc
mk_msg
      = do { Maybe TcSigmaType
mb_env_ty <- ExpSigmaType -> TcM (Maybe TcSigmaType)
readExpType_maybe ExpSigmaType
env_ty
                     -- by the time the message is rendered, the ExpType
                     -- will be filled in (except if we're debugging)
           ; TcSigmaType
fun_res' <- TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
fun_res_ty
           ; TcSigmaType
env'     <- case Maybe TcSigmaType
mb_env_ty of
                           Just env_ty :: TcSigmaType
env_ty -> TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
env_ty
                           Nothing     ->
                             do { Bool
dumping <- DumpFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl Bool
doptM DumpFlag
Opt_D_dump_tc_trace
                                ; MASSERT( dumping )
                                ; TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind }
           ; let -- See Note [Splitting nested sigma types in mismatched
                 --           function types]
                 (_, _, fun_tau :: TcSigmaType
fun_tau) = TcSigmaType -> ([EvVar], [TcSigmaType], TcSigmaType)
tcSplitNestedSigmaTys TcSigmaType
fun_res'
                 -- No need to call tcSplitNestedSigmaTys here, since env_ty is
                 -- an ExpRhoTy, i.e., it's already deeply instantiated.
                 (_, _, env_tau :: TcSigmaType
env_tau) = TcSigmaType -> ([EvVar], [TcSigmaType], TcSigmaType)
tcSplitSigmaTy TcSigmaType
env'
                 (args_fun :: [TcSigmaType]
args_fun, res_fun :: TcSigmaType
res_fun) = TcSigmaType -> ([TcSigmaType], TcSigmaType)
tcSplitFunTys TcSigmaType
fun_tau
                 (args_env :: [TcSigmaType]
args_env, res_env :: TcSigmaType
res_env) = TcSigmaType -> ([TcSigmaType], TcSigmaType)
tcSplitFunTys TcSigmaType
env_tau
                 n_fun :: Int
n_fun = [TcSigmaType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TcSigmaType]
args_fun
                 n_env :: Int
n_env = [TcSigmaType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TcSigmaType]
args_env
                 info :: SDoc
info  | Int
n_fun Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n_env = SDoc
Outputable.empty
                       | Int
n_fun Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n_env
                       , TcSigmaType -> Bool
not_fun TcSigmaType
res_env
                       = String -> SDoc
text "Probable cause:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
fun)
                         SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is applied to too few arguments"

                       | Bool
has_args
                       , TcSigmaType -> Bool
not_fun TcSigmaType
res_fun
                       = String -> SDoc
text "Possible cause:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
fun)
                         SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is applied to too many arguments"

                       | Bool
otherwise
                       = SDoc
Outputable.empty  -- Never suggest that a naked variable is                                         -- applied to too many args!
           ; SDoc -> IOEnv (Env TcGblEnv TcLclEnv) SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
info }
      where
        not_fun :: TcSigmaType -> Bool
not_fun ty :: TcSigmaType
ty   -- ty is definitely not an arrow type,
                     -- and cannot conceivably become one
          = case HasCallStack => TcSigmaType -> Maybe (TyCon, [TcSigmaType])
TcSigmaType -> Maybe (TyCon, [TcSigmaType])
tcSplitTyConApp_maybe TcSigmaType
ty of
              Just (tc :: TyCon
tc, _) -> TyCon -> Bool
isAlgTyCon TyCon
tc
              Nothing      -> Bool
False

{-
Note [Splitting nested sigma types in mismatched function types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When one applies a function to too few arguments, GHC tries to determine this
fact if possible so that it may give a helpful error message. It accomplishes
this by checking if the type of the applied function has more argument types
than supplied arguments.

Previously, GHC computed the number of argument types through tcSplitSigmaTy.
This is incorrect in the face of nested foralls, however! This caused Trac
#13311, for instance:

  f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b

If one uses `f` like so:

  do { f; putChar 'a' }

Then tcSplitSigmaTy will decompose the type of `f` into:

  Tyvars: [a]
  Context: (Monoid a)
  Argument types: []
  Return type: forall b. Monoid b => Maybe a -> Maybe b

That is, it will conclude that there are *no* argument types, and since `f`
was given no arguments, it won't print a helpful error message. On the other
hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to:

  Tyvars: [a, b]
  Context: (Monoid a, Monoid b)
  Argument types: [Maybe a]
  Return type: Maybe b

So now GHC recognizes that `f` has one more argument type than it was actually
provided.
-}

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

badFieldsUpd
  :: [LHsRecField' (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' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
-> [ConLike] -> SDoc
badFieldsUpd rbinds :: [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
rbinds data_cons :: [ConLike]
data_cons
  = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "No constructor has all these fields:")
       2 ([FastString] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [FastString]
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 :: [FastString]
conflictingFields = case [(FastString, [Bool])]
nonMembers of
        -- nonMember belongs to a different type.
        (nonMember :: FastString
nonMember, _) : _ -> [FastString
aMember, FastString
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 :: [(FastString, [Bool])]
growingSets = ((FastString, [Bool])
 -> (FastString, [Bool]) -> (FastString, [Bool]))
-> [(FastString, [Bool])] -> [(FastString, [Bool])]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 (FastString, [Bool])
-> (FastString, [Bool]) -> (FastString, [Bool])
forall a a. (a, [Bool]) -> (a, [Bool]) -> (a, [Bool])
combine [(FastString, [Bool])]
membership
            combine :: (a, [Bool]) -> (a, [Bool]) -> (a, [Bool])
combine (_, setMem :: [Bool]
setMem) (field :: a
field, fldMem :: [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.
            ([(FastString, [Bool])] -> FastString)
-> [[(FastString, [Bool])]] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map ((FastString, [Bool]) -> FastString
forall a b. (a, b) -> a
fst ((FastString, [Bool]) -> FastString)
-> ([(FastString, [Bool])] -> (FastString, [Bool]))
-> [(FastString, [Bool])]
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FastString, [Bool])] -> (FastString, [Bool])
forall a. [a] -> a
head) ([[(FastString, [Bool])]] -> [FastString])
-> [[(FastString, [Bool])]] -> [FastString]
forall a b. (a -> b) -> a -> b
$ ((FastString, [Bool]) -> (FastString, [Bool]) -> Bool)
-> [(FastString, [Bool])] -> [[(FastString, [Bool])]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ([Bool] -> [Bool] -> Bool
forall a. Eq a => a -> a -> Bool
(==) ([Bool] -> [Bool] -> Bool)
-> ((FastString, [Bool]) -> [Bool])
-> (FastString, [Bool])
-> (FastString, [Bool])
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (FastString, [Bool]) -> [Bool]
forall a b. (a, b) -> b
snd) [(FastString, [Bool])]
growingSets

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

    -- For each field, which constructors contain the field?
    membership :: [(FieldLabelString, [Bool])]
    membership :: [(FastString, [Bool])]
membership = [(FastString, [Bool])] -> [(FastString, [Bool])]
forall a. [(a, [Bool])] -> [(a, [Bool])]
sortMembership ([(FastString, [Bool])] -> [(FastString, [Bool])])
-> [(FastString, [Bool])] -> [(FastString, [Bool])]
forall a b. (a -> b) -> a -> b
$
        (FastString -> (FastString, [Bool]))
-> [FastString] -> [(FastString, [Bool])]
forall a b. (a -> b) -> [a] -> [b]
map (\fld :: FastString
fld -> (FastString
fld, (Set FastString -> Bool) -> [Set FastString] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> Set FastString -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FastString
fld) [Set FastString]
fieldLabelSets)) ([FastString] -> [(FastString, [Bool])])
-> [FastString] -> [(FastString, [Bool])]
forall a b. (a -> b) -> a -> b
$
          (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
 -> FastString)
-> [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
-> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> FastString
occNameFS (OccName -> FastString)
-> (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
    -> OccName)
-> LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> OccName)
-> (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
    -> RdrName)
-> LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AmbiguousFieldOcc GhcTcId -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc (AmbiguousFieldOcc GhcTcId -> RdrName)
-> (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
    -> AmbiguousFieldOcc GhcTcId)
-> LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (AmbiguousFieldOcc GhcTcId) -> AmbiguousFieldOcc GhcTcId
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located (AmbiguousFieldOcc GhcTcId) -> AmbiguousFieldOcc GhcTcId)
-> (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
    -> Located (AmbiguousFieldOcc GhcTcId))
-> LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> AmbiguousFieldOcc GhcTcId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> Located (AmbiguousFieldOcc GhcTcId)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
 -> Located (AmbiguousFieldOcc GhcTcId))
-> (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
    -> HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
-> LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> Located (AmbiguousFieldOcc GhcTcId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
rbinds

    fieldLabelSets :: [Set.Set FieldLabelString]
    fieldLabelSets :: [Set FastString]
fieldLabelSets = (ConLike -> Set FastString) -> [ConLike] -> [Set FastString]
forall a b. (a -> b) -> [a] -> [b]
map ([FastString] -> Set FastString
forall a. Ord a => [a] -> Set a
Set.fromList ([FastString] -> Set FastString)
-> (ConLike -> [FastString]) -> ConLike -> Set FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldLbl Name -> FastString) -> [FieldLbl Name] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map FieldLbl Name -> FastString
forall a. FieldLbl a -> FastString
flLabel ([FieldLbl Name] -> [FastString])
-> (ConLike -> [FieldLbl Name]) -> ConLike -> [FastString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConLike -> [FieldLbl Name]
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@(_, membershipRow :: [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 Trac #7989.
-}

naughtyRecordSel :: RdrName -> SDoc
naughtyRecordSel :: RdrName -> SDoc
naughtyRecordSel sel_id :: RdrName
sel_id
  = String -> SDoc
text "Cannot use record selector" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
sel_id) SDoc -> SDoc -> SDoc
<+>
    String -> SDoc
text "as a function due to escaped type variables" SDoc -> SDoc -> SDoc
$$
    String -> SDoc
text "Probable fix: use pattern-matching syntax instead"

notSelector :: Name -> SDoc
notSelector :: Name -> SDoc
notSelector field :: Name
field
  = [SDoc] -> SDoc
hsep [SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
field), String -> SDoc
text "is not a record selector"]

mixedSelectors :: [Id] -> [Id] -> SDoc
mixedSelectors :: [EvVar] -> [EvVar] -> SDoc
mixedSelectors data_sels :: [EvVar]
data_sels@(dc_rep_id :: EvVar
dc_rep_id:_) pat_syn_sels :: [EvVar]
pat_syn_sels@(ps_rep_id :: EvVar
ps_rep_id:_)
  = PtrString -> SDoc
ptext
      (String -> PtrString
sLit "Cannot use a mixture of pattern synonym and record selectors") SDoc -> SDoc -> SDoc
$$
    String -> SDoc
text "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 ":"
      SDoc -> SDoc -> SDoc
<+> (EvVar -> SDoc) -> [EvVar] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr [EvVar]
data_sels SDoc -> SDoc -> SDoc
$$
    String -> SDoc
text "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 ":"
      SDoc -> SDoc -> SDoc
<+> (EvVar -> SDoc) -> [EvVar] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr [EvVar]
pat_syn_sels
  where
    RecSelPatSyn rep_ps :: PatSyn
rep_ps = EvVar -> RecSelParent
recordSelectorTyCon EvVar
ps_rep_id
    RecSelData rep_dc :: TyCon
rep_dc = EvVar -> RecSelParent
recordSelectorTyCon EvVar
dc_rep_id
mixedSelectors _ _ = String -> SDoc
forall a. String -> a
panic "TcExpr: mixedSelectors emptylists"


missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc
missingStrictFields :: ConLike -> [FastString] -> SDoc
missingStrictFields con :: ConLike
con fields :: [FastString]
fields
  = SDoc
header SDoc -> SDoc -> SDoc
<> SDoc
rest
  where
    rest :: SDoc
rest | [FastString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FastString]
fields = SDoc
Outputable.empty  -- Happens for non-record constructors
                                           -- with strict fields
         | Bool
otherwise   = SDoc
colon SDoc -> SDoc -> SDoc
<+> (FastString -> SDoc) -> [FastString] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr [FastString]
fields

    header :: SDoc
header = String -> SDoc
text "Constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
con) SDoc -> SDoc -> SDoc
<+>
             String -> SDoc
text "does not have the required strict field(s)"

missingFields :: ConLike -> [FieldLabelString] -> SDoc
missingFields :: ConLike -> [FastString] -> SDoc
missingFields con :: ConLike
con fields :: [FastString]
fields
  = SDoc
header SDoc -> SDoc -> SDoc
<> SDoc
rest
  where
    rest :: SDoc
rest | [FastString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FastString]
fields = SDoc
Outputable.empty
         | Bool
otherwise = SDoc
colon SDoc -> SDoc -> SDoc
<+> (FastString -> SDoc) -> [FastString] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr [FastString]
fields
    header :: SDoc
header = String -> SDoc
text "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 "not initialised"

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

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

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

fieldNotInType :: RecSelParent -> RdrName -> SDoc
fieldNotInType :: RecSelParent -> RdrName -> SDoc
fieldNotInType p :: RecSelParent
p rdr :: RdrName
rdr
  = SDoc -> RdrName -> SDoc
unknownSubordinateErr (String -> SDoc
text "field of type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RecSelParent -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecSelParent
p)) RdrName
rdr

{-
************************************************************************
*                                                                      *
\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
name = do
    TcTypeEnv
type_env <- TcM TcTypeEnv
getLclTypeEnv
    case TcTypeEnv -> Name -> Maybe NotClosedReason
checkClosed TcTypeEnv
type_env Name
name of
      Nothing -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just reason :: 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 type_env :: TcTypeEnv
type_env n :: 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 type_env :: TcTypeEnv
type_env visited :: UniqSet Name
visited n :: Name
n = do
      -- 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 -> EvVar
tct_id = EvVar
tcid, tct_info :: TcTyThing -> IdBindingInfo
tct_info = IdBindingInfo
info }) -> case IdBindingInfo
info of
          ClosedLet   -> Maybe NotClosedReason
forall a. Maybe a
Nothing
          NotLetBound -> NotClosedReason -> Maybe NotClosedReason
forall a. a -> Maybe a
Just NotClosedReason
NotLetBoundReason
          NonClosedLet fvs :: UniqSet Name
fvs type_closed :: 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 reason :: 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
$ TcSigmaType -> VarSet
tyCoVarsOfType (EvVar -> TcSigmaType
idType EvVar
tcid) ]
        -- The binding is closed.
        _ -> 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
name reason :: NotClosedReason
reason =
      SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is used in a static form but it is not closed"
                        SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "because it"
                        SDoc -> SDoc -> SDoc
$$
                        [SDoc] -> SDoc
sep (NotClosedReason -> [SDoc]
causes NotClosedReason
reason)

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