{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {- % (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} module GHC.Tc.Gen.Expr ( tcCheckPolyExpr, tcCheckPolyExprNC, tcCheckMonoExpr, tcCheckMonoExprNC, tcMonoExpr, tcMonoExprNC, tcInferRho, tcInferRhoNC, tcPolyExpr, tcExpr, tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, tcCheckId, ) where import GHC.Prelude import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import {-# SOURCE #-} GHC.Tc.Gen.Splice ( tcTypedSplice, tcTypedBracket, tcUntypedBracket ) import GHC.Hs import GHC.Hs.Syn.Type import GHC.Rename.Utils import GHC.Tc.Utils.Zonk import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Types.Basic import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.Unique.FM import GHC.Types.Unique.Map import GHC.Types.Unique.Set import GHC.Core.Multiplicity import GHC.Core.UsageEnv import GHC.Tc.Errors.Types import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic, hasFixedRuntimeRep ) import GHC.Tc.Utils.Instantiate import GHC.Tc.Gen.App import GHC.Tc.Gen.Head import GHC.Tc.Gen.Bind ( tcLocalBinds ) import GHC.Tc.Instance.Family ( tcGetFamInstEnvs ) import GHC.Core.FamInstEnv ( FamInstEnvs ) import GHC.Rename.Expr ( mkExpandedExpr ) import GHC.Rename.Env ( addUsedGRE, getUpdFieldLbls ) import GHC.Tc.Utils.Env import GHC.Tc.Gen.Arrow import GHC.Tc.Gen.Match import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Core.Class(classTyCon) import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Coercion( mkSymCo ) import GHC.Tc.Types.Evidence import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Builtin.Uniques ( mkBuiltinUnique ) import GHC.Driver.Session import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Data.Bag ( unitBag ) 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 qualified Data.List.NonEmpty as NE {- ************************************************************************ * * \subsection{Main wrappers} * * ************************************************************************ -} tcCheckPolyExpr, tcCheckPolyExprNC :: LHsExpr GhcRn -- Expression to type check -> TcSigmaType -- Expected type (could be a polytype) -> TcM (LHsExpr GhcTc) -- Generalised expr with expected type -- tcCheckPolyExpr is a convenient place (frequent but not too frequent) -- place to add context information. -- The NC version does not do so, usually because the caller wants -- to do so themselves. tcCheckPolyExpr expr res_ty = tcPolyLExpr expr (mkCheckExpType res_ty) tcCheckPolyExprNC expr res_ty = tcPolyLExprNC expr (mkCheckExpType res_ty) -- These versions take an ExpType tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) tcPolyLExpr (L loc expr) res_ty = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad addExprCtxt expr $ -- Note [Error contexts in generated code] do { expr' <- tcPolyExpr expr res_ty ; return (L loc expr') } tcPolyLExprNC (L loc expr) res_ty = setSrcSpanA loc $ do { expr' <- tcPolyExpr expr res_ty ; return (L loc expr') } --------------- tcCheckMonoExpr, tcCheckMonoExprNC :: LHsExpr GhcRn -- Expression to type check -> TcRhoType -- Expected type -- Definitely no foralls at the top -> TcM (LHsExpr GhcTc) tcCheckMonoExpr expr res_ty = tcMonoExpr expr (mkCheckExpType res_ty) tcCheckMonoExprNC expr res_ty = tcMonoExprNC expr (mkCheckExpType res_ty) tcMonoExpr, tcMonoExprNC :: LHsExpr GhcRn -- Expression to type check -> ExpRhoType -- Expected type -- Definitely no foralls at the top -> TcM (LHsExpr GhcTc) tcMonoExpr (L loc expr) res_ty = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad addExprCtxt expr $ -- Note [Error contexts in generated code] do { expr' <- tcExpr expr res_ty ; return (L loc expr') } tcMonoExprNC (L loc expr) res_ty = setSrcSpanA loc $ do { expr' <- tcExpr expr res_ty ; return (L loc expr') } --------------- tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) -- Infer a *rho*-type. The return type is always instantiated. tcInferRho (L loc expr) = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad addExprCtxt expr $ -- Note [Error contexts in generated code] do { (expr', rho) <- tcInfer (tcExpr expr) ; return (L loc expr', rho) } tcInferRhoNC (L loc expr) = setSrcSpanA loc $ do { (expr', rho) <- tcInfer (tcExpr expr) ; return (L loc expr', rho) } {- ********************************************************************* * * tcExpr: the main expression typechecker * * ********************************************************************* -} tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) tcPolyExpr expr res_ty = do { traceTc "tcPolyExpr" (ppr res_ty) ; (wrap, expr') <- tcSkolemiseExpType GenSigCtxt res_ty $ \ res_ty -> tcExpr expr res_ty ; return $ mkHsWrap wrap expr' } tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -- Use tcApp to typecheck applications, which are treated specially -- by Quick Look. Specifically: -- - HsVar lone variables, to ensure that they can get an -- impredicative instantiation (via Quick Look -- driven by res_ty (in checking mode)). -- - HsApp value applications -- - HsAppType type applications -- - ExprWithTySig (e :: type) -- - HsRecSel overloaded record fields -- - HsExpanded renamer expansions -- - HsOpApp operator applications -- - HsOverLit overloaded literals -- These constructors are the union of -- - ones taken apart by GHC.Tc.Gen.Head.splitHsApps -- - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe -- See Note [Application chains and heads] in GHC.Tc.Gen.App tcExpr e@(HsVar {}) res_ty = tcApp e res_ty tcExpr e@(HsApp {}) res_ty = tcApp e res_ty tcExpr e@(OpApp {}) res_ty = tcApp e res_ty tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty tcExpr e@(HsRecSel {}) res_ty = tcApp e res_ty tcExpr e@(XExpr (HsExpanded {})) res_ty = tcApp e res_ty tcExpr e@(HsOverLit _ lit) res_ty = do { mb_res <- tcShortCutLit lit res_ty -- See Note [Short cut for overloaded literals] in GHC.Tc.Utils.Zonk ; case mb_res of Just lit' -> return (HsOverLit noAnn lit') Nothing -> tcApp e res_ty } -- Typecheck an occurrence of an unbound Id -- -- Some of these started life as a true expression hole "_". -- Others might simply be variables that accidentally have no binding site tcExpr (HsUnboundVar _ occ) res_ty = do { ty <- expTypeToType res_ty -- Allow Int# etc (#12531) ; her <- emitNewExprHole occ ty ; tcEmitBindingUsage bottomUE -- Holes fit any usage environment -- (#18491) ; return (HsUnboundVar her occ) } tcExpr e@(HsLit x lit) res_ty = do { let lit_ty = hsLitType lit ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty } tcExpr (HsPar x lpar expr rpar) res_ty = do { expr' <- tcMonoExprNC expr res_ty ; return (HsPar x lpar expr' rpar) } tcExpr (HsPragE x prag expr) res_ty = do { expr' <- tcMonoExpr expr res_ty ; return (HsPragE x (tcExprPrag prag) expr') } tcExpr (NegApp x expr neg_expr) res_ty = do { (expr', neg_expr') <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $ \[arg_ty] [arg_mult] -> tcScalingUsage arg_mult $ tcCheckMonoExpr expr arg_ty ; return (NegApp x expr' neg_expr') } tcExpr e@(HsIPVar _ x) res_ty = do { ip_ty <- newFlexiTyVarTy liftedTypeKind -- Create a unification type variable of kind 'Type'. -- (The type of an implicit parameter must have kind 'Type'.) ; let ip_name = mkStrLitTy (hsIPNameFS x) ; ipClass <- tcLookupClass ipClassName ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty]) ; tcWrapResult e (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLocA ip_var))) ip_ty res_ty } where -- Coerces a dictionary for `IP "x" t` into `t`. fromDict ipClass x ty = mkHsWrap $ mkWpCastR $ unwrapIP $ mkClassPred ipClass [x,ty] origin = IPOccOrigin x tcExpr (HsLam _ match) res_ty = do { (wrap, match') <- tcMatchLambda herald match_ctxt match res_ty ; return (mkHsWrap wrap (HsLam noExtField match')) } where match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } herald = ExpectedFunTyLam match tcExpr e@(HsLamCase x lc_variant matches) res_ty = do { (wrap, matches') <- tcMatchLambda herald match_ctxt matches res_ty ; return (mkHsWrap wrap $ HsLamCase x lc_variant matches') } where match_ctxt = MC { mc_what = LamCaseAlt lc_variant, mc_body = tcBody } herald = ExpectedFunTyLamCase lc_variant e {- ************************************************************************ * * Explicit lists * * ************************************************************************ -} -- Explicit lists [e1,e2,e3] have been expanded already in the renamer -- The expansion includes an ExplicitList, but it is always the built-in -- list type, so that's all we need concern ourselves with here. See -- GHC.Rename.Expr. Note [Handling overloaded and rebindable constructs] tcExpr (ExplicitList _ exprs) res_ty = do { res_ty <- expTypeToType res_ty ; (coi, elt_ty) <- matchExpectedListTy res_ty ; let tc_elt expr = tcCheckPolyExpr expr elt_ty ; exprs' <- mapM tc_elt exprs ; return $ mkHsWrapCo coi $ ExplicitList elt_ty exprs' } tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty | all tupArgPresent tup_args = do { let arity = length tup_args tup_tc = tupleTyCon boxity arity -- NB: tupleTyCon doesn't flatten 1-tuples -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make ; res_ty <- expTypeToType res_ty ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty -- Unboxed tuples have RuntimeRep vars, which we -- don't care about here -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys Boxed -> arg_tys ; tup_args1 <- tcTupArgs tup_args arg_tys' ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) } | otherwise = -- The tup_args are a mixture of Present and Missing (for tuple sections) do { let arity = length tup_args ; arg_tys <- case boxity of { Boxed -> newFlexiTyVarTys arity liftedTypeKind ; Unboxed -> replicateM arity newOpenFlexiTyVarTy } -- Handle tuple sections where ; tup_args1 <- tcTupArgs tup_args arg_tys ; let expr' = ExplicitTuple x tup_args1 boxity missing_tys = [Scaled mult ty | (Missing (Scaled mult _), ty) <- zip tup_args1 arg_tys] -- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make act_res_ty = mkScaledFunTys missing_tys (mkTupleTy1 boxity arg_tys) ; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty) ; tcWrapResultMono expr expr' act_res_ty res_ty } tcExpr (ExplicitSum _ alt arity expr) res_ty = do { let sum_tc = sumTyCon arity ; res_ty <- expTypeToType res_ty ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty ; -- Drop levity vars, we don't care about them here let arg_tys' = drop arity arg_tys arg_ty = arg_tys' `getNth` (alt - 1) ; expr' <- tcCheckPolyExpr expr arg_ty -- Check the whole res_ty, not just the arg_ty, to avoid #20277. -- Example: -- a :: TYPE rep (representation-polymorphic) -- (# 17# | #) :: (# Int# | a #) -- This should cause an error, even though (17# :: Int#) -- is not representation-polymorphic: we don't know how -- wide the concrete representation of the sum type will be. ; hasFixedRuntimeRep_syntactic FRRUnboxedSum res_ty ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } {- ************************************************************************ * * Let, case, if, do * * ************************************************************************ -} tcExpr (HsLet x tkLet binds tkIn expr) res_ty = do { (binds', expr') <- tcLocalBinds binds $ tcMonoExpr expr res_ty ; return (HsLet x tkLet binds' tkIn expr') } tcExpr (HsCase x scrut matches) res_ty = do { -- We used to typecheck the case alternatives first. -- The case patterns tend to give good type info to use -- when typechecking the scrutinee. For example -- case (map f) of -- (x:xs) -> ... -- will report that map is applied to too few arguments -- -- But now, in the GADT world, we need to typecheck the scrutinee -- first, to get type info that may be refined in the case alternatives mult <- newFlexiTyVarTy multiplicityTy -- Typecheck the scrutinee. We use tcInferRho but tcInferSigma -- would also be possible (tcMatchesCase accepts sigma-types) -- Interesting litmus test: do these two behave the same? -- case id of {..} -- case (\v -> v) of {..} -- This design choice is discussed in #17790 ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut ; traceTc "HsCase" (ppr scrut_ty) ; hasFixedRuntimeRep_syntactic FRRCase scrut_ty ; matches' <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty ; return (HsCase x scrut' matches') } where match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } tcExpr (HsIf x pred b1 b2) res_ty = do { pred' <- tcCheckMonoExpr pred boolTy ; (u1,b1') <- tcCollectingUsage $ tcMonoExpr b1 res_ty ; (u2,b2') <- tcCollectingUsage $ tcMonoExpr b2 res_ty ; tcEmitBindingUsage (supUE u1 u2) ; return (HsIf x pred' b1' b2') } tcExpr (HsMultiIf _ alts) res_ty = do { alts' <- mapM (wrapLocMA $ tcGRHS match_ctxt res_ty) alts ; res_ty <- readExpType res_ty ; return (HsMultiIf res_ty alts') } where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } tcExpr (HsDo _ do_or_lc stmts) res_ty = tcDoStmts do_or_lc stmts res_ty tcExpr (HsProc x pat cmd) res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty ; return $ mkHsWrapCo coi (HsProc x pat' cmd') } -- Typechecks the static form and wraps it with a call to 'fromStaticPtr'. -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. -- To type check -- (static e) :: p a -- we want to check (e :: a), -- and wrap (static e) in a call to -- fromStaticPtr :: IsStatic p => StaticPtr a -> p a tcExpr (HsStatic fvs expr) res_ty = do { res_ty <- expTypeToType res_ty ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty ; (expr', lie) <- captureConstraints $ addErrCtxt (hang (text "In the body of a static form:") 2 (ppr expr) ) $ tcCheckPolyExprNC expr expr_ty -- Check that the free variables of the static form are closed. -- It's OK to use nonDetEltsUniqSet here as the only side effects of -- checkClosedInStaticForm are error messages. ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs -- Require the type of the argument to be Typeable. ; typeableClass <- tcLookupClass typeableClassName ; typeable_ev <- emitWantedEvVar StaticOrigin $ mkTyConApp (classTyCon typeableClass) [liftedTypeKind, expr_ty] -- Insert the constraints of the static form in a global list for later -- validation. ; emitStaticConstraints lie -- Wrap the static form with the 'fromStaticPtr' call. ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName [p_ty] ; let wrap = mkWpEvVarApps [typeable_ev] <.> mkWpTyApps [expr_ty] ; loc <- getSrcSpanM ; static_ptr_ty_con <- tcLookupTyCon staticPtrTyConName ; return $ mkHsWrapCo co $ HsApp noComments (L (noAnnSrcSpan loc) $ mkHsWrap wrap fromStaticPtr) (L (noAnnSrcSpan loc) (HsStatic (fvs, mkTyConApp static_ptr_ty_con [expr_ty]) expr')) } {- ************************************************************************ * * Record construction and update * * ************************************************************************ -} tcExpr expr@(RecordCon { rcon_con = L loc con_name , rcon_flds = rbinds }) res_ty = do { con_like <- tcLookupConLike con_name ; (con_expr, con_sigma) <- tcInferId con_name ; (con_wrap, con_tau) <- topInstantiate orig con_sigma -- a shallow instantiation should really be enough for -- a data constructor. ; let arity = conLikeArity con_like Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau ; checkTc (conLikeHasBuilder con_like) $ nonBidirectionalErr (conLikeName con_like) ; rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds -- It is currently not possible for a record to have -- multiplicities. When they do, `tcRecordBinds` will take -- scaled types instead. Meanwhile, it's safe to take -- `scaledThing` above, as we know all the multiplicities are -- Many. ; let rcon_tc = mkHsWrap con_wrap con_expr expr' = RecordCon { rcon_ext = rcon_tc , rcon_con = L loc con_like , rcon_flds = rbinds' } ; ret <- tcWrapResultMono expr expr' actual_res_ty res_ty -- Check for missing fields. We do this after type-checking to get -- better types in error messages (cf #18869). For example: -- data T a = MkT { x :: a, y :: a } -- r = MkT { y = True } -- Then we'd like to warn about a missing field `x :: True`, rather than `x :: a0`. -- -- NB: to do this really properly we should delay reporting until typechecking is complete, -- via a new `HoleSort`. But that seems too much work. ; checkMissingFields con_like rbinds arg_tys ; return ret } where orig = OccurrenceOf con_name -- Record updates via dot syntax are replaced by desugared expressions -- in the renamer. See Note [Overview of record dot syntax] in -- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here -- and panic otherwise. tcExpr expr@(RecordUpd { rupd_expr = record_expr , rupd_flds = RegularRecUpdFields { xRecUpdFields = possible_parents , recUpdFields = rbnds } }) res_ty = assert (notNull rbnds) $ do { -- Desugar the record update. See Note [Record Updates]. ; (ds_expr, ds_res_ty, err_ctxt) <- desugarRecordUpd record_expr possible_parents rbnds res_ty -- Typecheck the desugared expression. ; expr' <- addErrCtxt err_ctxt $ tcExpr (mkExpandedExpr expr ds_expr) (Check ds_res_ty) -- NB: it's important to use ds_res_ty and not res_ty here. -- Test case: T18802b. ; addErrCtxt err_ctxt $ tcWrapResultMono expr expr' ds_res_ty res_ty -- We need to unify the result type of the desugared -- expression with the expected result type. -- -- See Note [Unifying result types in tcRecordUpd]. -- Test case: T10808. } tcExpr e@(RecordUpd { rupd_flds = OverloadedRecUpdFields {}}) _ = pprPanic "tcExpr: unexpected overloaded-dot RecordUpd" $ ppr e {- ************************************************************************ * * Arithmetic sequences e.g. [a,b..] and their parallel-array counterparts e.g. [: a,b.. :] * * ************************************************************************ -} tcExpr (ArithSeq _ witness seq) res_ty = tcArithSeq witness seq res_ty {- ************************************************************************ * * Record dot syntax * * ************************************************************************ -} -- These terms have been replaced by desugaring in the renamer. See -- Note [Overview of record dot syntax]. tcExpr (HsGetField _ _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented" tcExpr (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented" {- ************************************************************************ * * Template Haskell * * ************************************************************************ -} -- Here we get rid of it and add the finalizers to the global environment. -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. tcExpr (HsTypedSplice ext splice) res_ty = tcTypedSplice ext splice res_ty tcExpr e@(HsTypedBracket _ body) res_ty = tcTypedBracket e body res_ty tcExpr e@(HsUntypedBracket ps body) res_ty = tcUntypedBracket e body ps res_ty tcExpr (HsUntypedSplice splice _) res_ty = case splice of HsUntypedSpliceTop mod_finalizers expr -> do { addModFinalizersWithLclEnv mod_finalizers ; tcExpr expr res_ty } HsUntypedSpliceNested {} -> panic "tcExpr: invalid nested splice" {- ************************************************************************ * * Catch-all * * ************************************************************************ -} tcExpr (HsOverLabel {}) ty = pprPanic "tcExpr:HsOverLabel" (ppr ty) tcExpr (SectionL {}) ty = pprPanic "tcExpr:SectionL" (ppr ty) tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty) {- ************************************************************************ * * Arithmetic sequences [a..b] etc * * ************************************************************************ -} tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) tcArithSeq witness seq@(From expr) res_ty = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty ; expr' <-tcScalingUsage elt_mult $ tcCheckPolyExpr expr elt_ty ; enum_from <- newMethodFromName (ArithSeqOrigin seq) enumFromName [elt_ty] ; return $ mkHsWrap wrap $ ArithSeq enum_from wit' (From expr') } tcArithSeq witness seq@(FromThen expr1 expr2) res_ty = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) enumFromThenName [elt_ty] ; return $ mkHsWrap wrap $ ArithSeq enum_from_then wit' (FromThen expr1' expr2') } tcArithSeq witness seq@(FromTo expr1 expr2) res_ty = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) enumFromToName [elt_ty] ; return $ mkHsWrap wrap $ ArithSeq enum_from_to wit' (FromTo expr1' expr2') } tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty ; expr3' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr3 elt_ty ; eft <- newMethodFromName (ArithSeqOrigin seq) enumFromThenToName [elt_ty] ; return $ mkHsWrap wrap $ ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') } ----------------- arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType -> TcM (HsWrapper, Mult, TcType, Maybe (SyntaxExpr GhcTc)) arithSeqEltType Nothing res_ty = do { res_ty <- expTypeToType res_ty ; (coi, elt_ty) <- matchExpectedListTy res_ty ; return (mkWpCastN coi, OneTy, elt_ty, Nothing) } arithSeqEltType (Just fl) res_ty = do { ((elt_mult, elt_ty), fl') <- tcSyntaxOp ListOrigin fl [SynList] res_ty $ \ [elt_ty] [elt_mult] -> return (elt_mult, elt_ty) ; return (idHsWrapper, elt_mult, elt_ty, Just fl') } ---------------- tcTupArgs :: [HsTupArg GhcRn] -> [TcSigmaType] -- ^ Argument types. -- This function ensures they all have -- a fixed runtime representation. -> TcM [HsTupArg GhcTc] tcTupArgs args tys = do massert (equalLength args tys) checkTupSize (length args) zipWith3M go [1,2..] args tys where go :: Int -> HsTupArg GhcRn -> TcType -> TcM (HsTupArg GhcTc) go i (Missing {}) arg_ty = do { mult <- newFlexiTyVarTy multiplicityTy ; hasFixedRuntimeRep_syntactic (FRRTupleSection i) arg_ty ; return (Missing (Scaled mult arg_ty)) } go i (Present x expr) arg_ty = do { expr' <- tcCheckPolyExpr expr arg_ty ; hasFixedRuntimeRep_syntactic (FRRTupleArg i) arg_ty ; return (Present x expr') } --------------------------- -- See TcType.SyntaxOpType also for commentary tcSyntaxOp :: CtOrigin -> SyntaxExprRn -> [SyntaxOpType] -- ^ shape of syntax operator arguments -> ExpRhoType -- ^ overall result type -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments, -- takes a type per hole and a -- multiplicity per arrow in -- the shape. -> TcM (a, SyntaxExprTc) -- ^ Typecheck a syntax operator -- The operator is a variable or a lambda at this stage (i.e. renamer -- output)t tcSyntaxOp orig expr arg_tys res_ty = tcSyntaxOpGen orig expr arg_tys (SynType res_ty) -- | Slightly more general version of 'tcSyntaxOp' that allows the caller -- to specify the shape of the result of the syntax operator tcSyntaxOpGen :: CtOrigin -> SyntaxExprRn -> [SyntaxOpType] -> SyntaxOpType -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -> TcM (a, SyntaxExprTc) tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) [] -- Ugh!! But all this code is scheduled for demolition anyway ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma) ; (result, expr_wrap, arg_wraps, res_wrap) <- tcSynArgA orig op sigma arg_tys res_ty $ thing_inside ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma ) ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap expr , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) } tcSyntaxOpGen _ NoSyntaxExprRn _ _ _ = panic "tcSyntaxOpGen" {- Note [tcSynArg] ~~~~~~~~~~~~~~~ Because of the rich structure of SyntaxOpType, we must do the contra-/covariant thing when working down arrows, to get the instantiation vs. skolemisation decisions correct (and, more obviously, the orientation of the HsWrappers). We thus have two tcSynArgs. -} -- works on "expected" types, skolemising where necessary -- See Note [tcSynArg] tcSynArgE :: CtOrigin -> HsExpr GhcRn -- ^ the operator to check (for error messages only) -> TcSigmaType -> SyntaxOpType -- ^ shape it is expected to have -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments -> TcM (a, HsWrapper) -- ^ returns a wrapper :: (type of right shape) "->" (type passed in) tcSynArgE orig op sigma_ty syn_ty thing_inside = do { (skol_wrap, (result, ty_wrapper)) <- tcTopSkolemise GenSigCtxt sigma_ty (\ rho_ty -> go rho_ty syn_ty) ; return (result, skol_wrap <.> ty_wrapper) } where go rho_ty SynAny = do { result <- thing_inside [rho_ty] [] ; return (result, idHsWrapper) } go rho_ty SynRho -- same as SynAny, because we skolemise eagerly = do { result <- thing_inside [rho_ty] [] ; return (result, idHsWrapper) } go rho_ty SynList = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty ; result <- thing_inside [elt_ty] [] ; return (result, mkWpCastN list_co) } go rho_ty (SynFun arg_shape res_shape) = do { ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty , ( ( (result, arg_ty, res_ty, op_mult) , res_wrapper ) -- :: res_ty_out "->" res_ty , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty "->" arg_ty_out <- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $ \ [arg_ty] res_ty -> do { arg_tc_ty <- expTypeToType (scaledThing arg_ty) ; res_tc_ty <- expTypeToType res_ty -- another nested arrow is too much for now, -- but I bet we'll never need this ; massertPpr (case arg_shape of SynFun {} -> False; _ -> True) (text "Too many nested arrows in SyntaxOpType" $$ pprCtOrigin orig) ; let arg_mult = scaledMult arg_ty ; tcSynArgA orig op arg_tc_ty [] arg_shape $ \ arg_results arg_res_mults -> tcSynArgE orig op res_tc_ty res_shape $ \ res_results res_res_mults -> do { result <- thing_inside (arg_results ++ res_results) ([arg_mult] ++ arg_res_mults ++ res_res_mults) ; return (result, arg_tc_ty, res_tc_ty, arg_mult) }} ; let fun_wrap = mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper (Scaled op_mult arg_ty) res_ty -- NB: arg_ty comes from matchExpectedFunTys, so it has a -- fixed RuntimeRep, as needed to call mkWpFun. ; return (result, match_wrapper <.> fun_wrap) } where herald = ExpectedFunTySyntaxOp orig op go rho_ty (SynType the_ty) = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty ; result <- thing_inside [] [] ; return (result, wrap) } -- works on "actual" types, instantiating where necessary -- See Note [tcSynArg] tcSynArgA :: CtOrigin -> HsExpr GhcRn -- ^ the operator we are checking (for error messages) -> TcSigmaType -> [SyntaxOpType] -- ^ argument shapes -> SyntaxOpType -- ^ result shape -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments -> TcM (a, HsWrapper, [HsWrapper], HsWrapper) -- ^ returns a wrapper to be applied to the original function, -- wrappers to be applied to arguments -- and a wrapper to be applied to the overall expression tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside = do { (match_wrapper, arg_tys, res_ty) <- matchActualFunTysRho herald orig Nothing (length arg_shapes) sigma_ty -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty) ; ((result, res_wrapper), arg_wrappers) <- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults -> tc_syn_arg res_ty res_shape $ \ res_results -> thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults) ; return (result, match_wrapper, arg_wrappers, res_wrapper) } where herald = ExpectedFunTySyntaxOp orig op tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType] -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -> TcM (a, [HsWrapper]) -- the wrappers are for arguments tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside = do { ((result, arg_wraps), arg_wrap) <- tcSynArgE orig op arg_ty arg_shape $ \ arg1_results arg1_mults -> tc_syn_args_e arg_tys arg_shapes $ \ args_results args_mults -> thing_inside (arg1_results ++ args_results) (arg1_mults ++ args_mults) ; return (result, arg_wrap : arg_wraps) } tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] [] tc_syn_arg :: TcSigmaTypeFRR -> SyntaxOpType -> ([TcSigmaTypeFRR] -> TcM a) -> TcM (a, HsWrapper) -- the wrapper applies to the overall result tc_syn_arg res_ty SynAny thing_inside = do { result <- thing_inside [res_ty] ; return (result, idHsWrapper) } tc_syn_arg res_ty SynRho thing_inside = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty -- inst_wrap :: res_ty "->" rho_ty ; result <- thing_inside [rho_ty] ; return (result, inst_wrap) } tc_syn_arg res_ty SynList thing_inside = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty -- inst_wrap :: res_ty "->" rho_ty ; (list_co, elt_ty) <- matchExpectedListTy rho_ty -- list_co :: [elt_ty] ~N rho_ty ; result <- thing_inside [elt_ty] ; return (result, mkWpCastN (mkSymCo list_co) <.> inst_wrap) } tc_syn_arg _ (SynFun {}) _ = pprPanic "tcSynArgA hits a SynFun" (ppr orig) tc_syn_arg res_ty (SynType the_ty) thing_inside = do { wrap <- tcSubType orig GenSigCtxt res_ty the_ty ; result <- thing_inside [] ; return (result, wrap) } {- Note [Push result type in] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Unify with expected result before type-checking the args so that the info from res_ty percolates to args. This is when we might detect a too-few args situation. (One can think of cases when the opposite order would give a better error message.) experimenting with putting this first. Here's an example where it actually makes a real difference class C t a b | t a -> b instance C Char a Bool data P t a = forall b. (C t a b) => MkP b data Q t = MkQ (forall a. P t a) f1, f2 :: Q Char; f1 = MkQ (MkP True) f2 = MkQ (MkP True :: forall a. P Char a) With the change, f1 will type-check, because the 'Char' info from the signature is propagated into MkQ's argument. With the check in the other order, the extra signature in f2 is reqd. -} {- ********************************************************************* * * Desugaring record update * * ********************************************************************* -} {- Note [Record Updates] ~~~~~~~~~~~~~~~~~~~~~~~~ To typecheck a record update, we desugar it first. Suppose we have data T p q = T1 { x :: Int, y :: Bool, z :: Char } | T2 { v :: Char } | T3 { x :: Int } | T4 { p :: Float, y :: Bool, x :: Int } | T5 Then the record update `e { x=e1, y=e2 }` desugars as follows e { x=e1, y=e2 } ===> let { x' = e1; y' = e2 } in case e of T1 _ _ z -> T1 x' y' z T4 p _ _ -> T4 p y' x' T2, T3 and T5 should not occur, so we omit them from the match. The critical part of desugaring is to identify T and then T1/T4. Wrinkle [Disambiguating fields] As explained in Note [Disambiguating record updates] in GHC.Rename.Pat, to typecheck a record update we first need to disambiguate the field labels, in order to find a parent which has at least one constructor with all of the fields being updated. As mentioned in Note [Type-directed record disambiguation], we sometimes use type-directed disambiguation, although this mechanism is deprecated and scheduled for removal via the implementation of GHC proposal #366 https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst. All in all, this means that when typechecking a record update via desugaring, we take the following steps: (0) Perform a first typechecking pass on the record expression (`e` in the example above), to infer the type of the record being updated. (1) Disambiguate the record fields (potentially using the type obtained in (0)). (2) Desugar the record update as described above, using an HsExpansion. (a) Create a let-binding to share the record update right-hand sides. (b) Desugar the record update to a case expression updating all the relevant constructors (those that have all of the fields being updated). (3) Typecheck the desugared code. In (0), we call inferRho to infer the type of the record being updated. This returns the inferred type of the record, together with a typechecked expression (of type HsExpr GhcTc) and a collection of residual constraints. We have no need for the latter two, because we will typecheck again in (D3). So, for the time being (and until GHC proposal #366 is implemented), we simply drop them. Wrinkle [Using IdSig] As noted above, we want to let-bind the updated fields to avoid code duplication: let { x' = e1; y' = e2 } in case e of T1 _ _ z -> T1 x' y' z T4 p _ _ -> T4 p y' x' However, doing so in a naive way would cause difficulties for type inference. For example: data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int } foo r = r { f = \ k -> (k 3, k 'x') } If we desugar to: ds_foo r = let f' = \ k -> (k 3, k 'x') in case r of MkR _ b -> MkR f' b then we are unable to infer an appropriately polymorphic type for f', because we never infer higher-rank types. To circumvent this problem, we proceed as follows: 1. Obtain general field types by instantiating any of the constructors that contain all the necessary fields. (Note that the field type must be identical across different constructors of a given data constructor). 2. Let-bind an 'IdSig' with this type. This amounts to giving the let-bound 'Id's a partial type signature. In the above example, it's as if we wrote: ds_foo r = let f' :: (forall a. a -> a) -> (Int, _b) f' = \ k -> (k 3, k 'x') in case r of MkR _ b -> MkR f' b This allows us to compute the right type for f', and thus accept this record update. Note [Type-directed record disambiguation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC currently supports an additional type-directed disambiguation mechanism, which is deprecated and scheduled for removal as part of GHC proposal #366 https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst. To perform this disambiguation, when there are multiple possible parents for a record update, the renamer defers to the typechecker. See GHC.Tc.Gen.Expr.disambiguateRecordBinds, and in particular the auxiliary function identifyParentLabels, which picks a parent for the record update using the following additional mechanisms: (a) Use the type being pushed in, if it is already a TyConApp. The following are valid updates at type `R`: g :: R -> R g x = x { fld1 = 3 } g' x = x { fld1 = 3 } :: R (b) Use the type signature of the record expression, if it exists and is a TyConApp. Thus this is valid update at type `R`: h x = (x :: R) { fld1 = 3 } Note that this type-directed disambiguation mechanism isn't very robust, as it doesn't properly integrate with the rest of the typechecker. For example, the following updates will all be rejected as ambiguous: let r :: R r = blah in r { foo = 3 } \r. (r { foo = 3 }, r :: R) Record updates which require constraint-solving should instead use the -XOverloadedRecordUpdate extension, as described in Note [Overview of record dot syntax]. Note [Unifying result types in tcRecordUpd] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ After desugaring and typechecking a record update in the way described in Note [Record Updates], we must take care to unify the result types. Example: type family F (a :: Type) :: Type where {} data D a = MkD { fld :: F a } f :: F Int -> D Bool -> D Int f i r = r { fld = i } This record update desugars to: let x :: F alpha -- metavariable x = i in case r of MkD _ -> MkD x Because the type family F is not injective, our only hope for unifying the metavariable alpha is through the result type of the record update, which tells us that we should unify alpha := Int. Test case: T10808. Wrinkle [GADT result type in tcRecordUpd] When dealing with a GADT, we want to be careful about which result type we use. Example: data G a b where MkG :: { bar :: F a } -> G a Int g :: F Int -> G Float b -> G Int b g i r = r { bar = i } We **do not** want to use the result type from the constructor MkG, which would leave us with a result type "G alpha Int". Instead, we should use the result type from the GADT header, instantiating as above, to get "G alpha beta" which will get unified withy "G Int b". Test cases: T18809, HardRecordUpdate. -} -- | Desugars a record update @record_expr { fld1 = e1, fld2 = e2}@ into a case expression -- that matches on the constructors of the record @r@, as described in -- Note [Record Updates]. -- -- Returns a renamed but not-yet-typechecked expression, together with the -- result type of this desugared record update. desugarRecordUpd :: LHsExpr GhcRn -- ^ @record_expr@: expression to which the record update is applied -> NE.NonEmpty (HsRecUpdParent GhcRn) -- ^ Possible parent 'TyCon'/'PatSyn's for the record update, -- with the associated constructors and field labels -> [LHsRecUpdField GhcRn GhcRn] -- ^ the record update fields -> ExpRhoType -- ^ the expected result type of the record update -> TcM ( HsExpr GhcRn -- desugared record update expression , TcType -- result type of desugared record update , SDoc -- error context to push when typechecking -- the desugared code ) desugarRecordUpd record_expr possible_parents rbnds res_ty = do { -- STEP 0: typecheck the record_expr, the record to be updated. -- -- Until GHC proposal #366 is implemented, we still use the type of -- the record to disambiguate its fields, so we must infer the record -- type here before we can desugar. See Wrinkle [Disambiguating fields] -- in Note [Record Updates]. ; ((_, record_rho), _lie) <- captureConstraints $ -- see (1) below tcScalingUsage ManyTy $ -- see (2) below tcInferRho record_expr -- (1) -- Note that we capture, and then discard, the constraints. -- This `tcInferRho` is used *only* to identify the data type, -- so we can deal with field disambiguation. -- Then we are going to generate a desugared record update, including `record_expr`, -- and typecheck it from scratch. We don't want to generate the constraints twice! -- (2) -- Record update drops some of the content of the record (namely the -- content of the field being updated). As a consequence, unless the -- field being updated is unrestricted in the record, we need an -- unrestricted record. Currently, we simply always require an -- unrestricted record. -- -- Consider the following example: -- -- data R a = R { self :: a } -- bad :: a ⊸ () -- bad x = let r = R x in case r { self = () } of { R x' -> x' } -- -- This should definitely *not* typecheck. -- STEP 1: disambiguate the record update by computing a single parent -- which has a constructor with all of the fields being updated. -- -- See Note [Disambiguating record updates] in GHC.Rename.Pat. ; (cons, rbinds) <- disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty ; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds sel_ids = map selectorAmbiguousFieldOcc upd_flds upd_fld_names = map idName sel_ids relevant_cons = nonDetEltsUniqSet cons relevant_con = head relevant_cons -- STEP 2: desugar the record update. -- -- (a) Create new variables for the fields we are updating, -- so that we can share them across constructors. -- -- Example: -- -- e { x=e1, y=e2 } -- -- We want to let-bind variables to `e1` and `e2`: -- -- let x' :: Int -- x' = e1 -- y' :: Bool -- y' = e2 -- in ... -- Instantiate the type variables of any relevant constuctor -- with metavariables to obtain a type for each 'Id'. -- This will allow us to have 'Id's with polymorphic types -- by using 'IdSig'. See Wrinkle [Using IdSig] in Note [Record Updates]. ; let (univ_tvs, ex_tvs, eq_spec, _, _, arg_tys, con_res_ty) = conLikeFullSig relevant_con ; (subst, tc_tvs) <- newMetaTyVars (univ_tvs ++ ex_tvs) ; let (actual_univ_tys, _actual_ex_tys) = splitAtList univ_tvs $ map mkTyVarTy tc_tvs -- See Wrinkle [GADT result type in tcRecordUpd] -- for an explanation of the following. ds_res_ty = case relevant_con of RealDataCon con | not (null eq_spec) -- We only need to do this if we have actual GADT equalities. -> mkFamilyTyConApp (dataConTyCon con) actual_univ_tys _ -> substTy subst con_res_ty -- Gather pairs of let-bound Ids and their right-hand sides, -- e.g. (x', e1), (y', e2), ... ; let mk_upd_id :: Name -> LHsFieldBind GhcTc fld (LHsExpr GhcRn) -> TcM (Name, (TcId, LHsExpr GhcRn)) mk_upd_id fld_nm (L _ rbind) = do { let Scaled m arg_ty = lookupNameEnv_NF arg_ty_env fld_nm nm_occ = rdrNameOcc . nameRdrName $ fld_nm actual_arg_ty = substTy subst arg_ty rhs = hfbRHS rbind ; (_co, actual_arg_ty) <- hasFixedRuntimeRep (FRRRecordUpdate fld_nm (unLoc rhs)) actual_arg_ty -- We get a better error message by doing a (redundant) representation-polymorphism check here, -- rather than delaying until the typechecker typechecks the let-bindings, -- because the let-bound Ids have internal names. -- (As we will typecheck the let-bindings later, we can drop this coercion here.) -- See RepPolyRecordUpdate test. ; nm <- newNameAt nm_occ generatedSrcSpan ; let id = mkLocalId nm m actual_arg_ty -- NB: create fresh names to avoid any accidental shadowing -- occurring in the RHS expressions when creating the let bindings: -- -- let x1 = e1; x2 = e2; ... ; return (fld_nm, (id, rhs)) } arg_ty_env = mkNameEnv $ zipWith (\ lbl arg_ty -> (flSelector lbl, arg_ty)) (conLikeFieldLabels relevant_con) arg_tys ; traceTc "tcRecordUpd" $ vcat [ text "upd_fld_names:" <+> ppr upd_fld_names , text "relevant_cons:" <+> ppr relevant_cons ] ; upd_ids <- zipWithM mk_upd_id upd_fld_names rbinds ; let updEnv :: UniqMap Name (Id, LHsExpr GhcRn) updEnv = listToUniqMap $ upd_ids make_pat :: ConLike -> LMatch GhcRn (LHsExpr GhcRn) -- As explained in Note [Record Updates], to desugar -- -- e { x=e1, y=e2 } -- -- we generate a case statement, with an equation for -- each constructor of the record. For example, for -- the constructor -- -- T1 :: { x :: Int, y :: Bool, z :: Char } -> T p q -- -- we let-bind x' = e1, y' = e2 and generate the equation: -- -- T1 _ _ z -> T1 x' y' z make_pat conLike = mkSimpleMatch CaseAlt [pat] rhs where (lhs_con_pats, rhs_con_args) = zipWithAndUnzip mk_con_arg [1..] con_fields pat = genSimpleConPat con lhs_con_pats rhs = wrapGenSpan $ genHsApps con rhs_con_args con = conLikeName conLike con_fields = conLikeFieldLabels conLike mk_con_arg :: Int -> FieldLabel -> ( LPat GhcRn -- LHS constructor pattern argument , LHsExpr GhcRn ) -- RHS constructor argument mk_con_arg i fld_lbl = -- The following generates the pattern matches of the desugared `case` expression. -- For fields being updated (for example `x`, `y` in T1 and T4 in Note [Record Updates]), -- wildcards are used to avoid creating unused variables. case lookupUniqMap updEnv $ flSelector fld_lbl of -- Field is being updated: LHS = wildcard pattern, RHS = appropriate let-bound Id. Just (upd_id, _) -> (genWildPat, genLHsVar (idName upd_id)) -- Field is not being updated: LHS = variable pattern, RHS = that same variable. _ -> let fld_nm = mkInternalName (mkBuiltinUnique i) (nameOccName $ flSelector $ fld_lbl) generatedSrcSpan in (genVarPat fld_nm, genLHsVar fld_nm) -- STEP 2 (b): desugar to HsCase, as per note [Record Updates] ; let ds_expr :: HsExpr GhcRn ds_expr = HsLet noExtField noHsTok let_binds noHsTok (L gen case_expr) case_expr :: HsExpr GhcRn case_expr = HsCase noExtField record_expr (mkMatchGroup Generated (wrapGenSpan matches)) matches :: [LMatch GhcRn (LHsExpr GhcRn)] matches = map make_pat relevant_cons let_binds :: HsLocalBindsLR GhcRn GhcRn let_binds = HsValBinds noAnn $ XValBindsLR $ NValBinds upd_ids_lhs (map mk_idSig upd_ids) upd_ids_lhs :: [(RecFlag, LHsBindsLR GhcRn GhcRn)] upd_ids_lhs = [ (NonRecursive, unitBag $ genSimpleFunBind (idName id) [] rhs) | (_, (id, rhs)) <- upd_ids ] mk_idSig :: (Name, (Id, LHsExpr GhcRn)) -> LSig GhcRn mk_idSig (_, (id, _)) = L gen $ XSig $ IdSig id -- We let-bind variables using 'IdSig' in order to accept -- record updates involving higher-rank types. -- See Wrinkle [Using IdSig] in Note [Record Updates]. gen = noAnnSrcSpan generatedSrcSpan ; traceTc "desugarRecordUpd" $ vcat [ text "relevant_con:" <+> ppr relevant_con , text "res_ty:" <+> ppr res_ty , text "ds_res_ty:" <+> ppr ds_res_ty ] ; let cons = pprQuotedList relevant_cons err_lines = (text "In a record update at field" <> plural upd_fld_names <+> pprQuotedList upd_fld_names :) $ case relevant_con of RealDataCon con -> [ text "with type constructor" <+> quotes (ppr (dataConTyCon con)) , text "data constructor" <+> plural relevant_cons <+> cons ] PatSynCon {} -> [ text "with pattern synonym" <+> plural relevant_cons <+> cons ] ++ if null ex_tvs then [] else [ text "existential variable" <> plural ex_tvs <+> pprQuotedList ex_tvs ] err_ctxt = make_lines_msg err_lines ; return (ds_expr, ds_res_ty, err_ctxt) } -- | Pretty-print a collection of lines, adding commas at the end of each line, -- and adding "and" to the start of the last line. make_lines_msg :: [SDoc] -> SDoc make_lines_msg [] = empty make_lines_msg [last] = ppr last <> dot make_lines_msg [l1,l2] = l1 $$ text "and" <+> l2 <> dot make_lines_msg (l:ls) = l <> comma $$ make_lines_msg ls {- ********************************************************************* * * Record bindings * * **********************************************************************-} -- | Disambiguate the fields in a record update. -- -- Most of the disambiguation has been done by the renamer; this function -- performs a final type-directed disambiguation pass, as explained in -- Note [Type-directed record disambiguation]. disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType -> NE.NonEmpty (HsRecUpdParent GhcRn) -> [LHsRecUpdField GhcRn GhcRn] -> ExpRhoType -> TcM (UniqSet ConLike, [LHsRecUpdField GhcTc GhcRn]) disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty = do { fam_inst_envs <- tcGetFamInstEnvs -- Identify a single parent, using type-directed disambiguation -- if necessary. (Note that type-directed disambiguation of -- record field updates is is scheduled for removal, as per -- Note [Type-directed record disambiguation].) ; TcRecUpdParent { tcRecUpdLabels = lbls , tcRecUpdCons = cons } <- identifyParentLabels fam_inst_envs possible_parents -- Pick the right selector with that parent for each field ; rbnds' <- zipWithM lookupField (NE.toList lbls) rbnds ; return (cons, rbnds') } where -- Try to identify a single parent, using type-directed disambiguation. -- -- Any non-type-directed disambiguation will have been done already. -- See GHC.Rename.Env.lookupRecUpdFields. identifyParentLabels :: FamInstEnvs -> NE.NonEmpty (HsRecUpdParent GhcRn) -> TcM (HsRecUpdParent GhcTc) identifyParentLabels fam_inst_envs possible_parents = case possible_parents of -- Exactly one possible parent for the record update! p NE.:| [] -> lookup_parent_flds p -- Multiple possible parents: try harder to disambiguate. -- Can we get a parent TyCon from the pushed-in type? -- -- See (a) in Note [Type-directed record disambiguation] in GHC.Rename.Pat. _ NE.:| _ : _ | Just tc <- tyConOfET fam_inst_envs res_ty -> do { reportAmbiguousUpdate possible_parents tc ; try_disambiguated_tycon tc possible_parents } -- Does the expression being updated have a type signature? -- If so, try to extract a parent TyCon from it. -- -- See (b) inNote [Type-directed record disambiguation] in GHC.Rename.Pat. | Just {} <- obviousSig (unLoc record_expr) , Just tc <- tyConOf fam_inst_envs record_rho -> do { reportAmbiguousUpdate possible_parents tc ; try_disambiguated_tycon tc possible_parents } -- Nothing else we can try... p1 NE.:| p2 : ps -> do { p1 <- tcLookupRecSelParent p1 ; p2 <- tcLookupRecSelParent p2 ; ps <- mapM tcLookupRecSelParent ps ; failWithTc $ TcRnBadRecordUpdate (getUpdFieldLbls rbnds) $ MultiplePossibleParents (p1, p2, ps) } -- Try to use the 'TyCon' we learned from type-directed disambiguation. -- This might not work, if it doesn't match up with any of the parents we had -- computed on the basis of the field labels. -- (See test cases overloadedrecfields01 and T21946.) try_disambiguated_tycon :: TyCon -> NE.NonEmpty (HsRecUpdParent GhcRn) -> TcM (HsRecUpdParent GhcTc) try_disambiguated_tycon tc pars = do { pars <- mapMaybeM (fmap (guard_parent tc) . lookup_parent_flds) (NE.toList pars) ; case pars of [par] -> return par [] -> do { pars <- mapM tcLookupRecSelParent possible_parents ; failWithTc $ TcRnBadRecordUpdate (getUpdFieldLbls rbnds) $ InvalidTyConParent tc pars } _ -> pprPanic "try_disambiguated_tycon: more than 1 valid parent" (ppr $ map tcRecUpdParent pars) } guard_parent :: TyCon -> HsRecUpdParent GhcTc -> Maybe (HsRecUpdParent GhcTc) guard_parent disamb_tc cand_parent@(TcRecUpdParent { tcRecUpdParent = cand_tc }) = do { guard (RecSelData disamb_tc == cand_tc) ; return cand_parent } lookup_parent_flds :: HsRecUpdParent GhcRn -> TcM (HsRecUpdParent GhcTc) lookup_parent_flds par@(RnRecUpdParent { rnRecUpdLabels = lbls, rnRecUpdCons = cons }) = do { let cons' :: NonDetUniqFM ConLike ConLikeName cons' = NonDetUniqFM $ unsafeCastUFMKey $ getUniqSet cons ; cons <- traverse (tcLookupConLike . conLikeName_Name) cons' ; tc <- tcLookupRecSelParent par ; return $ TcRecUpdParent { tcRecUpdParent = tc , tcRecUpdLabels = lbls , tcRecUpdCons = unsafeUFMToUniqSet $ getNonDet cons } } lookupField :: FieldGlobalRdrElt -> LHsRecUpdField GhcRn GhcRn -> TcM (LHsRecUpdField GhcTc GhcRn) lookupField fl (L l upd) = do { let L loc af = hfbLHS upd rdr = ambiguousFieldOccRdrName af mb_gre = pickGREs rdr [fl] -- NB: this GRE can be 'Nothing' when in GHCi. -- See test T10439. -- Mark the record fields as used, now that we have disambiguated. -- There is no risk of duplicate deprecation warnings, as we have -- not marked the GREs as used previously. ; setSrcSpanA loc $ mapM_ (addUsedGRE True) mb_gre ; sel <- tcLookupId $ flSelector $ fieldGRELabel fl ; let L loc af = hfbLHS upd lbl = ambiguousFieldOccRdrName af ; return $ L l HsFieldBind { hfbAnn = hfbAnn upd , hfbLHS = L (l2l loc) $ Unambiguous sel (L (l2l loc) lbl) , hfbRHS = hfbRHS upd , hfbPun = hfbPun upd } } -- The type-directed disambiguation mechanism is scheduled for removal, -- as per Note [Type-directed record disambiguation]. -- So we emit a warning whenever the user relies on it. reportAmbiguousUpdate :: NE.NonEmpty (HsRecUpdParent GhcRn) -> TyCon -> TcM () reportAmbiguousUpdate parents parent_type = setSrcSpan loc $ addDiagnostic $ TcRnAmbiguousRecordUpdate rupd parent_type where rupd = RecordUpd { rupd_expr = record_expr , rupd_flds = RegularRecUpdFields { xRecUpdFields = parents , recUpdFields = rbnds } , rupd_ext = noExtField } loc = getLocA (head rbnds) {- Game plan for record bindings ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1. Find the TyCon for the bindings, from the first field label. 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty. For each binding field = value 3. Instantiate the field type (from the field label) using the type envt from step 2. 4 Type check the value using tcCheckPolyExprNC (in tcRecordField), passing the field type as the expected argument type. This extends OK when the field types are universally quantified. -} tcRecordBinds :: ConLike -> [TcType] -- Expected type for each field -> HsRecordBinds GhcRn -> TcM (HsRecordBinds GhcTc) tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) = do { mb_binds <- mapM do_bind rbinds ; return (HsRecFields (catMaybes mb_binds) dd) } where fields = map flSelector $ conLikeFieldLabels con_like flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys do_bind :: LHsRecField GhcRn (LHsExpr GhcRn) -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc))) do_bind (L l fld@(HsFieldBind { hfbLHS = f , hfbRHS = rhs })) = do { mb <- tcRecordField con_like flds_w_tys f rhs ; case mb of Nothing -> return Nothing Just (f', rhs') -> return (Just (L l (HsFieldBind { hfbAnn = hfbAnn fld , hfbLHS = f' , hfbRHS = rhs' , hfbPun = hfbPun fld}))) } fieldCtxt :: FieldLabelString -> SDoc fieldCtxt field_name = text "In the" <+> quotes (ppr field_name) <+> text "field of a record" tcRecordField :: ConLike -> Assoc Name Type -> LFieldOcc GhcRn -> LHsExpr GhcRn -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)) tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs | Just field_ty <- assocMaybe flds_w_tys sel_name = addErrCtxt (fieldCtxt field_lbl) $ do { rhs' <- tcCheckPolyExprNC rhs field_ty ; hasFixedRuntimeRep_syntactic (FRRRecordCon (unLoc lbl) (unLoc rhs')) field_ty ; let field_id = mkUserLocal (nameOccName sel_name) (nameUnique sel_name) ManyTy field_ty (locA loc) -- Yuk: the field_id has the *unique* of the selector Id -- (so we can find it easily) -- but is a LocalId with the appropriate type of the RHS -- (so the desugarer knows the type of local binder to make) ; return (Just (L loc (FieldOcc field_id lbl), rhs')) } | otherwise = do { addErrTc (badFieldConErr (getName con_like) field_lbl) ; return Nothing } where field_lbl = FieldLabelString $ occNameFS $ rdrNameOcc (unLoc lbl) checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM () checkMissingFields con_like rbinds arg_tys | null field_labels -- Not declared as a record; -- But C{} is still valid if no strict fields = if any isBanged field_strs then -- Illegal if any arg is strict addErrTc (TcRnMissingStrictFields con_like []) else do when (notNull field_strs && null field_labels) $ do let msg = TcRnMissingFields con_like [] (diagnosticTc True msg) | otherwise = do -- A record unless (null missing_s_fields) $ do fs <- zonk_fields missing_s_fields -- It is an error to omit a strict field, because -- we can't substitute it with (error "Missing field f") addErrTc (TcRnMissingStrictFields con_like fs) warn <- woptM Opt_WarnMissingFields when (warn && notNull missing_ns_fields) $ do fs <- zonk_fields missing_ns_fields -- It is not an error (though we may want) to omit a -- lazy field, because we can always use -- (error "Missing field f") instead. let msg = TcRnMissingFields con_like fs diagnosticTc True msg where -- we zonk the fields to get better types in error messages (#18869) zonk_fields fs = forM fs $ \(str,ty) -> do ty' <- zonkTcType ty return (str,ty') missing_s_fields = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info, isBanged str, not (fl `elemField` field_names_used) ] missing_ns_fields = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info, not (isBanged str), not (fl `elemField` field_names_used) ] field_names_used = hsRecFields rbinds field_labels = conLikeFieldLabels con_like field_info = zip3 field_labels field_strs arg_tys field_strs = conLikeImplBangs con_like fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds {- ************************************************************************ * * \subsection{Static Pointers} * * ************************************************************************ -} -- | Checks if the given name is closed and emits an error if not. -- -- See Note [Not-closed error messages]. checkClosedInStaticForm :: Name -> TcM () checkClosedInStaticForm name = do type_env <- getLclTypeEnv case checkClosed type_env name of Nothing -> return () Just reason -> addErrTc $ explain name reason where -- See Note [Checking closedness]. checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason checkClosed type_env n = checkLoop type_env (unitNameSet n) n checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason checkLoop type_env visited n = -- The @visited@ set is an accumulating parameter that contains the set of -- visited nodes, so we avoid repeating cycles in the traversal. case lookupNameEnv type_env n of Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of ClosedLet -> Nothing NotLetBound -> Just NotLetBoundReason NonClosedLet fvs type_closed -> listToMaybe $ -- Look for a non-closed variable in fvs [ NotClosed n' reason | n' <- nameSetElemsStable fvs , not (elemNameSet n' visited) , Just reason <- [checkLoop type_env (extendNameSet visited n') n'] ] ++ if type_closed then [] else -- We consider non-let-bound variables easier to figure out than -- non-closed types, so we report non-closed types to the user -- only if we cannot spot the former. [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ] -- The binding is closed. _ -> Nothing -- Converts a reason into a human-readable sentence. -- -- @explain name reason@ starts with -- -- " is used in a static form but it is not closed because it" -- -- and then follows a list of causes. For each id in the path, the text -- -- "uses which" -- -- is appended, yielding something like -- -- "uses which uses which uses which" -- -- until the end of the path is reached, which is reported as either -- -- "is not let-bound" -- -- when the final node is not let-bound, or -- -- "has a non-closed type because it contains the type variables: -- v1, v2, v3" -- -- when the final node has a non-closed type. -- explain :: Name -> NotClosedReason -> TcRnMessage explain = TcRnStaticFormNotClosed -- Note [Not-closed error messages] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- When variables in a static form are not closed, we go through the trouble -- of explaining why they aren't. -- -- Thus, the following program -- -- > {-# LANGUAGE StaticPointers #-} -- > module M where -- > -- > f x = static g -- > where -- > g = h -- > h = x -- -- produces the error -- -- 'g' is used in a static form but it is not closed because it -- uses 'h' which uses 'x' which is not let-bound. -- -- And a program like -- -- > {-# LANGUAGE StaticPointers #-} -- > module M where -- > -- > import Data.Typeable -- > import GHC.StaticPtr -- > -- > f :: Typeable a => a -> StaticPtr TypeRep -- > f x = const (static (g undefined)) (h x) -- > where -- > g = h -- > h = typeOf -- -- produces the error -- -- 'g' is used in a static form but it is not closed because it -- uses 'h' which has a non-closed type because it contains the -- type variables: 'a' -- -- Note [Checking closedness] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- @checkClosed@ checks if a binding is closed and returns a reason if it is -- not. -- -- The bindings define a graph where the nodes are ids, and there is an edge -- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free -- variables. -- -- When @n@ is not closed, it has to exist in the graph some node reachable -- from @n@ that it is not a let-bound variable or that it has a non-closed -- type. Thus, the "reason" is a path from @n@ to this offending node. -- -- When @n@ is not closed, we traverse the graph reachable from @n@ to build -- the reason. --