{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies, DataKinds, TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Gen.Expr
( tcCheckPolyExpr,
tcCheckMonoExpr, tcCheckMonoExprNC, tcMonoExpr, tcMonoExprNC,
tcInferSigma, tcInferRho, tcInferRhoNC,
tcExpr,
tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
tcCheckId,
addAmbiguousNameErr,
getFixedTyVars ) where
#include "GhclibHsVersions.h"
import GHC.Prelude
import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
import GHC.Builtin.Names.TH( liftStringName, liftName )
import GHC.Hs
import GHC.Tc.Utils.Zonk
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Types.Basic
import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Gen.Bind ( chooseInferredQuantifiers, tcLocalBinds )
import GHC.Tc.Gen.Sig ( tcUserTypeSig, tcInstSig )
import GHC.Tc.Solver ( simplifyInfer, InferMode(..) )
import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst, tcLookupDataFamInst_maybe )
import GHC.Core.FamInstEnv ( FamInstEnvs )
import GHC.Rename.Env ( addUsedGRE )
import GHC.Rename.Utils ( addNameClashErrRn, unknownSubordinateErr )
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Arrow
import GHC.Tc.Gen.Match
import GHC.Tc.Gen.HsType
import GHC.Tc.TyCl.PatSyn ( tcPatSynBuilderOcc, nonBidirectionalErr )
import GHC.Tc.Gen.Pat
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType as TcType
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr
import GHC.Core.TyCo.Subst (substTyWithInScope)
import GHC.Core.Type
import GHC.Tc.Types.Evidence
import GHC.Types.Var.Set
import GHC.Builtin.Types
import GHC.Builtin.PrimOps( tagToEnumKey )
import GHC.Builtin.Names
import GHC.Driver.Session
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet )
import GHC.Data.List.SetOps
import GHC.Data.Maybe
import GHC.Utils.Outputable as Outputable
import GHC.Data.FastString
import Control.Monad
import GHC.Core.Class(classTyCon)
import GHC.Types.Unique.Set ( nonDetEltsUniqSet )
import qualified GHC.LanguageExtensions as LangExt
import Data.Function
import Data.List (partition, sortBy, groupBy, intersect)
import qualified Data.Set as Set
tcCheckPolyExpr, tcCheckPolyExprNC
:: LHsExpr GhcRn
-> TcSigmaType
-> TcM (LHsExpr GhcTc)
tcCheckPolyExpr :: LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr TcSigmaType
res_ty = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcPolyExpr LHsExpr GhcRn
expr (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
res_ty)
tcCheckPolyExprNC :: LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
expr TcSigmaType
res_ty = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcPolyExprNC LHsExpr GhcRn
expr (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
res_ty)
tcPolyExpr, tcPolyExprNC
:: LHsExpr GhcRn -> ExpSigmaType
-> TcM (LHsExpr GhcTc)
tcPolyExpr :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcPolyExpr LHsExpr GhcRn
expr ExpSigmaType
res_ty
= LHsExpr GhcRn -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. LHsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt LHsExpr GhcRn
expr (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcPolyExpr" (ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
res_ty)
; LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcPolyExprNC LHsExpr GhcRn
expr ExpSigmaType
res_ty }
tcPolyExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcPolyExprNC (L SrcSpan
loc HsExpr GhcRn
expr) ExpSigmaType
res_ty
= SrcSpan
-> HsExpr GhcRn -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. SrcSpan -> HsExpr GhcRn -> TcRn a -> TcRn a
set_loc_and_ctxt SrcSpan
loc HsExpr GhcRn
expr (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcPolyExprNC" (ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
res_ty)
; (HsWrapper
wrap, HsExpr GhcTc
expr') <- UserTypeCtxt
-> ExpSigmaType
-> (ExpSigmaType -> TcM (HsExpr GhcTc))
-> TcM (HsWrapper, HsExpr GhcTc)
forall result.
UserTypeCtxt
-> ExpSigmaType
-> (ExpSigmaType -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemiseET UserTypeCtxt
GenSigCtxt ExpSigmaType
res_ty ((ExpSigmaType -> TcM (HsExpr GhcTc))
-> TcM (HsWrapper, HsExpr GhcTc))
-> (ExpSigmaType -> TcM (HsExpr GhcTc))
-> TcM (HsWrapper, HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ \ ExpSigmaType
res_ty ->
HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpSigmaType
res_ty
; LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcTc -> TcM (LHsExpr GhcTc))
-> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap HsExpr GhcTc
expr') }
where
set_loc_and_ctxt :: SrcSpan -> HsExpr GhcRn -> TcRn a -> TcRn a
set_loc_and_ctxt SrcSpan
l HsExpr GhcRn
e TcRn a
m = do
Bool
inGenCode <- TcRn Bool
inGeneratedCode
if Bool
inGenCode Bool -> Bool -> Bool
&& Bool -> Bool
not (SrcSpan -> Bool
isGeneratedSrcSpan SrcSpan
l)
then SrcSpan -> TcRn a -> TcRn a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
l (TcRn a -> TcRn a) -> TcRn a -> TcRn a
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcRn a -> TcRn a
forall a. LHsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt (SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsExpr GhcRn
e) TcRn a
m
else SrcSpan -> TcRn a -> TcRn a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
l TcRn a
m
tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
tcInferSigma le :: LHsExpr GhcRn
le@(L SrcSpan
loc HsExpr GhcRn
expr)
= LHsExpr GhcRn
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a. LHsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt LHsExpr GhcRn
le (TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType))
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType))
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$
do { (HsExpr GhcTc
fun, [LHsExprArgOut]
args, TcSigmaType
ty) <- HsExpr GhcRn -> TcM (HsExpr GhcTc, [LHsExprArgOut], TcSigmaType)
tcInferApp HsExpr GhcRn
expr
; (LHsExpr GhcTc, TcSigmaType) -> TcM (LHsExpr GhcTc, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
applyHsArgs HsExpr GhcTc
fun [LHsExprArgOut]
args), TcSigmaType
ty) }
tcCheckMonoExpr, tcCheckMonoExprNC
:: LHsExpr GhcRn
-> TcRhoType
-> TcM (LHsExpr GhcTc)
tcCheckMonoExpr :: LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
expr TcSigmaType
res_ty = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
expr (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
res_ty)
tcCheckMonoExprNC :: LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
expr TcSigmaType
res_ty = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr GhcRn
expr (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
res_ty)
tcMonoExpr, tcMonoExprNC
:: LHsExpr GhcRn
-> ExpRhoType
-> TcM (LHsExpr GhcTc)
tcMonoExpr :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
expr ExpSigmaType
res_ty
= LHsExpr GhcRn -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. LHsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt LHsExpr GhcRn
expr (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr GhcRn
expr ExpSigmaType
res_ty
tcMonoExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcMonoExprNC (L SrcSpan
loc HsExpr GhcRn
expr) ExpSigmaType
res_ty
= SrcSpan -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
do { HsExpr GhcTc
expr' <- HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpSigmaType
res_ty
; LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsExpr GhcTc
expr') }
tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
tcInferRho :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
tcInferRho LHsExpr GhcRn
le = LHsExpr GhcRn
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a. LHsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt LHsExpr GhcRn
le (LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
tcInferRhoNC LHsExpr GhcRn
le)
tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
tcInferRhoNC (L SrcSpan
loc HsExpr GhcRn
expr)
= SrcSpan
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType))
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$
do { (HsExpr GhcTc
expr', TcSigmaType
rho) <- (ExpSigmaType -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc, TcSigmaType)
forall a. (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
tcInfer (HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr)
; (LHsExpr GhcTc, TcSigmaType) -> TcM (LHsExpr GhcTc, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsExpr GhcTc
expr', TcSigmaType
rho) }
tcLExpr, tcLExprNC
:: LHsExpr GhcRn
-> ExpRhoType
-> TcM (LHsExpr GhcTc)
tcLExpr :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
expr ExpSigmaType
res_ty
= SrcSpan -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (LHsExpr GhcRn -> SrcSpan
forall l e. GenLocated l e -> l
getLoc LHsExpr GhcRn
expr) (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. LHsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt LHsExpr GhcRn
expr (LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcLExprNC LHsExpr GhcRn
expr ExpSigmaType
res_ty)
tcLExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcLExprNC (L SrcSpan
loc HsExpr GhcRn
expr) ExpSigmaType
res_ty
= SrcSpan -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
do { HsExpr GhcTc
expr' <- HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpSigmaType
res_ty
; LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsExpr GhcTc
expr') }
tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcExpr (HsVar XVar GhcRn
_ (L SrcSpan
_ IdP GhcRn
name)) ExpSigmaType
res_ty = Name -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcCheckId Name
IdP GhcRn
name ExpSigmaType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsUnboundVar XUnboundVar GhcRn
_ OccName
uv) ExpSigmaType
res_ty = HsExpr GhcRn -> OccName -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcUnboundId HsExpr GhcRn
e OccName
uv ExpSigmaType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsApp {}) ExpSigmaType
res_ty = HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpSigmaType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsAppType {}) ExpSigmaType
res_ty = HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpSigmaType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsLit XLitE GhcRn
x HsLit GhcRn
lit) 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 GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
e (XLitE GhcTc -> HsLit GhcTc -> HsExpr GhcTc
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcRn
XLitE GhcTc
x (HsLit GhcRn -> HsLit GhcTc
forall (p1 :: Pass) (p2 :: Pass).
HsLit (GhcPass p1) -> HsLit (GhcPass p2)
convertLit HsLit GhcRn
lit)) TcSigmaType
lit_ty ExpSigmaType
res_ty }
tcExpr (HsPar XPar GhcRn
x LHsExpr GhcRn
expr) ExpSigmaType
res_ty = do { LHsExpr GhcTc
expr' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcLExprNC LHsExpr GhcRn
expr ExpSigmaType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XPar GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcRn
XPar GhcTc
x LHsExpr GhcTc
expr') }
tcExpr (HsPragE XPragE GhcRn
x HsPragE GhcRn
prag LHsExpr GhcRn
expr) ExpSigmaType
res_ty
= do { LHsExpr GhcTc
expr' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
expr ExpSigmaType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XPragE GhcTc -> HsPragE GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p
HsPragE XPragE GhcRn
XPragE GhcTc
x (HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag HsPragE GhcRn
prag) LHsExpr GhcTc
expr') }
tcExpr (HsOverLit XOverLitE GhcRn
x HsOverLit GhcRn
lit) ExpSigmaType
res_ty
= do { HsOverLit GhcTc
lit' <- HsOverLit GhcRn -> ExpSigmaType -> TcM (HsOverLit GhcTc)
newOverloadedLit HsOverLit GhcRn
lit ExpSigmaType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XOverLitE GhcTc -> HsOverLit GhcTc -> HsExpr GhcTc
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcRn
XOverLitE GhcTc
x HsOverLit GhcTc
lit') }
tcExpr (NegApp XNegApp GhcRn
x LHsExpr GhcRn
expr SyntaxExpr GhcRn
neg_expr) ExpSigmaType
res_ty
= do { (LHsExpr GhcTc
expr', SyntaxExprTc
neg_expr')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> [TcSigmaType] -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc, SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
NegateOrigin SyntaxExprRn
SyntaxExpr GhcRn
neg_expr [SyntaxOpType
SynAny] ExpSigmaType
res_ty (([TcSigmaType] -> [TcSigmaType] -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc, SyntaxExprTc))
-> ([TcSigmaType] -> [TcSigmaType] -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc, SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\[TcSigmaType
arg_ty] [TcSigmaType
arg_mult] ->
TcSigmaType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
arg_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
expr (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
arg_ty)
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XNegApp GhcTc -> LHsExpr GhcTc -> SyntaxExpr GhcTc -> HsExpr GhcTc
forall p. XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p
NegApp XNegApp GhcRn
XNegApp GhcTc
x LHsExpr GhcTc
expr' SyntaxExprTc
SyntaxExpr GhcTc
neg_expr') }
tcExpr e :: HsExpr GhcRn
e@(HsIPVar XIPVar GhcRn
_ HsIPName
x) ExpSigmaType
res_ty
= do {
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 GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
e
(Class -> TcSigmaType -> TcSigmaType -> HsExpr GhcTc -> HsExpr GhcTc
fromDict Class
ipClass TcSigmaType
ip_name TcSigmaType
ip_ty (XVar GhcTc -> Located (IdP GhcTc) -> HsExpr GhcTc
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (EvVar -> Located EvVar
forall e. e -> Located e
noLoc EvVar
ip_var)))
TcSigmaType
ip_ty ExpSigmaType
res_ty }
where
fromDict :: Class -> TcSigmaType -> TcSigmaType -> HsExpr GhcTc -> HsExpr GhcTc
fromDict Class
ipClass TcSigmaType
x TcSigmaType
ty = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc)
-> HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsWrapper
mkWpCastR (TcCoercionR -> HsWrapper) -> TcCoercionR -> HsWrapper
forall a b. (a -> b) -> a -> b
$
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 XOverLabel GhcRn
_ Maybe (IdP GhcRn)
mb_fromLabel FastString
l) ExpSigmaType
res_ty
= do {
SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; case Maybe (IdP GhcRn)
mb_fromLabel of
Just IdP GhcRn
fromLabel -> HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcExpr (SrcSpan -> Name -> HsExpr GhcRn
applyFromLabel SrcSpan
loc Name
IdP GhcRn
fromLabel) ExpSigmaType
res_ty
Maybe (IdP GhcRn)
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 GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
e
(TcSigmaType -> HsExpr GhcTc -> HsExpr GhcTc
fromDict TcSigmaType
pred (XVar GhcTc -> Located (IdP GhcTc) -> HsExpr GhcTc
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (SrcSpan -> EvVar -> Located EvVar
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc EvVar
var)))
TcSigmaType
alpha ExpSigmaType
res_ty } }
where
fromDict :: TcSigmaType -> HsExpr GhcTc -> HsExpr GhcTc
fromDict TcSigmaType
pred = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc)
-> HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsWrapper
mkWpCastR (TcCoercionR -> HsWrapper) -> TcCoercionR -> HsWrapper
forall a b. (a -> b) -> a -> b
$ 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 SrcSpan
loc Name
fromLabel =
XAppTypeE GhcRn
-> LHsExpr GhcRn -> LHsWcType (NoGhcTc GhcRn) -> HsExpr GhcRn
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType NoExtField
XAppTypeE GhcRn
noExtField
(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 NoExtField
XVar GhcRn
noExtField (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 NoExtField
XTyLit GhcRn
noExtField (SourceText -> FastString -> HsTyLit
HsStrTy SourceText
NoSourceText FastString
l))))
tcExpr (HsLam XLam GhcRn
x MatchGroup GhcRn (LHsExpr GhcRn)
match) ExpSigmaType
res_ty
= do { (HsWrapper
wrap, MatchGroup GhcTc (LHsExpr GhcTc)
match') <- SDoc
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchLambda SDoc
herald TcMatchCtxt HsExpr
match_ctxt MatchGroup GhcRn (LHsExpr GhcRn)
match ExpSigmaType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (XLam GhcTc -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcRn
XLam GhcTc
x MatchGroup GhcTc (LHsExpr GhcTc)
match')) }
where
match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext GhcRn
-> (Located (body GhcRn)
-> ExpSigmaType -> TcM (Located (body GhcTc)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
forall p. HsMatchContext p
LambdaExpr, mc_body :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
mc_body = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcBody }
herald :: SDoc
herald = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The lambda expression" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (Depth -> SDoc -> SDoc
pprSetDepth (Int -> Depth
PartWay Int
1) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
MatchGroup GhcRn (LHsExpr GhcRn) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
MatchGroup (GhcPass idR) body -> SDoc
pprMatches MatchGroup GhcRn (LHsExpr GhcRn)
match),
String -> SDoc
text String
"has"]
tcExpr e :: HsExpr GhcRn
e@(HsLamCase XLamCase GhcRn
x MatchGroup GhcRn (LHsExpr GhcRn)
matches) ExpSigmaType
res_ty
= do { (HsWrapper
wrap, MatchGroup GhcTc (LHsExpr GhcTc)
matches')
<- SDoc
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchLambda SDoc
msg TcMatchCtxt HsExpr
match_ctxt MatchGroup GhcRn (LHsExpr GhcRn)
matches ExpSigmaType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XLamCase GhcTc -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall p. XLamCase p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase XLamCase GhcRn
XLamCase GhcTc
x MatchGroup GhcTc (LHsExpr GhcTc)
matches') }
where
msg :: SDoc
msg = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The function" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e)
, String -> SDoc
text String
"requires"]
match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext GhcRn
-> (Located (body GhcRn)
-> ExpSigmaType -> TcM (Located (body GhcTc)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
forall p. HsMatchContext p
CaseAlt, mc_body :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
mc_body = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcBody }
tcExpr e :: HsExpr GhcRn
e@(ExprWithTySig XExprWithTySig GhcRn
_ LHsExpr GhcRn
expr LHsSigWcType (NoGhcTc GhcRn)
hs_ty) ExpSigmaType
res_ty
= do { (HsExpr GhcTc
expr', TcSigmaType
poly_ty) <- LHsExpr GhcRn
-> LHsSigWcType (NoGhcTc GhcRn) -> TcM (HsExpr GhcTc, TcSigmaType)
tcExprWithSig LHsExpr GhcRn
expr LHsSigWcType (NoGhcTc GhcRn)
hs_ty
; HsExpr GhcRn
-> HsExpr GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
e HsExpr GhcTc
expr' TcSigmaType
poly_ty ExpSigmaType
res_ty }
tcExpr expr :: HsExpr GhcRn
expr@(OpApp XOpApp GhcRn
fix LHsExpr GhcRn
arg1 LHsExpr GhcRn
op LHsExpr GhcRn
arg2) ExpSigmaType
res_ty
| (L SrcSpan
loc (HsVar XVar GhcRn
_ (L SrcSpan
lv 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
= do { String -> SDoc -> TcRn ()
traceTc String
"Application rule" (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
op)
; (LHsExpr GhcTc
arg1', TcSigmaType
arg1_ty) <- SDoc
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
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
arg1 Int
1) (TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType))
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
tcInferRhoNC LHsExpr GhcRn
arg1
; let doc :: SDoc
doc = String -> SDoc
text String
"The first argument of ($) takes"
orig1 :: CtOrigin
orig1 = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
arg1
; (HsWrapper
wrap_arg1, [Scaled TcSigmaType
arg2_sigma], TcSigmaType
op_res_ty) <-
SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> Int
-> TcSigmaType
-> TcM (HsWrapper, [Scaled TcSigmaType], TcSigmaType)
matchActualFunTysRho SDoc
doc CtOrigin
orig1 (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
arg1)) Int
1 TcSigmaType
arg1_ty
; HsWrapper
mult_wrap <- CtOrigin -> TcSigmaType -> TcSigmaType -> TcM HsWrapper
tcSubMult CtOrigin
AppOrigin TcSigmaType
Many (Scaled TcSigmaType -> TcSigmaType
forall a. Scaled a -> TcSigmaType
scaledMult Scaled TcSigmaType
arg2_sigma)
; LHsExpr GhcTc
arg2' <- HsExpr GhcRn
-> LHsExpr GhcRn
-> Scaled TcSigmaType
-> Int
-> TcM (LHsExpr GhcTc)
tcArg HsExpr GhcRn
nl_op LHsExpr GhcRn
arg2 Scaled TcSigmaType
arg2_sigma Int
2
; 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 (Scaled TcSigmaType -> TcSigmaType
forall a. Scaled a -> a
scaledThing Scaled TcSigmaType
arg2_sigma)))
(HasDebugCallStack => TcSigmaType -> TcSigmaType
TcSigmaType -> TcSigmaType
tcTypeKind (Scaled TcSigmaType -> TcSigmaType
forall a. Scaled a -> a
scaledThing Scaled TcSigmaType
arg2_sigma)) TcSigmaType
liftedTypeKind
; EvVar
op_id <- Name -> TcM EvVar
tcLookupId Name
IdP GhcRn
op_name
; let op' :: LHsExpr GhcTc
op' = SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap ([TcSigmaType] -> HsWrapper
mkWpTyApps [ HasDebugCallStack => TcSigmaType -> TcSigmaType
TcSigmaType -> TcSigmaType
getRuntimeRep TcSigmaType
op_res_ty
, Scaled TcSigmaType -> TcSigmaType
forall a. Scaled a -> a
scaledThing Scaled TcSigmaType
arg2_sigma
, TcSigmaType
op_res_ty])
(XVar GhcTc -> Located (IdP GhcTc) -> HsExpr GhcTc
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (SrcSpan -> EvVar -> Located EvVar
forall l e. l -> e -> GenLocated l e
L SrcSpan
lv EvVar
op_id)))
expr' :: HsExpr GhcTc
expr' = XOpApp GhcTc
-> LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcRn
XOpApp GhcTc
fix (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap (HsWrapper
wrap_arg1 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
mult_wrap) LHsExpr GhcTc
arg1') LHsExpr GhcTc
op' LHsExpr GhcTc
arg2'
; HsExpr GhcRn
-> HsExpr GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
expr HsExpr GhcTc
expr' TcSigmaType
op_res_ty ExpSigmaType
res_ty }
| L SrcSpan
loc (HsRecFld XRecFld GhcRn
_ (Ambiguous XAmbiguous GhcRn
_ Located RdrName
lbl)) <- LHsExpr GhcRn
op
, Just LHsSigWcType GhcRn
sig_ty <- HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
arg1)
= 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 NoExtField
XRecFld GhcRn
noExtField (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 GhcTc)
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 String
"Non Application rule" (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
op)
; (LHsExpr GhcTc
op', TcSigmaType
op_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
tcInferRhoNC LHsExpr GhcRn
op
; (HsWrapper
wrap_fun, [Scaled TcSigmaType
arg1_ty, Scaled TcSigmaType
arg2_ty], TcSigmaType
op_res_ty)
<- SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> Int
-> TcSigmaType
-> TcM (HsWrapper, [Scaled TcSigmaType], TcSigmaType)
matchActualFunTysRho (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 -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
op)) Int
2 TcSigmaType
op_ty
; LHsExpr GhcTc
arg1' <- HsExpr GhcRn
-> LHsExpr GhcRn
-> Scaled TcSigmaType
-> Int
-> TcM (LHsExpr GhcTc)
tcArg HsExpr GhcRn
nl_op LHsExpr GhcRn
arg1 Scaled TcSigmaType
arg1_ty Int
1
; LHsExpr GhcTc
arg2' <- HsExpr GhcRn
-> LHsExpr GhcRn
-> Scaled TcSigmaType
-> Int
-> TcM (LHsExpr GhcTc)
tcArg HsExpr GhcRn
nl_op LHsExpr GhcRn
arg2 Scaled TcSigmaType
arg2_ty Int
2
; let expr' :: HsExpr GhcTc
expr' = XOpApp GhcTc
-> LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcRn
XOpApp GhcTc
fix LHsExpr GhcTc
arg1' (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
wrap_fun LHsExpr GhcTc
op') LHsExpr GhcTc
arg2'
; HsExpr GhcRn
-> HsExpr GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
expr HsExpr GhcTc
expr' TcSigmaType
op_res_ty ExpSigmaType
res_ty }
where
fn_orig :: CtOrigin
fn_orig = HsExpr GhcRn -> CtOrigin
exprCtOrigin HsExpr GhcRn
nl_op
nl_op :: HsExpr GhcRn
nl_op = LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
op
tcExpr expr :: HsExpr GhcRn
expr@(SectionR XSectionR GhcRn
x LHsExpr GhcRn
op LHsExpr GhcRn
arg2) ExpSigmaType
res_ty
= do { (LHsExpr GhcTc
op', TcSigmaType
op_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
tcInferRhoNC LHsExpr GhcRn
op
; (HsWrapper
wrap_fun, [Scaled TcSigmaType
arg1_mult TcSigmaType
arg1_ty, Scaled TcSigmaType
arg2_ty], TcSigmaType
op_res_ty)
<- SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> Int
-> TcSigmaType
-> TcM (HsWrapper, [Scaled TcSigmaType], TcSigmaType)
matchActualFunTysRho (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 -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
op)) Int
2 TcSigmaType
op_ty
; LHsExpr GhcTc
arg2' <- HsExpr GhcRn
-> LHsExpr GhcRn
-> Scaled TcSigmaType
-> Int
-> TcM (LHsExpr GhcTc)
tcArg (LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
op) LHsExpr GhcRn
arg2 Scaled TcSigmaType
arg2_ty Int
2
; let expr' :: HsExpr GhcTc
expr' = XSectionR GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR XSectionR GhcRn
XSectionR GhcTc
x (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
wrap_fun LHsExpr GhcTc
op') LHsExpr GhcTc
arg2'
act_res_ty :: TcSigmaType
act_res_ty = TcSigmaType -> TcSigmaType -> TcSigmaType -> TcSigmaType
mkVisFunTy TcSigmaType
arg1_mult TcSigmaType
arg1_ty TcSigmaType
op_res_ty
; HsExpr GhcRn
-> HsExpr GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' TcSigmaType
act_res_ty ExpSigmaType
res_ty }
where
fn_orig :: CtOrigin
fn_orig = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
op
tcExpr expr :: HsExpr GhcRn
expr@(SectionL XSectionL GhcRn
x LHsExpr GhcRn
arg1 LHsExpr GhcRn
op) ExpSigmaType
res_ty
= do { (LHsExpr GhcTc
op', TcSigmaType
op_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
tcInferRhoNC LHsExpr GhcRn
op
; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let n_reqd_args :: Int
n_reqd_args | Extension -> DynFlags -> Bool
xopt Extension
LangExt.PostfixOperators DynFlags
dflags = Int
1
| Bool
otherwise = Int
2
; (HsWrapper
wrap_fn, (Scaled TcSigmaType
arg1_ty:[Scaled TcSigmaType]
arg_tys), TcSigmaType
op_res_ty)
<- SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> Int
-> TcSigmaType
-> TcM (HsWrapper, [Scaled TcSigmaType], TcSigmaType)
matchActualFunTysRho (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 -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
op)) Int
n_reqd_args TcSigmaType
op_ty
; LHsExpr GhcTc
arg1' <- HsExpr GhcRn
-> LHsExpr GhcRn
-> Scaled TcSigmaType
-> Int
-> TcM (LHsExpr GhcTc)
tcArg (LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
op) LHsExpr GhcRn
arg1 Scaled TcSigmaType
arg1_ty Int
1
; let expr' :: HsExpr GhcTc
expr' = XSectionL GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL XSectionL GhcRn
XSectionL GhcTc
x LHsExpr GhcTc
arg1' (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
wrap_fn LHsExpr GhcTc
op')
act_res_ty :: TcSigmaType
act_res_ty = [Scaled TcSigmaType] -> TcSigmaType -> TcSigmaType
mkVisFunTys [Scaled TcSigmaType]
arg_tys TcSigmaType
op_res_ty
; HsExpr GhcRn
-> HsExpr GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' TcSigmaType
act_res_ty ExpSigmaType
res_ty }
where
fn_orig :: CtOrigin
fn_orig = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
op
tcExpr expr :: HsExpr GhcRn
expr@(ExplicitTuple XExplicitTuple GhcRn
x [LHsTupArg GhcRn]
tup_args Boxity
boxity) 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
; (TcCoercionR
coi, [TcSigmaType]
arg_tys) <- TyCon -> TcSigmaType -> TcM (TcCoercionR, [TcSigmaType])
matchExpectedTyConApp TyCon
tup_tc TcSigmaType
res_ty
; let arg_tys' :: [TcSigmaType]
arg_tys' = case Boxity
boxity of Boxity
Unboxed -> Int -> [TcSigmaType] -> [TcSigmaType]
forall a. Int -> [a] -> [a]
drop Int
arity [TcSigmaType]
arg_tys
Boxity
Boxed -> [TcSigmaType]
arg_tys
; [LHsTupArg GhcTc]
tup_args1 <- [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTc]
tcTupArgs [LHsTupArg GhcRn]
tup_args [TcSigmaType]
arg_tys'
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (XExplicitTuple GhcTc -> [LHsTupArg GhcTc] -> Boxity -> HsExpr GhcTc
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcRn
XExplicitTuple GhcTc
x [LHsTupArg GhcTc]
tup_args1 Boxity
boxity) }
| Bool
otherwise
=
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
{ Boxity
Boxed -> Int -> TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType]
newFlexiTyVarTys Int
arity TcSigmaType
liftedTypeKind
; Boxity
Unboxed -> Int
-> TcM TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
arity TcM TcSigmaType
newOpenFlexiTyVarTy }
; [LHsTupArg GhcTc]
tup_args1 <- [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTc]
tcTupArgs [LHsTupArg GhcRn]
tup_args [TcSigmaType]
arg_tys
; let expr' :: HsExpr GhcTc
expr' = XExplicitTuple GhcTc -> [LHsTupArg GhcTc] -> Boxity -> HsExpr GhcTc
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcRn
XExplicitTuple GhcTc
x [LHsTupArg GhcTc]
tup_args1 Boxity
boxity
missing_tys :: [Scaled TcSigmaType]
missing_tys = [TcSigmaType -> TcSigmaType -> Scaled TcSigmaType
forall a. TcSigmaType -> a -> Scaled a
Scaled TcSigmaType
mult TcSigmaType
ty | (L SrcSpan
_ (Missing (Scaled mult _)), TcSigmaType
ty) <- [LHsTupArg GhcTc]
-> [TcSigmaType] -> [(LHsTupArg GhcTc, TcSigmaType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LHsTupArg GhcTc]
tup_args1 [TcSigmaType]
arg_tys]
act_res_ty :: TcSigmaType
act_res_ty
= [Scaled TcSigmaType] -> TcSigmaType -> TcSigmaType
mkVisFunTys [Scaled TcSigmaType]
missing_tys (Boxity -> [TcSigmaType] -> TcSigmaType
mkTupleTy1 Boxity
boxity [TcSigmaType]
arg_tys)
; String -> SDoc -> TcRn ()
traceTc String
"ExplicitTuple" (TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
act_res_ty SDoc -> SDoc -> SDoc
$$ ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
res_ty)
; HsExpr GhcRn
-> HsExpr GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' TcSigmaType
act_res_ty ExpSigmaType
res_ty }
tcExpr (ExplicitSum XExplicitSum GhcRn
_ Int
alt Int
arity LHsExpr GhcRn
expr) 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
; (TcCoercionR
coi, [TcSigmaType]
arg_tys) <- TyCon -> TcSigmaType -> TcM (TcCoercionR, [TcSigmaType])
matchExpectedTyConApp TyCon
sum_tc TcSigmaType
res_ty
;
let arg_tys' :: [TcSigmaType]
arg_tys' = Int -> [TcSigmaType] -> [TcSigmaType]
forall a. Int -> [a] -> [a]
drop Int
arity [TcSigmaType]
arg_tys
; LHsExpr GhcTc
expr' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr 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
- Int
1))
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (XExplicitSum GhcTc -> Int -> Int -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum [TcSigmaType]
XExplicitSum GhcTc
arg_tys' Int
alt Int
arity LHsExpr GhcTc
expr' ) }
tcExpr (ExplicitList XExplicitList GhcRn
_ Maybe (SyntaxExpr GhcRn)
witness [LHsExpr GhcRn]
exprs) ExpSigmaType
res_ty
= case Maybe (SyntaxExpr GhcRn)
witness of
Maybe (SyntaxExpr GhcRn)
Nothing -> do { TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
res_ty
; (TcCoercionR
coi, TcSigmaType
elt_ty) <- TcSigmaType -> TcM (TcCoercionR, TcSigmaType)
matchExpectedListTy TcSigmaType
res_ty
; [LHsExpr GhcTc]
exprs' <- (LHsExpr GhcRn -> TcM (LHsExpr GhcTc))
-> [LHsExpr GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) [LHsExpr GhcTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcSigmaType -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc)
tc_elt TcSigmaType
elt_ty) [LHsExpr GhcRn]
exprs
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcTc
-> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] -> HsExpr GhcTc
forall p.
XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p
ExplicitList TcSigmaType
XExplicitList GhcTc
elt_ty Maybe (SyntaxExpr GhcTc)
forall a. Maybe a
Nothing [LHsExpr GhcTc]
exprs' }
Just SyntaxExpr GhcRn
fln -> do { (([LHsExpr GhcTc]
exprs', TcSigmaType
elt_ty), SyntaxExprTc
fln')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType]
-> [TcSigmaType] -> TcM ([LHsExpr GhcTc], TcSigmaType))
-> TcM (([LHsExpr GhcTc], TcSigmaType), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
ListOrigin SyntaxExprRn
SyntaxExpr GhcRn
fln
[TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
intTy, SyntaxOpType
SynList] ExpSigmaType
res_ty (([TcSigmaType]
-> [TcSigmaType] -> TcM ([LHsExpr GhcTc], TcSigmaType))
-> TcM (([LHsExpr GhcTc], TcSigmaType), SyntaxExprTc))
-> ([TcSigmaType]
-> [TcSigmaType] -> TcM ([LHsExpr GhcTc], TcSigmaType))
-> TcM (([LHsExpr GhcTc], TcSigmaType), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [TcSigmaType
elt_ty] [TcSigmaType
_int_mul, TcSigmaType
list_mul] ->
do { [LHsExpr GhcTc]
exprs' <-
(LHsExpr GhcRn -> TcM (LHsExpr GhcTc))
-> [LHsExpr GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) [LHsExpr GhcTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcSigmaType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
list_mul (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> (LHsExpr GhcRn -> TcM (LHsExpr GhcTc))
-> LHsExpr GhcRn
-> TcM (LHsExpr GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcSigmaType -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc)
tc_elt TcSigmaType
elt_ty) [LHsExpr GhcRn]
exprs
; ([LHsExpr GhcTc], TcSigmaType)
-> TcM ([LHsExpr GhcTc], TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsExpr GhcTc]
exprs', TcSigmaType
elt_ty) }
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcTc
-> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] -> HsExpr GhcTc
forall p.
XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p
ExplicitList TcSigmaType
XExplicitList GhcTc
elt_ty (SyntaxExprTc -> Maybe SyntaxExprTc
forall a. a -> Maybe a
Just SyntaxExprTc
fln') [LHsExpr GhcTc]
exprs' }
where tc_elt :: TcSigmaType -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc)
tc_elt TcSigmaType
elt_ty LHsExpr GhcRn
expr = LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr TcSigmaType
elt_ty
tcExpr (HsLet XLet GhcRn
x (L SrcSpan
l HsLocalBinds GhcRn
binds) LHsExpr GhcRn
expr) ExpSigmaType
res_ty
= do { (HsLocalBinds GhcTc
binds', LHsExpr GhcTc
expr') <- HsLocalBinds GhcRn
-> TcM (LHsExpr GhcTc) -> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
forall thing.
HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (TcM (LHsExpr GhcTc) -> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
expr ExpSigmaType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XLet GhcTc -> LHsLocalBinds GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XLet p -> LHsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet XLet GhcRn
XLet GhcTc
x (SrcSpan -> HsLocalBinds GhcTc -> LHsLocalBinds GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsLocalBinds GhcTc
binds') LHsExpr GhcTc
expr') }
tcExpr (HsCase XCase GhcRn
x LHsExpr GhcRn
scrut MatchGroup GhcRn (LHsExpr GhcRn)
matches) ExpSigmaType
res_ty
= do {
let mult :: TcSigmaType
mult = TcSigmaType
Many
; (LHsExpr GhcTc
scrut', TcSigmaType
scrut_ty) <- TcSigmaType
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
mult (TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType))
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
tcInferRho LHsExpr GhcRn
scrut
; String -> SDoc -> TcRn ()
traceTc String
"HsCase" (TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
scrut_ty)
; MatchGroup GhcTc (LHsExpr GhcTc)
matches' <- TcMatchCtxt HsExpr
-> Scaled TcSigmaType
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (MatchGroup GhcTc (LHsExpr GhcTc))
forall (body :: * -> *).
Outputable (body GhcRn) =>
TcMatchCtxt body
-> Scaled TcSigmaType
-> MatchGroup GhcRn (Located (body GhcRn))
-> ExpSigmaType
-> TcM (MatchGroup GhcTc (Located (body GhcTc)))
tcMatchesCase TcMatchCtxt HsExpr
match_ctxt (TcSigmaType -> TcSigmaType -> Scaled TcSigmaType
forall a. TcSigmaType -> a -> Scaled a
Scaled TcSigmaType
mult TcSigmaType
scrut_ty) MatchGroup GhcRn (LHsExpr GhcRn)
matches ExpSigmaType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCase GhcTc
-> LHsExpr GhcTc
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> HsExpr GhcTc
forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase XCase GhcRn
XCase GhcTc
x LHsExpr GhcTc
scrut' MatchGroup GhcTc (LHsExpr GhcTc)
matches') }
where
match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext GhcRn
-> (Located (body GhcRn)
-> ExpSigmaType -> TcM (Located (body GhcTc)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
forall p. HsMatchContext p
CaseAlt,
mc_body :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
mc_body = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcBody }
tcExpr (HsIf XIf GhcRn
x LHsExpr GhcRn
pred LHsExpr GhcRn
b1 LHsExpr GhcRn
b2) ExpSigmaType
res_ty
= do { LHsExpr GhcTc
pred' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
pred (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
boolTy)
; (UsageEnv
u1,LHsExpr GhcTc
b1') <- TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc)
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage (TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
b1 ExpSigmaType
res_ty
; (UsageEnv
u2,LHsExpr GhcTc
b2') <- TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc)
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage (TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
b2 ExpSigmaType
res_ty
; UsageEnv -> TcRn ()
tcEmitBindingUsage (UsageEnv -> UsageEnv -> UsageEnv
supUE UsageEnv
u1 UsageEnv
u2)
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XIf GhcTc
-> LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XIf p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsIf XIf GhcRn
XIf GhcTc
x LHsExpr GhcTc
pred' LHsExpr GhcTc
b1' LHsExpr GhcTc
b2') }
tcExpr (HsMultiIf XMultiIf GhcRn
_ [LGRHS GhcRn (LHsExpr GhcRn)]
alts) ExpSigmaType
res_ty
= do { [Located (GRHS GhcTc (LHsExpr GhcTc))]
alts' <- (LGRHS GhcRn (LHsExpr GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv) (Located (GRHS GhcTc (LHsExpr GhcTc))))
-> [LGRHS GhcRn (LHsExpr GhcRn)]
-> IOEnv
(Env TcGblEnv TcLclEnv) [Located (GRHS GhcTc (LHsExpr GhcTc))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((GRHS GhcRn (LHsExpr GhcRn) -> TcM (GRHS GhcTc (LHsExpr GhcTc)))
-> LGRHS GhcRn (LHsExpr GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv) (Located (GRHS GhcTc (LHsExpr GhcTc)))
forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM ((GRHS GhcRn (LHsExpr GhcRn) -> TcM (GRHS GhcTc (LHsExpr GhcTc)))
-> LGRHS GhcRn (LHsExpr GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv) (Located (GRHS GhcTc (LHsExpr GhcTc))))
-> (GRHS GhcRn (LHsExpr GhcRn) -> TcM (GRHS GhcTc (LHsExpr GhcTc)))
-> LGRHS GhcRn (LHsExpr GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv) (Located (GRHS GhcTc (LHsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ TcMatchCtxt HsExpr
-> ExpSigmaType
-> GRHS GhcRn (LHsExpr GhcRn)
-> TcM (GRHS GhcTc (LHsExpr GhcTc))
forall (body :: * -> *).
TcMatchCtxt body
-> ExpSigmaType
-> GRHS GhcRn (Located (body GhcRn))
-> TcM (GRHS GhcTc (Located (body GhcTc)))
tcGRHS TcMatchCtxt HsExpr
match_ctxt ExpSigmaType
res_ty) [LGRHS GhcRn (LHsExpr GhcRn)]
alts
; TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
readExpType ExpSigmaType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XMultiIf GhcTc
-> [Located (GRHS GhcTc (LHsExpr GhcTc))] -> HsExpr GhcTc
forall p. XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p
HsMultiIf TcSigmaType
XMultiIf GhcTc
res_ty [Located (GRHS GhcTc (LHsExpr GhcTc))]
alts') }
where match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext GhcRn
-> (Located (body GhcRn)
-> ExpSigmaType -> TcM (Located (body GhcTc)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
forall p. HsMatchContext p
IfAlt, mc_body :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
mc_body = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcBody }
tcExpr (HsDo XDo GhcRn
_ HsStmtContext GhcRn
do_or_lc Located [ExprLStmt GhcRn]
stmts) ExpSigmaType
res_ty
= do { HsExpr GhcTc
expr' <- HsStmtContext GhcRn
-> Located [ExprLStmt GhcRn] -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcDoStmts HsStmtContext GhcRn
do_or_lc Located [ExprLStmt GhcRn]
stmts ExpSigmaType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
expr' }
tcExpr (HsProc XProc GhcRn
x LPat GhcRn
pat LHsCmdTop GhcRn
cmd) ExpSigmaType
res_ty
= do { (Located (Pat GhcTc)
pat', LHsCmdTop GhcTc
cmd', TcCoercionR
coi) <- LPat GhcRn
-> LHsCmdTop GhcRn
-> ExpSigmaType
-> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercionR)
tcProc LPat GhcRn
pat LHsCmdTop GhcRn
cmd ExpSigmaType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (XProc GhcTc -> LPat GhcTc -> LHsCmdTop GhcTc -> HsExpr GhcTc
forall p. XProc p -> LPat p -> LHsCmdTop p -> HsExpr p
HsProc XProc GhcRn
XProc GhcTc
x Located (Pat GhcTc)
LPat GhcTc
pat' LHsCmdTop GhcTc
cmd') }
tcExpr (HsStatic XStatic GhcRn
fvs LHsExpr GhcRn
expr) ExpSigmaType
res_ty
= do { TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
res_ty
; (TcCoercionR
co, (TcSigmaType
p_ty, TcSigmaType
expr_ty)) <- TcSigmaType -> TcM (TcCoercionR, (TcSigmaType, TcSigmaType))
matchExpectedAppTy TcSigmaType
res_ty
; (LHsExpr GhcTc
expr', WantedConstraints
lie) <- TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc, WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc, WantedConstraints))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
SDoc -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"In the body of a static form:")
Int
2 (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
expr)
) (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
expr TcSigmaType
expr_ty
; (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
; 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]
; WantedConstraints -> TcRn ()
emitStaticConstraints WantedConstraints
lie
; HsExpr GhcTc
fromStaticPtr <- CtOrigin -> Name -> [TcSigmaType] -> TcM (HsExpr GhcTc)
newMethodFromName CtOrigin
StaticOrigin Name
fromStaticPtrName
[TcSigmaType
p_ty]
; let wrap :: HsWrapper
wrap = [TcSigmaType] -> HsWrapper
mkWpTyApps [TcSigmaType
expr_ty]
; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
co (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExtField
XApp GhcTc
noExtField
(SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsExpr GhcTc -> LHsExpr GhcTc) -> HsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap HsExpr GhcTc
fromStaticPtr)
(SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XStatic GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XStatic p -> LHsExpr p -> HsExpr p
HsStatic XStatic GhcRn
XStatic GhcTc
fvs LHsExpr GhcTc
expr'))
}
tcExpr expr :: HsExpr GhcRn
expr@(RecordCon { rcon_con_name :: forall p. HsExpr p -> Located (IdP p)
rcon_con_name = L SrcSpan
loc IdP GhcRn
con_name
, rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcRn
rbinds }) ExpSigmaType
res_ty
= do { ConLike
con_like <- Name -> TcM ConLike
tcLookupConLike Name
IdP GhcRn
con_name
; ConLike -> HsRecordBinds GhcRn -> TcRn ()
checkMissingFields ConLike
con_like HsRecordBinds GhcRn
rbinds
; (HsExpr GhcTc
con_expr, TcSigmaType
con_sigma) <- Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId Name
IdP GhcRn
con_name
; (HsWrapper
con_wrap, TcSigmaType
con_tau) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate CtOrigin
orig TcSigmaType
con_sigma
; let arity :: Int
arity = ConLike -> Int
conLikeArity ConLike
con_like
Right ([Scaled TcSigmaType]
arg_tys, TcSigmaType
actual_res_ty) = Int
-> TcSigmaType -> Either Int ([Scaled TcSigmaType], TcSigmaType)
tcSplitFunTysN Int
arity TcSigmaType
con_tau
; case ConLike -> Maybe EvVar
conLikeWrapId_maybe ConLike
con_like of {
Maybe EvVar
Nothing -> Name -> TcM (HsExpr GhcTc)
forall name a. Outputable name => name -> TcM a
nonBidirectionalErr (ConLike -> Name
conLikeName ConLike
con_like) ;
Just EvVar
con_id ->
do { HsRecordBinds GhcTc
rbinds' <- ConLike
-> [TcSigmaType]
-> HsRecordBinds GhcRn
-> TcM (HsRecordBinds GhcTc)
tcRecordBinds ConLike
con_like ((Scaled TcSigmaType -> TcSigmaType)
-> [Scaled TcSigmaType] -> [TcSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcSigmaType -> TcSigmaType
forall a. Scaled a -> a
scaledThing [Scaled TcSigmaType]
arg_tys) HsRecordBinds GhcRn
rbinds
; let rcon_tc :: RecordConTc
rcon_tc = RecordConTc :: ConLike -> HsExpr GhcTc -> RecordConTc
RecordConTc
{ rcon_con_like :: ConLike
rcon_con_like = ConLike
con_like
, rcon_con_expr :: HsExpr GhcTc
rcon_con_expr = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
con_wrap HsExpr GhcTc
con_expr }
expr' :: HsExpr GhcTc
expr' = RecordCon :: forall p.
XRecordCon p -> Located (IdP p) -> HsRecordBinds p -> HsExpr p
RecordCon { rcon_ext :: XRecordCon GhcTc
rcon_ext = RecordConTc
XRecordCon GhcTc
rcon_tc
, rcon_con_name :: Located (IdP GhcTc)
rcon_con_name = SrcSpan -> EvVar -> Located EvVar
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc EvVar
con_id
, rcon_flds :: HsRecordBinds GhcTc
rcon_flds = HsRecordBinds GhcTc
rbinds' }
; HsExpr GhcRn
-> HsExpr GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' TcSigmaType
actual_res_ty ExpSigmaType
res_ty } } }
where
orig :: CtOrigin
orig = Name -> CtOrigin
OccurrenceOf Name
IdP GhcRn
con_name
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 }) ExpSigmaType
res_ty
= ASSERT( notNull rbnds )
do {
(LHsExpr GhcTc
record_expr', TcSigmaType
record_rho) <- TcSigmaType
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
Many (TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType))
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
tcInferRho LHsExpr GhcRn
record_expr
; [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds <- LHsExpr GhcRn
-> TcSigmaType
-> [LHsRecUpdField GhcRn]
-> ExpSigmaType
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds LHsExpr GhcRn
record_expr TcSigmaType
record_rho [LHsRecUpdField GhcRn]
rbnds ExpSigmaType
res_ty
; let upd_flds :: [AmbiguousFieldOcc GhcTc]
upd_flds = (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> AmbiguousFieldOcc GhcTc)
-> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [AmbiguousFieldOcc GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
-> AmbiguousFieldOcc GhcTc
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
-> AmbiguousFieldOcc GhcTc)
-> (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
-> LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> AmbiguousFieldOcc GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
-> (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
-> LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
forall l e. GenLocated l e -> e
unLoc) [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds
upd_fld_occs :: [FastString]
upd_fld_occs = (AmbiguousFieldOcc GhcTc -> FastString)
-> [AmbiguousFieldOcc GhcTc] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> FastString
occNameFS (OccName -> FastString)
-> (AmbiguousFieldOcc GhcTc -> OccName)
-> AmbiguousFieldOcc GhcTc
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> OccName)
-> (AmbiguousFieldOcc GhcTc -> RdrName)
-> AmbiguousFieldOcc GhcTc
-> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AmbiguousFieldOcc GhcTc -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc) [AmbiguousFieldOcc GhcTc]
upd_flds
sel_ids :: [EvVar]
sel_ids = (AmbiguousFieldOcc GhcTc -> EvVar)
-> [AmbiguousFieldOcc GhcTc] -> [EvVar]
forall a b. (a -> b) -> [a] -> [b]
map AmbiguousFieldOcc GhcTc -> EvVar
selectorAmbiguousFieldOcc [AmbiguousFieldOcc GhcTc]
upd_flds
; 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 GhcTc) (LHsExpr GhcRn)
fld <- [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds,
let L SrcSpan
loc EvVar
sel_id = HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> Located EvVar
forall arg.
HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located EvVar
hsRecUpdFieldId (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
forall l e. GenLocated l e -> e
unLoc LHsRecField' (AmbiguousFieldOcc GhcTc) (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)
; let ([EvVar]
data_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 )
; let
EvVar
sel_id : [EvVar]
_ = [EvVar]
sel_ids
mtycon :: Maybe TyCon
mtycon :: Maybe TyCon
mtycon = case EvVar -> IdDetails
idDetails EvVar
sel_id of
RecSelId (RecSelData TyCon
tycon) Bool
_ -> TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tycon
IdDetails
_ -> Maybe TyCon
forall a. Maybe a
Nothing
con_likes :: [ConLike]
con_likes :: [ConLike]
con_likes = case EvVar -> IdDetails
idDetails EvVar
sel_id of
RecSelId (RecSelData TyCon
tc) Bool
_
-> (DataCon -> ConLike) -> [DataCon] -> [ConLike]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> ConLike
RealDataCon (TyCon -> [DataCon]
tyConDataCons TyCon
tc)
RecSelId (RecSelPatSyn PatSyn
ps) Bool
_
-> [PatSyn -> ConLike
PatSynCon PatSyn
ps]
IdDetails
_ -> String -> [ConLike]
forall a. String -> a
panic String
"tcRecordUpd"
relevant_cons :: [ConLike]
relevant_cons = [ConLike] -> [FastString] -> [ConLike]
conLikesWithFields [ConLike]
con_likes [FastString]
upd_fld_occs
; Bool -> SDoc -> TcRn ()
checkTc (Bool -> Bool
not ([ConLike] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConLike]
relevant_cons)) ([LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike] -> SDoc
badFieldsUpd [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds [ConLike]
con_likes)
; let con1 :: ConLike
con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
([EvVar]
con1_tvs, [EvVar]
_, [EqSpec]
_, [TcSigmaType]
_prov_theta, [TcSigmaType]
req_theta, [Scaled TcSigmaType]
scaled_con1_arg_tys, TcSigmaType
_)
= ConLike
-> ([EvVar], [EvVar], [EqSpec], [TcSigmaType], [TcSigmaType],
[Scaled TcSigmaType], TcSigmaType)
conLikeFullSig ConLike
con1
con1_arg_tys :: [TcSigmaType]
con1_arg_tys = (Scaled TcSigmaType -> TcSigmaType)
-> [Scaled TcSigmaType] -> [TcSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcSigmaType -> TcSigmaType
forall a. Scaled a -> a
scaledThing [Scaled TcSigmaType]
scaled_con1_arg_tys
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 TyCon
tc -> TyCon -> [TcSigmaType] -> TcSigmaType
mkFamilyTyConApp TyCon
tc [TcSigmaType]
con1_tv_tys
Maybe TyCon
Nothing -> ConLike -> [TcSigmaType] -> TcSigmaType
conLikeResTy ConLike
con1 [TcSigmaType]
con1_tv_tys
; 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))
; let flds1_w_tys :: [(FastString, TcSigmaType)]
flds1_w_tys = String
-> [FastString] -> [TcSigmaType] -> [(FastString, TcSigmaType)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"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 (FastString
fld, 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)
; 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 EvVar
tv = EvVar
tv EvVar -> VarSet -> Bool
`elemVarSet` VarSet
fixed_tvs
mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType)
mk_inst_ty :: TCvSubst -> (EvVar, TcSigmaType) -> TcM (TCvSubst, TcSigmaType)
mk_inst_ty TCvSubst
subst (EvVar
tv, TcSigmaType
result_inst_ty)
| EvVar -> Bool
is_fixed_tv EvVar
tv
= (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
= do { (TCvSubst
subst', 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) }
; (TCvSubst
result_subst, [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)
; (TCvSubst
scrut_subst, [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
; TcCoercionR
co_scrut <- Maybe (HsExpr GhcRn)
-> TcSigmaType -> TcSigmaType -> TcM TcCoercionR
unifyType (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
record_expr)) TcSigmaType
record_rho TcSigmaType
scrut_ty
; [LHsRecUpdField GhcTc]
rbinds' <- ConLike
-> [TcSigmaType]
-> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTc]
tcRecordUpd ConLike
con1 [TcSigmaType]
con1_arg_tys' [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds
; let theta' :: [TcSigmaType]
theta' = TCvSubst -> [TcSigmaType] -> [TcSigmaType]
substThetaUnchecked TCvSubst
scrut_subst (ConLike -> [TcSigmaType]
conLikeStupidTheta ConLike
con1)
; CtOrigin -> [TcSigmaType] -> TcRn ()
instStupidTheta CtOrigin
RecordUpdOrigin [TcSigmaType]
theta'
; let fam_co :: HsWrapper
fam_co :: HsWrapper
fam_co | Just TyCon
tycon <- Maybe TyCon
mtycon
, Just CoAxiom Unbranched
co_con <- TyCon -> Maybe (CoAxiom Unbranched)
tyConFamilyCoercion_maybe TyCon
tycon
= TcCoercionR -> HsWrapper
mkWpCastR (CoAxiom Unbranched -> [TcSigmaType] -> [TcCoercionR] -> TcCoercionR
mkTcUnbranchedAxInstCo CoAxiom Unbranched
co_con [TcSigmaType]
scrut_inst_tys [])
| Bool
otherwise
= HsWrapper
idHsWrapper
; 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'
; let upd_tc :: RecordUpdTc
upd_tc = 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 }
expr' :: HsExpr GhcTc
expr' = RecordUpd :: forall p.
XRecordUpd p -> LHsExpr p -> [LHsRecUpdField p] -> HsExpr p
RecordUpd { rupd_expr :: LHsExpr GhcTc
rupd_expr = HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
fam_co (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
TcCoercionR -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrapCo TcCoercionR
co_scrut LHsExpr GhcTc
record_expr'
, rupd_flds :: [LHsRecUpdField GhcTc]
rupd_flds = [LHsRecUpdField GhcTc]
rbinds'
, rupd_ext :: XRecordUpd GhcTc
rupd_ext = RecordUpdTc
XRecordUpd GhcTc
upd_tc }
; HsExpr GhcRn
-> HsExpr GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
expr HsExpr GhcTc
expr' TcSigmaType
rec_res_ty ExpSigmaType
res_ty }
tcExpr e :: HsExpr GhcRn
e@(HsRecFld XRecFld GhcRn
_ AmbiguousFieldOcc GhcRn
f) ExpSigmaType
res_ty
= HsExpr GhcRn
-> AmbiguousFieldOcc GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcCheckRecSelId HsExpr GhcRn
e AmbiguousFieldOcc GhcRn
f ExpSigmaType
res_ty
tcExpr (ArithSeq XArithSeq GhcRn
_ Maybe (SyntaxExpr GhcRn)
witness ArithSeqInfo GhcRn
seq) ExpSigmaType
res_ty
= Maybe (SyntaxExpr GhcRn)
-> ArithSeqInfo GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness ArithSeqInfo GhcRn
seq ExpSigmaType
res_ty
tcExpr (HsSpliceE XSpliceE GhcRn
_ (HsSpliced XSpliced GhcRn
_ ThModFinalizers
mod_finalizers (HsSplicedExpr HsExpr GhcRn
expr)))
ExpSigmaType
res_ty
= do ThModFinalizers -> TcRn ()
addModFinalizersWithLclEnv ThModFinalizers
mod_finalizers
HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpSigmaType
res_ty
tcExpr (HsSpliceE XSpliceE GhcRn
_ HsSplice GhcRn
splice) ExpSigmaType
res_ty = HsSplice GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcSpliceExpr HsSplice GhcRn
splice ExpSigmaType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsBracket XBracket GhcRn
_ HsBracket GhcRn
brack) ExpSigmaType
res_ty = HsExpr GhcRn
-> HsBracket GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcTypedBracket HsExpr GhcRn
e HsBracket GhcRn
brack ExpSigmaType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsRnBracketOut XRnBracketOut GhcRn
_ HsBracket GhcRn
brack [PendingRnSplice]
ps) ExpSigmaType
res_ty = HsExpr GhcRn
-> HsBracket GhcRn
-> [PendingRnSplice]
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcUntypedBracket HsExpr GhcRn
e HsBracket GhcRn
brack [PendingRnSplice]
ps ExpSigmaType
res_ty
tcExpr (XExpr (HsExpanded a b)) ExpSigmaType
t
= (HsExpr GhcTc -> HsExpr GhcTc)
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (XXExprGhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (XXExprGhcTc -> HsExpr GhcTc)
-> (HsExpr GhcTc -> XXExprGhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpansion (HsExpr GhcRn) (HsExpr GhcTc) -> XXExprGhcTc
ExpansionExpr (HsExpansion (HsExpr GhcRn) (HsExpr GhcTc) -> XXExprGhcTc)
-> (HsExpr GhcTc -> HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))
-> HsExpr GhcTc
-> XXExprGhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr GhcRn
-> HsExpr GhcTc -> HsExpansion (HsExpr GhcRn) (HsExpr GhcTc)
forall a b. a -> b -> HsExpansion a b
HsExpanded HsExpr GhcRn
a) (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
SrcSpan -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
generatedSrcSpan (HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
b ExpSigmaType
t)
tcExpr HsExpr GhcRn
other ExpSigmaType
_ = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLExpr" (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
other)
tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag (HsPragSCC XSCC GhcRn
x1 SourceText
src StringLiteral
ann) = XSCC GhcTc -> SourceText -> StringLiteral -> HsPragE GhcTc
forall p. XSCC p -> SourceText -> StringLiteral -> HsPragE p
HsPragSCC XSCC GhcRn
XSCC GhcTc
x1 SourceText
src StringLiteral
ann
tcExprPrag (HsPragTick XTickPragma GhcRn
x1 SourceText
src (StringLiteral, (Int, Int), (Int, Int))
info ((SourceText, SourceText), (SourceText, SourceText))
srcInfo) = XTickPragma GhcTc
-> SourceText
-> (StringLiteral, (Int, Int), (Int, Int))
-> ((SourceText, SourceText), (SourceText, SourceText))
-> HsPragE GhcTc
forall p.
XTickPragma p
-> SourceText
-> (StringLiteral, (Int, Int), (Int, Int))
-> ((SourceText, SourceText), (SourceText, SourceText))
-> HsPragE p
HsPragTick XTickPragma GhcRn
XTickPragma GhcTc
x1 SourceText
src (StringLiteral, (Int, Int), (Int, Int))
info ((SourceText, SourceText), (SourceText, SourceText))
srcInfo
tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn)
-> TcM (HsExpr GhcTc, TcSigmaType)
tcExprWithSig :: LHsExpr GhcRn
-> LHsSigWcType (NoGhcTc GhcRn) -> TcM (HsExpr GhcTc, TcSigmaType)
tcExprWithSig LHsExpr GhcRn
expr LHsSigWcType (NoGhcTc GhcRn)
hs_ty
= do { 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
$
SrcSpan -> LHsSigWcType GhcRn -> Maybe Name -> TcM TcIdSigInfo
tcUserTypeSig SrcSpan
loc LHsSigWcType GhcRn
LHsSigWcType (NoGhcTc GhcRn)
hs_ty Maybe Name
forall a. Maybe a
Nothing
; (LHsExpr GhcTc
expr', TcSigmaType
poly_ty) <- LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType)
tcExprSig LHsExpr GhcRn
expr TcIdSigInfo
sig_info
; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (XExprWithTySig GhcTc
-> LHsExpr GhcTc -> LHsSigWcType (NoGhcTc GhcTc) -> HsExpr GhcTc
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig NoExtField
XExprWithTySig GhcTc
noExtField LHsExpr GhcTc
expr' LHsSigWcType (NoGhcTc GhcRn)
LHsSigWcType (NoGhcTc GhcTc)
hs_ty, TcSigmaType
poly_ty) }
where
loc :: SrcSpan
loc = GenLocated SrcSpan (HsType GhcRn) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc (LHsSigWcType GhcRn -> GenLocated SrcSpan (HsType GhcRn)
forall pass. LHsSigWcType pass -> LHsType pass
hsSigWcType LHsSigWcType GhcRn
LHsSigWcType (NoGhcTc GhcRn)
hs_ty)
tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType
-> TcM (HsExpr GhcTc)
tcArithSeq :: Maybe (SyntaxExpr GhcRn)
-> ArithSeqInfo GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(From LHsExpr GhcRn
expr) ExpSigmaType
res_ty
= do { (HsWrapper
wrap, TcSigmaType
elt_mult, TcSigmaType
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpSigmaType
-> TcM
(HsWrapper, TcSigmaType, TcSigmaType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpSigmaType
res_ty
; LHsExpr GhcTc
expr' <-TcSigmaType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr TcSigmaType
elt_ty
; HsExpr GhcTc
enum_from <- CtOrigin -> Name -> [TcSigmaType] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
Name
enumFromName [TcSigmaType
elt_ty]
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
XArithSeq GhcTc
-> Maybe (SyntaxExpr GhcTc) -> ArithSeqInfo GhcTc -> HsExpr GhcTc
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq HsExpr GhcTc
XArithSeq GhcTc
enum_from Maybe SyntaxExprTc
Maybe (SyntaxExpr GhcTc)
wit' (LHsExpr GhcTc -> ArithSeqInfo GhcTc
forall id. LHsExpr id -> ArithSeqInfo id
From LHsExpr GhcTc
expr') }
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromThen LHsExpr GhcRn
expr1 LHsExpr GhcRn
expr2) ExpSigmaType
res_ty
= do { (HsWrapper
wrap, TcSigmaType
elt_mult, TcSigmaType
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpSigmaType
-> TcM
(HsWrapper, TcSigmaType, TcSigmaType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpSigmaType
res_ty
; LHsExpr GhcTc
expr1' <- TcSigmaType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 TcSigmaType
elt_ty
; LHsExpr GhcTc
expr2' <- TcSigmaType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 TcSigmaType
elt_ty
; HsExpr GhcTc
enum_from_then <- CtOrigin -> Name -> [TcSigmaType] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
Name
enumFromThenName [TcSigmaType
elt_ty]
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
XArithSeq GhcTc
-> Maybe (SyntaxExpr GhcTc) -> ArithSeqInfo GhcTc -> HsExpr GhcTc
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq HsExpr GhcTc
XArithSeq GhcTc
enum_from_then Maybe SyntaxExprTc
Maybe (SyntaxExpr GhcTc)
wit' (LHsExpr GhcTc -> LHsExpr GhcTc -> ArithSeqInfo GhcTc
forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThen LHsExpr GhcTc
expr1' LHsExpr GhcTc
expr2') }
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromTo LHsExpr GhcRn
expr1 LHsExpr GhcRn
expr2) ExpSigmaType
res_ty
= do { (HsWrapper
wrap, TcSigmaType
elt_mult, TcSigmaType
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpSigmaType
-> TcM
(HsWrapper, TcSigmaType, TcSigmaType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpSigmaType
res_ty
; LHsExpr GhcTc
expr1' <- TcSigmaType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 TcSigmaType
elt_ty
; LHsExpr GhcTc
expr2' <- TcSigmaType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 TcSigmaType
elt_ty
; HsExpr GhcTc
enum_from_to <- CtOrigin -> Name -> [TcSigmaType] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
Name
enumFromToName [TcSigmaType
elt_ty]
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
XArithSeq GhcTc
-> Maybe (SyntaxExpr GhcTc) -> ArithSeqInfo GhcTc -> HsExpr GhcTc
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq HsExpr GhcTc
XArithSeq GhcTc
enum_from_to Maybe SyntaxExprTc
Maybe (SyntaxExpr GhcTc)
wit' (LHsExpr GhcTc -> LHsExpr GhcTc -> ArithSeqInfo GhcTc
forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromTo LHsExpr GhcTc
expr1' LHsExpr GhcTc
expr2') }
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromThenTo LHsExpr GhcRn
expr1 LHsExpr GhcRn
expr2 LHsExpr GhcRn
expr3) ExpSigmaType
res_ty
= do { (HsWrapper
wrap, TcSigmaType
elt_mult, TcSigmaType
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpSigmaType
-> TcM
(HsWrapper, TcSigmaType, TcSigmaType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpSigmaType
res_ty
; LHsExpr GhcTc
expr1' <- TcSigmaType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 TcSigmaType
elt_ty
; LHsExpr GhcTc
expr2' <- TcSigmaType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 TcSigmaType
elt_ty
; LHsExpr GhcTc
expr3' <- TcSigmaType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr3 TcSigmaType
elt_ty
; HsExpr GhcTc
eft <- CtOrigin -> Name -> [TcSigmaType] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
Name
enumFromThenToName [TcSigmaType
elt_ty]
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
XArithSeq GhcTc
-> Maybe (SyntaxExpr GhcTc) -> ArithSeqInfo GhcTc -> HsExpr GhcTc
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq HsExpr GhcTc
XArithSeq GhcTc
eft Maybe SyntaxExprTc
Maybe (SyntaxExpr GhcTc)
wit' (LHsExpr GhcTc
-> LHsExpr GhcTc -> LHsExpr GhcTc -> ArithSeqInfo GhcTc
forall id.
LHsExpr id -> LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThenTo LHsExpr GhcTc
expr1' LHsExpr GhcTc
expr2' LHsExpr GhcTc
expr3') }
arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType
-> TcM (HsWrapper, Mult, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType :: Maybe (SyntaxExpr GhcRn)
-> ExpSigmaType
-> TcM
(HsWrapper, TcSigmaType, TcSigmaType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
Nothing ExpSigmaType
res_ty
= do { TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
res_ty
; (TcCoercionR
coi, TcSigmaType
elt_ty) <- TcSigmaType -> TcM (TcCoercionR, TcSigmaType)
matchExpectedListTy TcSigmaType
res_ty
; (HsWrapper, TcSigmaType, TcSigmaType, Maybe SyntaxExprTc)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsWrapper, TcSigmaType, TcSigmaType, Maybe SyntaxExprTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcCoercionR -> HsWrapper
mkWpCastN TcCoercionR
coi, TcSigmaType
One, TcSigmaType
elt_ty, Maybe SyntaxExprTc
forall a. Maybe a
Nothing) }
arithSeqEltType (Just SyntaxExpr GhcRn
fl) ExpSigmaType
res_ty
= do { ((TcSigmaType
elt_mult, TcSigmaType
elt_ty), SyntaxExprTc
fl')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType]
-> [TcSigmaType] -> TcM (TcSigmaType, TcSigmaType))
-> TcM ((TcSigmaType, TcSigmaType), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
ListOrigin SyntaxExprRn
SyntaxExpr GhcRn
fl [SyntaxOpType
SynList] ExpSigmaType
res_ty (([TcSigmaType] -> [TcSigmaType] -> TcM (TcSigmaType, TcSigmaType))
-> TcM ((TcSigmaType, TcSigmaType), SyntaxExprTc))
-> ([TcSigmaType]
-> [TcSigmaType] -> TcM (TcSigmaType, TcSigmaType))
-> TcM ((TcSigmaType, TcSigmaType), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\ [TcSigmaType
elt_ty] [TcSigmaType
elt_mult] -> (TcSigmaType, TcSigmaType) -> TcM (TcSigmaType, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcSigmaType
elt_mult, TcSigmaType
elt_ty)
; (HsWrapper, TcSigmaType, TcSigmaType, Maybe SyntaxExprTc)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsWrapper, TcSigmaType, TcSigmaType, Maybe SyntaxExprTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
idHsWrapper, TcSigmaType
elt_mult, TcSigmaType
elt_ty, SyntaxExprTc -> Maybe SyntaxExprTc
forall a. a -> Maybe a
Just SyntaxExprTc
fl') }
data HsExprArg id
= HsEValArg SrcSpan
(LHsExpr (GhcPass id))
| HsETypeArg SrcSpan
(LHsWcType (NoGhcTc (GhcPass id)))
!(XExprTypeArg id)
| HsEPrag SrcSpan
(HsPragE (GhcPass id))
| HsEPar SrcSpan
| HsEWrap !(XArgWrap id)
type LHsExprArgIn = HsExprArg 'Renamed
type LHsExprArgOut = HsExprArg 'Typechecked
instance OutputableBndrId id => Outputable (HsExprArg id) where
ppr :: HsExprArg id -> SDoc
ppr (HsEValArg SrcSpan
_ LHsExpr (GhcPass id)
tm) = LHsExpr (GhcPass id) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr (GhcPass id)
tm
ppr (HsEPrag SrcSpan
_ HsPragE (GhcPass id)
p) = String -> SDoc
text String
"HsPrag" SDoc -> SDoc -> SDoc
<+> HsPragE (GhcPass id) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsPragE (GhcPass id)
p
ppr (HsETypeArg SrcSpan
_ LHsWcType (NoGhcTc (GhcPass id))
hs_ty XExprTypeArg id
_) = Char -> SDoc
char Char
'@' SDoc -> SDoc -> SDoc
<> LHsWcType (GhcPass (NoGhcTcPass id)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsWcType (GhcPass (NoGhcTcPass id))
LHsWcType (NoGhcTc (GhcPass id))
hs_ty
ppr (HsEPar SrcSpan
_) = String -> SDoc
text String
"HsEPar"
ppr (HsEWrap XArgWrap id
w) = case IsPass id => GhcPass id
forall (p :: Pass). IsPass p => GhcPass p
ghcPass @id of
GhcPass id
GhcTc -> String -> SDoc
text String
"HsEWrap" SDoc -> SDoc -> SDoc
<+> HsWrapper -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsWrapper
XArgWrap id
w
GhcPass id
_ -> SDoc
empty
type family XExprTypeArg id where
XExprTypeArg 'Parsed = NoExtField
XExprTypeArg 'Renamed = NoExtField
XExprTypeArg 'Typechecked = Type
type family XArgWrap id where
XArgWrap 'Parsed = NoExtCon
XArgWrap 'Renamed = NoExtCon
XArgWrap 'Typechecked = HsWrapper
addArgWrap :: HsWrapper -> [LHsExprArgOut] -> [LHsExprArgOut]
addArgWrap :: HsWrapper -> [LHsExprArgOut] -> [LHsExprArgOut]
addArgWrap HsWrapper
wrap [LHsExprArgOut]
args
| HsWrapper -> Bool
isIdHsWrapper HsWrapper
wrap = [LHsExprArgOut]
args
| Bool
otherwise = XArgWrap 'Typechecked -> LHsExprArgOut
forall (id :: Pass). XArgWrap id -> HsExprArg id
HsEWrap HsWrapper
XArgWrap 'Typechecked
wrap LHsExprArgOut -> [LHsExprArgOut] -> [LHsExprArgOut]
forall a. a -> [a] -> [a]
: [LHsExprArgOut]
args
collectHsArgs :: HsExpr GhcRn -> (HsExpr GhcRn, [LHsExprArgIn])
collectHsArgs :: HsExpr GhcRn -> (HsExpr GhcRn, [LHsExprArgIn])
collectHsArgs HsExpr GhcRn
e = HsExpr GhcRn -> [LHsExprArgIn] -> (HsExpr GhcRn, [LHsExprArgIn])
forall (id :: Pass).
(XExprTypeArg id ~ NoExtField) =>
HsExpr (GhcPass id)
-> [HsExprArg id] -> (HsExpr (GhcPass id), [HsExprArg id])
go HsExpr GhcRn
e []
where
go :: HsExpr (GhcPass id)
-> [HsExprArg id] -> (HsExpr (GhcPass id), [HsExprArg id])
go (HsPar XPar (GhcPass id)
_ (L SrcSpan
l HsExpr (GhcPass id)
fun)) [HsExprArg id]
args = HsExpr (GhcPass id)
-> [HsExprArg id] -> (HsExpr (GhcPass id), [HsExprArg id])
go HsExpr (GhcPass id)
fun (SrcSpan -> HsExprArg id
forall (id :: Pass). SrcSpan -> HsExprArg id
HsEPar SrcSpan
l HsExprArg id -> [HsExprArg id] -> [HsExprArg id]
forall a. a -> [a] -> [a]
: [HsExprArg id]
args)
go (HsPragE XPragE (GhcPass id)
_ HsPragE (GhcPass id)
p (L SrcSpan
l HsExpr (GhcPass id)
fun)) [HsExprArg id]
args = HsExpr (GhcPass id)
-> [HsExprArg id] -> (HsExpr (GhcPass id), [HsExprArg id])
go HsExpr (GhcPass id)
fun (SrcSpan -> HsPragE (GhcPass id) -> HsExprArg id
forall (id :: Pass).
SrcSpan -> HsPragE (GhcPass id) -> HsExprArg id
HsEPrag SrcSpan
l HsPragE (GhcPass id)
p HsExprArg id -> [HsExprArg id] -> [HsExprArg id]
forall a. a -> [a] -> [a]
: [HsExprArg id]
args)
go (HsApp XApp (GhcPass id)
_ (L SrcSpan
l HsExpr (GhcPass id)
fun) GenLocated SrcSpan (HsExpr (GhcPass id))
arg) [HsExprArg id]
args = HsExpr (GhcPass id)
-> [HsExprArg id] -> (HsExpr (GhcPass id), [HsExprArg id])
go HsExpr (GhcPass id)
fun (SrcSpan -> GenLocated SrcSpan (HsExpr (GhcPass id)) -> HsExprArg id
forall (id :: Pass).
SrcSpan -> LHsExpr (GhcPass id) -> HsExprArg id
HsEValArg SrcSpan
l GenLocated SrcSpan (HsExpr (GhcPass id))
arg HsExprArg id -> [HsExprArg id] -> [HsExprArg id]
forall a. a -> [a] -> [a]
: [HsExprArg id]
args)
go (HsAppType XAppTypeE (GhcPass id)
_ (L SrcSpan
l HsExpr (GhcPass id)
fun) LHsWcType (NoGhcTc (GhcPass id))
hs_ty) [HsExprArg id]
args = HsExpr (GhcPass id)
-> [HsExprArg id] -> (HsExpr (GhcPass id), [HsExprArg id])
go HsExpr (GhcPass id)
fun (SrcSpan
-> LHsWcType (NoGhcTc (GhcPass id))
-> XExprTypeArg id
-> HsExprArg id
forall (id :: Pass).
SrcSpan
-> LHsWcType (NoGhcTc (GhcPass id))
-> XExprTypeArg id
-> HsExprArg id
HsETypeArg SrcSpan
l LHsWcType (NoGhcTc (GhcPass id))
hs_ty NoExtField
XExprTypeArg id
noExtField HsExprArg id -> [HsExprArg id] -> [HsExprArg id]
forall a. a -> [a] -> [a]
: [HsExprArg id]
args)
go HsExpr (GhcPass id)
e [HsExprArg id]
args = (HsExpr (GhcPass id)
e,[HsExprArg id]
args)
applyHsArgs :: HsExpr GhcTc -> [LHsExprArgOut]-> HsExpr GhcTc
applyHsArgs :: HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
applyHsArgs HsExpr GhcTc
fun [LHsExprArgOut]
args
= HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
go HsExpr GhcTc
fun [LHsExprArgOut]
args
where
go :: HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
go HsExpr GhcTc
fun [] = HsExpr GhcTc
fun
go HsExpr GhcTc
fun (HsEWrap XArgWrap 'Typechecked
wrap : [LHsExprArgOut]
args) = HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
go (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
XArgWrap 'Typechecked
wrap HsExpr GhcTc
fun) [LHsExprArgOut]
args
go HsExpr GhcTc
fun (HsEValArg SrcSpan
l LHsExpr GhcTc
arg : [LHsExprArgOut]
args) = HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
go (XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExtField
XApp GhcTc
noExtField (SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsExpr GhcTc
fun) LHsExpr GhcTc
arg) [LHsExprArgOut]
args
go HsExpr GhcTc
fun (HsETypeArg SrcSpan
l LHsWcType (NoGhcTc GhcTc)
hs_ty XExprTypeArg 'Typechecked
ty : [LHsExprArgOut]
args) = HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
go (XAppTypeE GhcTc
-> LHsExpr GhcTc -> LHsWcType (NoGhcTc GhcTc) -> HsExpr GhcTc
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE GhcTc
XExprTypeArg 'Typechecked
ty (SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsExpr GhcTc
fun) LHsWcType (NoGhcTc GhcTc)
hs_ty) [LHsExprArgOut]
args
go HsExpr GhcTc
fun (HsEPar SrcSpan
l : [LHsExprArgOut]
args) = HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
go (XPar GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar NoExtField
XPar GhcTc
noExtField (SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsExpr GhcTc
fun)) [LHsExprArgOut]
args
go HsExpr GhcTc
fun (HsEPrag SrcSpan
l HsPragE GhcTc
p : [LHsExprArgOut]
args) = HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
go (XPragE GhcTc -> HsPragE GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p
HsPragE NoExtField
XPragE GhcTc
noExtField HsPragE GhcTc
p (SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsExpr GhcTc
fun)) [LHsExprArgOut]
args
isHsValArg :: HsExprArg id -> Bool
isHsValArg :: HsExprArg id -> Bool
isHsValArg (HsEValArg {}) = Bool
True
isHsValArg HsExprArg id
_ = Bool
False
isArgPar :: HsExprArg id -> Bool
isArgPar :: HsExprArg id -> Bool
isArgPar (HsEPar {}) = Bool
True
isArgPar HsExprArg id
_ = Bool
False
getFunLoc :: [HsExprArg 'Renamed] -> Maybe SrcSpan
getFunLoc :: [LHsExprArgIn] -> Maybe SrcSpan
getFunLoc [] = Maybe SrcSpan
forall a. Maybe a
Nothing
getFunLoc (LHsExprArgIn
a:[LHsExprArgIn]
_) = SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just (SrcSpan -> Maybe SrcSpan) -> SrcSpan -> Maybe SrcSpan
forall a b. (a -> b) -> a -> b
$ case LHsExprArgIn
a of
HsEValArg SrcSpan
l LHsExpr GhcRn
_ -> SrcSpan
l
HsETypeArg SrcSpan
l LHsWcType (NoGhcTc GhcRn)
_ XExprTypeArg 'Renamed
_ -> SrcSpan
l
HsEPrag SrcSpan
l HsPragE GhcRn
_ -> SrcSpan
l
HsEPar SrcSpan
l -> SrcSpan
l
tcApp :: HsExpr GhcRn
-> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
expr ExpSigmaType
res_ty
= do { (HsExpr GhcTc
fun, [LHsExprArgOut]
args, TcSigmaType
app_res_ty) <- HsExpr GhcRn -> TcM (HsExpr GhcTc, [LHsExprArgOut], TcSigmaType)
tcInferApp HsExpr GhcRn
expr
; if HsExpr GhcTc -> Bool
isTagToEnum HsExpr GhcTc
fun
then HsExpr GhcRn
-> HsExpr GhcTc
-> [LHsExprArgOut]
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcTagToEnum HsExpr GhcRn
expr HsExpr GhcTc
fun [LHsExprArgOut]
args TcSigmaType
app_res_ty ExpSigmaType
res_ty
else
do { let expr' :: HsExpr GhcTc
expr' = HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
applyHsArgs HsExpr GhcTc
fun [LHsExprArgOut]
args
; Bool
-> HsExpr GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
-> TcM (HsExpr GhcTc)
forall a.
Bool
-> HsExpr GhcTc -> TcSigmaType -> ExpSigmaType -> TcM a -> TcM a
addFunResCtxt Bool
True HsExpr GhcTc
fun TcSigmaType
app_res_ty ExpSigmaType
res_ty (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
HsExpr GhcRn
-> HsExpr GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
expr HsExpr GhcTc
expr' TcSigmaType
app_res_ty ExpSigmaType
res_ty } }
tcInferApp :: HsExpr GhcRn
-> TcM ( HsExpr GhcTc
, [LHsExprArgOut]
, TcSigmaType)
tcInferApp :: HsExpr GhcRn -> TcM (HsExpr GhcTc, [LHsExprArgOut], TcSigmaType)
tcInferApp HsExpr GhcRn
expr
|
HsRecFld XRecFld GhcRn
_ AmbiguousFieldOcc GhcRn
fld_lbl <- HsExpr GhcRn
fun
, Ambiguous XAmbiguous GhcRn
_ Located RdrName
lbl <- AmbiguousFieldOcc GhcRn
fld_lbl
, HsEValArg SrcSpan
_ (L SrcSpan
_ HsExpr GhcRn
arg) : [LHsExprArgIn]
_ <- (LHsExprArgIn -> Bool) -> [LHsExprArgIn] -> [LHsExprArgIn]
forall a. (a -> Bool) -> [a] -> [a]
filterOut LHsExprArgIn -> Bool
forall (id :: Pass). HsExprArg id -> Bool
isArgPar [LHsExprArgIn]
args
, Just LHsSigWcType GhcRn
sig_ty <- HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig HsExpr GhcRn
arg
= 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
; (HsExpr GhcTc
tc_fun, TcSigmaType
fun_ty) <- AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTc, 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)
; HsExpr GhcRn
-> HsExpr GhcTc
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM (HsExpr GhcTc, [LHsExprArgOut], TcSigmaType)
tcInferApp_finish HsExpr GhcRn
fun HsExpr GhcTc
tc_fun TcSigmaType
fun_ty [LHsExprArgIn]
args }
| Bool
otherwise
= do { (HsExpr GhcTc
tc_fun, TcSigmaType
fun_ty) <- TcM (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
set_fun_loc (HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferAppHead HsExpr GhcRn
fun)
; HsExpr GhcRn
-> HsExpr GhcTc
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM (HsExpr GhcTc, [LHsExprArgOut], TcSigmaType)
tcInferApp_finish HsExpr GhcRn
fun HsExpr GhcTc
tc_fun TcSigmaType
fun_ty [LHsExprArgIn]
args }
where
(HsExpr GhcRn
fun, [LHsExprArgIn]
args) = HsExpr GhcRn -> (HsExpr GhcRn, [LHsExprArgIn])
collectHsArgs HsExpr GhcRn
expr
set_fun_loc :: TcM (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
set_fun_loc TcM (HsExpr GhcTc, TcSigmaType)
thing_inside
= case [LHsExprArgIn] -> Maybe SrcSpan
getFunLoc [LHsExprArgIn]
args of
Maybe SrcSpan
Nothing -> TcM (HsExpr GhcTc, TcSigmaType)
thing_inside
Just SrcSpan
loc -> SrcSpan
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (HsExpr GhcTc, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc TcM (HsExpr GhcTc, TcSigmaType)
thing_inside
tcInferApp_finish
:: HsExpr GhcRn
-> HsExpr GhcTc -> TcSigmaType
-> [LHsExprArgIn]
-> TcM (HsExpr GhcTc, [LHsExprArgOut], TcSigmaType)
tcInferApp_finish :: HsExpr GhcRn
-> HsExpr GhcTc
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM (HsExpr GhcTc, [LHsExprArgOut], TcSigmaType)
tcInferApp_finish HsExpr GhcRn
rn_fun HsExpr GhcTc
tc_fun TcSigmaType
fun_sigma [LHsExprArgIn]
rn_args
= do { ([LHsExprArgOut]
tc_args, TcSigmaType
actual_res_ty) <- HsExpr GhcRn
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM ([LHsExprArgOut], TcSigmaType)
tcArgs HsExpr GhcRn
rn_fun TcSigmaType
fun_sigma [LHsExprArgIn]
rn_args
; (HsExpr GhcTc, [LHsExprArgOut], TcSigmaType)
-> TcM (HsExpr GhcTc, [LHsExprArgOut], TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
tc_fun, [LHsExprArgOut]
tc_args, TcSigmaType
actual_res_ty) }
mk_op_msg :: LHsExpr GhcRn -> SDoc
mk_op_msg :: LHsExpr GhcRn -> SDoc
mk_op_msg LHsExpr GhcRn
op = String -> SDoc
text String
"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 String
"takes"
tcInferAppHead :: HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferAppHead :: HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferAppHead HsExpr GhcRn
e
= case HsExpr GhcRn
e of
HsVar XVar GhcRn
_ (L SrcSpan
_ IdP GhcRn
nm) -> Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId Name
IdP GhcRn
nm
HsRecFld XRecFld GhcRn
_ AmbiguousFieldOcc GhcRn
f -> AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferRecSelId AmbiguousFieldOcc GhcRn
f
ExprWithTySig XExprWithTySig GhcRn
_ LHsExpr GhcRn
e LHsSigWcType (NoGhcTc GhcRn)
hs_ty -> TcM (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
add_ctxt (TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (HsExpr GhcTc, TcSigmaType))
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (HsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn
-> LHsSigWcType (NoGhcTc GhcRn) -> TcM (HsExpr GhcTc, TcSigmaType)
tcExprWithSig LHsExpr GhcRn
e LHsSigWcType (NoGhcTc GhcRn)
hs_ty
HsExpr GhcRn
_ -> TcM (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
add_ctxt (TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (HsExpr GhcTc, TcSigmaType))
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (HsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$ (ExpSigmaType -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc, TcSigmaType)
forall a. (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
tcInfer (HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
e)
where
add_ctxt :: TcM (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
add_ctxt TcM (HsExpr GhcTc, TcSigmaType)
thing = SDoc
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (HsExpr GhcTc, TcSigmaType)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsExpr GhcRn -> SDoc
exprCtxt HsExpr GhcRn
e) TcM (HsExpr GhcTc, TcSigmaType)
thing
tcArgs :: HsExpr GhcRn
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM ([LHsExprArgOut], TcSigmaType)
tcArgs :: HsExpr GhcRn
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM ([LHsExprArgOut], TcSigmaType)
tcArgs HsExpr GhcRn
fun TcSigmaType
orig_fun_ty [LHsExprArgIn]
orig_args
= Int
-> [Scaled TcSigmaType]
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM ([LHsExprArgOut], TcSigmaType)
go Int
1 [] TcSigmaType
orig_fun_ty [LHsExprArgIn]
orig_args
where
fun_orig :: CtOrigin
fun_orig = HsExpr GhcRn -> CtOrigin
exprCtOrigin HsExpr GhcRn
fun
herald :: SDoc
herald = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The function" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
fun)
, String -> SDoc
text String
"is applied to"]
n_val_args :: Int
n_val_args = (LHsExprArgIn -> Bool) -> [LHsExprArgIn] -> Int
forall a. (a -> Bool) -> [a] -> Int
count LHsExprArgIn -> Bool
forall (id :: Pass). HsExprArg id -> Bool
isHsValArg [LHsExprArgIn]
orig_args
fun_is_out_of_scope :: Bool
fun_is_out_of_scope
= case HsExpr GhcRn
fun of
HsUnboundVar {} -> Bool
True
HsExpr GhcRn
_ -> Bool
False
go :: Int
-> [Scaled TcSigmaType]
-> TcSigmaType
-> [LHsExprArgIn] -> TcM ([LHsExprArgOut], TcSigmaType)
go :: Int
-> [Scaled TcSigmaType]
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM ([LHsExprArgOut], TcSigmaType)
go Int
_ [Scaled TcSigmaType]
_ TcSigmaType
fun_ty [] = String -> SDoc -> TcRn ()
traceTc String
"tcArgs:ret" (TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
fun_ty) TcRn ()
-> TcM ([LHsExprArgOut], TcSigmaType)
-> TcM ([LHsExprArgOut], TcSigmaType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ([LHsExprArgOut], TcSigmaType)
-> TcM ([LHsExprArgOut], TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], TcSigmaType
fun_ty)
go Int
n [Scaled TcSigmaType]
so_far TcSigmaType
fun_ty (HsEPar SrcSpan
sp : [LHsExprArgIn]
args)
= do { ([LHsExprArgOut]
args', TcSigmaType
res_ty) <- Int
-> [Scaled TcSigmaType]
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM ([LHsExprArgOut], TcSigmaType)
go Int
n [Scaled TcSigmaType]
so_far TcSigmaType
fun_ty [LHsExprArgIn]
args
; ([LHsExprArgOut], TcSigmaType)
-> TcM ([LHsExprArgOut], TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> LHsExprArgOut
forall (id :: Pass). SrcSpan -> HsExprArg id
HsEPar SrcSpan
sp LHsExprArgOut -> [LHsExprArgOut] -> [LHsExprArgOut]
forall a. a -> [a] -> [a]
: [LHsExprArgOut]
args', TcSigmaType
res_ty) }
go Int
n [Scaled TcSigmaType]
so_far TcSigmaType
fun_ty (HsEPrag SrcSpan
sp HsPragE GhcRn
prag : [LHsExprArgIn]
args)
= do { ([LHsExprArgOut]
args', TcSigmaType
res_ty) <- Int
-> [Scaled TcSigmaType]
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM ([LHsExprArgOut], TcSigmaType)
go Int
n [Scaled TcSigmaType]
so_far TcSigmaType
fun_ty [LHsExprArgIn]
args
; ([LHsExprArgOut], TcSigmaType)
-> TcM ([LHsExprArgOut], TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsPragE GhcTc -> LHsExprArgOut
forall (id :: Pass).
SrcSpan -> HsPragE (GhcPass id) -> HsExprArg id
HsEPrag SrcSpan
sp (HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag HsPragE GhcRn
prag) LHsExprArgOut -> [LHsExprArgOut] -> [LHsExprArgOut]
forall a. a -> [a] -> [a]
: [LHsExprArgOut]
args', TcSigmaType
res_ty) }
go Int
n [Scaled TcSigmaType]
so_far TcSigmaType
fun_ty (HsETypeArg SrcSpan
loc LHsWcType (NoGhcTc GhcRn)
hs_ty_arg XExprTypeArg 'Renamed
_ : [LHsExprArgIn]
args)
| Bool
fun_is_out_of_scope
= Int
-> [Scaled TcSigmaType]
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM ([LHsExprArgOut], TcSigmaType)
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Scaled TcSigmaType]
so_far TcSigmaType
fun_ty [LHsExprArgIn]
args
| Bool
otherwise
= do { (HsWrapper
wrap1, TcSigmaType
upsilon_ty) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiateInferred CtOrigin
fun_orig TcSigmaType
fun_ty
; case TcSigmaType -> Maybe (TyVarBinder, TcSigmaType)
tcSplitForAllTy_maybe TcSigmaType
upsilon_ty of
Just (TyVarBinder
tvb, 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 ->
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))
LHsWcType (NoGhcTc GhcRn)
hs_ty_arg TcSigmaType
kind
; TcSigmaType
inner_ty <- TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
inner_ty
; 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
; String -> SDoc -> TcRn ()
traceTc String
"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 ])
; ([LHsExprArgOut]
args', TcSigmaType
res_ty) <- Int
-> [Scaled TcSigmaType]
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM ([LHsExprArgOut], TcSigmaType)
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Scaled TcSigmaType]
so_far TcSigmaType
insted_ty [LHsExprArgIn]
args
; ([LHsExprArgOut], TcSigmaType)
-> TcM ([LHsExprArgOut], TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper -> [LHsExprArgOut] -> [LHsExprArgOut]
addArgWrap HsWrapper
wrap1 ([LHsExprArgOut] -> [LHsExprArgOut])
-> [LHsExprArgOut] -> [LHsExprArgOut]
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> LHsWcType (NoGhcTc GhcTc)
-> XExprTypeArg 'Typechecked
-> LHsExprArgOut
forall (id :: Pass).
SrcSpan
-> LHsWcType (NoGhcTc (GhcPass id))
-> XExprTypeArg id
-> HsExprArg id
HsETypeArg SrcSpan
loc LHsWcType (NoGhcTc GhcRn)
LHsWcType (NoGhcTc GhcTc)
hs_ty_arg TcSigmaType
XExprTypeArg 'Typechecked
ty_arg LHsExprArgOut -> [LHsExprArgOut] -> [LHsExprArgOut]
forall a. a -> [a] -> [a]
: [LHsExprArgOut]
args'
, TcSigmaType
res_ty ) }
Maybe (TyVarBinder, TcSigmaType)
_ -> TcSigmaType
-> HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
-> TcM ([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))
LHsWcType (NoGhcTc GhcRn)
hs_ty_arg }
go Int
n [Scaled TcSigmaType]
so_far TcSigmaType
fun_ty (HsEValArg SrcSpan
loc LHsExpr GhcRn
arg : [LHsExprArgIn]
args)
= do { (HsWrapper
wrap, Scaled TcSigmaType
arg_ty, TcSigmaType
res_ty)
<- SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> (Int, [Scaled TcSigmaType])
-> TcSigmaType
-> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType)
matchActualFunTySigma SDoc
herald CtOrigin
fun_orig (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
fun)
(Int
n_val_args, [Scaled TcSigmaType]
so_far) TcSigmaType
fun_ty
; LHsExpr GhcTc
arg' <- HsExpr GhcRn
-> LHsExpr GhcRn
-> Scaled TcSigmaType
-> Int
-> TcM (LHsExpr GhcTc)
tcArg HsExpr GhcRn
fun LHsExpr GhcRn
arg Scaled TcSigmaType
arg_ty Int
n
; ([LHsExprArgOut]
args', TcSigmaType
inner_res_ty) <- Int
-> [Scaled TcSigmaType]
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM ([LHsExprArgOut], TcSigmaType)
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Scaled TcSigmaType
arg_tyScaled TcSigmaType -> [Scaled TcSigmaType] -> [Scaled TcSigmaType]
forall a. a -> [a] -> [a]
:[Scaled TcSigmaType]
so_far) TcSigmaType
res_ty [LHsExprArgIn]
args
; ([LHsExprArgOut], TcSigmaType)
-> TcM ([LHsExprArgOut], TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper -> [LHsExprArgOut] -> [LHsExprArgOut]
addArgWrap HsWrapper
wrap ([LHsExprArgOut] -> [LHsExprArgOut])
-> [LHsExprArgOut] -> [LHsExprArgOut]
forall a b. (a -> b) -> a -> b
$ SrcSpan -> LHsExpr GhcTc -> LHsExprArgOut
forall (id :: Pass).
SrcSpan -> LHsExpr (GhcPass id) -> HsExprArg id
HsEValArg SrcSpan
loc LHsExpr GhcTc
arg' LHsExprArgOut -> [LHsExprArgOut] -> [LHsExprArgOut]
forall a. a -> [a] -> [a]
: [LHsExprArgOut]
args'
, TcSigmaType
inner_res_ty ) }
ty_app_err :: TcSigmaType -> a -> IOEnv (Env TcGblEnv TcLclEnv) b
ty_app_err TcSigmaType
ty a
arg
= do { (TidyEnv
_, 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 String
"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 String
"to a visible type argument" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
arg) }
tcArg :: HsExpr GhcRn
-> LHsExpr GhcRn
-> Scaled TcSigmaType
-> Int
-> TcM (LHsExpr GhcTc)
tcArg :: HsExpr GhcRn
-> LHsExpr GhcRn
-> Scaled TcSigmaType
-> Int
-> TcM (LHsExpr GhcTc)
tcArg HsExpr GhcRn
fun LHsExpr GhcRn
arg (Scaled TcSigmaType
mult TcSigmaType
ty) Int
arg_no
= SDoc -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsExpr GhcRn -> LHsExpr GhcRn -> Int -> SDoc
forall fun arg.
(Outputable fun, Outputable arg) =>
fun -> arg -> Int -> SDoc
funAppCtxt HsExpr GhcRn
fun LHsExpr GhcRn
arg Int
arg_no) (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcArg" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
arg_no SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"of" SDoc -> SDoc -> SDoc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
fun
, String -> SDoc
text String
"arg type:" SDoc -> SDoc -> SDoc
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
ty
, String -> SDoc
text String
"arg:" SDoc -> SDoc -> SDoc
<+> LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
arg ]
; TcSigmaType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
arg TcSigmaType
ty }
tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTc]
tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTc]
tcTupArgs [LHsTupArg GhcRn]
args [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 GhcTc))
go (L l
l (Missing {}), TcSigmaType
arg_ty) = do { TcSigmaType
mult <- TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
multiplicityTy
; GenLocated l (HsTupArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (l -> HsTupArg GhcTc -> GenLocated l (HsTupArg GhcTc)
forall l e. l -> e -> GenLocated l e
L l
l (XMissing GhcTc -> HsTupArg GhcTc
forall id. XMissing id -> HsTupArg id
Missing (TcSigmaType -> TcSigmaType -> Scaled TcSigmaType
forall a. TcSigmaType -> a -> Scaled a
Scaled TcSigmaType
mult TcSigmaType
arg_ty))) }
go (L l
l (Present XPresent GhcRn
x LHsExpr GhcRn
expr), TcSigmaType
arg_ty) = do { LHsExpr GhcTc
expr' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr TcSigmaType
arg_ty
; GenLocated l (HsTupArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (l -> HsTupArg GhcTc -> GenLocated l (HsTupArg GhcTc)
forall l e. l -> e -> GenLocated l e
L l
l (XPresent GhcTc -> LHsExpr GhcTc -> HsTupArg GhcTc
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcRn
XPresent GhcTc
x LHsExpr GhcTc
expr')) }
tcSyntaxOp :: CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp :: CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
orig SyntaxExprRn
expr [SyntaxOpType]
arg_tys ExpSigmaType
res_ty
= CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen CtOrigin
orig SyntaxExprRn
expr [SyntaxOpType]
arg_tys (ExpSigmaType -> SyntaxOpType
SynType ExpSigmaType
res_ty)
tcSyntaxOpGen :: CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen :: CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen CtOrigin
orig (SyntaxExprRn HsExpr GhcRn
op) [SyntaxOpType]
arg_tys SyntaxOpType
res_ty [TcSigmaType] -> [TcSigmaType] -> TcM a
thing_inside
= do { (HsExpr GhcTc
expr, TcSigmaType
sigma) <- HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferAppHead HsExpr GhcRn
op
; String -> SDoc -> TcRn ()
traceTc String
"tcSyntaxOpGen" (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
op SDoc -> SDoc -> SDoc
$$ HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr SDoc -> SDoc -> SDoc
$$ TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
sigma)
; (a
result, HsWrapper
expr_wrap, [HsWrapper]
arg_wraps, HsWrapper
res_wrap)
<- CtOrigin
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall a.
CtOrigin
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig TcSigmaType
sigma [SyntaxOpType]
arg_tys SyntaxOpType
res_ty (([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper))
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall a b. (a -> b) -> a -> b
$
[TcSigmaType] -> [TcSigmaType] -> TcM a
thing_inside
; String -> SDoc -> TcRn ()
traceTc String
"tcSyntaxOpGen" (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
op SDoc -> SDoc -> SDoc
$$ HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr SDoc -> SDoc -> SDoc
$$ TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
sigma )
; (a, SyntaxExprTc) -> TcM (a, SyntaxExprTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, SyntaxExprTc :: HsExpr GhcTc -> [HsWrapper] -> HsWrapper -> SyntaxExprTc
SyntaxExprTc { syn_expr :: HsExpr GhcTc
syn_expr = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
expr_wrap HsExpr GhcTc
expr
, syn_arg_wraps :: [HsWrapper]
syn_arg_wraps = [HsWrapper]
arg_wraps
, syn_res_wrap :: HsWrapper
syn_res_wrap = HsWrapper
res_wrap }) }
tcSyntaxOpGen CtOrigin
_ SyntaxExprRn
NoSyntaxExprRn [SyntaxOpType]
_ SyntaxOpType
_ [TcSigmaType] -> [TcSigmaType] -> TcM a
_ = String -> TcM (a, SyntaxExprTc)
forall a. String -> a
panic String
"tcSyntaxOpGen"
tcSynArgE :: CtOrigin
-> TcSigmaType
-> SyntaxOpType
-> ([TcSigmaType] -> [Mult] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE :: CtOrigin
-> TcSigmaType
-> SyntaxOpType
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig TcSigmaType
sigma_ty SyntaxOpType
syn_ty [TcSigmaType] -> [TcSigmaType] -> TcM a
thing_inside
= do { (HsWrapper
skol_wrap, (a
result, HsWrapper
ty_wrapper))
<- UserTypeCtxt
-> TcSigmaType
-> (TcSigmaType -> TcM (a, HsWrapper))
-> TcM (HsWrapper, (a, HsWrapper))
forall result.
UserTypeCtxt
-> TcSigmaType
-> (TcSigmaType -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemise UserTypeCtxt
GenSigCtxt TcSigmaType
sigma_ty ((TcSigmaType -> TcM (a, HsWrapper))
-> TcM (HsWrapper, (a, HsWrapper)))
-> (TcSigmaType -> TcM (a, HsWrapper))
-> TcM (HsWrapper, (a, HsWrapper))
forall a b. (a -> b) -> a -> b
$ \ 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 TcSigmaType
rho_ty SyntaxOpType
SynAny
= do { a
result <- [TcSigmaType] -> [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 TcSigmaType
rho_ty SyntaxOpType
SynRho
= do { a
result <- [TcSigmaType] -> [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 TcSigmaType
rho_ty SyntaxOpType
SynList
= do { (TcCoercionR
list_co, TcSigmaType
elt_ty) <- TcSigmaType -> TcM (TcCoercionR, TcSigmaType)
matchExpectedListTy TcSigmaType
rho_ty
; a
result <- [TcSigmaType] -> [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 TcSigmaType
rho_ty (SynFun SyntaxOpType
arg_shape SyntaxOpType
res_shape)
= do { ( HsWrapper
match_wrapper
, ( ( (a
result, TcSigmaType
arg_ty, TcSigmaType
res_ty, TcSigmaType
op_mult)
, HsWrapper
res_wrapper )
, HsWrapper
arg_wrapper1, [], HsWrapper
arg_wrapper2 ) )
<- SDoc
-> UserTypeCtxt
-> Int
-> ExpSigmaType
-> ([Scaled ExpSigmaType]
-> ExpSigmaType
-> TcM
(((a, TcSigmaType, TcSigmaType, TcSigmaType), HsWrapper),
HsWrapper, [HsWrapper], HsWrapper))
-> TcM
(HsWrapper,
(((a, TcSigmaType, TcSigmaType, TcSigmaType), HsWrapper),
HsWrapper, [HsWrapper], HsWrapper))
forall a.
SDoc
-> UserTypeCtxt
-> Int
-> ExpSigmaType
-> ([Scaled ExpSigmaType] -> ExpSigmaType -> TcM a)
-> TcM (HsWrapper, a)
matchExpectedFunTys SDoc
herald UserTypeCtxt
GenSigCtxt Int
1 (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
rho_ty) (([Scaled ExpSigmaType]
-> ExpSigmaType
-> TcM
(((a, TcSigmaType, TcSigmaType, TcSigmaType), HsWrapper),
HsWrapper, [HsWrapper], HsWrapper))
-> TcM
(HsWrapper,
(((a, TcSigmaType, TcSigmaType, TcSigmaType), HsWrapper),
HsWrapper, [HsWrapper], HsWrapper)))
-> ([Scaled ExpSigmaType]
-> ExpSigmaType
-> TcM
(((a, TcSigmaType, TcSigmaType, TcSigmaType), HsWrapper),
HsWrapper, [HsWrapper], HsWrapper))
-> TcM
(HsWrapper,
(((a, TcSigmaType, TcSigmaType, TcSigmaType), HsWrapper),
HsWrapper, [HsWrapper], HsWrapper))
forall a b. (a -> b) -> a -> b
$
\ [Scaled ExpSigmaType
arg_ty] ExpSigmaType
res_ty ->
do { TcSigmaType
arg_tc_ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType (Scaled ExpSigmaType -> ExpSigmaType
forall a. Scaled a -> a
scaledThing Scaled ExpSigmaType
arg_ty)
; TcSigmaType
res_tc_ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
res_ty
; MASSERT2( case arg_shape of
SynFun {} -> False;
_ -> True
, text "Too many nested arrows in SyntaxOpType" $$
pprCtOrigin orig )
; let arg_mult :: TcSigmaType
arg_mult = Scaled ExpSigmaType -> TcSigmaType
forall a. Scaled a -> TcSigmaType
scaledMult Scaled ExpSigmaType
arg_ty
; CtOrigin
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType]
-> [TcSigmaType]
-> TcM ((a, TcSigmaType, TcSigmaType, TcSigmaType), HsWrapper))
-> TcM
(((a, TcSigmaType, TcSigmaType, TcSigmaType), HsWrapper),
HsWrapper, [HsWrapper], HsWrapper)
forall a.
CtOrigin
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig TcSigmaType
arg_tc_ty [] SyntaxOpType
arg_shape (([TcSigmaType]
-> [TcSigmaType]
-> TcM ((a, TcSigmaType, TcSigmaType, TcSigmaType), HsWrapper))
-> TcM
(((a, TcSigmaType, TcSigmaType, TcSigmaType), HsWrapper),
HsWrapper, [HsWrapper], HsWrapper))
-> ([TcSigmaType]
-> [TcSigmaType]
-> TcM ((a, TcSigmaType, TcSigmaType, TcSigmaType), HsWrapper))
-> TcM
(((a, TcSigmaType, TcSigmaType, TcSigmaType), HsWrapper),
HsWrapper, [HsWrapper], HsWrapper)
forall a b. (a -> b) -> a -> b
$
\ [TcSigmaType]
arg_results [TcSigmaType]
arg_res_mults ->
CtOrigin
-> TcSigmaType
-> SyntaxOpType
-> ([TcSigmaType]
-> [TcSigmaType] -> TcM (a, TcSigmaType, TcSigmaType, TcSigmaType))
-> TcM ((a, TcSigmaType, TcSigmaType, TcSigmaType), HsWrapper)
forall a.
CtOrigin
-> TcSigmaType
-> SyntaxOpType
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig TcSigmaType
res_tc_ty SyntaxOpType
res_shape (([TcSigmaType]
-> [TcSigmaType] -> TcM (a, TcSigmaType, TcSigmaType, TcSigmaType))
-> TcM ((a, TcSigmaType, TcSigmaType, TcSigmaType), HsWrapper))
-> ([TcSigmaType]
-> [TcSigmaType] -> TcM (a, TcSigmaType, TcSigmaType, TcSigmaType))
-> TcM ((a, TcSigmaType, TcSigmaType, TcSigmaType), HsWrapper)
forall a b. (a -> b) -> a -> b
$
\ [TcSigmaType]
res_results [TcSigmaType]
res_res_mults ->
do { a
result <- [TcSigmaType] -> [TcSigmaType] -> TcM a
thing_inside ([TcSigmaType]
arg_results [TcSigmaType] -> [TcSigmaType] -> [TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [TcSigmaType]
res_results) ([TcSigmaType
arg_mult] [TcSigmaType] -> [TcSigmaType] -> [TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [TcSigmaType]
arg_res_mults [TcSigmaType] -> [TcSigmaType] -> [TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [TcSigmaType]
res_res_mults)
; (a, TcSigmaType, TcSigmaType, TcSigmaType)
-> TcM (a, TcSigmaType, TcSigmaType, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, TcSigmaType
arg_tc_ty, TcSigmaType
res_tc_ty, TcSigmaType
arg_mult) }}
; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return ( a
result
, HsWrapper
match_wrapper HsWrapper -> HsWrapper -> HsWrapper
<.>
HsWrapper
-> HsWrapper
-> Scaled TcSigmaType
-> TcSigmaType
-> SDoc
-> HsWrapper
mkWpFun (HsWrapper
arg_wrapper2 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
arg_wrapper1) HsWrapper
res_wrapper
(TcSigmaType -> TcSigmaType -> Scaled TcSigmaType
forall a. TcSigmaType -> a -> Scaled a
Scaled TcSigmaType
op_mult TcSigmaType
arg_ty) TcSigmaType
res_ty SDoc
doc ) }
where
herald :: SDoc
herald = String -> SDoc
text String
"This rebindable syntax expects a function with"
doc :: SDoc
doc = String -> SDoc
text String
"When checking a rebindable syntax operator arising from" SDoc -> SDoc -> SDoc
<+> CtOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr CtOrigin
orig
go TcSigmaType
rho_ty (SynType ExpSigmaType
the_ty)
= do { HsWrapper
wrap <- CtOrigin
-> UserTypeCtxt -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
tcSubTypePat CtOrigin
orig UserTypeCtxt
GenSigCtxt ExpSigmaType
the_ty TcSigmaType
rho_ty
; a
result <- [TcSigmaType] -> [TcSigmaType] -> TcM a
thing_inside [] []
; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
wrap) }
tcSynArgA :: CtOrigin
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> [Mult] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA :: CtOrigin
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig TcSigmaType
sigma_ty [SyntaxOpType]
arg_shapes SyntaxOpType
res_shape [TcSigmaType] -> [TcSigmaType] -> TcM a
thing_inside
= do { (HsWrapper
match_wrapper, [Scaled TcSigmaType]
arg_tys, TcSigmaType
res_ty)
<- SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> Int
-> TcSigmaType
-> TcM (HsWrapper, [Scaled TcSigmaType], TcSigmaType)
matchActualFunTysRho 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
; ((a
result, HsWrapper
res_wrapper), [HsWrapper]
arg_wrappers)
<- [TcSigmaType]
-> [SyntaxOpType]
-> ([TcSigmaType] -> [TcSigmaType] -> TcM (a, HsWrapper))
-> TcM ((a, HsWrapper), [HsWrapper])
forall a.
[TcSigmaType]
-> [SyntaxOpType]
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e ((Scaled TcSigmaType -> TcSigmaType)
-> [Scaled TcSigmaType] -> [TcSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcSigmaType -> TcSigmaType
forall a. Scaled a -> a
scaledThing [Scaled TcSigmaType]
arg_tys) [SyntaxOpType]
arg_shapes (([TcSigmaType] -> [TcSigmaType] -> TcM (a, HsWrapper))
-> TcM ((a, HsWrapper), [HsWrapper]))
-> ([TcSigmaType] -> [TcSigmaType] -> TcM (a, HsWrapper))
-> TcM ((a, HsWrapper), [HsWrapper])
forall a b. (a -> b) -> a -> b
$ \ [TcSigmaType]
arg_results [TcSigmaType]
arg_res_mults ->
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
$ \ [TcSigmaType]
res_results ->
[TcSigmaType] -> [TcSigmaType] -> TcM a
thing_inside ([TcSigmaType]
arg_results [TcSigmaType] -> [TcSigmaType] -> [TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [TcSigmaType]
res_results) ((Scaled TcSigmaType -> TcSigmaType)
-> [Scaled TcSigmaType] -> [TcSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcSigmaType -> TcSigmaType
forall a. Scaled a -> TcSigmaType
scaledMult [Scaled TcSigmaType]
arg_tys [TcSigmaType] -> [TcSigmaType] -> [TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [TcSigmaType]
arg_res_mults)
; (a, HsWrapper, [HsWrapper], HsWrapper)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
match_wrapper, [HsWrapper]
arg_wrappers, HsWrapper
res_wrapper) }
where
herald :: SDoc
herald = String -> SDoc
text String
"This rebindable syntax expects a function with"
tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]
-> ([TcSigmaType] -> [Mult] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e :: [TcSigmaType]
-> [SyntaxOpType]
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e (TcSigmaType
arg_ty : [TcSigmaType]
arg_tys) (SyntaxOpType
arg_shape : [SyntaxOpType]
arg_shapes) [TcSigmaType] -> [TcSigmaType] -> TcM a
thing_inside
= do { ((a
result, [HsWrapper]
arg_wraps), HsWrapper
arg_wrap)
<- CtOrigin
-> TcSigmaType
-> SyntaxOpType
-> ([TcSigmaType] -> [TcSigmaType] -> TcM (a, [HsWrapper]))
-> TcM ((a, [HsWrapper]), HsWrapper)
forall a.
CtOrigin
-> TcSigmaType
-> SyntaxOpType
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig TcSigmaType
arg_ty SyntaxOpType
arg_shape (([TcSigmaType] -> [TcSigmaType] -> TcM (a, [HsWrapper]))
-> TcM ((a, [HsWrapper]), HsWrapper))
-> ([TcSigmaType] -> [TcSigmaType] -> TcM (a, [HsWrapper]))
-> TcM ((a, [HsWrapper]), HsWrapper)
forall a b. (a -> b) -> a -> b
$ \ [TcSigmaType]
arg1_results [TcSigmaType]
arg1_mults ->
[TcSigmaType]
-> [SyntaxOpType]
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, [HsWrapper])
forall a.
[TcSigmaType]
-> [SyntaxOpType]
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e [TcSigmaType]
arg_tys [SyntaxOpType]
arg_shapes (([TcSigmaType] -> [TcSigmaType] -> TcM a) -> TcM (a, [HsWrapper]))
-> ([TcSigmaType] -> [TcSigmaType] -> TcM a)
-> TcM (a, [HsWrapper])
forall a b. (a -> b) -> a -> b
$ \ [TcSigmaType]
args_results [TcSigmaType]
args_mults ->
[TcSigmaType] -> [TcSigmaType] -> TcM a
thing_inside ([TcSigmaType]
arg1_results [TcSigmaType] -> [TcSigmaType] -> [TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [TcSigmaType]
args_results) ([TcSigmaType]
arg1_mults [TcSigmaType] -> [TcSigmaType] -> [TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [TcSigmaType]
args_mults)
; (a, [HsWrapper]) -> TcM (a, [HsWrapper])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
arg_wrap HsWrapper -> [HsWrapper] -> [HsWrapper]
forall a. a -> [a] -> [a]
: [HsWrapper]
arg_wraps) }
tc_syn_args_e [TcSigmaType]
_ [SyntaxOpType]
_ [TcSigmaType] -> [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] -> [TcSigmaType] -> TcM a
thing_inside [] []
tc_syn_arg :: TcSigmaType -> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper)
tc_syn_arg :: TcSigmaType
-> SyntaxOpType -> ([TcSigmaType] -> TcM a) -> TcM (a, HsWrapper)
tc_syn_arg TcSigmaType
res_ty SyntaxOpType
SynAny [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 TcSigmaType
res_ty SyntaxOpType
SynRho [TcSigmaType] -> TcM a
thing_inside
= do { (HsWrapper
inst_wrap, TcSigmaType
rho_ty) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate CtOrigin
orig TcSigmaType
res_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 TcSigmaType
res_ty SyntaxOpType
SynList [TcSigmaType] -> TcM a
thing_inside
= do { (HsWrapper
inst_wrap, TcSigmaType
rho_ty) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate CtOrigin
orig TcSigmaType
res_ty
; (TcCoercionR
list_co, 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 -> TcCoercionR
mkTcSymCo TcCoercionR
list_co) HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
inst_wrap) }
tc_syn_arg TcSigmaType
_ (SynFun {}) [TcSigmaType] -> TcM a
_
= String -> SDoc -> TcM (a, HsWrapper)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcSynArgA hits a SynFun" (CtOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr CtOrigin
orig)
tc_syn_arg TcSigmaType
res_ty (SynType ExpSigmaType
the_ty) [TcSigmaType] -> TcM a
thing_inside
= do { HsWrapper
wrap <- CtOrigin
-> UserTypeCtxt -> TcSigmaType -> ExpSigmaType -> TcM HsWrapper
tcSubType 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) }
tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)
tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType)
tcExprSig LHsExpr GhcRn
expr (CompleteSig { sig_bndr :: TcIdSigInfo -> EvVar
sig_bndr = EvVar
poly_id, sig_loc :: TcIdSigInfo -> SrcSpan
sig_loc = SrcSpan
loc })
= SrcSpan
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType))
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$
do { let poly_ty :: TcSigmaType
poly_ty = EvVar -> TcSigmaType
idType EvVar
poly_id
; (HsWrapper
wrap, LHsExpr GhcTc
expr') <- UserTypeCtxt
-> TcSigmaType
-> (TcSigmaType -> TcM (LHsExpr GhcTc))
-> TcM (HsWrapper, LHsExpr GhcTc)
forall result.
UserTypeCtxt
-> TcSigmaType
-> (TcSigmaType -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemiseScoped UserTypeCtxt
ExprSigCtxt TcSigmaType
poly_ty ((TcSigmaType -> TcM (LHsExpr GhcTc))
-> TcM (HsWrapper, LHsExpr GhcTc))
-> (TcSigmaType -> TcM (LHsExpr GhcTc))
-> TcM (HsWrapper, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ \TcSigmaType
rho_ty ->
LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
expr TcSigmaType
rho_ty
; (LHsExpr GhcTc, TcSigmaType) -> TcM (LHsExpr GhcTc, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
wrap LHsExpr GhcTc
expr', TcSigmaType
poly_ty) }
tcExprSig 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 GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType))
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$
do { (TcLevel
tclvl, WantedConstraints
wanted, (LHsExpr GhcTc
expr', TcIdSigInst
sig_inst))
<- TcM (LHsExpr GhcTc, TcIdSigInst)
-> TcM (TcLevel, WantedConstraints, (LHsExpr GhcTc, TcIdSigInst))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints (TcM (LHsExpr GhcTc, TcIdSigInst)
-> TcM (TcLevel, WantedConstraints, (LHsExpr GhcTc, TcIdSigInst)))
-> TcM (LHsExpr GhcTc, TcIdSigInst)
-> TcM (TcLevel, WantedConstraints, (LHsExpr GhcTc, TcIdSigInst))
forall a b. (a -> b) -> a -> b
$
do { TcIdSigInst
sig_inst <- TcIdSigInfo -> TcM TcIdSigInst
tcInstSig TcIdSigInfo
sig
; LHsExpr GhcTc
expr' <- [(Name, EvVar)] -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall r. [(Name, EvVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv ((VarBndr EvVar Specificity -> EvVar)
-> [(Name, VarBndr EvVar Specificity)] -> [(Name, EvVar)]
forall b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd VarBndr EvVar Specificity -> EvVar
forall tv argf. VarBndr tv argf -> tv
binderVar ([(Name, VarBndr EvVar Specificity)] -> [(Name, EvVar)])
-> [(Name, VarBndr EvVar Specificity)] -> [(Name, EvVar)]
forall a b. (a -> b) -> a -> b
$ TcIdSigInst -> [(Name, VarBndr EvVar Specificity)]
sig_inst_skols TcIdSigInst
sig_inst) (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
[(Name, EvVar)] -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall r. [(Name, EvVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv (TcIdSigInst -> [(Name, EvVar)]
sig_inst_wcs TcIdSigInst
sig_inst) (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
expr (TcIdSigInst -> TcSigmaType
sig_inst_tau TcIdSigInst
sig_inst)
; (LHsExpr GhcTc, TcIdSigInst) -> TcM (LHsExpr GhcTc, TcIdSigInst)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcTc
expr', TcIdSigInst
sig_inst) }
; 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
; ([EvVar]
qtvs, [EvVar]
givens, TcEvBinds
ev_binds, WantedConstraints
residual, Bool
_)
<- 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
; ([VarBndr EvVar Specificity]
binders, [TcSigmaType]
my_theta) <- [TcSigmaType]
-> VarSet
-> [EvVar]
-> Maybe TcIdSigInst
-> TcM ([VarBndr EvVar Specificity], [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 = [VarBndr EvVar Specificity] -> TcSigmaType -> TcSigmaType
mkInvisForAllTys [VarBndr EvVar Specificity]
binders ([TcSigmaType] -> TcSigmaType -> TcSigmaType
mkPhiTy [TcSigmaType]
my_theta TcSigmaType
tau)
; HsWrapper
wrap <- if TcSigmaType
inferred_sigma TcSigmaType -> TcSigmaType -> Bool
`eqType` TcSigmaType
my_sigma
then HsWrapper -> TcM HsWrapper
forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
idHsWrapper
else UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper
tcSubTypeSigma UserTypeCtxt
ExprSigCtxt TcSigmaType
inferred_sigma TcSigmaType
my_sigma
; String -> SDoc -> TcRn ()
traceTc String
"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 GhcTc, TcSigmaType) -> TcM (LHsExpr GhcTc, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
poly_wrap LHsExpr GhcTc
expr', TcSigmaType
my_sigma) }
tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId :: Name -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcCheckId Name
name ExpSigmaType
res_ty
| Name
name Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tagToEnumKey
= SDoc -> TcM (HsExpr GhcTc)
forall a. SDoc -> TcRn a
failWithTc (String -> SDoc
text String
"tagToEnum# must appear applied to one argument")
| Bool
otherwise
= do { (HsExpr GhcTc
expr, TcSigmaType
actual_res_ty) <- Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId Name
name
; String -> SDoc -> TcRn ()
traceTc String
"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 GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
-> TcM (HsExpr GhcTc)
forall a.
Bool
-> HsExpr GhcTc -> TcSigmaType -> ExpSigmaType -> TcM a -> TcM a
addFunResCtxt Bool
False HsExpr GhcTc
expr TcSigmaType
actual_res_ty ExpSigmaType
res_ty (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
CtOrigin
-> HsExpr GhcRn
-> HsExpr GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResultO (Name -> CtOrigin
OccurrenceOf Name
name) (XVar GhcRn -> GenLocated SrcSpan (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcRn
noExtField (Name -> GenLocated SrcSpan Name
forall e. e -> Located e
noLoc Name
name)) HsExpr GhcTc
expr
TcSigmaType
actual_res_ty ExpSigmaType
res_ty }
tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckRecSelId :: HsExpr GhcRn
-> AmbiguousFieldOcc GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcCheckRecSelId HsExpr GhcRn
rn_expr f :: AmbiguousFieldOcc GhcRn
f@(Unambiguous {}) ExpSigmaType
res_ty
= do { (HsExpr GhcTc
expr, TcSigmaType
actual_res_ty) <- AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferRecSelId AmbiguousFieldOcc GhcRn
f
; HsExpr GhcRn
-> HsExpr GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
rn_expr HsExpr GhcTc
expr TcSigmaType
actual_res_ty ExpSigmaType
res_ty }
tcCheckRecSelId HsExpr GhcRn
rn_expr (Ambiguous XAmbiguous GhcRn
_ Located RdrName
lbl) ExpSigmaType
res_ty
= case TcSigmaType -> Maybe (Scaled TcSigmaType, TcSigmaType)
tcSplitFunTy_maybe (TcSigmaType -> Maybe (Scaled TcSigmaType, TcSigmaType))
-> Maybe TcSigmaType -> Maybe (Scaled TcSigmaType, TcSigmaType)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExpSigmaType -> Maybe TcSigmaType
checkingExpType_maybe ExpSigmaType
res_ty of
Maybe (Scaled TcSigmaType, TcSigmaType)
Nothing -> Located RdrName -> TcM (HsExpr GhcTc)
forall a. Located RdrName -> TcM a
ambiguousSelector Located RdrName
lbl
Just (Scaled TcSigmaType
arg, TcSigmaType
_) -> do { Name
sel_name <- Located RdrName -> TcSigmaType -> TcM Name
disambiguateSelector Located RdrName
lbl (Scaled TcSigmaType -> TcSigmaType
forall a. Scaled a -> a
scaledThing Scaled TcSigmaType
arg)
; HsExpr GhcRn
-> AmbiguousFieldOcc GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
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 }
tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTc, TcRhoType)
tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferRecSelId (Unambiguous XUnambiguous GhcRn
sel (L SrcSpan
_ RdrName
lbl))
= do { (HsExpr GhcTc
expr', TcSigmaType
ty) <- RdrName -> Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id RdrName
lbl Name
XUnambiguous GhcRn
sel
; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr', TcSigmaType
ty) }
tcInferRecSelId (Ambiguous XAmbiguous GhcRn
_ Located RdrName
lbl)
= Located RdrName -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. Located RdrName -> TcM a
ambiguousSelector Located RdrName
lbl
tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId Name
id_name
| 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 GhcTc, TcSigmaType)
tc_infer_id (Name -> RdrName
nameRdrName Name
id_name) Name
id_name
else Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_assert Name
id_name }
| Bool
otherwise
= do { (HsExpr GhcTc
expr, TcSigmaType
ty) <- RdrName -> Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id (Name -> RdrName
nameRdrName Name
id_name) Name
id_name
; String -> SDoc -> TcRn ()
traceTc String
"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 GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr, TcSigmaType
ty) }
tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_assert Name
assert_name
= do { EvVar
assert_error_id <- Name -> TcM EvVar
tcLookupId Name
assertErrorName
; (HsWrapper
wrap, TcSigmaType
id_rho) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate (Name -> CtOrigin
OccurrenceOf Name
assert_name)
(EvVar -> TcSigmaType
idType EvVar
assert_error_id)
; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (XVar GhcTc -> Located (IdP GhcTc) -> HsExpr GhcTc
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (EvVar -> Located EvVar
forall e. e -> Located e
noLoc EvVar
assert_error_id)), TcSigmaType
id_rho)
}
tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id RdrName
lbl 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
; EvVar -> TcRn ()
checkThLocalId EvVar
id
; UsageEnv -> TcRn ()
tcEmitBindingUsage (UsageEnv -> TcRn ()) -> UsageEnv -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Name -> TcSigmaType -> UsageEnv
forall n. NamedThing n => n -> TcSigmaType -> UsageEnv
unitUE Name
id_name TcSigmaType
One
; EvVar -> TcM (HsExpr GhcTc, TcSigmaType)
forall (m :: * -> *) p.
(Monad m, XVar p ~ NoExtField, IdP p ~ EvVar) =>
EvVar -> m (HsExpr p, TcSigmaType)
return_id EvVar
id }
AGlobal (AnId EvVar
id)
-> do { EvVar -> TcRn ()
check_naughty EvVar
id
; EvVar -> TcM (HsExpr GhcTc, TcSigmaType)
forall (m :: * -> *) p.
(Monad m, XVar p ~ NoExtField, IdP p ~ EvVar) =>
EvVar -> m (HsExpr p, TcSigmaType)
return_id EvVar
id }
AGlobal (AConLike ConLike
cl) -> case ConLike
cl of
RealDataCon DataCon
con -> DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
return_data_con DataCon
con
PatSynCon PatSyn
ps -> PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)
tcPatSynBuilderOcc PatSyn
ps
TcTyThing
_ -> SDoc -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. SDoc -> TcRn a
failWithTc (SDoc -> TcM (HsExpr GhcTc, TcSigmaType))
-> SDoc -> TcM (HsExpr GhcTc, 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 String
"used where a value identifier was expected" }
where
return_id :: EvVar -> m (HsExpr p, TcSigmaType)
return_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 NoExtField
XVar p
noExtField (EvVar -> Located EvVar
forall e. e -> Located e
noLoc EvVar
id), EvVar -> TcSigmaType
idType EvVar
id)
return_data_con :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
return_data_con DataCon
con
= do { let tvs :: [VarBndr EvVar Specificity]
tvs = DataCon -> [VarBndr EvVar Specificity]
dataConUserTyVarBinders DataCon
con
theta :: [TcSigmaType]
theta = DataCon -> [TcSigmaType]
dataConOtherTheta DataCon
con
args :: [Scaled TcSigmaType]
args = DataCon -> [Scaled TcSigmaType]
dataConOrigArgTys DataCon
con
res :: TcSigmaType
res = DataCon -> TcSigmaType
dataConOrigResTy DataCon
con
; [TcSigmaType]
mul_vars <- Int -> TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType]
newFlexiTyVarTys ([Scaled TcSigmaType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled TcSigmaType]
args) TcSigmaType
multiplicityTy
; let scaleArgs :: [Scaled TcSigmaType] -> [Scaled TcSigmaType]
scaleArgs [Scaled TcSigmaType]
args' = String
-> (TcSigmaType -> Scaled TcSigmaType -> Scaled TcSigmaType)
-> [TcSigmaType]
-> [Scaled TcSigmaType]
-> [Scaled TcSigmaType]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"return_data_con" TcSigmaType -> Scaled TcSigmaType -> Scaled TcSigmaType
forall a. TcSigmaType -> Scaled a -> Scaled a
combine [TcSigmaType]
mul_vars [Scaled TcSigmaType]
args'
combine :: TcSigmaType -> Scaled a -> Scaled a
combine TcSigmaType
var (Scaled TcSigmaType
One a
ty) = TcSigmaType -> a -> Scaled a
forall a. TcSigmaType -> a -> Scaled a
Scaled TcSigmaType
var a
ty
combine TcSigmaType
_ Scaled a
scaled_ty = Scaled a
scaled_ty
etaWrapper :: t (Scaled TcSigmaType) -> HsWrapper
etaWrapper t (Scaled TcSigmaType)
arg_tys = (Scaled TcSigmaType -> HsWrapper -> HsWrapper)
-> HsWrapper -> t (Scaled TcSigmaType) -> HsWrapper
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Scaled TcSigmaType
scaled_ty HsWrapper
wr -> HsWrapper -> HsWrapper -> Scaled TcSigmaType -> SDoc -> HsWrapper
WpFun HsWrapper
WpHole HsWrapper
wr Scaled TcSigmaType
scaled_ty SDoc
empty) HsWrapper
WpHole t (Scaled TcSigmaType)
arg_tys
; let shouldInstantiate :: Bool
shouldInstantiate = (Bool -> Bool
not ([TcSigmaType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [TcSigmaType]
dataConStupidTheta DataCon
con)) Bool -> Bool -> Bool
||
TcSigmaType -> Bool
isKindLevPoly (TyCon -> TcSigmaType
tyConResKind (DataCon -> TyCon
dataConTyCon DataCon
con)))
; case Bool
shouldInstantiate of
Bool
True -> do { (TCvSubst
subst, [EvVar]
tvs') <- [EvVar] -> TcM (TCvSubst, [EvVar])
newMetaTyVars ([VarBndr EvVar Specificity] -> [EvVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr EvVar Specificity]
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
args' :: [Scaled TcSigmaType]
args' = HasCallStack =>
TCvSubst -> [Scaled TcSigmaType] -> [Scaled TcSigmaType]
TCvSubst -> [Scaled TcSigmaType] -> [Scaled TcSigmaType]
substScaledTys TCvSubst
subst [Scaled TcSigmaType]
args
res' :: TcSigmaType
res' = HasCallStack => TCvSubst -> TcSigmaType -> TcSigmaType
TCvSubst -> TcSigmaType -> TcSigmaType
substTy TCvSubst
subst TcSigmaType
res
; HsWrapper
wrap <- CtOrigin -> [TcSigmaType] -> [TcSigmaType] -> TcM HsWrapper
instCall (Name -> CtOrigin
OccurrenceOf Name
id_name) [TcSigmaType]
tys' [TcSigmaType]
theta'
; let scaled_arg_tys :: [Scaled TcSigmaType]
scaled_arg_tys = [Scaled TcSigmaType] -> [Scaled TcSigmaType]
scaleArgs [Scaled TcSigmaType]
args'
eta_wrap :: HsWrapper
eta_wrap = [Scaled TcSigmaType] -> HsWrapper
forall (t :: * -> *).
Foldable t =>
t (Scaled TcSigmaType) -> HsWrapper
etaWrapper [Scaled TcSigmaType]
scaled_arg_tys
; DataCon -> [TcSigmaType] -> TcRn ()
addDataConStupidTheta DataCon
con [TcSigmaType]
tys'
; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (HsWrapper
eta_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap)
(XConLikeOut GhcTc -> ConLike -> HsExpr GhcTc
forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut NoExtField
XConLikeOut GhcTc
noExtField (DataCon -> ConLike
RealDataCon DataCon
con))
, [Scaled TcSigmaType] -> TcSigmaType -> TcSigmaType
mkVisFunTys [Scaled TcSigmaType]
scaled_arg_tys TcSigmaType
res')
}
Bool
False -> let scaled_arg_tys :: [Scaled TcSigmaType]
scaled_arg_tys = [Scaled TcSigmaType] -> [Scaled TcSigmaType]
scaleArgs [Scaled TcSigmaType]
args
wrap1 :: HsWrapper
wrap1 = [TcSigmaType] -> HsWrapper
mkWpTyApps ([EvVar] -> [TcSigmaType]
mkTyVarTys ([EvVar] -> [TcSigmaType]) -> [EvVar] -> [TcSigmaType]
forall a b. (a -> b) -> a -> b
$ [VarBndr EvVar Specificity] -> [EvVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr EvVar Specificity]
tvs)
eta_wrap :: HsWrapper
eta_wrap = [Scaled TcSigmaType] -> HsWrapper
forall (t :: * -> *).
Foldable t =>
t (Scaled TcSigmaType) -> HsWrapper
etaWrapper ((TcSigmaType -> Scaled TcSigmaType)
-> [TcSigmaType] -> [Scaled TcSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map TcSigmaType -> Scaled TcSigmaType
forall a. a -> Scaled a
unrestricted [TcSigmaType]
theta [Scaled TcSigmaType]
-> [Scaled TcSigmaType] -> [Scaled TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [Scaled TcSigmaType]
scaled_arg_tys)
wrap2 :: HsWrapper
wrap2 = [EvVar] -> HsWrapper
mkWpTyLams ([EvVar] -> HsWrapper) -> [EvVar] -> HsWrapper
forall a b. (a -> b) -> a -> b
$ [VarBndr EvVar Specificity] -> [EvVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr EvVar Specificity]
tvs
in (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (HsWrapper
wrap2 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
eta_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap1)
(XConLikeOut GhcTc -> ConLike -> HsExpr GhcTc
forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut NoExtField
XConLikeOut GhcTc
noExtField (DataCon -> ConLike
RealDataCon DataCon
con))
, [VarBndr EvVar Specificity] -> TcSigmaType -> TcSigmaType
mkInvisForAllTys [VarBndr EvVar Specificity]
tvs (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$ [TcSigmaType] -> TcSigmaType -> TcSigmaType
mkInvisFunTysMany [TcSigmaType]
theta (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$ [Scaled TcSigmaType] -> TcSigmaType -> TcSigmaType
mkVisFunTys [Scaled TcSigmaType]
scaled_arg_tys TcSigmaType
res)
}
check_naughty :: EvVar -> TcRn ()
check_naughty 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 -> OccName -> ExpRhoType -> TcM (HsExpr GhcTc)
tcUnboundId :: HsExpr GhcRn -> OccName -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcUnboundId HsExpr GhcRn
rn_expr OccName
occ ExpSigmaType
res_ty
= do { TcSigmaType
ty <- TcM TcSigmaType
newOpenFlexiTyVarTy
; Name
name <- OccName -> TcM Name
forall gbl lcl. OccName -> TcRnIf gbl lcl Name
newSysName OccName
occ
; let ev :: EvVar
ev = HasDebugCallStack => Name -> TcSigmaType -> TcSigmaType -> EvVar
Name -> TcSigmaType -> TcSigmaType -> EvVar
mkLocalId Name
name TcSigmaType
Many TcSigmaType
ty
; OccName -> EvVar -> TcSigmaType -> TcRn ()
emitNewExprHole OccName
occ EvVar
ev TcSigmaType
ty
; CtOrigin
-> HsExpr GhcRn
-> HsExpr GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResultO (OccName -> CtOrigin
UnboundOccurrenceOf OccName
occ) HsExpr GhcRn
rn_expr
(XVar GhcTc -> Located (IdP GhcTc) -> HsExpr GhcTc
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (EvVar -> Located EvVar
forall e. e -> Located e
noLoc EvVar
ev)) TcSigmaType
ty ExpSigmaType
res_ty }
isTagToEnum :: HsExpr GhcTc -> Bool
isTagToEnum :: HsExpr GhcTc -> Bool
isTagToEnum (HsVar XVar GhcTc
_ (L SrcSpan
_ IdP GhcTc
fun_id)) = EvVar
IdP GhcTc
fun_id EvVar -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tagToEnumKey
isTagToEnum HsExpr GhcTc
_ = Bool
False
tcTagToEnum :: HsExpr GhcRn -> HsExpr GhcTc -> [LHsExprArgOut]
-> TcSigmaType -> ExpRhoType
-> TcM (HsExpr GhcTc)
tcTagToEnum :: HsExpr GhcRn
-> HsExpr GhcTc
-> [LHsExprArgOut]
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcTagToEnum HsExpr GhcRn
expr HsExpr GhcTc
fun [LHsExprArgOut]
args TcSigmaType
app_res_ty ExpSigmaType
res_ty
= do { TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
readExpType ExpSigmaType
res_ty
; TcSigmaType
ty' <- TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
res_ty
; case HasCallStack => TcSigmaType -> Maybe (TyCon, [TcSigmaType])
TcSigmaType -> Maybe (TyCon, [TcSigmaType])
tcSplitTyConApp_maybe TcSigmaType
ty' of {
Maybe (TyCon, [TcSigmaType])
Nothing -> do { SDoc -> TcRn ()
addErrTc (TcSigmaType -> SDoc -> SDoc
mk_error TcSigmaType
ty' SDoc
doc1)
; TcM (HsExpr GhcTc)
vanilla_result } ;
Just (TyCon
tc, [TcSigmaType]
tc_args) ->
do {
; FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; case FamInstEnvs
-> TyCon
-> [TcSigmaType]
-> Maybe (TyCon, [TcSigmaType], TcCoercionR)
tcLookupDataFamInst_maybe FamInstEnvs
fam_envs TyCon
tc [TcSigmaType]
tc_args of {
Maybe (TyCon, [TcSigmaType], TcCoercionR)
Nothing -> do { TcSigmaType -> TyCon -> TcRn ()
check_enumeration TcSigmaType
ty' TyCon
tc
; TcM (HsExpr GhcTc)
vanilla_result } ;
Just (TyCon
rep_tc, [TcSigmaType]
rep_args, TcCoercionR
coi) ->
do {
TcSigmaType -> TyCon -> TcRn ()
check_enumeration TcSigmaType
ty' TyCon
rep_tc
; let val_arg :: [LHsExprArgOut]
val_arg = (LHsExprArgOut -> Bool) -> [LHsExprArgOut] -> [LHsExprArgOut]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (LHsExprArgOut -> Bool) -> LHsExprArgOut -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExprArgOut -> Bool
forall (id :: Pass). HsExprArg id -> Bool
isHsValArg) [LHsExprArgOut]
args
rep_ty :: TcSigmaType
rep_ty = TyCon -> [TcSigmaType] -> TcSigmaType
mkTyConApp TyCon
rep_tc [TcSigmaType]
rep_args
fun' :: HsExpr GhcTc
fun' = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (TcSigmaType -> HsWrapper
WpTyApp TcSigmaType
rep_ty) HsExpr GhcTc
fun
expr' :: HsExpr GhcTc
expr' = HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
applyHsArgs HsExpr GhcTc
fun' [LHsExprArgOut]
val_arg
df_wrap :: HsWrapper
df_wrap = TcCoercionR -> HsWrapper
mkWpCastR (TcCoercionR -> TcCoercionR
mkTcSymCo TcCoercionR
coi)
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
df_wrap HsExpr GhcTc
expr') }}}}}
where
vanilla_result :: TcM (HsExpr GhcTc)
vanilla_result
= do { let expr' :: HsExpr GhcTc
expr' = HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
applyHsArgs HsExpr GhcTc
fun [LHsExprArgOut]
args
; HsExpr GhcRn
-> HsExpr GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
expr HsExpr GhcTc
expr' TcSigmaType
app_res_ty ExpSigmaType
res_ty }
check_enumeration :: TcSigmaType -> TyCon -> TcRn ()
check_enumeration TcSigmaType
ty' TyCon
tc
| TyCon -> Bool
isEnumerationTyCon TyCon
tc = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = SDoc -> TcRn ()
addErrTc (TcSigmaType -> SDoc -> SDoc
mk_error TcSigmaType
ty' SDoc
doc2)
doc1 :: SDoc
doc1 = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Specify the type by giving a type signature"
, String -> SDoc
text String
"e.g. (tagToEnum# x) :: Bool" ]
doc2 :: SDoc
doc2 = String -> SDoc
text String
"Result type must be an enumeration type"
mk_error :: TcType -> SDoc -> SDoc
mk_error :: TcSigmaType -> SDoc -> SDoc
mk_error TcSigmaType
ty SDoc
what
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Bad call to tagToEnum#"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"at type" SDoc -> SDoc -> SDoc
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
ty)
Int
2 SDoc
what
checkThLocalId :: Id -> TcM ()
checkThLocalId :: EvVar -> TcRn ()
checkThLocalId 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 (TopLevelFlag
top_lvl, Int
bind_lvl, 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
Maybe (TopLevelFlag, Int, ThStage)
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()
checkCrossStageLifting :: TopLevelFlag -> EvVar -> ThStage -> TcRn ()
checkCrossStageLifting TopLevelFlag
top_lvl EvVar
id (Brack ThStage
_ (TcPending TcRef [PendingTcSplice]
ps_var TcRef WantedConstraints
lie_var QuoteWrapper
q))
| 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)
| Bool
otherwise
=
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)
; HsExpr GhcTc
lift <- if TcSigmaType -> Bool
isStringTy TcSigmaType
id_ty then
do { EvVar
sid <- Name -> TcM EvVar
tcLookupId Name
GHC.Builtin.Names.TH.liftStringName
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar GhcTc -> Located (IdP GhcTc) -> HsExpr GhcTc
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (EvVar -> Located EvVar
forall e. e -> Located e
noLoc EvVar
sid)) }
else
TcRef WantedConstraints -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a. TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar TcRef WantedConstraints
lie_var (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
CtOrigin -> Name -> [TcSigmaType] -> TcM (HsExpr GhcTc)
newMethodFromName (Name -> CtOrigin
OccurrenceOf Name
id_name)
Name
GHC.Builtin.Names.TH.liftName
[HasDebugCallStack => TcSigmaType -> TcSigmaType
TcSigmaType -> TcSigmaType
getRuntimeRep TcSigmaType
id_ty, TcSigmaType
id_ty]
; [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 GhcTc -> PendingTcSplice
PendingTcSplice Name
id_name
(LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap (QuoteWrapper -> HsWrapper
applyQuoteWrapper QuoteWrapper
q) (HsExpr GhcTc -> LHsExpr GhcTc
forall e. e -> Located e
noLoc HsExpr GhcTc
lift))
(IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar EvVar
IdP GhcTc
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 TopLevelFlag
_ EvVar
_ ThStage
_ = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
polySpliceErr :: Id -> SDoc
polySpliceErr :: EvVar -> SDoc
polySpliceErr EvVar
id
= String -> SDoc
text String
"Can't splice the polymorphic local variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvVar
id)
getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet
getFixedTyVars :: [FastString] -> [EvVar] -> [ConLike] -> VarSet
getFixedTyVars [FastString]
upd_fld_occs [EvVar]
univ_tvs [ConLike]
cons
= [EvVar] -> VarSet
mkVarSet [EvVar
tv1 | ConLike
con <- [ConLike]
cons
, let ([EvVar]
u_tvs, [EvVar]
_, [EqSpec]
eqspec, [TcSigmaType]
prov_theta
, [TcSigmaType]
req_theta, [Scaled TcSigmaType]
arg_tys, TcSigmaType
_)
= ConLike
-> ([EvVar], [EvVar], [EqSpec], [TcSigmaType], [TcSigmaType],
[Scaled 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 ((Scaled TcSigmaType -> TcSigmaType)
-> [Scaled TcSigmaType] -> [TcSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcSigmaType -> TcSigmaType
forall a. Scaled a -> a
scaledThing [Scaled TcSigmaType]
fixed_tys)
VarSet -> VarSet -> VarSet
`unionVarSet` [TcSigmaType] -> VarSet
tyCoVarsOfTypes [TcSigmaType]
theta
fixed_tys :: [Scaled TcSigmaType]
fixed_tys = [Scaled TcSigmaType
ty | (FieldLbl Name
fl, Scaled TcSigmaType
ty) <- [FieldLbl Name]
-> [Scaled TcSigmaType] -> [(FieldLbl Name, Scaled TcSigmaType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FieldLbl Name]
flds [Scaled 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)]
, (EvVar
tv1,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 ]
disambiguateSelector :: Located RdrName -> Type -> TcM Name
disambiguateSelector :: Located RdrName -> TcSigmaType -> TcM Name
disambiguateSelector lr :: Located RdrName
lr@(L SrcSpan
_ RdrName
rdr) 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
Maybe TyCon
Nothing -> Located RdrName -> TcM Name
forall a. Located RdrName -> TcM a
ambiguousSelector Located RdrName
lr
Just 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 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) }
Maybe GlobalRdrElt
Nothing -> SDoc -> TcM Name
forall a. SDoc -> TcRn a
failWithTc (RecSelParent -> RdrName -> SDoc
fieldNotInType RecSelParent
parent RdrName
rdr) } }
ambiguousSelector :: Located RdrName -> TcM a
ambiguousSelector :: Located RdrName -> TcM a
ambiguousSelector (L SrcSpan
_ RdrName
rdr)
= do { RdrName -> TcRn ()
addAmbiguousNameErr RdrName
rdr
; TcM a
forall env a. IOEnv env a
failM }
addAmbiguousNameErr :: RdrName -> TcM ()
addAmbiguousNameErr :: RdrName -> TcRn ()
addAmbiguousNameErr 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}
disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType
-> [LHsRecUpdField GhcRn] -> ExpRhoType
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds :: LHsExpr GhcRn
-> TcSigmaType
-> [LHsRecUpdField GhcRn]
-> ExpSigmaType
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds LHsExpr GhcRn
record_expr TcSigmaType
record_rho [LHsRecUpdField GhcRn]
rbnds ExpSigmaType
res_ty
= 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
Just [(LHsRecUpdField GhcRn, Name)]
rbnds' -> ((LHsRecUpdField GhcRn, Name)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)))
-> [(LHsRecUpdField GhcRn, Name)]
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (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 GhcTc) (LHsExpr GhcRn))
lookupSelector [(LHsRecUpdField GhcRn, Name)]
rbnds'
Maybe [(LHsRecUpdField GhcRn, Name)]
Nothing ->
do { FamInstEnvs
fam_inst_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; [(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
; RecSelParent
p <- FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
identifyParent FamInstEnvs
fam_inst_envs [[RecSelParent]]
possible_parents
; TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
forall r. TcM r -> TcM r
checkNoErrs (TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)])
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
forall a b. (a -> b) -> a -> b
$ ((LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)))
-> [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (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 GhcTc) (LHsExpr GhcRn))
pickParent RecSelParent
p) [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
rbnds_with_parents }
where
isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)
isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn, Name)
isUnambiguous LHsRecUpdField GhcRn
x = case GenLocated SrcSpan (AmbiguousFieldOcc GhcRn)
-> AmbiguousFieldOcc GhcRn
forall l e. GenLocated l e -> e
unLoc (HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (LHsRecUpdField GhcRn
-> HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
forall l e. GenLocated l e -> e
unLoc LHsRecUpdField GhcRn
x)) of
Unambiguous XUnambiguous GhcRn
sel_name Located RdrName
_ -> (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
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 l e. GenLocated l e -> e
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 l e. GenLocated l e -> e
unLoc)
[LHsRecUpdField GhcRn]
rbnds
identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
identifyParent FamInstEnvs
fam_inst_envs [[RecSelParent]]
possible_parents
= case ([RecSelParent] -> [RecSelParent] -> [RecSelParent])
-> [[RecSelParent]] -> [RecSelParent]
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 [RecSelParent] -> [RecSelParent] -> [RecSelParent]
forall a. Eq a => [a] -> [a] -> [a]
intersect [[RecSelParent]]
possible_parents of
[] -> SDoc -> TcM RecSelParent
forall a. SDoc -> TcRn a
failWithTc ([LHsRecUpdField GhcRn] -> SDoc
noPossibleParents [LHsRecUpdField GhcRn]
rbnds)
[RecSelParent
p] -> RecSelParent -> TcM RecSelParent
forall (m :: * -> *) a. Monad m => a -> m a
return RecSelParent
p
RecSelParent
_:[RecSelParent]
_ | Just 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)
| Just {} <- HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
record_expr)
, Just 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)
[RecSelParent]
_ -> SDoc -> TcM RecSelParent
forall a. SDoc -> TcRn a
failWithTc SDoc
badOverloadedUpdate
pickParent :: RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
pickParent :: RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
pickParent RecSelParent
p (LHsRecUpdField GhcRn
upd, [(RecSelParent, GlobalRdrElt)]
xs)
= case RecSelParent
-> [(RecSelParent, GlobalRdrElt)] -> Maybe GlobalRdrElt
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup RecSelParent
p [(RecSelParent, GlobalRdrElt)]
xs of
Just GlobalRdrElt
gre -> do { Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(RecSelParent, GlobalRdrElt)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(RecSelParent, GlobalRdrElt)] -> [(RecSelParent, GlobalRdrElt)]
forall a. [a] -> [a]
tail [(RecSelParent, GlobalRdrElt)]
xs)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
let L SrcSpan
loc AmbiguousFieldOcc GhcRn
_ = HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (LHsRecUpdField GhcRn
-> HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
forall l e. GenLocated l e -> e
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 GhcTc) (LHsExpr GhcRn))
lookupSelector (LHsRecUpdField GhcRn
upd, GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre) }
Maybe GlobalRdrElt
Nothing -> do { SDoc -> TcRn ()
addErrTc (RecSelParent -> RdrName -> SDoc
fieldNotInType RecSelParent
p
(Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc (HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located RdrName
forall (p :: Pass). HsRecUpdField (GhcPass p) -> Located RdrName
hsRecUpdFieldRdr (LHsRecUpdField GhcRn
-> HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
forall l e. GenLocated l e -> e
unLoc LHsRecUpdField GhcRn
upd))))
; (LHsRecUpdField GhcRn, Name)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTc) (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))) }
lookupSelector :: (LHsRecUpdField GhcRn, Name)
-> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector :: (LHsRecUpdField GhcRn, Name)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector (L SrcSpan
l HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
upd, Name
n)
= do { EvVar
i <- Name -> TcM EvVar
tcLookupId Name
n
; let L SrcSpan
loc AmbiguousFieldOcc GhcRn
af = HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> GenLocated SrcSpan (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 GhcTc) (LHsExpr GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)))
-> LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
upd { hsRecFieldLbl :: GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
hsRecFieldLbl
= SrcSpan
-> AmbiguousFieldOcc GhcTc
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XUnambiguous GhcTc -> Located RdrName -> AmbiguousFieldOcc GhcTc
forall pass.
XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Unambiguous EvVar
XUnambiguous GhcTc
i (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
lbl)) } }
tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs TcSigmaType
ty0
= case HasCallStack => TcSigmaType -> Maybe (TyCon, [TcSigmaType])
TcSigmaType -> Maybe (TyCon, [TcSigmaType])
tcSplitTyConApp_maybe TcSigmaType
ty of
Just (TyCon
tc, [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))
Maybe (TyCon, [TcSigmaType])
Nothing -> Maybe TyCon
forall a. Maybe a
Nothing
where
([EvVar]
_, [TcSigmaType]
_, TcSigmaType
ty) = TcSigmaType -> ([EvVar], [TcSigmaType], TcSigmaType)
tcSplitSigmaTy TcSigmaType
ty0
tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon
tyConOfET :: FamInstEnvs -> ExpSigmaType -> Maybe TyCon
tyConOfET FamInstEnvs
fam_inst_envs 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
lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents 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 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)) }
obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (ExprWithTySig XExprWithTySig GhcRn
_ LHsExpr GhcRn
_ LHsSigWcType (NoGhcTc GhcRn)
ty) = LHsSigWcType GhcRn -> Maybe (LHsSigWcType GhcRn)
forall a. a -> Maybe a
Just LHsSigWcType GhcRn
LHsSigWcType (NoGhcTc GhcRn)
ty
obviousSig (HsPar XPar GhcRn
_ LHsExpr GhcRn
p) = HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
p)
obviousSig HsExpr GhcRn
_ = Maybe (LHsSigWcType GhcRn)
forall a. Maybe a
Nothing
tcRecordBinds
:: ConLike
-> [TcType]
-> HsRecordBinds GhcRn
-> TcM (HsRecordBinds GhcTc)
tcRecordBinds :: ConLike
-> [TcSigmaType]
-> HsRecordBinds GhcRn
-> TcM (HsRecordBinds GhcTc)
tcRecordBinds ConLike
con_like [TcSigmaType]
arg_tys (HsRecFields [LHsRecField GhcRn (LHsExpr GhcRn)]
rbinds Maybe (Located Int)
dd)
= do { [Maybe (LHsRecField GhcTc (LHsExpr GhcTc))]
mb_binds <- (LHsRecField GhcRn (LHsExpr GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe (LHsRecField GhcTc (LHsExpr GhcTc))))
-> [LHsRecField GhcRn (LHsExpr GhcRn)]
-> IOEnv
(Env TcGblEnv TcLclEnv) [Maybe (LHsRecField GhcTc (LHsExpr GhcTc))]
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 GhcTc (LHsExpr GhcTc)))
do_bind [LHsRecField GhcRn (LHsExpr GhcRn)]
rbinds
; HsRecordBinds GhcTc -> TcM (HsRecordBinds GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsRecField GhcTc (LHsExpr GhcTc)]
-> Maybe (Located Int) -> HsRecordBinds GhcTc
forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields ([Maybe (LHsRecField GhcTc (LHsExpr GhcTc))]
-> [LHsRecField GhcTc (LHsExpr GhcTc)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (LHsRecField GhcTc (LHsExpr GhcTc))]
mb_binds) Maybe (Located 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 String
"tcRecordBinds" [Name]
fields [TcSigmaType]
arg_tys
do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv) (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
do_bind (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 GhcTc, LHsExpr GhcTc)
mb <- ConLike
-> [(Name, TcSigmaType)]
-> Located (FieldOcc GhcRn)
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, TcSigmaType)]
flds_w_tys Located (FieldOcc GhcRn)
f LHsExpr GhcRn
rhs
; case Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)
mb of
Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)
Nothing -> Maybe (LHsRecField GhcTc (LHsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv) (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LHsRecField GhcTc (LHsExpr GhcTc))
forall a. Maybe a
Nothing
Just (LFieldOcc GhcTc
f', LHsExpr GhcTc
rhs') -> Maybe (LHsRecField GhcTc (LHsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv) (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsRecField GhcTc (LHsExpr GhcTc)
-> Maybe (LHsRecField GhcTc (LHsExpr GhcTc))
forall a. a -> Maybe a
Just (SrcSpan
-> HsRecField' (FieldOcc GhcTc) (LHsExpr GhcTc)
-> LHsRecField GhcTc (LHsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsRecField GhcRn (LHsExpr GhcRn)
fld { hsRecFieldLbl :: LFieldOcc GhcTc
hsRecFieldLbl = LFieldOcc GhcTc
f'
, hsRecFieldArg :: LHsExpr GhcTc
hsRecFieldArg = LHsExpr GhcTc
rhs' }))) }
tcRecordUpd
:: ConLike
-> [TcType]
-> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTc]
tcRecordUpd :: ConLike
-> [TcSigmaType]
-> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTc]
tcRecordUpd ConLike
con_like [TcSigmaType]
arg_tys [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds = ([Maybe (LHsRecUpdField GhcTc)] -> [LHsRecUpdField GhcTc])
-> IOEnv (Env TcGblEnv TcLclEnv) [Maybe (LHsRecUpdField GhcTc)]
-> TcM [LHsRecUpdField GhcTc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (LHsRecUpdField GhcTc)] -> [LHsRecUpdField GhcTc]
forall a. [Maybe a] -> [a]
catMaybes (IOEnv (Env TcGblEnv TcLclEnv) [Maybe (LHsRecUpdField GhcTc)]
-> TcM [LHsRecUpdField GhcTc])
-> IOEnv (Env TcGblEnv TcLclEnv) [Maybe (LHsRecUpdField GhcTc)]
-> TcM [LHsRecUpdField GhcTc]
forall a b. (a -> b) -> a -> b
$ (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsRecUpdField GhcTc)))
-> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [Maybe (LHsRecUpdField GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsRecUpdField GhcTc))
do_bind [LHsRecField' (AmbiguousFieldOcc GhcTc) (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 String
"tcRecordUpd" [Name]
fields [TcSigmaType]
arg_tys
do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecUpdField GhcTc))
do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsRecUpdField GhcTc))
do_bind (L SrcSpan
l fld :: HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
fld@(HsRecField { hsRecFieldLbl :: forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl = L SrcSpan
loc AmbiguousFieldOcc GhcTc
af
, hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = LHsExpr GhcRn
rhs }))
= do { let lbl :: RdrName
lbl = AmbiguousFieldOcc GhcTc -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc AmbiguousFieldOcc GhcTc
af
sel_id :: EvVar
sel_id = AmbiguousFieldOcc GhcTc -> EvVar
selectorAmbiguousFieldOcc AmbiguousFieldOcc GhcTc
af
f :: Located (FieldOcc GhcRn)
f = SrcSpan -> FieldOcc GhcRn -> Located (FieldOcc GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XCFieldOcc GhcRn -> 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 GhcTc, LHsExpr GhcTc)
mb <- ConLike
-> [(Name, TcSigmaType)]
-> Located (FieldOcc GhcRn)
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, TcSigmaType)]
flds_w_tys Located (FieldOcc GhcRn)
f LHsExpr GhcRn
rhs
; case Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)
mb of
Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)
Nothing -> Maybe (LHsRecUpdField GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsRecUpdField GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LHsRecUpdField GhcTc)
forall a. Maybe a
Nothing
Just (LFieldOcc GhcTc
f', LHsExpr GhcTc
rhs') ->
Maybe (LHsRecUpdField GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsRecUpdField GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsRecUpdField GhcTc -> Maybe (LHsRecUpdField GhcTc)
forall a. a -> Maybe a
Just
(SrcSpan
-> HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcTc)
-> LHsRecUpdField GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
fld { hsRecFieldLbl :: GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
hsRecFieldLbl
= SrcSpan
-> AmbiguousFieldOcc GhcTc
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XUnambiguous GhcTc -> Located RdrName -> AmbiguousFieldOcc GhcTc
forall pass.
XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Unambiguous
(FieldOcc GhcTc -> XCFieldOcc GhcTc
forall pass. FieldOcc pass -> XCFieldOcc pass
extFieldOcc (LFieldOcc GhcTc -> FieldOcc GhcTc
forall l e. GenLocated l e -> e
unLoc LFieldOcc GhcTc
f'))
(SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
lbl))
, hsRecFieldArg :: LHsExpr GhcTc
hsRecFieldArg = LHsExpr GhcTc
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 GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, TcSigmaType)]
flds_w_tys (L SrcSpan
loc (FieldOcc XCFieldOcc GhcRn
sel_name Located RdrName
lbl)) LHsExpr GhcRn
rhs
| Just 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 GhcTc, LHsExpr GhcTc))
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (FastString -> SDoc
fieldCtxt FastString
field_lbl) (TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)))
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
do { LHsExpr GhcTc
rhs' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
rhs TcSigmaType
field_ty
; let field_id :: EvVar
field_id = OccName -> Unique -> TcSigmaType -> TcSigmaType -> SrcSpan -> EvVar
mkUserLocal (Name -> OccName
nameOccName Name
XCFieldOcc GhcRn
sel_name)
(Name -> Unique
nameUnique Name
XCFieldOcc GhcRn
sel_name)
TcSigmaType
Many TcSigmaType
field_ty SrcSpan
loc
; Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return ((LFieldOcc GhcTc, LHsExpr GhcTc)
-> Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)
forall a. a -> Maybe a
Just (SrcSpan -> FieldOcc GhcTc -> LFieldOcc GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XCFieldOcc GhcTc -> Located RdrName -> FieldOcc GhcTc
forall pass. XCFieldOcc pass -> Located RdrName -> FieldOcc pass
FieldOcc EvVar
XCFieldOcc GhcTc
field_id Located RdrName
lbl), LHsExpr GhcTc
rhs')) }
| Bool
otherwise
= do { SDoc -> TcRn ()
addErrTc (ConLike -> FastString -> SDoc
badFieldCon ConLike
con_like FastString
field_lbl)
; Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)
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 -> RdrName
forall l e. GenLocated l e -> e
unLoc Located RdrName
lbl)
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM ()
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcRn ()
checkMissingFields ConLike
con_like HsRecordBinds GhcRn
rbinds
| [FieldLbl Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLbl Name]
field_labels
= if (HsImplBang -> Bool) -> [HsImplBang] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any HsImplBang -> Bool
isBanged [HsImplBang]
field_strs then
SDoc -> TcRn ()
addErrTc (ConLike -> [FastString] -> SDoc
missingStrictFields ConLike
con_like [])
else do
Bool
warn <- WarningFlag -> TcRn 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
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 -> TcRn 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 | (FieldLbl Name
fl, 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 | (FieldLbl Name
fl, 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 String
"missingFields"
[FieldLbl Name]
field_labels
[HsImplBang]
field_strs
field_strs :: [HsImplBang]
field_strs = ConLike -> [HsImplBang]
conLikeImplBangs ConLike
con_like
FieldLbl a
fl elemField :: FieldLbl a -> t a -> Bool
`elemField` t a
flds = (a -> Bool) -> t a -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ 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
fieldCtxt :: FieldLabelString -> SDoc
fieldCtxt :: FastString -> SDoc
fieldCtxt FastString
field_name
= String -> SDoc
text String
"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 String
"field of a record")
addExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt LHsExpr GhcRn
e TcRn a
thing_inside = SDoc -> TcRn a -> TcRn a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsExpr GhcRn -> SDoc
exprCtxt (LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
e)) TcRn a
thing_inside
exprCtxt :: HsExpr GhcRn -> SDoc
exprCtxt :: HsExpr GhcRn -> SDoc
exprCtxt HsExpr GhcRn
expr = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"In the expression:") Int
2 (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HsExpr GhcRn -> HsExpr GhcRn
forall (p :: Pass). HsExpr (GhcPass p) -> HsExpr (GhcPass p)
stripParensHsExpr HsExpr GhcRn
expr))
addFunResCtxt :: Bool
-> HsExpr GhcTc -> TcType -> ExpRhoType
-> TcM a -> TcM a
addFunResCtxt :: Bool
-> HsExpr GhcTc -> TcSigmaType -> ExpSigmaType -> TcM a -> TcM a
addFunResCtxt Bool
has_args HsExpr GhcTc
fun TcSigmaType
fun_res_ty ExpSigmaType
env_ty
= (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addLandmarkErrCtxtM (\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)
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
; TcSigmaType
fun_res' <- TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
fun_res_ty
; TcSigmaType
env' <- case Maybe TcSigmaType
mb_env_ty of
Just TcSigmaType
env_ty -> TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
env_ty
Maybe TcSigmaType
Nothing ->
do { Bool
dumping <- DumpFlag -> TcRn 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
([EvVar]
_, [TcSigmaType]
_, TcSigmaType
fun_tau) = TcSigmaType -> ([EvVar], [TcSigmaType], TcSigmaType)
tcSplitNestedSigmaTys TcSigmaType
fun_res'
([EvVar]
_, [TcSigmaType]
_, TcSigmaType
env_tau) = TcSigmaType -> ([EvVar], [TcSigmaType], TcSigmaType)
tcSplitSigmaTy TcSigmaType
env'
([Scaled TcSigmaType]
args_fun, TcSigmaType
res_fun) = TcSigmaType -> ([Scaled TcSigmaType], TcSigmaType)
tcSplitFunTys TcSigmaType
fun_tau
([Scaled TcSigmaType]
args_env, TcSigmaType
res_env) = TcSigmaType -> ([Scaled TcSigmaType], TcSigmaType)
tcSplitFunTys TcSigmaType
env_tau
n_fun :: Int
n_fun = [Scaled TcSigmaType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled TcSigmaType]
args_fun
n_env :: Int
n_env = [Scaled TcSigmaType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled 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 String
"Probable cause:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
fun)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is applied to too few arguments"
| Bool
has_args
, TcSigmaType -> Bool
not_fun TcSigmaType
res_fun
= String -> SDoc
text String
"Possible cause:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
fun)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is applied to too many arguments"
| Bool
otherwise
= SDoc
Outputable.empty
; SDoc -> IOEnv (Env TcGblEnv TcLclEnv) SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
info }
where
not_fun :: TcSigmaType -> Bool
not_fun TcSigmaType
ty
= case HasCallStack => TcSigmaType -> Maybe (TyCon, [TcSigmaType])
TcSigmaType -> Maybe (TyCon, [TcSigmaType])
tcSplitTyConApp_maybe TcSigmaType
ty of
Just (TyCon
tc, [TcSigmaType]
_) -> TyCon -> Bool
isAlgTyCon TyCon
tc
Maybe (TyCon, [TcSigmaType])
Nothing -> Bool
False
badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc
badFieldTypes :: [(FastString, TcSigmaType)] -> SDoc
badFieldTypes [(FastString, TcSigmaType)]
prs
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"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)
Int
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 | (FastString
f,TcSigmaType
ty) <- [(FastString, TcSigmaType)]
prs ])
badFieldsUpd
:: [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike]
-> SDoc
badFieldsUpd :: [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike] -> SDoc
badFieldsUpd [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds [ConLike]
data_cons
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"No constructor has all these fields:")
Int
2 ([FastString] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [FastString]
conflictingFields)
where
conflictingFields :: [FastString]
conflictingFields = case [(FastString, [Bool])]
nonMembers of
(FastString
nonMember, [Bool]
_) : [(FastString, [Bool])]
_ -> [FastString
aMember, FastString
nonMember]
[] -> let
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 (a
_, [Bool]
setMem) (a
field, [Bool]
fldMem)
= (a
field, (Bool -> Bool -> Bool) -> [Bool] -> [Bool] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Bool -> Bool
(&&) [Bool]
setMem [Bool]
fldMem)
in
([(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)
([(FastString, [Bool])]
members, [(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
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 (\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 GhcTc) (LHsExpr GhcRn)
-> FastString)
-> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> FastString
occNameFS (OccName -> FastString)
-> (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> OccName)
-> LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> OccName)
-> (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> RdrName)
-> LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AmbiguousFieldOcc GhcTc -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc (AmbiguousFieldOcc GhcTc -> RdrName)
-> (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> AmbiguousFieldOcc GhcTc)
-> LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
-> AmbiguousFieldOcc GhcTc
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
-> AmbiguousFieldOcc GhcTc)
-> (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
-> LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> AmbiguousFieldOcc GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
-> (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
-> LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
forall l e. GenLocated l e -> e
unLoc) [LHsRecField' (AmbiguousFieldOcc GhcTc) (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
sortMembership :: [(a, [Bool])] -> [(a, [Bool])]
sortMembership =
((Int, (a, [Bool])) -> (a, [Bool]))
-> [(Int, (a, [Bool]))] -> [(a, [Bool])]
forall a b. (a -> b) -> [a] -> [b]
map (Int, (a, [Bool])) -> (a, [Bool])
forall a b. (a, b) -> b
snd ([(Int, (a, [Bool]))] -> [(a, [Bool])])
-> ([(a, [Bool])] -> [(Int, (a, [Bool]))])
-> [(a, [Bool])]
-> [(a, [Bool])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
((Int, (a, [Bool])) -> (Int, (a, [Bool])) -> Ordering)
-> [(Int, (a, [Bool]))] -> [(Int, (a, [Bool]))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Int, (a, [Bool])) -> Int)
-> (Int, (a, [Bool]))
-> (Int, (a, [Bool]))
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, (a, [Bool])) -> Int
forall a b. (a, b) -> a
fst) ([(Int, (a, [Bool]))] -> [(Int, (a, [Bool]))])
-> ([(a, [Bool])] -> [(Int, (a, [Bool]))])
-> [(a, [Bool])]
-> [(Int, (a, [Bool]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
((a, [Bool]) -> (Int, (a, [Bool])))
-> [(a, [Bool])] -> [(Int, (a, [Bool]))]
forall a b. (a -> b) -> [a] -> [b]
map (\ item :: (a, [Bool])
item@(a
_, [Bool]
membershipRow) -> ([Bool] -> Int
countTrue [Bool]
membershipRow, (a, [Bool])
item))
countTrue :: [Bool] -> Int
countTrue = (Bool -> Bool) -> [Bool] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Bool -> Bool
forall a. a -> a
id
naughtyRecordSel :: RdrName -> SDoc
naughtyRecordSel :: RdrName -> SDoc
naughtyRecordSel RdrName
sel_id
= String -> SDoc
text String
"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 String
"as a function due to escaped type variables" SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"Probable fix: use pattern-matching syntax instead"
notSelector :: Name -> SDoc
notSelector :: Name -> SDoc
notSelector Name
field
= [SDoc] -> SDoc
hsep [SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
field), String -> SDoc
text String
"is not a record selector"]
mixedSelectors :: [Id] -> [Id] -> SDoc
mixedSelectors :: [EvVar] -> [EvVar] -> SDoc
mixedSelectors data_sels :: [EvVar]
data_sels@(EvVar
dc_rep_id:[EvVar]
_) pat_syn_sels :: [EvVar]
pat_syn_sels@(EvVar
ps_rep_id:[EvVar]
_)
= PtrString -> SDoc
ptext
(String -> PtrString
sLit String
"Cannot use a mixture of pattern synonym and record selectors") SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"Record selectors defined by"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Name
tyConName TyCon
rep_dc))
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
":"
SDoc -> SDoc -> SDoc
<+> (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 String
"Pattern synonym selectors defined by"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (PatSyn -> Name
patSynName PatSyn
rep_ps))
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
":"
SDoc -> SDoc -> SDoc
<+> (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 PatSyn
rep_ps = EvVar -> RecSelParent
recordSelectorTyCon EvVar
ps_rep_id
RecSelData TyCon
rep_dc = EvVar -> RecSelParent
recordSelectorTyCon EvVar
dc_rep_id
mixedSelectors [EvVar]
_ [EvVar]
_ = String -> SDoc
forall a. String -> a
panic String
"GHC.Tc.Gen.Expr: mixedSelectors emptylists"
missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc
missingStrictFields :: ConLike -> [FastString] -> SDoc
missingStrictFields ConLike
con [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 String
"Constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
con) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"does not have the required strict field(s)"
missingFields :: ConLike -> [FieldLabelString] -> SDoc
missingFields :: ConLike -> [FastString] -> SDoc
missingFields ConLike
con [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 String
"Fields of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
con) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"not initialised"
noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc
noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc
noPossibleParents [LHsRecUpdField GhcRn]
rbinds
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"No type has all these fields:")
Int
2 ([GenLocated SrcSpan (AmbiguousFieldOcc GhcRn)] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [GenLocated SrcSpan (AmbiguousFieldOcc GhcRn)]
fields)
where
fields :: [GenLocated SrcSpan (AmbiguousFieldOcc GhcRn)]
fields = (LHsRecUpdField GhcRn
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
-> [LHsRecUpdField GhcRn]
-> [GenLocated SrcSpan (AmbiguousFieldOcc GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
-> (LHsRecUpdField GhcRn
-> HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn))
-> LHsRecUpdField GhcRn
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsRecUpdField GhcRn
-> HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
forall l e. GenLocated l e -> e
unLoc) [LHsRecUpdField GhcRn]
rbinds
badOverloadedUpdate :: SDoc
badOverloadedUpdate :: SDoc
badOverloadedUpdate = String -> SDoc
text String
"Record update is ambiguous, and requires a type signature"
fieldNotInType :: RecSelParent -> RdrName -> SDoc
fieldNotInType :: RecSelParent -> RdrName -> SDoc
fieldNotInType RecSelParent
p RdrName
rdr
= SDoc -> RdrName -> SDoc
unknownSubordinateErr (String -> SDoc
text String
"field of type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RecSelParent -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecSelParent
p)) RdrName
rdr
data NotClosedReason = NotLetBoundReason
| NotTypeClosed VarSet
| NotClosed Name NotClosedReason
checkClosedInStaticForm :: Name -> TcM ()
checkClosedInStaticForm :: Name -> TcRn ()
checkClosedInStaticForm Name
name = do
TcTypeEnv
type_env <- TcM TcTypeEnv
getLclTypeEnv
case TcTypeEnv -> Name -> Maybe NotClosedReason
checkClosed TcTypeEnv
type_env Name
name of
Maybe NotClosedReason
Nothing -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just NotClosedReason
reason -> SDoc -> TcRn ()
addErrTc (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Name -> NotClosedReason -> SDoc
explain Name
name NotClosedReason
reason
where
checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
checkClosed TcTypeEnv
type_env Name
n = TcTypeEnv -> UniqSet Name -> Name -> Maybe NotClosedReason
checkLoop TcTypeEnv
type_env (Name -> UniqSet Name
unitNameSet Name
n) Name
n
checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason
checkLoop :: TcTypeEnv -> UniqSet Name -> Name -> Maybe NotClosedReason
checkLoop TcTypeEnv
type_env UniqSet Name
visited Name
n = do
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
IdBindingInfo
ClosedLet -> Maybe NotClosedReason
forall a. Maybe a
Nothing
IdBindingInfo
NotLetBound -> NotClosedReason -> Maybe NotClosedReason
forall a. a -> Maybe a
Just NotClosedReason
NotLetBoundReason
NonClosedLet UniqSet Name
fvs Bool
type_closed -> [NotClosedReason] -> Maybe NotClosedReason
forall a. [a] -> Maybe a
listToMaybe ([NotClosedReason] -> Maybe NotClosedReason)
-> [NotClosedReason] -> Maybe NotClosedReason
forall a b. (a -> b) -> a -> b
$
[ Name -> NotClosedReason -> NotClosedReason
NotClosed Name
n' NotClosedReason
reason
| Name
n' <- UniqSet Name -> [Name]
nameSetElemsStable UniqSet Name
fvs
, Bool -> Bool
not (Name -> UniqSet Name -> Bool
elemNameSet Name
n' UniqSet Name
visited)
, Just NotClosedReason
reason <- [TcTypeEnv -> UniqSet Name -> Name -> Maybe NotClosedReason
checkLoop TcTypeEnv
type_env (UniqSet Name -> Name -> UniqSet Name
extendNameSet UniqSet Name
visited Name
n') Name
n']
] [NotClosedReason] -> [NotClosedReason] -> [NotClosedReason]
forall a. [a] -> [a] -> [a]
++
if Bool
type_closed then
[]
else
[ VarSet -> NotClosedReason
NotTypeClosed (VarSet -> NotClosedReason) -> VarSet -> NotClosedReason
forall a b. (a -> b) -> a -> b
$ TcSigmaType -> VarSet
tyCoVarsOfType (EvVar -> TcSigmaType
idType EvVar
tcid) ]
Maybe TcTyThing
_ -> Maybe NotClosedReason
forall a. Maybe a
Nothing
explain :: Name -> NotClosedReason -> SDoc
explain :: Name -> NotClosedReason -> SDoc
explain Name
name NotClosedReason
reason =
SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is used in a static form but it is not closed"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"because it"
SDoc -> SDoc -> SDoc
$$
[SDoc] -> SDoc
sep (NotClosedReason -> [SDoc]
causes NotClosedReason
reason)
causes :: NotClosedReason -> [SDoc]
causes :: NotClosedReason -> [SDoc]
causes NotClosedReason
NotLetBoundReason = [String -> SDoc
text String
"is not let-bound."]
causes (NotTypeClosed VarSet
vs) =
[ String -> SDoc
text String
"has a non-closed type because it contains the"
, String -> SDoc
text String
"type variables:" SDoc -> SDoc -> SDoc
<+>
VarSet -> ([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 Name
n NotClosedReason
reason) =
let msg :: SDoc
msg = String -> SDoc
text String
"uses" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"which"
in case NotClosedReason
reason of
NotClosed Name
_ NotClosedReason
_ -> SDoc
msg SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: NotClosedReason -> [SDoc]
causes NotClosedReason
reason
NotClosedReason
_ -> let ([SDoc]
xs0, [SDoc]
xs1) = Int -> [SDoc] -> ([SDoc], [SDoc])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
1 ([SDoc] -> ([SDoc], [SDoc])) -> [SDoc] -> ([SDoc], [SDoc])
forall a b. (a -> b) -> a -> b
$ NotClosedReason -> [SDoc]
causes NotClosedReason
reason
in (SDoc -> SDoc) -> [SDoc] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SDoc
msg SDoc -> SDoc -> SDoc
<+>) [SDoc]
xs0 [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
xs1