diff options
Diffstat (limited to 'compiler/GHC/Tc/Gen/Expr.hs')
| -rw-r--r-- | compiler/GHC/Tc/Gen/Expr.hs | 1409 |
1 files changed, 71 insertions, 1338 deletions
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 9870c36ff5..9d40225a55 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -14,9 +14,9 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Tc.Gen.Expr - ( tcCheckPolyExpr, + ( tcCheckPolyExpr, tcCheckPolyExprNC, tcCheckMonoExpr, tcCheckMonoExprNC, tcMonoExpr, tcMonoExprNC, - tcInferSigma, tcInferRho, tcInferRhoNC, + tcInferRho, tcInferRhoNC, tcExpr, tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, tcCheckId, @@ -28,7 +28,6 @@ module GHC.Tc.Gen.Expr import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) -import GHC.Builtin.Names.TH( liftStringName, liftName ) import GHC.Hs import GHC.Tc.Utils.Zonk @@ -38,18 +37,16 @@ import GHC.Types.Basic import GHC.Core.Multiplicity import GHC.Core.UsageEnv import GHC.Tc.Utils.Instantiate -import GHC.Tc.Gen.Bind ( chooseInferredQuantifiers, tcLocalBinds ) -import GHC.Tc.Gen.Sig ( tcUserTypeSig, tcInstSig ) -import GHC.Tc.Solver ( simplifyInfer, InferMode(..) ) -import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst, tcLookupDataFamInst_maybe ) +import GHC.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.Rename.Utils ( addNameClashErrRn, unknownSubordinateErr ) import GHC.Tc.Utils.Env import GHC.Tc.Gen.Arrow import GHC.Tc.Gen.Match import GHC.Tc.Gen.HsType -import GHC.Tc.TyCl.PatSyn ( tcPatSynBuilderOcc, nonBidirectionalErr ) import GHC.Tc.Gen.Pat import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Origin @@ -64,19 +61,14 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Core.TyCon -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr -import GHC.Core.TyCo.Subst (substTyWithInScope) import GHC.Core.Type import GHC.Tc.Types.Evidence import GHC.Types.Var.Set import GHC.Builtin.Types -import GHC.Builtin.PrimOps( tagToEnumKey ) import GHC.Builtin.Names import GHC.Driver.Session import GHC.Types.SrcLoc import GHC.Utils.Misc -import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet ) import GHC.Data.List.SetOps import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable @@ -84,7 +76,7 @@ import GHC.Utils.Panic import GHC.Data.FastString import Control.Monad import GHC.Core.Class(classTyCon) -import GHC.Types.Unique.Set +import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet ) import qualified GHC.LanguageExtensions as LangExt import Data.Function @@ -118,7 +110,7 @@ tcPolyExpr, tcPolyExprNC -> TcM (LHsExpr GhcTc) tcPolyExpr expr res_ty - = addExprCtxt expr $ + = addLExprCtxt expr $ do { traceTc "tcPolyExpr" (ppr res_ty) ; tcPolyExprNC expr res_ty } @@ -134,21 +126,11 @@ tcPolyExprNC (L loc expr) res_ty set_loc_and_ctxt l e m = do inGenCode <- inGeneratedCode if inGenCode && not (isGeneratedSrcSpan l) - then setSrcSpan l $ addExprCtxt (L l e) m + then setSrcSpan l $ + addExprCtxt e m else setSrcSpan l m --------------- -tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType) --- Used by tcRnExpr to implement GHCi :type --- It goes against the principle of eager instantiation, --- so we expect very very few calls to this function --- Most clients will want tcInferRho -tcInferSigma le@(L loc expr) - = addExprCtxt le $ setSrcSpan loc $ - do { (fun, args, ty) <- tcInferApp expr - ; return (L loc (applyHsArgs fun args), ty) } - ---------------- tcCheckMonoExpr, tcCheckMonoExprNC :: LHsExpr GhcRn -- Expression to type check -> TcRhoType -- Expected type @@ -164,7 +146,7 @@ tcMonoExpr, tcMonoExprNC -> TcM (LHsExpr GhcTc) tcMonoExpr expr res_ty - = addExprCtxt expr $ + = addLExprCtxt expr $ tcMonoExprNC expr res_ty tcMonoExprNC (L loc expr) res_ty @@ -175,7 +157,8 @@ tcMonoExprNC (L loc expr) res_ty --------------- tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) -- Infer a *rho*-type. The return type is always instantiated. -tcInferRho le = addExprCtxt le (tcInferRhoNC le) +tcInferRho le = addLExprCtxt le $ + tcInferRhoNC le tcInferRhoNC (L loc expr) = setSrcSpan loc $ @@ -189,36 +172,45 @@ tcInferRhoNC (L loc expr) * * ********************************************************************* -} -tcLExpr, tcLExprNC - :: LHsExpr GhcRn -- Expression to type check - -> ExpRhoType -- Expected type - -- Definitely no foralls at the top - -> TcM (LHsExpr GhcTc) - -tcLExpr expr res_ty - = setSrcSpan (getLoc expr) $ addExprCtxt expr (tcLExprNC expr res_ty) - -tcLExprNC (L loc expr) res_ty - = setSrcSpan loc $ - do { expr' <- tcExpr expr res_ty - ; return (L loc expr') } - tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -tcExpr (HsVar _ (L _ name)) res_ty = tcCheckId name res_ty -tcExpr e@(HsUnboundVar _ uv) res_ty = tcUnboundId e uv res_ty -tcExpr e@(HsApp {}) res_ty = tcApp e res_ty -tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty +-- Use tcApp to typecheck appplications, which are treated specially +-- by Quick Look. Specifically: +-- - HsApp: value applications +-- - HsTypeApp: type applications +-- - HsVar: lone variables, to ensure that they can get an +-- impredicative instantiation (via Quick Look +-- driven by res_ty (in checking mode). +-- - ExprWithTySig: (e :: type) +-- 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@(HsAppType {}) res_ty = tcApp e res_ty +tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty +tcExpr e@(HsRecFld {}) res_ty = 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 e@(HsUnboundVar _ occ) res_ty + = do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (#12531) + ; name <- newSysName occ + ; let ev = mkLocalId name Many ty + ; emitNewExprHole occ ev ty + ; tcWrapResultO (UnboundOccurrenceOf occ) e + (HsUnboundVar ev occ) ty res_ty } 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 expr) res_ty = do { expr' <- tcLExprNC expr res_ty - ; return (HsPar x expr') } +tcExpr (HsPar x expr) res_ty + = do { expr' <- tcMonoExprNC expr res_ty + ; return (HsPar x expr') } tcExpr (HsPragE x prag expr) res_ty - = do { expr' <- tcLExpr expr res_ty + = do { expr' <- tcMonoExpr expr res_ty ; return (HsPragE x (tcExprPrag prag) expr') } tcExpr (HsOverLit x lit) res_ty @@ -229,7 +221,7 @@ 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 $ tcLExpr expr (mkCheckExpType arg_ty) + tcScalingUsage arg_mult $ tcCheckMonoExpr expr arg_ty ; return (NegApp x expr' neg_expr') } tcExpr e@(HsIPVar _ x) res_ty @@ -297,10 +289,6 @@ tcExpr e@(HsLamCase x matches) res_ty , text "requires"] match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } -tcExpr e@(ExprWithTySig _ expr hs_ty) res_ty - = do { (expr', poly_ty) <- tcExprWithSig expr hs_ty - ; tcWrapResult e expr' poly_ty res_ty } - {- Note [Type-checking overloaded labels] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -345,102 +333,10 @@ With PostfixOperators we don't actually require the function to take two arguments at all. For example, (x `not`) means (not x); you get postfix operators! Not Haskell 98, but it's less work and kind of useful. - -Note [Typing rule for ($)] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -People write - runST $ blah -so much, where - runST :: (forall s. ST s a) -> a -that I have finally given in and written a special type-checking -rule just for saturated applications of ($). - * Infer the type of the first argument - * Decompose it; should be of form (arg2_ty -> res_ty), - where arg2_ty might be a polytype - * Use arg2_ty to typecheck arg2 -} -tcExpr expr@(OpApp fix arg1 op arg2) res_ty - | (L loc (HsVar _ (L lv op_name))) <- op - , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] - = do { traceTc "Application rule" (ppr op) - ; (arg1', arg1_ty) <- addErrCtxt (funAppCtxt op arg1 1) $ - tcInferRhoNC arg1 - - ; let doc = text "The first argument of ($) takes" - orig1 = lexprCtOrigin arg1 - ; (wrap_arg1, [arg2_sigma], op_res_ty) <- - matchActualFunTysRho doc orig1 (Just (unLoc arg1)) 1 arg1_ty - - ; mult_wrap <- tcSubMult AppOrigin Many (scaledMult arg2_sigma) - -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. - -- - -- When ($) becomes multiplicity-polymorphic, then the above check will - -- need to go. But in the meantime, it would produce ill-typed - -- desugared code to accept linear functions to the left of a ($). - - -- We have (arg1 $ arg2) - -- So: arg1_ty = arg2_ty -> op_res_ty - -- where arg2_sigma maybe polymorphic; that's the point - - ; arg2' <- tcArg nl_op arg2 arg2_sigma 2 - - -- Make sure that the argument type has kind '*' - -- ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b - -- Eg we do not want to allow (D# $ 4.0#) #5570 - -- (which gives a seg fault) - ; _ <- unifyKind (Just (XHsType $ NHsCoreTy (scaledThing arg2_sigma))) - (tcTypeKind (scaledThing arg2_sigma)) liftedTypeKind - -- Ignore the evidence. arg2_sigma must have type * or #, - -- because we know (arg2_sigma -> op_res_ty) is well-kinded - -- (because otherwise matchActualFunTysRho would fail) - -- So this 'unifyKind' will either succeed with Refl, or will - -- produce an insoluble constraint * ~ #, which we'll report later. - - -- NB: unlike the argument type, the *result* type, op_res_ty can - -- have any kind (#8739), so we don't need to check anything for that - - ; op_id <- tcLookupId op_name - ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep op_res_ty - , scaledThing arg2_sigma - , op_res_ty]) - (HsVar noExtField (L lv op_id))) - -- arg1' :: arg1_ty - -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty) - -- op' :: (a2_ty -> op_res_ty) -> a2_ty -> op_res_ty - - expr' = OpApp fix (mkLHsWrap (wrap_arg1 <.> mult_wrap) arg1') op' arg2' - - ; tcWrapResult expr expr' op_res_ty res_ty } - - | L loc (HsRecFld _ (Ambiguous _ lbl)) <- op - , Just sig_ty <- obviousSig (unLoc arg1) - -- See Note [Disambiguating record fields] - = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty - ; sel_name <- disambiguateSelector lbl sig_tc_ty - ; let op' = L loc (HsRecFld noExtField (Unambiguous sel_name lbl)) - ; tcExpr (OpApp fix arg1 op' arg2) res_ty - } - - | otherwise - = do { traceTc "Non Application rule" (ppr op) - ; (op', op_ty) <- tcInferRhoNC op - - ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) - <- matchActualFunTysRho (mk_op_msg op) fn_orig - (Just (unLoc op)) 2 op_ty - -- You might think we should use tcInferApp here, but there is - -- too much impedance-matching, because tcApp may return wrappers as - -- well as type-checked arguments. - - ; arg1' <- tcArg nl_op arg1 arg1_ty 1 - ; arg2' <- tcArg nl_op arg2 arg2_ty 2 - - ; let expr' = OpApp fix arg1' (mkLHsWrap wrap_fun op') arg2' - ; tcWrapResult expr expr' op_res_ty res_ty } - where - fn_orig = exprCtOrigin nl_op - nl_op = unLoc op +tcExpr expr@(OpApp {}) res_ty + = tcApp expr res_ty -- Right sections, equivalent to \ x -> x `op` expr, or -- \ x -> op x expr @@ -449,8 +345,8 @@ tcExpr expr@(SectionR x op arg2) res_ty = do { (op', op_ty) <- tcInferRhoNC op ; (wrap_fun, [Scaled arg1_mult arg1_ty, arg2_ty], op_res_ty) <- matchActualFunTysRho (mk_op_msg op) fn_orig - (Just (unLoc op)) 2 op_ty - ; arg2' <- tcArg (unLoc op) arg2 arg2_ty 2 + (Just (ppr op)) 2 op_ty + ; arg2' <- tcValArg (unLoc op) arg2 arg2_ty 2 ; let expr' = SectionR x (mkLHsWrap wrap_fun op') arg2' act_res_ty = mkVisFunTy arg1_mult arg1_ty op_res_ty ; tcWrapResultMono expr expr' act_res_ty res_ty } @@ -469,8 +365,8 @@ tcExpr expr@(SectionL x arg1 op) res_ty ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty) <- matchActualFunTysRho (mk_op_msg op) fn_orig - (Just (unLoc op)) n_reqd_args op_ty - ; arg1' <- tcArg (unLoc op) arg1 arg1_ty 1 + (Just (ppr op)) n_reqd_args op_ty + ; arg1' <- tcValArg (unLoc op) arg1 arg1_ty 1 ; let expr' = SectionL x arg1' (mkLHsWrap wrap_fn op') act_res_ty = mkVisFunTys arg_tys op_res_ty ; tcWrapResultMono expr expr' act_res_ty res_ty } @@ -510,7 +406,7 @@ tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty ; let expr' = ExplicitTuple x tup_args1 boxity missing_tys = [Scaled mult ty | (L _ (Missing (Scaled mult _)), ty) <- zip tup_args1 arg_tys] - -- See Note [Linear fields generalization] + -- See Note [Linear fields generalization] in GHC.Tc.Gen.App act_res_ty = mkVisFunTys missing_tys (mkTupleTy1 boxity arg_tys) -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make @@ -565,7 +461,7 @@ tcExpr (ExplicitList _ witness exprs) res_ty tcExpr (HsLet x (L l binds) expr) res_ty = do { (binds', expr') <- tcLocalBinds binds $ - tcLExpr expr res_ty + tcMonoExpr expr res_ty ; return (HsLet x (L l binds') expr') } tcExpr (HsCase x scrut matches) res_ty @@ -598,9 +494,9 @@ tcExpr (HsCase x scrut matches) res_ty mc_body = tcBody } tcExpr (HsIf x pred b1 b2) res_ty - = do { pred' <- tcLExpr pred (mkCheckExpType boolTy) - ; (u1,b1') <- tcCollectingUsage $ tcLExpr b1 res_ty - ; (u2,b2') <- tcCollectingUsage $ tcLExpr 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') } @@ -858,7 +754,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty -- -- This should definitely *not* typecheck. - -- STEP -1 See Note [Disambiguating record fields] + -- STEP -1 See Note [Disambiguating record fields] in GHC.Tc.Gen.Head -- After this we know that rbinds is unambiguous ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds @@ -929,7 +825,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty -- Check that we're not dealing with a unidirectional pattern -- synonym ; unless (isJust $ conLikeWrapId_maybe con1) - (nonBidirectionalErr (conLikeName con1)) + (nonBidirectionalErr (conLikeName con1)) -- STEP 3 Note [Criteria for update] -- Check that each updated field is polymorphic; that is, its type @@ -972,7 +868,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty scrut_ty = TcType.substTy scrut_subst con1_res_ty con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys - ; co_scrut <- unifyType (Just (unLoc record_expr)) record_rho scrut_ty + ; co_scrut <- unifyType (Just (ppr record_expr)) record_rho scrut_ty -- NB: normal unification is OK here (as opposed to subsumption), -- because for this to work out, both record_rho and scrut_ty have -- to be normal datatypes -- no contravariant stuff can go on @@ -1012,8 +908,6 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty ; tcWrapResult expr expr' rec_res_ty res_ty } -tcExpr e@(HsRecFld _ f) res_ty - = tcCheckRecSelId e f res_ty {- ************************************************************************ @@ -1069,37 +963,11 @@ tcExpr (XExpr (HsExpanded a b)) t ************************************************************************ -} -tcExpr other _ = pprPanic "tcLExpr" (ppr other) +tcExpr other _ = pprPanic "tcExpr" (ppr other) -- Include ArrForm, ArrApp, which shouldn't appear at all -- Also HsTcBracketOut, HsQuasiQuoteE -{- ********************************************************************* -* * - Pragmas on expressions -* * -********************************************************************* -} - -tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc -tcExprPrag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann - - -{- ********************************************************************* -* * - Expression with type signature e::ty -* * -********************************************************************* -} - -tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn) - -> TcM (HsExpr GhcTc, TcSigmaType) -tcExprWithSig expr hs_ty - = do { sig_info <- checkNoErrs $ -- Avoid error cascade - tcUserTypeSig loc hs_ty Nothing - ; (expr', poly_ty) <- tcExprSig expr sig_info - ; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) } - where - loc = getLoc (hsSigWcType hs_ty) - {- ************************************************************************ * * @@ -1160,400 +1028,13 @@ arithSeqEltType (Just fl) res_ty \ [elt_ty] [elt_mult] -> return (elt_mult, elt_ty) ; return (idHsWrapper, elt_mult, elt_ty, Just fl') } -{- -************************************************************************ -* * - Applications -* * -************************************************************************ --} - -{- Note [Typechecking applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We typecheck application chains (f e1 @ty e2) specially: - -* So we can report errors like "in the third arument of a call of f" - -* So we can do Visible Type Application (VTA), for which we must not - eagerly instantiate the function part of the application. - -* So that we can do Quick Look impredicativity. - -The idea is: - -* Use collectHsArgs, which peels off - HsApp, HsTypeApp, HsPrag, HsPar - returning the function in the corner and the arguments - -* Use tcInferAppHead to infer the type of the fuction, - as an (uninstantiated) TcSigmaType - There are special cases for - HsVar, HsREcFld, and ExprWithTySig - Otherwise, delegate back to tcExpr, which - infers an (instantiated) TcRhoType - -Some cases that /won't/ work: - -1. Consider this (which uses visible type application): - - (let { f :: forall a. a -> a; f x = x } in f) @Int - - Since 'let' is not among the special cases for tcInferAppHead, - we'll delegate back to tcExpr, which will instantiate f's type - and the type application to @Int will fail. Too bad! - --} - --- HsExprArg is a very local type, used only within this module. --- It's really a zipper for an application chain --- It's a GHC-specific type, so using TTG only where necessary -data HsExprArg id - = HsEValArg SrcSpan -- Of the function - (LHsExpr (GhcPass id)) - | HsETypeArg SrcSpan -- Of the function - (LHsWcType (NoGhcTc (GhcPass id))) - !(XExprTypeArg id) - | HsEPrag SrcSpan - (HsPragE (GhcPass id)) - | HsEPar SrcSpan -- Of the nested expr - | HsEWrap !(XArgWrap id) -- Wrapper, after typechecking only - --- The outer location is the location of the application itself -type LHsExprArgIn = HsExprArg 'Renamed -type LHsExprArgOut = HsExprArg 'Typechecked - -instance OutputableBndrId id => Outputable (HsExprArg id) where - ppr (HsEValArg _ tm) = ppr tm - ppr (HsEPrag _ p) = text "HsPrag" <+> ppr p - ppr (HsETypeArg _ hs_ty _) = char '@' <> ppr hs_ty - ppr (HsEPar _) = text "HsEPar" - ppr (HsEWrap w) = case ghcPass @id of - GhcTc -> text "HsEWrap" <+> ppr w -#if __GLASGOW_HASKELL__ <= 900 - _ -> empty -#endif - -type family XExprTypeArg id where - XExprTypeArg 'Parsed = NoExtField - XExprTypeArg 'Renamed = NoExtField - XExprTypeArg 'Typechecked = Type - -type family XArgWrap id where - XArgWrap 'Parsed = NoExtCon - XArgWrap 'Renamed = NoExtCon - XArgWrap 'Typechecked = HsWrapper - -addArgWrap :: HsWrapper -> [LHsExprArgOut] -> [LHsExprArgOut] -addArgWrap wrap args - | isIdHsWrapper wrap = args - | otherwise = HsEWrap wrap : args - -collectHsArgs :: HsExpr GhcRn -> (HsExpr GhcRn, [LHsExprArgIn]) -collectHsArgs e = go e [] - where - go (HsPar _ (L l fun)) args = go fun (HsEPar l : args) - go (HsPragE _ p (L l fun)) args = go fun (HsEPrag l p : args) - go (HsApp _ (L l fun) arg) args = go fun (HsEValArg l arg : args) - go (HsAppType _ (L l fun) hs_ty) args = go fun (HsETypeArg l hs_ty noExtField : args) - go e args = (e,args) - -applyHsArgs :: HsExpr GhcTc -> [LHsExprArgOut]-> HsExpr GhcTc -applyHsArgs fun args - = go fun args - where - go fun [] = fun - go fun (HsEWrap wrap : args) = go (mkHsWrap wrap fun) args - go fun (HsEValArg l arg : args) = go (HsApp noExtField (L l fun) arg) args - go fun (HsETypeArg l hs_ty ty : args) = go (HsAppType ty (L l fun) hs_ty) args - go fun (HsEPar l : args) = go (HsPar noExtField (L l fun)) args - go fun (HsEPrag l p : args) = go (HsPragE noExtField p (L l fun)) args - -isHsValArg :: HsExprArg id -> Bool -isHsValArg (HsEValArg {}) = True -isHsValArg _ = False - -isArgPar :: HsExprArg id -> Bool -isArgPar (HsEPar {}) = True -isArgPar _ = False - -getFunLoc :: [HsExprArg 'Renamed] -> Maybe SrcSpan -getFunLoc [] = Nothing -getFunLoc (a:_) = Just $ case a of - HsEValArg l _ -> l - HsETypeArg l _ _ -> l - HsEPrag l _ -> l - HsEPar l -> l - ---------------------------- -tcApp :: HsExpr GhcRn -- either HsApp or HsAppType - -> ExpRhoType -> TcM (HsExpr GhcTc) --- See Note [Typechecking applications] -tcApp expr res_ty - = do { (fun, args, app_res_ty) <- tcInferApp expr - ; if isTagToEnum fun - then tcTagToEnum expr fun args app_res_ty res_ty - -- Done here because we have res_ty, - -- whereas tcInferApp does not - else - - -- The wildly common case - do { let expr' = applyHsArgs fun args - ; addFunResCtxt True fun app_res_ty res_ty $ - tcWrapResult expr expr' app_res_ty res_ty } } - ---------------------------- -tcInferApp :: HsExpr GhcRn - -> TcM ( HsExpr GhcTc -- Function - , [LHsExprArgOut] -- Arguments - , TcSigmaType) -- Inferred type: a sigma-type! --- Also used by Module.tcRnExpr to implement GHCi :type -tcInferApp expr - | -- Gruesome special case for ambiguous record selectors - HsRecFld _ fld_lbl <- fun - , Ambiguous _ lbl <- fld_lbl -- Still ambiguous - , HsEValArg _ (L _ arg) : _ <- filterOut isArgPar args -- A value arg is first - , Just sig_ty <- obviousSig arg -- A type sig on the arg disambiguates - = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty - ; sel_name <- disambiguateSelector lbl sig_tc_ty - ; (tc_fun, fun_ty) <- tcInferRecSelId (Unambiguous sel_name lbl) - ; tcInferApp_finish fun tc_fun fun_ty args } - - | otherwise -- The wildly common case - = do { (tc_fun, fun_ty) <- set_fun_loc (tcInferAppHead fun) - ; tcInferApp_finish fun tc_fun fun_ty args } - where - (fun, args) = collectHsArgs expr - set_fun_loc thing_inside - = case getFunLoc args of - Nothing -> thing_inside -- Don't set the location twice - Just loc -> setSrcSpan loc thing_inside - -tcInferApp_finish - :: HsExpr GhcRn -- Renamed function - -> HsExpr GhcTc -> TcSigmaType -- Function and its type - -> [LHsExprArgIn] -- Arguments - -> TcM (HsExpr GhcTc, [LHsExprArgOut], TcSigmaType) -tcInferApp_finish rn_fun tc_fun fun_sigma rn_args - = do { (tc_args, actual_res_ty) <- tcArgs rn_fun fun_sigma rn_args - ; return (tc_fun, tc_args, actual_res_ty) } - -mk_op_msg :: LHsExpr GhcRn -> SDoc -mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes" - ----------------- -tcInferAppHead :: HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) --- Infer type of the head of an application, returning a /SigmaType/ --- i.e. the 'f' in (f e1 ... en) --- We get back a SigmaType because we have special cases for --- * A bare identifier (just look it up) --- This case also covers a record selectro HsRecFld --- * An expression with a type signature (e :: ty) --- --- Note that [] and (,,) are both HsVar: --- see Note [Empty lists] and [ExplicitTuple] in GHC.Hs.Expr --- --- NB: 'e' cannot be HsApp, HsTyApp, HsPrag, HsPar, because those --- cases are dealt with by collectHsArgs. --- --- See Note [Typechecking applications] -tcInferAppHead e - = case e of - HsVar _ (L _ nm) -> tcInferId nm - HsRecFld _ f -> tcInferRecSelId f - ExprWithTySig _ e hs_ty -> add_ctxt $ tcExprWithSig e hs_ty - _ -> add_ctxt $ tcInfer (tcExpr e) - where - add_ctxt thing = addErrCtxt (exprCtxt e) thing - ----------------- --- | Type-check the arguments to a function, possibly including visible type --- applications -tcArgs :: HsExpr GhcRn -- ^ The function itself (for err msgs only) - -> TcSigmaType -- ^ the (uninstantiated) type of the function - -> [LHsExprArgIn] -- ^ the args - -> TcM ([LHsExprArgOut], TcSigmaType) - -- ^ (a wrapper for the function, the tc'd args, result type) -tcArgs fun orig_fun_ty orig_args - = go 1 [] orig_fun_ty orig_args - where - fun_orig = exprCtOrigin fun - herald = sep [ text "The function" <+> quotes (ppr fun) - , text "is applied to"] - - -- Count value args only when complaining about a function - -- applied to too many value args - -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify. - n_val_args = count isHsValArg orig_args - - fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] - = case fun of - HsUnboundVar {} -> True - _ -> False - - go :: Int -- Which argment number this is (incl type args) - -> [Scaled TcSigmaType] -- Value args to which applied so far - -> TcSigmaType - -> [LHsExprArgIn] -> TcM ([LHsExprArgOut], TcSigmaType) - go _ _ fun_ty [] = traceTc "tcArgs:ret" (ppr fun_ty) >> return ([], fun_ty) - - go n so_far fun_ty (HsEPar sp : args) - = do { (args', res_ty) <- go n so_far fun_ty args - ; return (HsEPar sp : args', res_ty) } - - go n so_far fun_ty (HsEPrag sp prag : args) - = do { (args', res_ty) <- go n so_far fun_ty args - ; return (HsEPrag sp (tcExprPrag prag) : args', res_ty) } - - go n so_far fun_ty (HsETypeArg loc hs_ty_arg _ : args) - | fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] - = go (n+1) so_far fun_ty args - - | otherwise - = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty - -- wrap1 :: fun_ty "->" upsilon_ty - ; case tcSplitForAllTy_maybe upsilon_ty of - Just (tvb, inner_ty) - | binderArgFlag tvb == Specified -> - -- It really can't be Inferred, because we've justn - -- instantiated those. But, oddly, it might just be Required. - -- See Note [Required quantifiers in the type of a term] - do { let tv = binderVar tvb - kind = tyVarKind tv - ; ty_arg <- tcHsTypeApp hs_ty_arg kind - - ; inner_ty <- zonkTcType inner_ty - -- See Note [Visible type application zonk] - ; let in_scope = mkInScopeSet (tyCoVarsOfTypes [upsilon_ty, ty_arg]) - insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty - -- NB: tv and ty_arg have the same kind, so this - -- substitution is kind-respecting - ; traceTc "VTA" (vcat [ppr tv, debugPprType kind - , debugPprType ty_arg - , debugPprType (tcTypeKind ty_arg) - , debugPprType inner_ty - , debugPprType insted_ty ]) - - ; (args', res_ty) <- go (n+1) so_far insted_ty args - ; return ( addArgWrap wrap1 $ HsETypeArg loc hs_ty_arg ty_arg : args' - , res_ty ) } - _ -> ty_app_err upsilon_ty hs_ty_arg } - - go n so_far fun_ty (HsEValArg loc arg : args) - = do { (wrap, arg_ty, res_ty) - <- matchActualFunTySigma herald fun_orig (Just fun) - (n_val_args, so_far) fun_ty - ; arg' <- tcArg fun arg arg_ty n - ; (args', inner_res_ty) <- go (n+1) (arg_ty:so_far) res_ty args - ; return ( addArgWrap wrap $ HsEValArg loc arg' : args' - , inner_res_ty ) } - - ty_app_err ty arg - = do { (_, ty) <- zonkTidyTcType emptyTidyEnv ty - ; failWith $ - text "Cannot apply expression of type" <+> quotes (ppr ty) $$ - text "to a visible type argument" <+> quotes (ppr arg) } - -{- Note [Required quantifiers in the type of a term] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#15859) - - data A k :: k -> Type -- A :: forall k -> k -> Type - type KindOf (a :: k) = k -- KindOf :: forall k. k -> Type - a = (undefind :: KindOf A) @Int - -With ImpredicativeTypes (thin ice, I know), we instantiate -KindOf at type (forall k -> k -> Type), so - KindOf A = forall k -> k -> Type -whose first argument is Required - -We want to reject this type application to Int, but in earlier -GHCs we had an ASSERT that Required could not occur here. - -The ice is thin; c.f. Note [No Required TyCoBinder in terms] -in GHC.Core.TyCo.Rep. - -Note [VTA for out-of-scope functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose 'wurble' is not in scope, and we have - (wurble @Int @Bool True 'x') - -Then the renamer will make (HsUnboundVar "wurble) for 'wurble', -and the typechecker will typecheck it with tcUnboundId, giving it -a type 'alpha', and emitting a deferred Hole, to be reported later. - -But then comes the visible type application. If we do nothing, we'll -generate an immediate failure (in tc_app_err), saying that a function -of type 'alpha' can't be applied to Bool. That's insane! And indeed -users complain bitterly (#13834, #17150.) - -The right error is the Hole, which has /already/ been emitted by -tcUnboundId. It later reports 'wurble' as out of scope, and tries to -give its type. - -Fortunately in tcArgs we still have access to the function, so we can -check if it is a HsUnboundVar. We use this info to simply skip over -any visible type arguments. We've already inferred the type of the -function, so we'll /already/ have emitted a Hole; -failing preserves that constraint. - -We do /not/ want to fail altogether in this case (via failM) becuase -that may abandon an entire instance decl, which (in the presence of --fdefer-type-errors) leads to leading to #17792. - -Downside; the typechecked term has lost its visible type arguments; we -don't even kind-check them. But let's jump that bridge if we come to -it. Meanwhile, let's not crash! - -Note [Visible type application zonk] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg). - -* tcHsTypeApp only guarantees that - - ty_arg is zonked - - kind(zonk(tv)) = kind(ty_arg) - (checkExpectedKind zonks as it goes). - -So we must zonk inner_ty as well, to guarantee consistency between zonk(tv) -and inner_ty. Otherwise we can build an ill-kinded type. An example was -#14158, where we had: - id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a -and we had the visible type application - id @(->) - -* We instantiated k := kappa, yielding - forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a -* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *). -* That instantiated (->) as ((->) q1 q1), and unified kappa := q1, - Here q1 :: RuntimeRep -* Now we substitute - cat :-> (->) q1 q1 :: TYPE q1 -> TYPE q1 -> * - but we must first zonk the inner_ty to get - forall (a :: TYPE q1). cat a a - so that the result of substitution is well-kinded - Failing to do so led to #14158. --} - ----------------- -tcArg :: HsExpr GhcRn -- The function (for error messages) - -> LHsExpr GhcRn -- Actual arguments - -> Scaled TcSigmaType -- expected arg type - -> Int -- # of argument - -> TcM (LHsExpr GhcTc) -- Resulting argument -tcArg fun arg (Scaled mult ty) arg_no - = addErrCtxt (funAppCtxt fun arg arg_no) $ - do { traceTc "tcArg" $ - vcat [ ppr arg_no <+> text "of" <+> ppr fun - , text "arg type:" <+> ppr ty - , text "arg:" <+> ppr arg ] - ; tcScalingUsage mult $ tcCheckPolyExprNC arg ty } - ---------------- tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTc] tcTupArgs args tys = ASSERT( equalLength args tys ) mapM go (args `zip` tys) where - go (L l (Missing {}), arg_ty) = do { mult <- newFlexiTyVarTy multiplicityTy - ; return (L l (Missing (Scaled mult arg_ty))) } + go (L l (Missing {}), arg_ty) = do { mult <- newFlexiTyVarTy multiplicityTy + ; return (L l (Missing (Scaled mult arg_ty))) } go (L l (Present x expr), arg_ty) = do { expr' <- tcCheckPolyExpr expr arg_ty ; return (L l (Present x expr')) } @@ -1570,7 +1051,7 @@ tcSyntaxOp :: CtOrigin -> TcM (a, SyntaxExprTc) -- ^ Typecheck a syntax operator -- The operator is a variable or a lambda at this stage (i.e. renamer --- output) +-- output)t tcSyntaxOp orig expr arg_tys res_ty = tcSyntaxOpGen orig expr arg_tys (SynType res_ty) @@ -1583,7 +1064,9 @@ tcSyntaxOpGen :: CtOrigin -> ([TcSigmaType] -> [Mult] -> TcM a) -> TcM (a, SyntaxExprTc) tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside - = do { (expr, sigma) <- tcInferAppHead op + = do { (expr, sigma) <- tcInferAppHead op [] Nothing + -- Nothing here might be improved, 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 sigma arg_tys res_ty $ @@ -1756,497 +1239,14 @@ Here's an example where it actually makes a real difference With the change, f1 will type-check, because the 'Char' info from the signature is propagated into MkQ's argument. With the check in the other order, the extra signature in f2 is reqd. - -************************************************************************ -* * - Expressions with a type signature - expr :: type -* * -********************************************************************* -} - -tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType) -tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) - = setSrcSpan loc $ -- Sets the location for the implication constraint - do { let poly_ty = idType poly_id - ; (wrap, expr') <- tcSkolemiseScoped ExprSigCtxt poly_ty $ \rho_ty -> - tcCheckMonoExprNC expr rho_ty - ; return (mkLHsWrap wrap expr', poly_ty) } - -tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc }) - = setSrcSpan loc $ -- Sets the location for the implication constraint - do { (tclvl, wanted, (expr', sig_inst)) - <- pushLevelAndCaptureConstraints $ - do { sig_inst <- tcInstSig sig - ; expr' <- tcExtendNameTyVarEnv (mapSnd binderVar $ sig_inst_skols sig_inst) $ - tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $ - tcCheckPolyExprNC expr (sig_inst_tau sig_inst) - ; return (expr', sig_inst) } - -- See Note [Partial expression signatures] - ; let tau = sig_inst_tau sig_inst - infer_mode | null (sig_inst_theta sig_inst) - , isNothing (sig_inst_wcx sig_inst) - = ApplyMR - | otherwise - = NoRestrictions - ; (qtvs, givens, ev_binds, residual, _) - <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted - ; emitConstraints residual - - ; tau <- zonkTcType tau - ; let inferred_theta = map evVarPred givens - tau_tvs = tyCoVarsOfType tau - ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta - tau_tvs qtvs (Just sig_inst) - ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau - my_sigma = mkInvisForAllTys binders (mkPhiTy my_theta tau) - ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis. - then return idHsWrapper -- Fast path; also avoids complaint when we infer - -- an ambiguous type and have AllowAmbiguousType - -- e..g infer x :: forall a. F a -> Int - else tcSubTypeSigma ExprSigCtxt inferred_sigma my_sigma - - ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma) - ; let poly_wrap = wrap - <.> mkWpTyLams qtvs - <.> mkWpLams givens - <.> mkWpLet ev_binds - ; return (mkLHsWrap poly_wrap expr', my_sigma) } - - -{- Note [Partial expression signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Partial type signatures on expressions are easy to get wrong. But -here is a guiding principile - e :: ty -should behave like - let x :: ty - x = e - in x - -So for partial signatures we apply the MR if no context is given. So - e :: IO _ apply the MR - e :: _ => IO _ do not apply the MR -just like in GHC.Tc.Gen.Bind.decideGeneralisationPlan - -This makes a difference (#11670): - peek :: Ptr a -> IO CLong - peek ptr = peekElemOff undefined 0 :: _ -from (peekElemOff undefined 0) we get - type: IO w - constraints: Storable w - -We must NOT try to generalise over 'w' because the signature specifies -no constraints so we'll complain about not being able to solve -Storable w. Instead, don't generalise; then _ gets instantiated to -CLong, as it should. -} {- ********************************************************************* * * - tcInferId + Record bindings * * ********************************************************************* -} -tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc) -tcCheckId name res_ty - | name `hasKey` tagToEnumKey - = failWithTc (text "tagToEnum# must appear applied to one argument") - -- tcApp catches the case (tagToEnum# arg) - - | otherwise - = do { (expr, actual_res_ty) <- tcInferId name - ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty]) - ; addFunResCtxt False expr actual_res_ty res_ty $ - tcWrapResultO (OccurrenceOf name) (HsVar noExtField (noLoc name)) expr - actual_res_ty res_ty } - -tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -tcCheckRecSelId rn_expr f@(Unambiguous {}) res_ty - = do { (expr, actual_res_ty) <- tcInferRecSelId f - ; tcWrapResult rn_expr expr actual_res_ty res_ty } -tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty - = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of - Nothing -> ambiguousSelector lbl - Just (arg, _) -> do { sel_name <- disambiguateSelector lbl (scaledThing arg) - ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl) - res_ty } - ------------------------- -tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTc, TcRhoType) -tcInferRecSelId (Unambiguous sel (L _ lbl)) - = do { (expr', ty) <- tc_infer_id lbl sel - ; return (expr', ty) } -tcInferRecSelId (Ambiguous _ lbl) - = ambiguousSelector lbl - ------------------------- -tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType) --- Look up an occurrence of an Id --- Do not instantiate its type -tcInferId id_name - | id_name `hasKey` assertIdKey - = do { dflags <- getDynFlags - ; if gopt Opt_IgnoreAsserts dflags - then tc_infer_id (nameRdrName id_name) id_name - else tc_infer_assert id_name } - - | otherwise - = do { (expr, ty) <- tc_infer_id (nameRdrName id_name) id_name - ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty) - ; return (expr, ty) } - -tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcSigmaType) --- Deal with an occurrence of 'assert' --- See Note [Adding the implicit parameter to 'assert'] -tc_infer_assert assert_name - = do { assert_error_id <- tcLookupId assertErrorName - ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name) - (idType assert_error_id) - ; return (mkHsWrap wrap (HsVar noExtField (noLoc assert_error_id)), id_rho) - } - -tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTc, TcSigmaType) -tc_infer_id lbl id_name - = do { thing <- tcLookup id_name - ; case thing of - ATcId { tct_id = id } - -> do { check_naughty id -- Note [Local record selectors] - ; checkThLocalId id - ; tcEmitBindingUsage $ unitUE id_name One - ; return_id id } - - AGlobal (AnId id) - -> do { check_naughty id - ; return_id id } - -- A global cannot possibly be ill-staged - -- nor does it need the 'lifting' treatment - -- hence no checkTh stuff here - - AGlobal (AConLike cl) -> case cl of - RealDataCon con -> return_data_con con - PatSynCon ps -> tcPatSynBuilderOcc ps - - _ -> failWithTc $ - ppr thing <+> text "used where a value identifier was expected" } - where - return_id id = return (HsVar noExtField (noLoc id), idType id) - - return_data_con con - = do { let tvs = dataConUserTyVarBinders con - theta = dataConOtherTheta con - args = dataConOrigArgTys con - res = dataConOrigResTy con - - -- See Note [Linear fields generalization] - ; mul_vars <- newFlexiTyVarTys (length args) multiplicityTy - ; let scaleArgs args' = zipWithEqual "return_data_con" combine mul_vars args' - combine var (Scaled One ty) = Scaled var ty - combine _ scaled_ty = scaled_ty - -- The combine function implements the fact that, as - -- described in Note [Linear fields generalization], if a - -- field is not linear (last line) it isn't made polymorphic. - - etaWrapper arg_tys = foldr (\scaled_ty wr -> WpFun WpHole wr scaled_ty empty) WpHole arg_tys - - -- See Note [Instantiating stupid theta] - ; let shouldInstantiate = (not (null (dataConStupidTheta con)) || - isKindLevPoly (tyConResKind (dataConTyCon con))) - ; case shouldInstantiate of - True -> do { (subst, tvs') <- newMetaTyVars (binderVars tvs) - ; let tys' = mkTyVarTys tvs' - theta' = substTheta subst theta - args' = substScaledTys subst args - res' = substTy subst res - ; wrap <- instCall (OccurrenceOf id_name) tys' theta' - ; let scaled_arg_tys = scaleArgs args' - eta_wrap = etaWrapper scaled_arg_tys - ; addDataConStupidTheta con tys' - ; return ( mkHsWrap (eta_wrap <.> wrap) - (HsConLikeOut noExtField (RealDataCon con)) - , mkVisFunTys scaled_arg_tys res') - } - False -> let scaled_arg_tys = scaleArgs args - wrap1 = mkWpTyApps (mkTyVarTys $ binderVars tvs) - eta_wrap = etaWrapper (map unrestricted theta ++ scaled_arg_tys) - wrap2 = mkWpTyLams $ binderVars tvs - in return ( mkHsWrap (wrap2 <.> eta_wrap <.> wrap1) - (HsConLikeOut noExtField (RealDataCon con)) - , mkInvisForAllTys tvs $ mkInvisFunTysMany theta $ mkVisFunTys scaled_arg_tys res) - } - - check_naughty id - | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl) - | otherwise = return () - - -tcUnboundId :: HsExpr GhcRn -> OccName -> ExpRhoType -> TcM (HsExpr GhcTc) --- Typecheck an occurrence of an unbound Id --- --- Some of these started life as a true expression hole "_". --- Others might simply be variables that accidentally have no binding site --- --- We turn all of them into HsVar, since HsUnboundVar can't contain an --- Id; and indeed the evidence for the ExprHole does bind it, so it's --- not unbound any more! -tcUnboundId rn_expr occ res_ty - = do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (#12531) - ; name <- newSysName occ - ; let ev = mkLocalId name Many ty - ; emitNewExprHole occ ev ty - ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr - (HsVar noExtField (noLoc ev)) ty res_ty } - - -{- -Note [Adding the implicit parameter to 'assert'] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The typechecker transforms (assert e1 e2) to (assertError e1 e2). -This isn't really the Right Thing because there's no way to "undo" -if you want to see the original source code in the typechecker -output. We'll have fix this in due course, when we care more about -being able to reconstruct the exact original program. - -Note [tagToEnum#] -~~~~~~~~~~~~~~~~~ -Nasty check to ensure that tagToEnum# is applied to a type that is an -enumeration TyCon. Unification may refine the type later, but this -check won't see that, alas. It's crude, because it relies on our -knowing *now* that the type is ok, which in turn relies on the -eager-unification part of the type checker pushing enough information -here. In theory the Right Thing to do is to have a new form of -constraint but I definitely cannot face that! And it works ok as-is. - -Here's are two cases that should fail - f :: forall a. a - f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable - - g :: Int - g = tagToEnum# 0 -- Int is not an enumeration - -When data type families are involved it's a bit more complicated. - data family F a - data instance F [Int] = A | B | C -Then we want to generate something like - tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int] -Usually that coercion is hidden inside the wrappers for -constructors of F [Int] but here we have to do it explicitly. - -It's all grotesquely complicated. - -Note [Instantiating stupid theta] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Normally, when we infer the type of an Id, we don't instantiate, -because we wish to allow for visible type application later on. -But if a datacon has a stupid theta, we're a bit stuck. We need -to emit the stupid theta constraints with instantiated types. It's -difficult to defer this to the lazy instantiation, because a stupid -theta has no spot to put it in a type. So we just instantiate eagerly -in this case. Thus, users cannot use visible type application with -a data constructor sporting a stupid theta. I won't feel so bad for -the users that complain. - -Note [Linear fields generalization] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As per Note [Polymorphisation of linear fields], linear field of data -constructors get a polymorphic type when the data constructor is used as a term. - - Just :: forall {p} a. a #p-> Maybe a - -This rule is known only to the typechecker: Just keeps its linear type in Core. - -In order to desugar this generalised typing rule, we simply eta-expand: - - \a (x # p :: a) -> Just @a x - -has the appropriate type. We insert these eta-expansion with WpFun wrappers. - -A small hitch: if the constructor is levity-polymorphic (unboxed tuples, sums, -certain newtypes with -XUnliftedNewtypes) then this strategy produces - - \r1 r2 a b (x # p :: a) (y # q :: b) -> (# a, b #) - -Which has type - - forall r1 r2 a b. a #p-> b #q-> (# a, b #) - -Which violates the levity-polymorphism restriction see Note [Levity polymorphism -checking] in DsMonad. - -So we really must instantiate r1 and r2 rather than quantify over them. For -simplicity, we just instantiate the entire type, as described in Note -[Instantiating stupid theta]. It breaks visible type application with unboxed -tuples, sums and levity-polymorphic newtypes, but this doesn't appear to be used -anywhere. - -A better plan: let's force all representation variable to be *inferred*, so that -they are not subject to visible type applications. Then we can instantiate -inferred argument eagerly. --} - -isTagToEnum :: HsExpr GhcTc -> Bool -isTagToEnum (HsVar _ (L _ fun_id)) = fun_id `hasKey` tagToEnumKey -isTagToEnum _ = False - -tcTagToEnum :: HsExpr GhcRn -> HsExpr GhcTc -> [LHsExprArgOut] - -> TcSigmaType -> ExpRhoType - -> TcM (HsExpr GhcTc) --- tagToEnum# :: forall a. Int# -> a --- See Note [tagToEnum#] Urgh! -tcTagToEnum expr fun args app_res_ty res_ty - = do { res_ty <- readExpType res_ty - ; ty' <- zonkTcType res_ty - - -- Check that the type is algebraic - ; case tcSplitTyConApp_maybe ty' of { - Nothing -> do { addErrTc (mk_error ty' doc1) - ; vanilla_result } ; - Just (tc, tc_args) -> - - do { -- Look through any type family - ; fam_envs <- tcGetFamInstEnvs - ; case tcLookupDataFamInst_maybe fam_envs tc tc_args of { - Nothing -> do { check_enumeration ty' tc - ; vanilla_result } ; - Just (rep_tc, rep_args, coi) -> - - do { -- coi :: tc tc_args ~R rep_tc rep_args - check_enumeration ty' rep_tc - ; let val_arg = dropWhile (not . isHsValArg) args - rep_ty = mkTyConApp rep_tc rep_args - fun' = mkHsWrap (WpTyApp rep_ty) fun - expr' = applyHsArgs fun' val_arg - df_wrap = mkWpCastR (mkTcSymCo coi) - ; return (mkHsWrap df_wrap expr') }}}}} - - where - vanilla_result - = do { let expr' = applyHsArgs fun args - ; tcWrapResult expr expr' app_res_ty res_ty } - - check_enumeration ty' tc - | isEnumerationTyCon tc = return () - | otherwise = addErrTc (mk_error ty' doc2) - - doc1 = vcat [ text "Specify the type by giving a type signature" - , text "e.g. (tagToEnum# x) :: Bool" ] - doc2 = text "Result type must be an enumeration type" - - mk_error :: TcType -> SDoc -> SDoc - mk_error ty what - = hang (text "Bad call to tagToEnum#" - <+> text "at type" <+> ppr ty) - 2 what - -{- -************************************************************************ -* * - Template Haskell checks -* * -************************************************************************ --} - -checkThLocalId :: Id -> TcM () --- The renamer has already done checkWellStaged, --- in 'GHC.Rename.Splice.checkThLocalName', so don't repeat that here. --- Here we just add constraints fro cross-stage lifting -checkThLocalId id - = do { mb_local_use <- getStageAndBindLevel (idName id) - ; case mb_local_use of - Just (top_lvl, bind_lvl, use_stage) - | thLevel use_stage > bind_lvl - -> checkCrossStageLifting top_lvl id use_stage - _ -> return () -- Not a locally-bound thing, or - -- no cross-stage link - } - --------------------------------------- -checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM () --- If we are inside typed brackets, and (use_lvl > bind_lvl) --- we must check whether there's a cross-stage lift to do --- Examples \x -> [|| x ||] --- [|| map ||] --- --- This is similar to checkCrossStageLifting in GHC.Rename.Splice, but --- this code is applied to *typed* brackets. - -checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q)) - | isTopLevel top_lvl - = when (isExternalName id_name) (keepAlive id_name) - -- See Note [Keeping things alive for Template Haskell] in GHC.Rename.Splice - - | otherwise - = -- Nested identifiers, such as 'x' in - -- E.g. \x -> [|| h x ||] - -- We must behave as if the reference to x was - -- h $(lift x) - -- We use 'x' itself as the splice proxy, used by - -- the desugarer to stitch it all back together. - -- If 'x' occurs many times we may get many identical - -- bindings of the same splice proxy, but that doesn't - -- matter, although it's a mite untidy. - do { let id_ty = idType id - ; checkTc (isTauTy id_ty) (polySpliceErr id) - -- If x is polymorphic, its occurrence sites might - -- have different instantiations, so we can't use plain - -- 'x' as the splice proxy name. I don't know how to - -- solve this, and it's probably unimportant, so I'm - -- just going to flag an error for now - - ; lift <- if isStringTy id_ty then - do { sid <- tcLookupId GHC.Builtin.Names.TH.liftStringName - -- See Note [Lifting strings] - ; return (HsVar noExtField (noLoc sid)) } - else - setConstraintVar lie_var $ - -- Put the 'lift' constraint into the right LIE - newMethodFromName (OccurrenceOf id_name) - GHC.Builtin.Names.TH.liftName - [getRuntimeRep id_ty, id_ty] - - -- Update the pending splices - ; ps <- readMutVar ps_var - ; let pending_splice = PendingTcSplice id_name - (nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLoc lift)) - (nlHsVar id)) - ; writeMutVar ps_var (pending_splice : ps) - - ; return () } - where - id_name = idName id - -checkCrossStageLifting _ _ _ = return () - -polySpliceErr :: Id -> SDoc -polySpliceErr id - = text "Can't splice the polymorphic local variable" <+> quotes (ppr id) - -{- -Note [Lifting strings] -~~~~~~~~~~~~~~~~~~~~~~ -If we see $(... [| s |] ...) where s::String, we don't want to -generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc. -So this conditional short-circuits the lifting mechanism to generate -(liftString "xy") in that case. I didn't want to use overlapping instances -for the Lift class in TH.Syntax, because that can lead to overlapping-instance -errors in a polymorphic situation. - -If this check fails (which isn't impossible) we get another chance; see -Note [Converting strings] in "GHC.ThToHs" - -Local record selectors -~~~~~~~~~~~~~~~~~~~~~~ -Record selectors for TyCons in this module are ordinary local bindings, -which show up as ATcIds rather than AGlobals. So we need to check for -naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds. - - -************************************************************************ -* * -\subsection{Record bindings} -* * -************************************************************************ --} - getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet -- These tyvars must not change across the updates getFixedTyVars upd_fld_occs univ_tvs cons @@ -2271,129 +1271,9 @@ getFixedTyVars upd_fld_occs univ_tvs cons , (tv1,tv) <- univ_tvs `zip` u_tvs , tv `elemVarSet` fixed_tvs ] -{- -Note [Disambiguating record fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the -XDuplicateRecordFields extension is used, and the renamer -encounters a record selector or update that it cannot immediately -disambiguate (because it involves fields that belong to multiple -datatypes), it will defer resolution of the ambiguity to the -typechecker. In this case, the `Ambiguous` constructor of -`AmbiguousFieldOcc` is used. - -Consider the following definitions: - - data S = MkS { foo :: Int } - data T = MkT { foo :: Int, bar :: Int } - data U = MkU { bar :: Int, baz :: Int } - -When the renamer sees `foo` as a selector or an update, it will not -know which parent datatype is in use. - -For selectors, there are two possible ways to disambiguate: - -1. Check if the pushed-in type is a function whose domain is a - datatype, for example: - - f s = (foo :: S -> Int) s - - g :: T -> Int - g = foo - - This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`. - -2. Check if the selector is applied to an argument that has a type - signature, for example: - - h = foo (s :: S) - - This is checked by `tcApp`. - - -Updates are slightly more complex. The `disambiguateRecordBinds` -function tries to determine the parent datatype in three ways: - -1. Check for types that have all the fields being updated. For example: - - f x = x { foo = 3, bar = 2 } - - Here `f` must be updating `T` because neither `S` nor `U` have - both fields. This may also discover that no possible type exists. - For example the following will be rejected: - - f' x = x { foo = 3, baz = 3 } - -2. Use the type being pushed in, if it is already a TyConApp. The - following are valid updates to `T`: - - g :: T -> T - g x = x { foo = 3 } - - g' x = x { foo = 3 } :: T - -3. Use the type signature of the record expression, if it exists and - is a TyConApp. Thus this is valid update to `T`: - - h x = (x :: T) { foo = 3 } - - -Note that we do not look up the types of variables being updated, and -no constraint-solving is performed, so for example the following will -be rejected as ambiguous: - - let bad (s :: S) = foo s - - let r :: T - r = blah - in r { foo = 3 } - - \r. (r { foo = 3 }, r :: T ) - -We could add further tests, of a more heuristic nature. For example, -rather than looking for an explicit signature, we could try to infer -the type of the argument to a selector or the record expression being -updated, in case we are lucky enough to get a TyConApp straight -away. However, it might be hard for programmers to predict whether a -particular update is sufficiently obvious for the signature to be -omitted. Moreover, this might change the behaviour of typechecker in -non-obvious ways. - -See also Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat. --} - --- Given a RdrName that refers to multiple record fields, and the type --- of its argument, try to determine the name of the selector that is --- meant. -disambiguateSelector :: Located RdrName -> Type -> TcM Name -disambiguateSelector lr@(L _ rdr) parent_type - = do { fam_inst_envs <- tcGetFamInstEnvs - ; case tyConOf fam_inst_envs parent_type of - Nothing -> ambiguousSelector lr - Just p -> - do { xs <- lookupParents rdr - ; let parent = RecSelData p - ; case lookup parent xs of - Just gre -> do { addUsedGRE True gre - ; return (gre_name gre) } - Nothing -> failWithTc (fieldNotInType parent rdr) } } - --- This field name really is ambiguous, so add a suitable "ambiguous --- occurrence" error, then give up. -ambiguousSelector :: Located RdrName -> TcM a -ambiguousSelector (L _ rdr) - = do { addAmbiguousNameErr rdr - ; failM } - --- | This name really is ambiguous, so add a suitable "ambiguous --- occurrence" error, then continue -addAmbiguousNameErr :: RdrName -> TcM () -addAmbiguousNameErr rdr - = do { env <- getGlobalRdrEnv - ; let gres = lookupGRE_RdrName rdr env - ; setErrCtxt [] $ addNameClashErrRn rdr gres} -- Disambiguate the fields in a record update. --- See Note [Disambiguating record fields] +-- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType -> [LHsRecUpdField GhcRn] -> ExpRhoType -> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] @@ -2488,44 +1368,6 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty = L loc (Unambiguous i (L loc lbl)) } } --- Extract the outermost TyCon of a type, if there is one; for --- data families this is the representation tycon (because that's --- where the fields live). -tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon -tyConOf fam_inst_envs ty0 - = case tcSplitTyConApp_maybe ty of - Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys)) - Nothing -> Nothing - where - (_, _, ty) = tcSplitSigmaTy ty0 - --- Variant of tyConOf that works for ExpTypes -tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon -tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0 - --- For an ambiguous record field, find all the candidate record --- selectors (as GlobalRdrElts) and their parents. -lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)] -lookupParents rdr - = do { env <- getGlobalRdrEnv - ; let gres = lookupGRE_RdrName rdr env - ; mapM lookupParent gres } - where - lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt) - lookupParent gre = do { id <- tcLookupId (gre_name gre) - ; if isRecordSelector id - then return (recordSelectorTyCon id, gre) - else failWithTc (notSelector (gre_name gre)) } - --- A type signature on the argument of an ambiguous record selector or --- the record expression in an update must be "obvious", i.e. the --- outermost constructor ignoring parentheses. -obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn) -obviousSig (ExprWithTySig _ _ ty) = Just ty -obviousSig (HsPar _ p) = obviousSig (unLoc p) -obviousSig _ = Nothing - - {- Game plan for record bindings ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2538,7 +1380,7 @@ For each binding field = value 3. Instantiate the field type (from the field label) using the type envt from step 2. -4 Type check the value using tcArg, passing the field type as +4 Type check the value using tcValArg, passing the field type as the expected argument type. This extends OK when the field types are universally quantified. @@ -2678,103 +1520,8 @@ fieldCtxt :: FieldLabelString -> SDoc fieldCtxt field_name = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") -addExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a -addExprCtxt e thing_inside = addErrCtxt (exprCtxt (unLoc e)) thing_inside - -exprCtxt :: HsExpr GhcRn -> SDoc -exprCtxt expr = hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr)) - -addFunResCtxt :: Bool -- There is at least one argument - -> HsExpr GhcTc -> TcType -> ExpRhoType - -> TcM a -> TcM a --- When we have a mis-match in the return type of a function --- try to give a helpful message about too many/few arguments --- --- Used for naked variables too; but with has_args = False -addFunResCtxt has_args fun fun_res_ty env_ty - = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg) - -- NB: use a landmark error context, so that an empty context - -- doesn't suppress some more useful context - where - mk_msg - = do { mb_env_ty <- readExpType_maybe env_ty - -- by the time the message is rendered, the ExpType - -- will be filled in (except if we're debugging) - ; fun_res' <- zonkTcType fun_res_ty - ; env' <- case mb_env_ty of - Just env_ty -> zonkTcType env_ty - Nothing -> - do { dumping <- doptM Opt_D_dump_tc_trace - ; MASSERT( dumping ) - ; newFlexiTyVarTy liftedTypeKind } - ; let -- See Note [Splitting nested sigma types in mismatched - -- function types] - (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res' - -- No need to call tcSplitNestedSigmaTys here, since env_ty is - -- an ExpRhoTy, i.e., it's already instantiated. - (_, _, env_tau) = tcSplitSigmaTy env' - (args_fun, res_fun) = tcSplitFunTys fun_tau - (args_env, res_env) = tcSplitFunTys env_tau - n_fun = length args_fun - n_env = length args_env - info | n_fun == n_env = Outputable.empty - | n_fun > n_env - , not_fun res_env - = text "Probable cause:" <+> quotes (ppr fun) - <+> text "is applied to too few arguments" - - | has_args - , not_fun res_fun - = text "Possible cause:" <+> quotes (ppr fun) - <+> text "is applied to too many arguments" - - | otherwise - = Outputable.empty -- Never suggest that a naked variable is -- applied to too many args! - ; return info } - where - not_fun ty -- ty is definitely not an arrow type, - -- and cannot conceivably become one - = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> isAlgTyCon tc - Nothing -> False - -{- -Note [Splitting nested sigma types in mismatched function types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When one applies a function to too few arguments, GHC tries to determine this -fact if possible so that it may give a helpful error message. It accomplishes -this by checking if the type of the applied function has more argument types -than supplied arguments. - -Previously, GHC computed the number of argument types through tcSplitSigmaTy. -This is incorrect in the face of nested foralls, however! This caused Trac -#13311, for instance: - - f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b - -If one uses `f` like so: - - do { f; putChar 'a' } - -Then tcSplitSigmaTy will decompose the type of `f` into: - - Tyvars: [a] - Context: (Monoid a) - Argument types: [] - Return type: forall b. Monoid b => Maybe a -> Maybe b - -That is, it will conclude that there are *no* argument types, and since `f` -was given no arguments, it won't print a helpful error message. On the other -hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to: - - Tyvars: [a, b] - Context: (Monoid a, Monoid b) - Argument types: [Maybe a] - Return type: Maybe b - -So now GHC recognizes that `f` has one more argument type than it was actually -provided. --} +mk_op_msg :: LHsExpr GhcRn -> SDoc +mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes" badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc badFieldTypes prs @@ -2818,7 +1565,7 @@ badFieldsUpd rbinds data_cons -- For each field, which constructors contain the field? membership :: [(FieldLabelString, [Bool])] membership = sortMembership $ - map (\fld -> (fld, map (elementOfUniqSet fld) fieldLabelSets)) $ + map (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) $ map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds fieldLabelSets :: [UniqSet FieldLabelString] @@ -2858,16 +1605,6 @@ Finding the smallest subset is hard, so the code here makes a decent stab, no more. See #7989. -} -naughtyRecordSel :: RdrName -> SDoc -naughtyRecordSel sel_id - = text "Cannot use record selector" <+> quotes (ppr sel_id) <+> - text "as a function due to escaped type variables" $$ - text "Probable fix: use pattern-matching syntax instead" - -notSelector :: Name -> SDoc -notSelector field - = hsep [quotes (ppr field), text "is not a record selector"] - mixedSelectors :: [Id] -> [Id] -> SDoc mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) = ptext @@ -2918,10 +1655,6 @@ noPossibleParents rbinds badOverloadedUpdate :: SDoc badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature" -fieldNotInType :: RecSelParent -> RdrName -> SDoc -fieldNotInType p rdr - = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr - {- ************************************************************************ * * |