{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Gen.Expr
( tcCheckPolyExpr, tcCheckPolyExprNC,
tcCheckMonoExpr, tcCheckMonoExprNC,
tcMonoExpr, tcMonoExprNC,
tcInferRho, tcInferRhoNC,
tcPolyExpr, tcExpr,
tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
tcCheckId,
getFixedTyVars ) where
import GHC.Prelude
import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
import GHC.Hs
import GHC.Rename.Utils
import GHC.Tc.Utils.Zonk
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Types.Basic
import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Gen.App
import GHC.Tc.Gen.Head
import GHC.Tc.Gen.Bind ( tcLocalBinds )
import GHC.Tc.Instance.Family ( tcGetFamInstEnvs )
import GHC.Core.FamInstEnv ( FamInstEnvs )
import GHC.Rename.Env ( addUsedGRE )
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Arrow
import GHC.Tc.Gen.Match
import GHC.Tc.Gen.HsType
import GHC.Tc.Gen.Pat
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType as TcType
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Tc.Types.Evidence
import GHC.Types.Var.Set
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Driver.Session
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Data.List.SetOps
import GHC.Data.Maybe
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import Control.Monad
import GHC.Core.Class(classTyCon)
import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )
import Data.Function
import Data.List (partition, sortBy, groupBy, intersect)
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)
tcPolyLExpr 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)
tcPolyLExprNC LHsExpr GhcRn
expr (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
res_ty)
tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType
-> TcM (LHsExpr GhcTc)
tcPolyLExpr :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcPolyLExpr (L loc expr) ExpSigmaType
res_ty
= SrcSpanAnn' (EpAnn AnnListItem)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' (EpAnn AnnListItem)
loc (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
HsExpr GhcRn
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
expr (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
do { HsExpr GhcTc
expr' <- HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr GhcRn
expr ExpSigmaType
res_ty
; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnn' (EpAnn AnnListItem)
-> HsExpr GhcTc
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
loc HsExpr GhcTc
expr') }
tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcPolyLExprNC (L loc expr) ExpSigmaType
res_ty
= SrcSpanAnn' (EpAnn AnnListItem)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' (EpAnn AnnListItem)
loc (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
do { HsExpr GhcTc
expr' <- HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr GhcRn
expr ExpSigmaType
res_ty
; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnn' (EpAnn AnnListItem)
-> HsExpr GhcTc
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
loc HsExpr GhcTc
expr') }
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 (L loc expr) ExpSigmaType
res_ty
= SrcSpanAnn' (EpAnn AnnListItem)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' (EpAnn AnnListItem)
loc (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
HsExpr GhcRn
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
expr (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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
; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnn' (EpAnn AnnListItem)
-> HsExpr GhcTc
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
loc HsExpr GhcTc
expr') }
tcMonoExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcMonoExprNC (L loc expr) ExpSigmaType
res_ty
= SrcSpanAnn' (EpAnn AnnListItem)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' (EpAnn AnnListItem)
loc (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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
; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnn' (EpAnn AnnListItem)
-> HsExpr GhcTc
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
loc HsExpr GhcTc
expr') }
tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
tcInferRho :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
tcInferRho (L loc expr)
= SrcSpanAnn' (EpAnn AnnListItem)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' (EpAnn AnnListItem)
loc (TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
forall a b. (a -> b) -> a -> b
$
HsExpr GhcRn
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
expr (TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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)
; (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnn' (EpAnn AnnListItem)
-> HsExpr GhcTc
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
loc HsExpr GhcTc
expr', TcSigmaType
rho) }
tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
tcInferRhoNC (L loc expr)
= SrcSpanAnn' (EpAnn AnnListItem)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' (EpAnn AnnListItem)
loc (TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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)
; (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnn' (EpAnn AnnListItem)
-> HsExpr GhcTc
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
loc HsExpr GhcTc
expr', TcSigmaType
rho) }
tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr GhcRn
expr ExpSigmaType
res_ty
= do { String -> SDoc -> TcRn ()
traceTc String
"tcPolyExpr" (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
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap HsExpr GhcTc
expr' }
tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcExpr e :: HsExpr GhcRn
e@(HsVar {}) ExpSigmaType
res_ty = HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e 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@(OpApp {}) 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@(ExprWithTySig {}) ExpSigmaType
res_ty = HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpSigmaType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsRecSel {}) ExpSigmaType
res_ty = HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpSigmaType
res_ty
tcExpr e :: HsExpr GhcRn
e@(XExpr (HsExpanded {})) ExpSigmaType
res_ty = HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpSigmaType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsOverLit XOverLitE GhcRn
_ HsOverLit GhcRn
lit) ExpSigmaType
res_ty
= do { Maybe (HsOverLit GhcTc)
mb_res <- HsOverLit GhcRn -> ExpSigmaType -> TcM (Maybe (HsOverLit GhcTc))
tcShortCutLit HsOverLit GhcRn
lit ExpSigmaType
res_ty
; case Maybe (HsOverLit GhcTc)
mb_res of
Just HsOverLit GhcTc
lit' -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XOverLitE GhcTc -> HsOverLit GhcTc -> HsExpr GhcTc
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcTc
forall a. EpAnn a
noAnn HsOverLit GhcTc
lit')
Maybe (HsOverLit GhcTc)
Nothing -> HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpSigmaType
res_ty }
tcExpr (HsUnboundVar XUnboundVar GhcRn
_ OccName
occ) ExpSigmaType
res_ty
= do { TcSigmaType
ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
res_ty
; HoleExprRef
her <- OccName -> TcSigmaType -> TcM HoleExprRef
emitNewExprHole OccName
occ TcSigmaType
ty
; UsageEnv -> TcRn ()
tcEmitBindingUsage UsageEnv
bottomUE
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XUnboundVar GhcTc -> OccName -> HsExpr GhcTc
forall p. XUnboundVar p -> OccName -> HsExpr p
HsUnboundVar HoleExprRef
XUnboundVar GhcTc
her OccName
occ) }
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 LHsToken "(" GhcRn
lpar LHsExpr GhcRn
expr LHsToken ")" GhcRn
rpar) ExpSigmaType
res_ty
= do { GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr GhcRn
expr ExpSigmaType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XPar GhcTc
-> LHsToken "(" GhcTc
-> LHsExpr GhcTc
-> LHsToken ")" GhcTc
-> HsExpr GhcTc
forall p.
XPar p -> LHsToken "(" p -> LHsExpr p -> LHsToken ")" p -> HsExpr p
HsPar XPar GhcRn
XPar GhcTc
x LHsToken "(" GhcRn
LHsToken "(" GhcTc
lpar GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
LHsExpr GhcTc
expr' LHsToken ")" GhcRn
LHsToken ")" GhcTc
rpar) }
tcExpr (HsPragE XPragE GhcRn
x HsPragE GhcRn
prag LHsExpr GhcRn
expr) ExpSigmaType
res_ty
= do { GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcMonoExpr 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) GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
LHsExpr GhcTc
expr') }
tcExpr (NegApp XNegApp GhcRn
x LHsExpr GhcRn
expr SyntaxExpr GhcRn
neg_expr) ExpSigmaType
res_ty
= do { (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
expr', SyntaxExprTc
neg_expr')
<- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType]
-> [TcSigmaType]
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcM
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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]
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcM
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
SyntaxExprTc))
-> ([TcSigmaType]
-> [TcSigmaType]
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcM
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\[TcSigmaType
arg_ty] [TcSigmaType
arg_mult] ->
TcSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
arg_mult (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
expr 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 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
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 -> LIdP GhcTc -> HsExpr GhcTc
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (EvVar -> LocatedAn NameAnn EvVar
forall a an. a -> LocatedAn an a
noLocA 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 (HsLam XLam GhcRn
_ MatchGroup GhcRn (LHsExpr GhcRn)
match) ExpSigmaType
res_ty
= do { (HsWrapper
wrap, MatchGroup
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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 NoExtField
XLam GhcTc
noExtField MatchGroup
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
MatchGroup GhcTc (LHsExpr GhcTc)
match')) }
where
match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext GhcRn
-> (LocatedA (body GhcRn)
-> ExpSigmaType -> TcM (LocatedA (body GhcTc)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
forall p. HsMatchContext p
LambdaExpr, mc_body :: LocatedA (HsExpr GhcRn)
-> ExpSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
mc_body = LocatedA (HsExpr GhcRn)
-> ExpSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
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 (LocatedA (HsExpr GhcRn)) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
MatchGroup (GhcPass idR) body -> SDoc
pprMatches MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
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 (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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 (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
MatchGroup GhcTc (LHsExpr GhcTc)
matches') }
where
msg :: SDoc
msg = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The function" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e)
, String -> SDoc
text String
"requires"]
match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext GhcRn
-> (LocatedA (body GhcRn)
-> ExpSigmaType -> TcM (LocatedA (body GhcTc)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
forall p. HsMatchContext p
CaseAlt, mc_body :: LocatedA (HsExpr GhcRn)
-> ExpSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
mc_body = LocatedA (HsExpr GhcRn)
-> ExpSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcBody }
tcExpr (ExplicitList XExplicitList GhcRn
_ [LHsExpr GhcRn]
exprs) 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
; let tc_elt :: LocatedA (HsExpr GhcRn) -> TcM (LHsExpr GhcTc)
tc_elt LocatedA (HsExpr GhcRn)
expr = LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LocatedA (HsExpr GhcRn)
LHsExpr GhcRn
expr TcSigmaType
elt_ty
; [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)]
exprs' <- (LocatedA (HsExpr GhcRn)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> [LocatedA (HsExpr GhcRn)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LocatedA (HsExpr GhcRn)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
LocatedA (HsExpr GhcRn) -> TcM (LHsExpr GhcTc)
tc_elt [LocatedA (HsExpr GhcRn)]
[LHsExpr GhcRn]
exprs
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcTc -> [LHsExpr GhcTc] -> HsExpr GhcTc
forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList TcSigmaType
XExplicitList GhcTc
elt_ty [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)]
[LHsExpr GhcTc]
exprs' }
tcExpr expr :: HsExpr GhcRn
expr@(ExplicitTuple XExplicitTuple GhcRn
x [HsTupArg GhcRn]
tup_args Boxity
boxity) ExpSigmaType
res_ty
| (HsTupArg GhcRn -> Bool) -> [HsTupArg GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all HsTupArg GhcRn -> Bool
forall (p :: Pass). HsTupArg (GhcPass p) -> Bool
tupArgPresent [HsTupArg GhcRn]
tup_args
= do { let arity :: Int
arity = [HsTupArg GhcRn] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsTupArg GhcRn]
tup_args
tup_tc :: TyCon
tup_tc = Boxity -> Int -> TyCon
tupleTyCon Boxity
boxity Int
arity
; 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
; [HsTupArg GhcTc]
tup_args1 <- [HsTupArg GhcRn] -> [TcSigmaType] -> TcM [HsTupArg GhcTc]
tcTupArgs [HsTupArg 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 -> [HsTupArg GhcTc] -> Boxity -> HsExpr GhcTc
forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcRn
XExplicitTuple GhcTc
x [HsTupArg GhcTc]
tup_args1 Boxity
boxity) }
| Bool
otherwise
=
do { let arity :: Int
arity = [HsTupArg GhcRn] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsTupArg 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 }
; [HsTupArg GhcTc]
tup_args1 <- [HsTupArg GhcRn] -> [TcSigmaType] -> TcM [HsTupArg GhcTc]
tcTupArgs [HsTupArg GhcRn]
tup_args [TcSigmaType]
arg_tys
; let expr' :: HsExpr GhcTc
expr' = XExplicitTuple GhcTc -> [HsTupArg GhcTc] -> Boxity -> HsExpr GhcTc
forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcRn
XExplicitTuple GhcTc
x [HsTupArg GhcTc]
tup_args1 Boxity
boxity
missing_tys :: [Scaled TcSigmaType]
missing_tys = [TcSigmaType -> TcSigmaType -> Scaled TcSigmaType
forall a. TcSigmaType -> a -> Scaled a
Scaled TcSigmaType
mult TcSigmaType
ty | (Missing (Scaled mult _), TcSigmaType
ty) <- [HsTupArg GhcTc]
-> [TcSigmaType] -> [(HsTupArg GhcTc, TcSigmaType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [HsTupArg 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
; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
LHsExpr GhcTc
expr' ) }
tcExpr (HsLet XLet GhcRn
x HsLocalBinds GhcRn
binds LHsExpr GhcRn
expr) ExpSigmaType
res_ty
= do { (HsLocalBinds GhcTc
binds', GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
expr') <- HsLocalBinds GhcRn
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcM
(HsLocalBinds GhcTc,
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall thing.
HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcM
(HsLocalBinds GhcTc,
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcM
(HsLocalBinds GhcTc,
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
expr ExpSigmaType
res_ty
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XLet GhcTc -> HsLocalBinds GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XLet p -> HsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet XLet GhcRn
XLet GhcTc
x HsLocalBinds GhcTc
binds' GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
LHsExpr GhcTc
expr') }
tcExpr (HsCase XCase GhcRn
x LHsExpr GhcRn
scrut MatchGroup GhcRn (LHsExpr GhcRn)
matches) ExpSigmaType
res_ty
= do {
TcSigmaType
mult <- TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
multiplicityTy
; (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
scrut', TcSigmaType
scrut_ty) <- TcSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
mult (TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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 (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
matches' <- TcMatchCtxt HsExpr
-> Scaled TcSigmaType
-> MatchGroup GhcRn (LocatedA (HsExpr GhcRn))
-> ExpSigmaType
-> TcM
(MatchGroup
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
forall (body :: * -> *).
AnnoBody body =>
TcMatchCtxt body
-> Scaled TcSigmaType
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> ExpSigmaType
-> TcM (MatchGroup GhcTc (LocatedA (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 (LocatedA (HsExpr GhcRn))
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 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
LHsExpr GhcTc
scrut' MatchGroup
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
MatchGroup GhcTc (LHsExpr GhcTc)
matches') }
where
match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext GhcRn
-> (LocatedA (body GhcRn)
-> ExpSigmaType -> TcM (LocatedA (body GhcTc)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
forall p. HsMatchContext p
CaseAlt,
mc_body :: LocatedA (HsExpr GhcRn)
-> ExpSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
mc_body = LocatedA (HsExpr GhcRn)
-> ExpSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
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 { GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
pred' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
pred TcSigmaType
boolTy
; (UsageEnv
u1,GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
b1') <- TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcM
(UsageEnv,
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcM
(UsageEnv,
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcM
(UsageEnv,
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
b1 ExpSigmaType
res_ty
; (UsageEnv
u2,GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
b2') <- TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcM
(UsageEnv,
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcM
(UsageEnv,
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcM
(UsageEnv,
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcMonoExpr 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 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
LHsExpr GhcTc
pred' GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
LHsExpr GhcTc
b1' GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
LHsExpr GhcTc
b2') }
tcExpr (HsMultiIf XMultiIf GhcRn
_ [LGRHS GhcRn (LHsExpr GhcRn)]
alts) ExpSigmaType
res_ty
= do { [Located
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
alts' <- (Located (GRHS GhcRn (LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Located
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))))
-> [Located (GRHS GhcRn (LocatedA (HsExpr GhcRn)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[Located
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((GRHS GhcRn (LocatedA (HsExpr GhcRn))
-> TcM
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
-> Located (GRHS GhcRn (LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Located
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM ((GRHS GhcRn (LocatedA (HsExpr GhcRn))
-> TcM
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
-> Located (GRHS GhcRn (LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Located
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))))
-> (GRHS GhcRn (LocatedA (HsExpr GhcRn))
-> TcM
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
-> Located (GRHS GhcRn (LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Located
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
forall a b. (a -> b) -> a -> b
$ TcMatchCtxt HsExpr
-> ExpSigmaType
-> GRHS GhcRn (LocatedA (HsExpr GhcRn))
-> TcM
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
forall (body :: * -> *).
TcMatchCtxt body
-> ExpSigmaType
-> GRHS GhcRn (LocatedA (body GhcRn))
-> TcM (GRHS GhcTc (LocatedA (body GhcTc)))
tcGRHS TcMatchCtxt HsExpr
match_ctxt ExpSigmaType
res_ty) [Located (GRHS GhcRn (LocatedA (HsExpr GhcRn)))]
[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 -> [LGRHS GhcTc (LHsExpr GhcTc)] -> HsExpr GhcTc
forall p. XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p
HsMultiIf TcSigmaType
XMultiIf GhcTc
res_ty [Located
(GRHS
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
[LGRHS GhcTc (LHsExpr GhcTc)]
alts') }
where match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext GhcRn
-> (LocatedA (body GhcRn)
-> ExpSigmaType -> TcM (LocatedA (body GhcTc)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
forall p. HsMatchContext p
IfAlt, mc_body :: LocatedA (HsExpr GhcRn)
-> ExpSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
mc_body = LocatedA (HsExpr GhcRn)
-> ExpSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcBody }
tcExpr (HsDo XDo GhcRn
_ HsStmtContext (HsDoRn GhcRn)
do_or_lc XRec GhcRn [ExprLStmt GhcRn]
stmts) ExpSigmaType
res_ty
= HsStmtContext GhcRn
-> LocatedL [ExprLStmt GhcRn] -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcDoStmts HsStmtContext GhcRn
HsStmtContext (HsDoRn GhcRn)
do_or_lc LocatedL [ExprLStmt GhcRn]
XRec GhcRn [ExprLStmt GhcRn]
stmts ExpSigmaType
res_ty
tcExpr (HsProc XProc GhcRn
x LPat GhcRn
pat LHsCmdTop GhcRn
cmd) ExpSigmaType
res_ty
= do { (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
pat', GenLocated SrcSpan (HsCmdTop 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 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcTc)
LPat GhcTc
pat' GenLocated SrcSpan (HsCmdTop GhcTc)
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
; (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
expr', WantedConstraints
lie) <- TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcM
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcM
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
WantedConstraints))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcM
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
WantedConstraints)
forall a b. (a -> b) -> a -> b
$
SDoc
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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 (LocatedA (HsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedA (HsExpr GhcRn)
LHsExpr GhcRn
expr)
) (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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 EpAnnCO
XApp GhcTc
noComments
(SrcSpanAnn' (EpAnn AnnListItem)
-> HsExpr GhcTc
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnn' (EpAnn AnnListItem)
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (HsExpr GhcTc
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> HsExpr GhcTc
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap HsExpr GhcTc
fromStaticPtr)
(SrcSpanAnn' (EpAnn AnnListItem)
-> HsExpr GhcTc
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnn' (EpAnn AnnListItem)
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (XStatic GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XStatic p -> LHsExpr p -> HsExpr p
HsStatic XStatic GhcRn
XStatic GhcTc
fvs GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
LHsExpr GhcTc
expr'))
}
tcExpr expr :: HsExpr GhcRn
expr@(RecordCon { rcon_con :: forall p. HsExpr p -> XRec p (ConLikeP p)
rcon_con = L loc 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
con_name
; (HsExpr GhcTc
con_expr, TcSigmaType
con_sigma) <- Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId Name
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
; Bool -> SDoc -> TcRn ()
checkTc (ConLike -> Bool
conLikeHasBuilder ConLike
con_like) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Name -> SDoc
forall a. Outputable a => a -> SDoc
nonBidirectionalErr (ConLike -> Name
conLikeName ConLike
con_like)
; HsRecFields
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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 :: HsExpr GhcTc
rcon_tc = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
con_wrap HsExpr GhcTc
con_expr
expr' :: HsExpr GhcTc
expr' = RecordCon :: forall p.
XRecordCon p -> XRec p (ConLikeP p) -> HsRecordBinds p -> HsExpr p
RecordCon { rcon_ext :: XRecordCon GhcTc
rcon_ext = HsExpr GhcTc
XRecordCon GhcTc
rcon_tc
, rcon_con :: XRec GhcTc (ConLikeP GhcTc)
rcon_con = SrcSpanAnnN -> ConLike -> GenLocated SrcSpanAnnN ConLike
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc ConLike
con_like
, rcon_flds :: HsRecordBinds GhcTc
rcon_flds = HsRecFields
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
HsRecordBinds GhcTc
rbinds' }
; HsExpr GhcTc
ret <- HsExpr GhcRn
-> HsExpr GhcTc
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' TcSigmaType
actual_res_ty ExpSigmaType
res_ty
; ConLike -> HsRecordBinds GhcRn -> [Scaled TcSigmaType] -> TcRn ()
checkMissingFields ConLike
con_like HsRecordBinds GhcRn
rbinds [Scaled TcSigmaType]
arg_tys
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
ret }
where
orig :: CtOrigin
orig = Name -> CtOrigin
OccurrenceOf Name
con_name
tcExpr expr :: HsExpr GhcRn
expr@(RecordUpd { rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr = LHsExpr GhcRn
record_expr, rupd_flds :: forall p. HsExpr p -> Either [LHsRecUpdField p] [LHsRecUpdProj p]
rupd_flds = Left [LHsRecUpdField GhcRn]
rbnds }) ExpSigmaType
res_ty
= Bool -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a. HasCallStack => Bool -> a -> a
assert ([GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
-> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
[LHsRecUpdField GhcRn]
rbnds) (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
do {
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
record_expr', TcSigmaType
record_rho) <- TcSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
Many (TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc),
TcSigmaType)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
tcInferRho LHsExpr GhcRn
record_expr
; [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
rbinds <- LHsExpr GhcRn
-> TcSigmaType
-> [LHsRecUpdField GhcRn]
-> ExpSigmaType
-> TcM
[LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds LHsExpr GhcRn
record_expr TcSigmaType
record_rho [LHsRecUpdField GhcRn]
rbnds ExpSigmaType
res_ty
; let upd_flds :: [AmbiguousFieldOcc GhcTc]
upd_flds = (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> AmbiguousFieldOcc GhcTc)
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
-> [AmbiguousFieldOcc GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
-> AmbiguousFieldOcc GhcTc
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
-> AmbiguousFieldOcc GhcTc)
-> (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> AmbiguousFieldOcc GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS (HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
-> (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc) [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr 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)
| GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
fld <- [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
rbinds,
let L SrcSpan
loc EvVar
sel_id = HsFieldBind (LAmbiguousFieldOcc GhcTc) (LocatedA (HsExpr GhcRn))
-> GenLocated SrcSpan EvVar
forall arg.
HsFieldBind (LAmbiguousFieldOcc GhcTc) arg
-> GenLocated SrcSpan EvVar
hsRecUpdFieldId (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr 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
; Bool -> TcRn ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ((EvVar -> Bool) -> [EvVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all EvVar -> Bool
isPatSynRecordSelector [EvVar]
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)) ([LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike] -> SDoc
badFieldsUpd [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
[LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds [ConLike]
con_likes)
; let con1 :: ConLike
con1 = Bool -> ([ConLike] -> ConLike) -> [ConLike] -> ConLike
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([ConLike] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConLike]
relevant_cons) ) [ConLike] -> ConLike
forall a. [a] -> a
head [ConLike]
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 = (FieldLabel -> FastString) -> [FieldLabel] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> FastString
flLabel ([FieldLabel] -> [FastString]) -> [FieldLabel] -> [FastString]
forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLabel]
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 -> SDoc -> TcRn ()
checkTc (ConLike -> Bool
conLikeHasBuilder ConLike
con1) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Name -> SDoc
forall a. Outputable a => a -> SDoc
nonBidirectionalErr (ConLike -> Name
conLikeName ConLike
con1)
; 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 SDoc -> TcSigmaType -> TcSigmaType -> TcM TcCoercionR
unifyType (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (LocatedA (HsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedA (HsExpr GhcRn)
LHsExpr GhcRn
record_expr)) TcSigmaType
record_rho TcSigmaType
scrut_ty
; [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
rbinds' <- ConLike
-> [TcSigmaType]
-> [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTc]
tcRecordUpd ConLike
con1 [TcSigmaType]
con1_arg_tys' [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
[LHsFieldBind GhcTc (LAmbiguousFieldOcc 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
-> Either [LHsRecUpdField p] [LHsRecUpdProj 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 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
LHsExpr GhcTc
record_expr'
, rupd_flds :: Either [LHsRecUpdField GhcTc] [LHsRecUpdProj GhcTc]
rupd_flds = [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
-> Either
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldLabelStrings GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
forall a b. a -> Either a b
Left [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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 (RecordUpd {}) ExpSigmaType
_ = String -> TcM (HsExpr GhcTc)
forall a. String -> a
panic String
"GHC.Tc.Gen.Expr: tcExpr: The impossible happened!"
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 (HsGetField XGetField GhcRn
_ LHsExpr GhcRn
_ XRec GhcRn (DotFieldOcc GhcRn)
_) ExpSigmaType
_ = String -> TcM (HsExpr GhcTc)
forall a. String -> a
panic String
"GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented"
tcExpr (HsProjection XProjection GhcRn
_ [XRec GhcRn (DotFieldOcc GhcRn)]
_) ExpSigmaType
_ = String -> TcM (HsExpr GhcTc)
forall a. String -> a
panic String
"GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented"
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 (HsBracketRn GhcRn)
brack [PendingRnSplice' GhcRn]
ps) ExpSigmaType
res_ty = HsExpr GhcRn
-> HsBracket GhcRn
-> [PendingRnSplice]
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcUntypedBracket HsExpr GhcRn
e HsBracket GhcRn
HsBracket (HsBracketRn GhcRn)
brack [PendingRnSplice]
[PendingRnSplice' GhcRn]
ps ExpSigmaType
res_ty
tcExpr (HsOverLabel {}) ExpSigmaType
ty = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:HsOverLabel" (ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
ty)
tcExpr (SectionL {}) ExpSigmaType
ty = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:SectionL" (ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
ty)
tcExpr (SectionR {}) ExpSigmaType
ty = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:SectionR" (ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
ty)
tcExpr (HsTcBracketOut {}) ExpSigmaType
ty = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:HsTcBracketOut" (ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
ty)
tcExpr (HsTick {}) ExpSigmaType
ty = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:HsTick" (ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
ty)
tcExpr (HsBinTick {}) ExpSigmaType
ty = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcExpr:HsBinTick" (ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
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
; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
expr' <-TcSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
elt_mult (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
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
; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
expr1' <- TcSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
elt_mult (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 TcSigmaType
elt_ty
; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
expr2' <- TcSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
elt_mult (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
LHsExpr GhcTc
expr1' GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
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
; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
expr1' <- TcSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
elt_mult (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 TcSigmaType
elt_ty
; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
expr2' <- TcSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
elt_mult (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
LHsExpr GhcTc
expr1' GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
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
; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
expr1' <- TcSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
elt_mult (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 TcSigmaType
elt_ty
; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
expr2' <- TcSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
elt_mult (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 TcSigmaType
elt_ty
; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
expr3' <- TcSigmaType
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. TcSigmaType -> TcM a -> TcM a
tcScalingUsage TcSigmaType
elt_mult (TcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
LHsExpr GhcTc
expr1' GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
LHsExpr GhcTc
expr2' GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
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') }
tcTupArgs :: [HsTupArg GhcRn] -> [TcSigmaType] -> TcM [HsTupArg GhcTc]
tcTupArgs :: [HsTupArg GhcRn] -> [TcSigmaType] -> TcM [HsTupArg GhcTc]
tcTupArgs [HsTupArg GhcRn]
args [TcSigmaType]
tys
= do Bool -> TcRn ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ([HsTupArg GhcRn] -> [TcSigmaType] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [HsTupArg GhcRn]
args [TcSigmaType]
tys)
Int -> TcRn ()
checkTupSize ([HsTupArg GhcRn] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsTupArg GhcRn]
args)
((HsTupArg GhcRn, TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc))
-> [(HsTupArg GhcRn, TcSigmaType)] -> TcM [HsTupArg GhcTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsTupArg GhcRn, TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
go ([HsTupArg GhcRn]
args [HsTupArg GhcRn]
-> [TcSigmaType] -> [(HsTupArg GhcRn, TcSigmaType)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TcSigmaType]
tys)
where
go :: (HsTupArg GhcRn, TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
go (Missing {}, TcSigmaType
arg_ty) = do { TcSigmaType
mult <- TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
multiplicityTy
; HsTupArg GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XMissing GhcTc -> HsTupArg GhcTc
forall id. XMissing id -> HsTupArg id
Missing (TcSigmaType -> TcSigmaType -> Scaled TcSigmaType
forall a. TcSigmaType -> a -> Scaled a
Scaled TcSigmaType
mult TcSigmaType
arg_ty)) }
go (Present XPresent GhcRn
x LHsExpr GhcRn
expr, TcSigmaType
arg_ty) = do { GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr TcSigmaType
arg_ty
; HsTupArg GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XPresent GhcTc -> LHsExpr GhcTc -> HsTupArg GhcTc
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcRn
XPresent GhcTc
x GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
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, AppCtxt)
-> [HsExprArg 'TcpRn] -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferAppHead (HsExpr GhcRn
op, HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
op Int
0 SrcSpan
noSrcSpan) []
; 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
; Bool -> SDoc -> TcRn ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (case SyntaxOpType
arg_shape of
SynFun {} -> Bool
False;
SyntaxOpType
_ -> Bool
True)
(String -> SDoc
text String
"Too many nested arrows in SyntaxOpType" SDoc -> SDoc -> SDoc
$$
CtOrigin -> SDoc
pprCtOrigin CtOrigin
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 SDoc
-> Int
-> TcSigmaType
-> TcM (HsWrapper, [Scaled TcSigmaType], TcSigmaType)
matchActualFunTysRho SDoc
herald CtOrigin
orig Maybe SDoc
forall a. Maybe a
Nothing
([SyntaxOpType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SyntaxOpType]
arg_shapes) 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) }
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 :: [FieldLabel]
flds = ConLike -> [FieldLabel]
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 | (FieldLabel
fl, Scaled TcSigmaType
ty) <- [FieldLabel]
-> [Scaled TcSigmaType] -> [(FieldLabel, Scaled TcSigmaType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FieldLabel]
flds [Scaled TcSigmaType]
arg_tys
, Bool -> Bool
not (FieldLabel -> FastString
flLabel FieldLabel
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 ]
disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType
-> [LHsRecUpdField GhcRn] -> ExpRhoType
-> TcM [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds :: LHsExpr GhcRn
-> TcSigmaType
-> [LHsRecUpdField GhcRn]
-> ExpSigmaType
-> TcM
[LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds LHsExpr GhcRn
record_expr TcSigmaType
record_rho [LHsRecUpdField GhcRn]
rbnds ExpSigmaType
res_ty
= case (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
Name))
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
-> Maybe
[(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
Name)
LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn, Name)
isUnambiguous [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
[LHsRecUpdField GhcRn]
rbnds of
Just [(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
Name)]
rbnds' -> ((GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
Name)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))))
-> [(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
Name)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
Name)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))))
(LHsRecUpdField GhcRn, Name)
-> TcM
(LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector [(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
Name)]
rbnds'
Maybe
[(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
Name)]
Nothing ->
do { FamInstEnvs
fam_inst_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; [(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
[(RecSelParent, GlobalRdrElt)])]
rbnds_with_parents <- IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
[(RecSelParent, GlobalRdrElt)])]
TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
getUpdFieldsParents
; let possible_parents :: [[RecSelParent]]
possible_parents = ((GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
[(RecSelParent, GlobalRdrElt)])
-> [RecSelParent])
-> [(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
[(RecSelParent, GlobalRdrElt)])]
-> [[RecSelParent]]
forall a b. (a -> b) -> [a] -> [b]
map (((RecSelParent, GlobalRdrElt) -> RecSelParent)
-> [(RecSelParent, GlobalRdrElt)] -> [RecSelParent]
forall a b. (a -> b) -> [a] -> [b]
map (RecSelParent, GlobalRdrElt) -> RecSelParent
forall a b. (a, b) -> a
fst ([(RecSelParent, GlobalRdrElt)] -> [RecSelParent])
-> ((GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
[(RecSelParent, GlobalRdrElt)])
-> [(RecSelParent, GlobalRdrElt)])
-> (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
[(RecSelParent, GlobalRdrElt)])
-> [RecSelParent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
[(RecSelParent, GlobalRdrElt)])
-> [(RecSelParent, GlobalRdrElt)]
forall a b. (a, b) -> b
snd) [(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
[(RecSelParent, GlobalRdrElt)])]
rbnds_with_parents
; RecSelParent
p <- FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
identifyParent FamInstEnvs
fam_inst_envs [[RecSelParent]]
possible_parents
; IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
forall r. TcM r -> TcM r
checkNoErrs (IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))])
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
forall a b. (a -> b) -> a -> b
$ ((GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
[(RecSelParent, GlobalRdrElt)])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))))
-> [(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
[(RecSelParent, GlobalRdrElt)])]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> TcM
(LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
pickParent RecSelParent
p) [(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr 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 (HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcRn)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
LHsRecUpdField GhcRn
x)) of
Unambiguous XUnambiguous GhcRn
sel_name LocatedN RdrName
_ -> (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
Name)
-> Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
Name)
forall a. a -> Maybe a
Just (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
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)]]
-> [(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
[(RecSelParent, GlobalRdrElt)])])
-> IOEnv (Env TcGblEnv TcLclEnv) [[(RecSelParent, GlobalRdrElt)]]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
[(RecSelParent, GlobalRdrElt)])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
-> [[(RecSelParent, GlobalRdrElt)]]
-> [(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
[(RecSelParent, GlobalRdrElt)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
[LHsRecUpdField GhcRn]
rbnds) (IOEnv (Env TcGblEnv TcLclEnv) [[(RecSelParent, GlobalRdrElt)]]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
[(RecSelParent, GlobalRdrElt)])])
-> IOEnv (Env TcGblEnv TcLclEnv) [[(RecSelParent, GlobalRdrElt)]]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))),
[(RecSelParent, GlobalRdrElt)])]
forall a b. (a -> b) -> a -> b
$ (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> IOEnv (Env TcGblEnv TcLclEnv) [(RecSelParent, GlobalRdrElt)])
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
-> IOEnv (Env TcGblEnv TcLclEnv) [[(RecSelParent, GlobalRdrElt)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
(Bool
-> RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) [(RecSelParent, GlobalRdrElt)]
lookupParents Bool
False (RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) [(RecSelParent, GlobalRdrElt)])
-> (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> RdrName)
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> IOEnv (Env TcGblEnv TcLclEnv) [(RecSelParent, GlobalRdrElt)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan RdrName -> RdrName)
-> (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> GenLocated SrcSpan RdrName)
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
-> GenLocated SrcSpan RdrName
forall (p :: Pass).
HsRecUpdField (GhcPass p) -> GenLocated SrcSpan RdrName
hsRecUpdFieldRdr (HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
-> GenLocated SrcSpan RdrName)
-> (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> GenLocated SrcSpan RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc)
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
[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 -> TcM 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 ->
do { TyCon -> TcRn ()
reportAmbiguousField TyCon
p
; RecSelParent -> TcM RecSelParent
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> RecSelParent
RecSelData TyCon
p) }
| Just {} <- HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (LocatedA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LocatedA (HsExpr GhcRn)
LHsExpr GhcRn
record_expr)
, Just TyCon
tc <- FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs TcSigmaType
record_rho
-> do { TyCon -> TcRn ()
reportAmbiguousField TyCon
tc
; RecSelParent -> TcM RecSelParent
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> RecSelParent
RecSelData TyCon
tc) }
[RecSelParent]
_ -> SDoc -> TcM RecSelParent
forall a. SDoc -> TcM a
failWithTc SDoc
badOverloadedUpdate
pickParent :: RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> TcM (LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
pickParent :: RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> TcM
(LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
pickParent RecSelParent
p (LHsRecUpdField GhcRn
upd, [(RecSelParent, GlobalRdrElt)]
xs)
= case RecSelParent
-> [(RecSelParent, GlobalRdrElt)] -> Maybe GlobalRdrElt
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup RecSelParent
p [(RecSelParent, GlobalRdrElt)]
xs of
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
_ = HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcRn)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
LHsRecUpdField GhcRn
upd)
SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Bool -> GlobalRdrElt -> TcRn ()
addUsedGRE Bool
True GlobalRdrElt
gre
; (LHsRecUpdField GhcRn, Name)
-> TcM
(LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector (LHsRecUpdField GhcRn
upd, GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre) }
Maybe GlobalRdrElt
Nothing -> do { SDoc -> TcRn ()
addErrTc (RecSelParent -> RdrName -> SDoc
fieldNotInType RecSelParent
p
(GenLocated SrcSpan RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc (HsRecUpdField GhcRn -> GenLocated SrcSpan RdrName
forall (p :: Pass).
HsRecUpdField (GhcPass p) -> GenLocated SrcSpan RdrName
hsRecUpdFieldRdr (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
LHsRecUpdField GhcRn
upd))))
; (LHsRecUpdField GhcRn, Name)
-> TcM
(LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector (LHsRecUpdField GhcRn
upd, GlobalRdrElt -> Name
greMangledName ((RecSelParent, GlobalRdrElt) -> GlobalRdrElt
forall a b. (a, b) -> b
snd ([(RecSelParent, GlobalRdrElt)] -> (RecSelParent, GlobalRdrElt)
forall a. [a] -> a
head [(RecSelParent, GlobalRdrElt)]
xs))) }
lookupSelector :: (LHsRecUpdField GhcRn, Name)
-> TcM (LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector :: (LHsRecUpdField GhcRn, Name)
-> TcM
(LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector (L l upd, Name
n)
= do { EvVar
i <- Name -> TcM EvVar
tcLookupId Name
n
; let L SrcSpan
loc AmbiguousFieldOcc GhcRn
af = HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcRn)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
upd
lbl :: RdrName
lbl = AmbiguousFieldOcc GhcRn -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc AmbiguousFieldOcc GhcRn
af
; GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))))
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))))
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnn' (EpAnn AnnListItem)
-> HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
l HsFieldBind :: forall lhs rhs.
XHsFieldBind lhs -> lhs -> rhs -> Bool -> HsFieldBind lhs rhs
HsFieldBind
{ hfbAnn :: XHsFieldBind (GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
hfbAnn = HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
-> XHsFieldBind (GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
forall lhs rhs. HsFieldBind lhs rhs -> XHsFieldBind lhs
hfbAnn HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
upd
, hfbLHS :: GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
hfbLHS
= SrcSpan
-> AmbiguousFieldOcc GhcTc
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XUnambiguous GhcTc -> LocatedN RdrName -> AmbiguousFieldOcc GhcTc
forall pass.
XUnambiguous pass -> LocatedN RdrName -> AmbiguousFieldOcc pass
Unambiguous EvVar
XUnambiguous GhcTc
i (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
lbl))
, hfbRHS :: LocatedA (HsExpr GhcRn)
hfbRHS = HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
-> LocatedA (HsExpr GhcRn)
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
upd
, hfbPun :: Bool
hfbPun = HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
-> Bool
forall lhs rhs. HsFieldBind lhs rhs -> Bool
hfbPun HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
upd
}
}
reportAmbiguousField :: TyCon -> TcM ()
reportAmbiguousField :: TyCon -> TcRn ()
reportAmbiguousField TyCon
parent_type =
SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ WarningFlag -> Bool -> SDoc -> TcRn ()
warnIfFlag WarningFlag
Opt_WarnAmbiguousFields Bool
True (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"The record update" SDoc -> SDoc -> SDoc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
rupd
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"with type" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
parent_type
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is ambiguous."
, String -> SDoc
text String
"This will not be supported by -XDuplicateRecordFields in future releases of GHC."
]
where
rupd :: HsExpr GhcRn
rupd = RecordUpd :: forall p.
XRecordUpd p
-> LHsExpr p
-> Either [LHsRecUpdField p] [LHsRecUpdProj p]
-> HsExpr p
RecordUpd { rupd_expr :: LHsExpr GhcRn
rupd_expr = LHsExpr GhcRn
record_expr, rupd_flds :: Either [LHsRecUpdField GhcRn] [LHsRecUpdProj GhcRn]
rupd_flds = [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
-> Either
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldLabelStrings GhcRn))
(LocatedA (HsExpr GhcRn)))]
forall a b. a -> Either a b
Left [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
[LHsRecUpdField GhcRn]
rbnds, rupd_ext :: XRecordUpd GhcRn
rupd_ext = NoExtField
XRecordUpd GhcRn
noExtField }
loc :: SrcSpan
loc = GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA ([GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
forall a. [a] -> a
head [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
[LHsRecUpdField GhcRn]
rbnds)
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
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))]
mb_binds <- (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcRn)) (LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))))
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcRn)) (LocatedA (HsExpr GhcRn)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcRn)) (LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))))
LHsRecField GhcRn (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
do_bind [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcRn)) (LocatedA (HsExpr GhcRn)))]
[LHsRecField GhcRn (LHsExpr GhcRn)]
rbinds
; HsRecFields
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsRecFields
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsRecField
GhcTc
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))]
-> Maybe (Located Int)
-> HsRecFields
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields ([Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))]
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
forall a. [Maybe a] -> [a]
catMaybes [Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))]
mb_binds) Maybe (Located Int)
dd) }
where
fields :: [Name]
fields = (FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector ([FieldLabel] -> [Name]) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con_like
flds_w_tys :: [(Name, 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)
-> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
do_bind (L l fld@(HsFieldBind { hfbLHS = f
, hfbRHS = rhs }))
= do { Maybe
(GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
mb <- ConLike
-> [(Name, TcSigmaType)]
-> LFieldOcc GhcRn
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, TcSigmaType)]
flds_w_tys GenLocated SrcSpan (FieldOcc GhcRn)
LFieldOcc GhcRn
f LocatedA (HsExpr GhcRn)
LHsExpr GhcRn
rhs
; case Maybe
(GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
mb of
Maybe
(GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
Nothing -> Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
forall a. Maybe a
Nothing
Just (GenLocated SrcSpan (FieldOcc GhcTc)
f', GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
rhs') -> Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))))
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
forall a. a -> Maybe a
Just (SrcSpanAnn' (EpAnn AnnListItem)
-> HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
l (HsFieldBind :: forall lhs rhs.
XHsFieldBind lhs -> lhs -> rhs -> Bool -> HsFieldBind lhs rhs
HsFieldBind
{ hfbAnn :: XHsFieldBind (GenLocated SrcSpan (FieldOcc GhcTc))
hfbAnn = HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcRn)) (LocatedA (HsExpr GhcRn))
-> XHsFieldBind (GenLocated SrcSpan (FieldOcc GhcRn))
forall lhs rhs. HsFieldBind lhs rhs -> XHsFieldBind lhs
hfbAnn HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcRn)) (LocatedA (HsExpr GhcRn))
fld
, hfbLHS :: GenLocated SrcSpan (FieldOcc GhcTc)
hfbLHS = GenLocated SrcSpan (FieldOcc GhcTc)
f'
, hfbRHS :: GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
hfbRHS = GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
rhs'
, hfbPun :: Bool
hfbPun = HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcRn)) (LocatedA (HsExpr GhcRn))
-> Bool
forall lhs rhs. HsFieldBind lhs rhs -> Bool
hfbPun HsFieldBind
(GenLocated SrcSpan (FieldOcc GhcRn)) (LocatedA (HsExpr GhcRn))
fld}))) }
tcRecordUpd
:: ConLike
-> [TcType]
-> [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTc]
tcRecordUpd :: ConLike
-> [TcSigmaType]
-> [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTc]
tcRecordUpd ConLike
con_like [TcSigmaType]
arg_tys [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds = ([Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))]
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))])
-> IOEnv
(Env TcGblEnv TcLclEnv)
[Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))]
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
forall a. [Maybe a] -> [a]
catMaybes (IOEnv
(Env TcGblEnv TcLclEnv)
[Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))])
-> IOEnv
(Env TcGblEnv TcLclEnv)
[Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))]
forall a b. (a -> b) -> a -> b
$ (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))))
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))))
LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecUpdField GhcTc))
do_bind [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
[LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds
where
fields :: [Name]
fields = (FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector ([FieldLabel] -> [Name]) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con_like
flds_w_tys :: [(Name, 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 :: LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecUpdField GhcTc))
do_bind :: LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecUpdField GhcTc))
do_bind (L l fld@(HsFieldBind { hfbLHS = L loc af
, hfbRHS = 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 :: GenLocated SrcSpan (FieldOcc GhcRn)
f = SrcSpan -> FieldOcc GhcRn -> GenLocated SrcSpan (FieldOcc GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XCFieldOcc GhcRn -> XRec GhcRn RdrName -> FieldOcc GhcRn
forall pass. XCFieldOcc pass -> XRec pass RdrName -> FieldOcc pass
FieldOcc (EvVar -> Name
idName EvVar
sel_id) (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
lbl))
; Maybe
(GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
mb <- ConLike
-> [(Name, TcSigmaType)]
-> LFieldOcc GhcRn
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, TcSigmaType)]
flds_w_tys GenLocated SrcSpan (FieldOcc GhcRn)
LFieldOcc GhcRn
f LocatedA (HsExpr GhcRn)
LHsExpr GhcRn
rhs
; case Maybe
(GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
mb of
Maybe
(GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
Nothing -> Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
forall a. Maybe a
Nothing
Just (GenLocated SrcSpan (FieldOcc GhcTc)
f', GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
rhs') ->
Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))))
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
forall a. a -> Maybe a
Just
(SrcSpanAnn' (EpAnn AnnListItem)
-> HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
l (HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))
fld { hfbLHS :: GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
hfbLHS
= SrcSpan
-> AmbiguousFieldOcc GhcTc
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XUnambiguous GhcTc -> LocatedN RdrName -> AmbiguousFieldOcc GhcTc
forall pass.
XUnambiguous pass -> LocatedN RdrName -> AmbiguousFieldOcc pass
Unambiguous
(FieldOcc GhcTc -> XCFieldOcc GhcTc
forall pass. FieldOcc pass -> XCFieldOcc pass
foExt (GenLocated SrcSpan (FieldOcc GhcTc) -> FieldOcc GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan (FieldOcc GhcTc)
f'))
(SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
lbl))
, hfbRHS :: GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
hfbRHS = GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
rhs' }))) }
tcRecordField :: ConLike -> Assoc Name Type
-> LFieldOcc GhcRn -> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField :: ConLike
-> [(Name, TcSigmaType)]
-> LFieldOcc GhcRn
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, TcSigmaType)]
flds_w_tys (L loc (FieldOcc sel_name 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
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (FastString -> SDoc
fieldCtxt FastString
field_lbl) (IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$
do { GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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
(GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return ((GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> Maybe
(GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. a -> Maybe a
Just (SrcSpan -> FieldOcc GhcTc -> GenLocated SrcSpan (FieldOcc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XCFieldOcc GhcTc -> XRec GhcTc RdrName -> FieldOcc GhcTc
forall pass. XCFieldOcc pass -> XRec pass RdrName -> FieldOcc pass
FieldOcc EvVar
XCFieldOcc GhcTc
field_id XRec GhcRn RdrName
XRec GhcTc RdrName
lbl), GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
rhs')) }
| Bool
otherwise
= do { SDoc -> TcRn ()
addErrTc (ConLike -> FastString -> SDoc
badFieldCon ConLike
con_like FastString
field_lbl)
; Maybe
(GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
(GenLocated SrcSpan (FieldOcc GhcTc),
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr 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 (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
XRec GhcRn RdrName
lbl)
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM ()
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcSigmaType] -> TcRn ()
checkMissingFields ConLike
con_like HsRecordBinds GhcRn
rbinds [Scaled TcSigmaType]
arg_tys
| [FieldLabel] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
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, TcSigmaType)] -> SDoc
missingStrictFields ConLike
con_like [])
else do
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([HsImplBang] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [HsImplBang]
field_strs Bool -> Bool -> Bool
&& [FieldLabel] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
field_labels)
(DiagnosticReason -> Bool -> SDoc -> TcRn ()
diagnosticTc (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnMissingFields) Bool
True
(ConLike -> [(FastString, TcSigmaType)] -> SDoc
missingFields ConLike
con_like []))
| Bool
otherwise = do
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(FastString, TcSigmaType)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FastString, TcSigmaType)]
missing_s_fields) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
[(FastString, TcSigmaType)]
fs <- [(FastString, TcSigmaType)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(FastString, TcSigmaType)]
forall (t :: * -> *) a.
Traversable t =>
t (a, TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (t (a, TcSigmaType))
zonk_fields [(FastString, TcSigmaType)]
missing_s_fields
SDoc -> TcRn ()
addErrTc (ConLike -> [(FastString, TcSigmaType)] -> SDoc
missingStrictFields ConLike
con_like [(FastString, TcSigmaType)]
fs)
Bool
warn <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnMissingFields
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
warn Bool -> Bool -> Bool
&& [(FastString, TcSigmaType)] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [(FastString, TcSigmaType)]
missing_ns_fields) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
[(FastString, TcSigmaType)]
fs <- [(FastString, TcSigmaType)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(FastString, TcSigmaType)]
forall (t :: * -> *) a.
Traversable t =>
t (a, TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (t (a, TcSigmaType))
zonk_fields [(FastString, TcSigmaType)]
missing_ns_fields
DiagnosticReason -> Bool -> SDoc -> TcRn ()
diagnosticTc (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnMissingFields) Bool
True
(ConLike -> [(FastString, TcSigmaType)] -> SDoc
missingFields ConLike
con_like [(FastString, TcSigmaType)]
fs)
where
zonk_fields :: t (a, TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (t (a, TcSigmaType))
zonk_fields t (a, TcSigmaType)
fs = t (a, TcSigmaType)
-> ((a, TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (a, TcSigmaType))
-> IOEnv (Env TcGblEnv TcLclEnv) (t (a, TcSigmaType))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM t (a, TcSigmaType)
fs (((a, TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (a, TcSigmaType))
-> IOEnv (Env TcGblEnv TcLclEnv) (t (a, TcSigmaType)))
-> ((a, TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (a, TcSigmaType))
-> IOEnv (Env TcGblEnv TcLclEnv) (t (a, TcSigmaType))
forall a b. (a -> b) -> a -> b
$ \(a
str,TcSigmaType
ty) -> do
TcSigmaType
ty' <- TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
ty
(a, TcSigmaType) -> IOEnv (Env TcGblEnv TcLclEnv) (a, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
str,TcSigmaType
ty')
missing_s_fields :: [(FastString, TcSigmaType)]
missing_s_fields
= [ (FieldLabel -> FastString
flLabel FieldLabel
fl, Scaled TcSigmaType -> TcSigmaType
forall a. Scaled a -> a
scaledThing Scaled TcSigmaType
ty) | (FieldLabel
fl,HsImplBang
str,Scaled TcSigmaType
ty) <- [(FieldLabel, HsImplBang, Scaled TcSigmaType)]
field_info,
HsImplBang -> Bool
isBanged HsImplBang
str,
Bool -> Bool
not (FieldLabel
fl FieldLabel -> [Name] -> Bool
forall (t :: * -> *). Foldable t => FieldLabel -> t Name -> Bool
`elemField` [Name]
[XCFieldOcc GhcRn]
field_names_used)
]
missing_ns_fields :: [(FastString, TcSigmaType)]
missing_ns_fields
= [ (FieldLabel -> FastString
flLabel FieldLabel
fl, Scaled TcSigmaType -> TcSigmaType
forall a. Scaled a -> a
scaledThing Scaled TcSigmaType
ty) | (FieldLabel
fl,HsImplBang
str,Scaled TcSigmaType
ty) <- [(FieldLabel, HsImplBang, Scaled TcSigmaType)]
field_info,
Bool -> Bool
not (HsImplBang -> Bool
isBanged HsImplBang
str),
Bool -> Bool
not (FieldLabel
fl FieldLabel -> [Name] -> Bool
forall (t :: * -> *). Foldable t => FieldLabel -> t Name -> Bool
`elemField` [Name]
[XCFieldOcc GhcRn]
field_names_used)
]
field_names_used :: [XCFieldOcc GhcRn]
field_names_used = HsRecFields GhcRn (LocatedA (HsExpr GhcRn)) -> [XCFieldOcc GhcRn]
forall p arg. UnXRec p => HsRecFields p arg -> [XCFieldOcc p]
hsRecFields HsRecFields GhcRn (LocatedA (HsExpr GhcRn))
HsRecordBinds GhcRn
rbinds
field_labels :: [FieldLabel]
field_labels = ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con_like
field_info :: [(FieldLabel, HsImplBang, Scaled TcSigmaType)]
field_info = [FieldLabel]
-> [HsImplBang]
-> [Scaled TcSigmaType]
-> [(FieldLabel, HsImplBang, Scaled TcSigmaType)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [FieldLabel]
field_labels [HsImplBang]
field_strs [Scaled TcSigmaType]
arg_tys
field_strs :: [HsImplBang]
field_strs = ConLike -> [HsImplBang]
conLikeImplBangs ConLike
con_like
FieldLabel
fl elemField :: FieldLabel -> t Name -> Bool
`elemField` t Name
flds = (Name -> Bool) -> t Name -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ Name
fl' -> FieldLabel -> Name
flSelector FieldLabel
fl Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
fl') t Name
flds
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
<+> String -> SDoc
text String
"field of a record"
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
:: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike]
-> SDoc
badFieldsUpd :: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike] -> SDoc
badFieldsUpd [LHsFieldBind GhcTc (LAmbiguousFieldOcc 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 = Bool
-> ((FastString, [Bool]) -> FastString)
-> (FastString, [Bool])
-> FastString
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([(FastString, [Bool])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FastString, [Bool])]
members) ) (FastString, [Bool]) -> FastString
forall a b. (a, b) -> a
fst ([(FastString, [Bool])] -> (FastString, [Bool])
forall a. [a] -> a
head [(FastString, [Bool])]
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, (UniqSet FastString -> Bool) -> [UniqSet FastString] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (FastString
fld FastString -> UniqSet FastString -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet`) [UniqSet FastString]
fieldLabelSets)) ([FastString] -> [(FastString, [Bool])])
-> [FastString] -> [(FastString, [Bool])]
forall a b. (a -> b) -> a -> b
$
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> FastString)
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
-> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> FastString
occNameFS (OccName -> FastString)
-> (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> OccName)
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> OccName)
-> (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> RdrName)
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AmbiguousFieldOcc GhcTc -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc (AmbiguousFieldOcc GhcTc -> RdrName)
-> (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> AmbiguousFieldOcc GhcTc)
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
-> AmbiguousFieldOcc GhcTc
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
-> AmbiguousFieldOcc GhcTc)
-> (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> AmbiguousFieldOcc GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS (HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
-> (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))
-> HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc) [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
(LocatedA (HsExpr GhcRn)))]
[LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds
fieldLabelSets :: [UniqSet FieldLabelString]
fieldLabelSets :: [UniqSet FastString]
fieldLabelSets = (ConLike -> UniqSet FastString)
-> [ConLike] -> [UniqSet FastString]
forall a b. (a -> b) -> [a] -> [b]
map ([FastString] -> UniqSet FastString
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet ([FastString] -> UniqSet FastString)
-> (ConLike -> [FastString]) -> ConLike -> UniqSet FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldLabel -> FastString) -> [FieldLabel] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> FastString
flLabel ([FieldLabel] -> [FastString])
-> (ConLike -> [FieldLabel]) -> ConLike -> [FastString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConLike -> [FieldLabel]
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
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]
_)
= String -> SDoc
text 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
<> SDoc
colon
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
<> SDoc
colon
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, TcType)] -> SDoc
missingStrictFields :: ConLike -> [(FastString, TcSigmaType)] -> SDoc
missingStrictFields ConLike
con [(FastString, TcSigmaType)]
fields
= [SDoc] -> SDoc
vcat [SDoc
header, Int -> SDoc -> SDoc
nest Int
2 SDoc
rest]
where
pprField :: (a, a) -> SDoc
pprField (a
f,a
ty) = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
f SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
ty
rest :: SDoc
rest | [(FastString, TcSigmaType)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FastString, TcSigmaType)]
fields = SDoc
Outputable.empty
| Bool
otherwise = [SDoc] -> SDoc
vcat (((FastString, TcSigmaType) -> SDoc)
-> [(FastString, TcSigmaType)] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FastString, TcSigmaType) -> SDoc
forall a a. (Outputable a, Outputable a) => (a, a) -> SDoc
pprField [(FastString, TcSigmaType)]
fields)
header :: SDoc
header = String -> SDoc
text String
"Constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
con) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"does not have the required strict field(s)" SDoc -> SDoc -> SDoc
<>
if [(FastString, TcSigmaType)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FastString, TcSigmaType)]
fields then SDoc
Outputable.empty else SDoc
colon
missingFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc
missingFields :: ConLike -> [(FastString, TcSigmaType)] -> SDoc
missingFields ConLike
con [(FastString, TcSigmaType)]
fields
= [SDoc] -> SDoc
vcat [SDoc
header, Int -> SDoc -> SDoc
nest Int
2 SDoc
rest]
where
pprField :: (a, a) -> SDoc
pprField (a
f,a
ty) = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
f SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
ty
rest :: SDoc
rest | [(FastString, TcSigmaType)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FastString, TcSigmaType)]
fields = SDoc
Outputable.empty
| Bool
otherwise = [SDoc] -> SDoc
vcat (((FastString, TcSigmaType) -> SDoc)
-> [(FastString, TcSigmaType)] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FastString, TcSigmaType) -> SDoc
forall a a. (Outputable a, Outputable a) => (a, a) -> SDoc
pprField [(FastString, TcSigmaType)]
fields)
header :: SDoc
header = String -> SDoc
text String
"Fields of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
con) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"not initialised" SDoc -> SDoc -> SDoc
<>
if [(FastString, TcSigmaType)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FastString, TcSigmaType)]
fields then SDoc
Outputable.empty else SDoc
colon
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 = (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
-> [GenLocated SrcSpan (AmbiguousFieldOcc GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcRn)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS (HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
-> (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))
-> HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc) [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(HsFieldBind
(GenLocated SrcSpan (AmbiguousFieldOcc GhcRn))
(LocatedA (HsExpr GhcRn)))]
[LHsRecUpdField GhcRn]
rbinds
badOverloadedUpdate :: SDoc
badOverloadedUpdate :: SDoc
badOverloadedUpdate = String -> SDoc
text String
"Record update is ambiguous, and requires a type signature"
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 =
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