diff options
| author | CarrieMY <carrie.xmy@gmail.com> | 2022-05-25 16:43:03 +0200 |
|---|---|---|
| committer | sheaf <sam.derbyshire@gmail.com> | 2022-05-25 16:43:03 +0200 |
| commit | e74fc066cb33e5b7ae0d37cedb30230c597ef1ce (patch) | |
| tree | cc17cbbe235ada53bdac93e06cbfe4ca632ffa4a | |
| parent | 2ff18e390b119c611b3dd429b76cfcbf36ef9545 (diff) | |
| download | haskell-wip/T18802.tar.gz | |
Desugar RecordUpd in `tcExpr`wip/T18802
This patch typechecks record updates by desugaring them inside
the typechecker using the HsExpansion mechanism, and then typechecking
this desugared result.
Example:
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
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'
The desugared expression is put into an HsExpansion, and we typecheck
that.
The full details are given in Note [Record Updates] in GHC.Tc.Gen.Expr.
Fixes #2595 #3632 #10808 #10856 #16501 #18311 #18802 #21158 #21289
Updates haddock submodule
46 files changed, 1015 insertions, 762 deletions
diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index 0999c5d7d1..1416e231a9 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -44,7 +44,6 @@ module GHC.Core.Coercion ( mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo, mkKindCo, castCoercionKind, castCoercionKind1, castCoercionKind2, - mkFamilyTyConAppCo, mkHeteroCoercionType, mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, @@ -1614,29 +1613,6 @@ castCoercionKind g h1 h2 where (Pair t1 t2, r) = coercionKindRole g -mkFamilyTyConAppCo :: TyCon -> [CoercionN] -> CoercionN --- ^ Given a family instance 'TyCon' and its arg 'Coercion's, return the --- corresponding family 'Coercion'. E.g: --- --- > data family T a --- > data instance T (Maybe b) = MkT b --- --- Where the instance 'TyCon' is :RTL, so: --- --- > mkFamilyTyConAppCo :RTL (co :: a ~# Int) = T (Maybe a) ~# T (Maybe Int) --- --- cf. 'mkFamilyTyConApp' -mkFamilyTyConAppCo tc cos - | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc - , let tvs = tyConTyVars tc - fam_cos = assertPpr (tvs `equalLength` cos) (ppr tc <+> ppr cos) $ - map (liftCoSubstWith Nominal tvs cos) fam_tys - = mkTyConAppCo Nominal fam_tc fam_cos - | otherwise - = mkTyConAppCo Nominal tc cos - --- See Note [Newtype coercions] in GHC.Core.TyCon - mkPiCos :: Role -> [Var] -> Coercion -> Coercion mkPiCos r vs co = foldr (mkPiCo r) co vs diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index a4960ca555..76699dc4f3 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -163,21 +163,6 @@ instance Outputable SyntaxExprTc where ppr NoSyntaxExprTc = text "<no syntax expr>" --- | Extra data fields for a 'RecordUpd', added by the type checker -data RecordUpdTc = RecordUpdTc - { rupd_cons :: [ConLike] - -- Filled in by the type checker to the - -- _non-empty_ list of DataCons that have - -- all the upd'd fields - - , rupd_in_tys :: [Type] -- Argument types of *input* record type - , rupd_out_tys :: [Type] -- and *output* record type - -- For a data family, these are the type args of the - -- /representation/ type constructor - - , rupd_wrap :: HsWrapper -- See Note [Record Update HsWrapper] - } - -- | HsWrap appears only in typechecker output data HsWrap hs_syn = HsWrap HsWrapper -- the wrapper (hs_syn GhcTc) -- the thing that is wrapped @@ -397,7 +382,10 @@ type instance XRecordCon GhcTc = PostTcExpr -- Instantiated constructor fu type instance XRecordUpd GhcPs = EpAnn [AddEpAnn] type instance XRecordUpd GhcRn = NoExtField -type instance XRecordUpd GhcTc = RecordUpdTc +type instance XRecordUpd GhcTc = DataConCantHappen + -- We desugar record updates in the typechecker. + -- See [Handling overloaded and rebindable constructs], + -- and [Record Updates] in GHC.Tc.Gen.Expr. type instance XGetField GhcPs = EpAnnCO type instance XGetField GhcRn = NoExtField diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index 987e47f047..1904de63d4 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -395,7 +395,6 @@ deriving instance Data (ArithSeqInfo GhcPs) deriving instance Data (ArithSeqInfo GhcRn) deriving instance Data (ArithSeqInfo GhcTc) -deriving instance Data RecordUpdTc deriving instance Data CmdTopTc deriving instance Data PendingRnSplice deriving instance Data PendingTcSplice diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs index be1fd40ce0..b93d87a9b3 100644 --- a/compiler/GHC/Hs/Syn/Type.hs +++ b/compiler/GHC/Hs/Syn/Type.hs @@ -116,11 +116,7 @@ hsExprType (HsLet _ _ _ _ body) = lhsExprType body hsExprType (HsDo ty _ _) = ty hsExprType (ExplicitList ty _) = mkListTy ty hsExprType (RecordCon con_expr _ _) = hsExprType con_expr -hsExprType e@(RecordUpd (RecordUpdTc { rupd_cons = cons, rupd_out_tys = out_tys }) _ _) = - case cons of - con_like:_ -> conLikeResTy con_like out_tys - [] -> pprPanic "hsExprType: RecordUpdTc with empty rupd_cons" - (ppr e) +hsExprType (RecordUpd v _ _) = dataConCantHappen v hsExprType (HsGetField { gf_ext = v }) = dataConCantHappen v hsExprType (HsProjection { proj_ext = v }) = dataConCantHappen v hsExprType (ExprWithTySig _ e _) = lhsExprType e diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 8e2980edaa..e5bcd5959f 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -345,13 +345,17 @@ emptyRecStmtName :: (Anno [GenLocated ~ SrcSpanAnnL) => StmtLR GhcRn GhcRn bodyR emptyRecStmtId :: Stmt GhcTc (LocatedA (HsCmd GhcTc)) -mkRecStmt :: (Anno [GenLocated + +mkRecStmt :: forall (idL :: Pass) bodyR. + (Anno [GenLocated (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) (StmtLR (GhcPass idL) GhcPs bodyR)] ~ SrcSpanAnnL) => EpAnn AnnList -> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR] -> StmtLR (GhcPass idL) GhcPs bodyR +mkRecStmt anns stmts = (emptyRecStmt' anns :: StmtLR (GhcPass idL) GhcPs bodyR) + { recS_stmts = stmts } mkHsIntegral i = OverLit noExtField (HsIntegral i) @@ -438,7 +442,6 @@ emptyRecStmt = emptyRecStmt' noAnn emptyRecStmtName = emptyRecStmt' noExtField emptyRecStmtId = emptyRecStmt' unitRecStmtTc -- a panic might trigger during zonking -mkRecStmt anns stmts = (emptyRecStmt' anns) { recS_stmts = stmts } mkLetStmt :: EpAnn [AddEpAnn] -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b) mkLetStmt anns binds = LetStmt anns binds diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 6b8ced95ad..9d87eec5e0 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -32,7 +32,6 @@ import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs ) import GHC.HsToCore.Errors.Types import GHC.Types.SourceText import GHC.Types.Name -import GHC.Types.Name.Env import GHC.Core.FamInstEnv( topNormaliseType ) import GHC.HsToCore.Quote import GHC.Hs @@ -44,7 +43,6 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad import GHC.Core.Type import GHC.Core.TyCo.Rep -import GHC.Core.Multiplicity import GHC.Core.Coercion( instNewTyCon_maybe, mkSymCo ) import GHC.Core import GHC.Core.Utils @@ -54,14 +52,12 @@ import GHC.Driver.Session import GHC.Types.CostCentre import GHC.Types.Id import GHC.Types.Id.Make -import GHC.Types.Var.Env import GHC.Unit.Module import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Types.Basic -import GHC.Data.Maybe import GHC.Types.SrcLoc import GHC.Types.Tickish import GHC.Utils.Misc @@ -485,261 +481,7 @@ dsExpr (RecordCon { rcon_con = L _ con_like ; return (mkCoreApps con_expr' con_args) } -{- -Record update is a little harder. Suppose we have the decl: -\begin{verbatim} - data T = T1 {op1, op2, op3 :: Int} - | T2 {op4, op2 :: Int} - | T3 -\end{verbatim} -Then we translate as follows: -\begin{verbatim} - r { op2 = e } -===> - let op2 = e in - case r of - T1 op1 _ op3 -> T1 op1 op2 op3 - T2 op4 _ -> T2 op4 op2 - other -> recUpdError "M.hs/230" -\end{verbatim} -It's important that we use the constructor Ids for @T1@, @T2@ etc on the -RHSs, and do not generate a Core constructor application directly, because the constructor -might do some argument-evaluation first; and may have to throw away some -dictionaries. - -Note [Update for GADTs] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a b where - MkT :: { foo :: a } -> T a Int - - upd :: T s t -> s -> T s t - upd z y = z { foo = y} - -We need to get this: - $WMkT :: a -> T a Int - MkT :: (b ~# Int) => a -> T a b - - upd = /\s t. \(z::T s t) (y::s) -> - case z of - MkT (co :: t ~# Int) _ -> $WMkT @s y |> T (Refl s) (Sym co) - -Note the final cast - T (Refl s) (Sym co) :: T s Int ~ T s t -which uses co, bound by the GADT match. This is the wrap_co coercion -in wrapped_rhs. How do we produce it? - -* Start with raw materials - tc, the tycon: T - univ_tvs, the universally quantified tyvars of MkT: a,b - NB: these are in 1-1 correspondence with the tyvars of tc - -* Form univ_cos, a coercion for each of tc's args: (Refl s) (Sym co) - We replaced - a by (Refl s) since 's' instantiates 'a' - b by (Sym co) since 'b' is in the data-con's EqSpec - -* Then form the coercion T (Refl s) (Sym co) - -It gets more complicated when data families are involved (#18809). -Consider - data family F x - data instance F (a,b) where - MkF :: { foo :: Int } -> F (Int,b) - - bar :: F (s,t) -> Int -> F (s,t) - bar z y = z { foo = y} - -We have - data R:FPair a b where - MkF :: { foo :: Int } -> R:FPair Int b - - $WMkF :: Int -> F (Int,b) - MkF :: forall a b. (a ~# Int) => Int -> R:FPair a b - - bar :: F (s,t) -> Int -> F (s,t) - bar = /\s t. \(z::F (s,t)) \(y::Int) -> - case z |> co1 of - MkF (co2::s ~# Int) _ -> $WMkF @t y |> co3 - -(Side note: here (z |> co1) is built by typechecking the scrutinee, so -we ignore it here. In general the scrutinee is an arbitrary expression.) - -The question is: what is co3, the cast for the RHS? - co3 :: F (Int,t) ~ F (s,t) -Again, we can construct it using co2, bound by the GADT match. -We do /exactly/ the same as the non-family case up to building -univ_cos. But that gives us - rep_tc: R:FPair - univ_cos: (Sym co2) (Refl t) -But then we use mkTcFamilyTyConAppCo to "lift" this to the coercion -we want, namely - F (Sym co2, Refl t) :: F (Int,t) ~ F (s,t) - --} - -dsExpr RecordUpd { rupd_flds = Right _} = - -- Not possible due to elimination in the renamer. See Note - -- [Handling overloaded and rebindable constructs] - panic "The impossible happened" -dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields - , rupd_ext = RecordUpdTc - { rupd_cons = cons_to_upd - , rupd_in_tys = in_inst_tys - , rupd_out_tys = out_inst_tys - , rupd_wrap = dict_req_wrap }} ) - | null fields - = dsLExpr record_expr - | otherwise - = assertPpr (notNull cons_to_upd) (ppr expr) $ - - do { record_expr' <- dsLExpr record_expr - ; field_binds' <- mapM ds_field fields - ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding - upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds'] - - -- It's important to generate the match with matchWrapper, - -- and the right hand sides with applications of the wrapper Id - -- so that everything works when we are doing fancy unboxing on the - -- constructor arguments. - ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd - ; ([discrim_var], matching_code) - <- matchWrapper RecUpd (Just [record_expr]) -- See Note [Scrutinee in Record updates] - (MG { mg_alts = noLocA alts - , mg_ext = MatchGroupTc [unrestricted in_ty] out_ty - , mg_origin = FromSource - }) - -- FromSource is not strictly right, but we - -- want incomplete pattern-match warnings - - ; return (add_field_binds field_binds' $ - bindNonRec discrim_var record_expr' matching_code) } - where - ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr) - -- Clone the Id in the HsRecField, because its Name is that - -- of the record selector, and we must not make that a local binder - -- else we shadow other uses of the record selector - -- Hence 'lcl_id'. Cf #2735 - ds_field (L _ rec_field) - = do { rhs <- dsLExpr (hfbRHS rec_field) - ; let fld_id = unLoc (hsRecUpdFieldId rec_field) - ; lcl_id <- newSysLocalDs (idMult fld_id) (idType fld_id) - ; return (idName fld_id, lcl_id, rhs) } - - add_field_binds [] expr = expr - add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr) - - -- Awkwardly, for families, the match goes - -- from instance type to family type - (in_ty, out_ty) = - case (head cons_to_upd) of - RealDataCon data_con -> - let tycon = dataConTyCon data_con in - (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys) - PatSynCon pat_syn -> - ( patSynInstResTy pat_syn in_inst_tys - , patSynInstResTy pat_syn out_inst_tys) - mk_alt upd_fld_env con - = do { let (univ_tvs, ex_tvs, eq_spec, - prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con - arg_tys' = map (scaleScaled Many) arg_tys - -- Record updates consume the source record with multiplicity - -- Many. Therefore all the fields need to be scaled thus. - user_tvs = binderVars $ conLikeUserTyVarBinders con - - in_subst :: TCvSubst - in_subst = extendTCvInScopeList (zipTvSubst univ_tvs in_inst_tys) ex_tvs - -- The in_subst clones the universally quantified type - -- variables. It will be used to substitute into types that - -- contain existentials, however, so make sure to extend the - -- in-scope set with ex_tvs (#20278). - - out_tv_env :: TvSubstEnv - out_tv_env = zipTyEnv univ_tvs out_inst_tys - - -- I'm not bothering to clone the ex_tvs - ; eqs_vars <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec)) - ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta) - ; arg_ids <- newSysLocalsDs (substScaledTysUnchecked in_subst arg_tys') - ; let field_labels = conLikeFieldLabels con - val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg - field_labels arg_ids - mk_val_arg fl pat_arg_id - = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) - - inst_con = noLocA $ mkHsWrap wrap (mkConLikeTc con) - -- Reconstruct with the WrapId so that unpacking happens - wrap = mkWpEvVarApps theta_vars <.> - dict_req_wrap <.> - mkWpTyApps [ lookupVarEnv out_tv_env tv - `orElse` mkTyVarTy tv - | tv <- user_tvs ] - -- Be sure to use user_tvs (which may be ordered - -- differently than `univ_tvs ++ ex_tvs) above. - -- See Note [DataCon user type variable binders] - -- in GHC.Core.DataCon. - rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args - - -- Tediously wrap the application in a cast - -- Note [Update for GADTs] - wrapped_rhs = - case con of - RealDataCon data_con - | null eq_spec -> rhs - | otherwise -> mkLHsWrap (mkWpCastN wrap_co) rhs - -- This wrap is the punchline: Note [Update for GADTs] - where - rep_tc = dataConTyCon data_con - wrap_co = mkTcFamilyTyConAppCo rep_tc univ_cos - univ_cos = zipWithEqual "dsExpr:upd" mk_univ_co univ_tvs out_inst_tys - - mk_univ_co :: TyVar -- Universal tyvar from the DataCon - -> Type -- Corresponding instantiating type - -> Coercion - mk_univ_co univ_tv inst_ty - = case lookupVarEnv eq_spec_env univ_tv of - Just co -> co - Nothing -> mkTcNomReflCo inst_ty - - eq_spec_env :: VarEnv Coercion - eq_spec_env = mkVarEnv [ (eqSpecTyVar spec, mkTcSymCo (mkTcCoVarCo eqs_var)) - | (spec,eqs_var) <- zipEqual "dsExpr:upd2" eq_spec eqs_vars ] - - -- eq_spec is always null for a PatSynCon - PatSynCon _ -> rhs - - - req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys - - pat = noLocA $ ConPat { pat_con = noLocA con - , pat_args = PrefixCon [] $ map nlVarPat arg_ids - , pat_con_ext = ConPatTc - { cpt_tvs = ex_tvs - , cpt_dicts = eqs_vars ++ theta_vars - , cpt_binds = emptyTcEvBinds - , cpt_arg_tys = in_inst_tys - , cpt_wrap = req_wrap - } - } - ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) } - -{- Note [Scrutinee in Record updates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider #17783: - - data PartialRec = No - | Yes { a :: Int, b :: Bool } - update No = No - update r@(Yes {}) = r { b = False } - -In the context of pattern-match checking, the occurrence of @r@ in -@r { b = False }@ is to be treated as if it was a scrutinee, as can be seen by -the following desugaring: - - r { b = False } ==> case r of Yes a b -> Yes a False - -Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above. --} +dsExpr (RecordUpd x _ _) = dataConCantHappen x -- Here is where we desugar the Template Haskell brackets and escapes diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 055afd7e84..0323998ecb 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -23,7 +23,7 @@ free variables. -} module GHC.Rename.Expr ( - rnLExpr, rnExpr, rnStmts, + rnLExpr, rnExpr, rnStmts, mkExpandedExpr, AnnoBody ) where @@ -151,6 +151,41 @@ but several have a little bit of special treatment: on the fly, in GHC.Tc.Gen.Head.splitHsApps. RebindableSyntax does not affect this. +* RecordUpd: we desugar record updates into case expressions, + in GHC.Tc.Gen.Expr.tcExpr. + + Example: + + 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 + + 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' + + See Note [Record Updates] in GHC.Tc.Gen.Expr for more details. + + This is done in the typechecker, not the renamer, for two reasons: + + - (Until we implement GHC proposal #366) + We need to know the type of the record to disambiguate its fields. + + - We use the type signature of the data constructor to provide IdSigs + to the let-bound variables (x', y' in the example above). This is + needed to accept programs such as + + data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int } + foo r = r { f = \ k -> (k 3, k 'x') } + + in which an updated field has a higher-rank type. + See Wrinkle [Using IdSig] in Note [Record Updates] in GHC.Tc.Gen.Expr. + Note [Overloaded labels] ~~~~~~~~~~~~~~~~~~~~~~~~ For overloaded labels, note that we /only/ apply `fromLabel` to the @@ -1154,9 +1189,10 @@ rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = L _ rec_stmts })) thing_inside = do { (return_op, fvs1) <- lookupQualifiedDoStmtName ctxt returnMName ; (mfix_op, fvs2) <- lookupQualifiedDoStmtName ctxt mfixName ; (bind_op, fvs3) <- lookupQualifiedDoStmtName ctxt bindMName - ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op - , recS_mfix_fn = mfix_op - , recS_bind_fn = bind_op } + ; let empty_rec_stmt = (emptyRecStmtName :: StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) + { recS_ret_fn = return_op + , recS_mfix_fn = mfix_op + , recS_bind_fn = bind_op } -- Step1: Bring all the binders of the mdo into scope -- (Remember that this also removes the binders from the diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 4c1f2e59dc..bb6cedf395 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -21,6 +21,8 @@ module GHC.Rename.Utils ( badQualBndrErr, typeAppErr, badFieldConErr, wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType, genHsIntegralLit, genHsTyLit, genSimpleConPat, + genVarPat, genWildPat, + genSimpleFunBind, genFunBind, newLocalBndrRn, newLocalBndrsRn, @@ -55,7 +57,7 @@ import GHC.Types.SourceText ( SourceText(..), IntegralLit ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Types.Basic ( TopLevelFlag(..) ) +import GHC.Types.Basic ( TopLevelFlag(..), Origin(Generated) ) import GHC.Data.List.SetOps ( removeDups ) import GHC.Data.Maybe ( whenIsJust ) import GHC.Driver.Session @@ -680,12 +682,32 @@ genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit) genHsTyLit :: FastString -> HsType GhcRn genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText -genSimpleConPat :: Name -> [Name] -> LPat GhcRn --- The pattern (C x1 .. xn) -genSimpleConPat con args +genSimpleConPat :: Name -> [LPat GhcRn] -> LPat GhcRn +-- The pattern (C p1 .. pn) +genSimpleConPat con pats = wrapGenSpan $ ConPat { pat_con_ext = noExtField , pat_con = wrapGenSpan con - , pat_args = PrefixCon [] (map genVarPat args) } + , pat_args = PrefixCon [] pats } genVarPat :: Name -> LPat GhcRn genVarPat n = wrapGenSpan $ VarPat noExtField (wrapGenSpan n) + +genWildPat :: LPat GhcRn +genWildPat = wrapGenSpan $ WildPat noExtField + +genSimpleFunBind :: Name -> [LPat GhcRn] + -> LHsExpr GhcRn -> LHsBind GhcRn +genSimpleFunBind fun pats expr + = L gen $ genFunBind (L gen fun) + [mkMatch (mkPrefixFunRhs (L gen fun)) pats expr + emptyLocalBinds] + where + gen = noAnnSrcSpan generatedSrcSpan + +genFunBind :: LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)] + -> HsBind GhcRn +genFunBind fn ms + = FunBind { fun_id = fn + , fun_matches = mkMatchGroup Generated (wrapGenSpan ms) + , fun_ext = emptyNameSet + , fun_tick = [] } diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 182818616a..e1679d82d0 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -82,7 +82,7 @@ import GHC.Types.Error import GHC.Types.Hint (UntickedPromotedThing(..)) import GHC.Types.FieldLabel (FieldLabelString) import GHC.Types.ForeignCall (CLabelString) -import GHC.Types.Name (Name, OccName, getSrcLoc) +import GHC.Types.Name (Name, OccName, getSrcLoc, getSrcSpan) import GHC.Types.Name.Reader import GHC.Types.SrcLoc import GHC.Types.TyThing (TyThing) @@ -2950,14 +2950,15 @@ pprRelevantBindings :: RelevantBindings -> SDoc -- This function should be in "GHC.Tc.Errors.Ppr", -- but's it's here for the moment as it's needed in "GHC.Tc.Errors". pprRelevantBindings (RelevantBindings bds ran_out_of_fuel) = - ppUnless (null bds) $ + ppUnless (null rel_bds) $ hang (text "Relevant bindings include") - 2 (vcat (map ppr_binding bds) $$ ppWhen ran_out_of_fuel discardMsg) + 2 (vcat (map ppr_binding rel_bds) $$ ppWhen ran_out_of_fuel discardMsg) where ppr_binding (nm, tidy_ty) = sep [ pprPrefixOcc nm <+> dcolon <+> ppr tidy_ty , nest 2 (parens (text "bound at" <+> ppr (getSrcLoc nm)))] + rel_bds = filter (not . isGeneratedSrcSpan . getSrcSpan . fst) bds discardMsg :: SDoc discardMsg = text "(Some bindings suppressed;" <+> diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 492c46c7df..45c3dabbe5 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -23,7 +23,7 @@ module GHC.Tc.Gen.Expr tcPolyExpr, tcExpr, tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, tcCheckId, - getFixedTyVars ) where + ) where import GHC.Prelude @@ -37,16 +37,18 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Types.Basic import GHC.Types.Error +import GHC.Types.Unique.Map ( UniqMap, listToUniqMap, lookupUniqMap ) import GHC.Core.Multiplicity import GHC.Core.UsageEnv import GHC.Tc.Errors.Types -import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) +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 ) import GHC.Tc.Utils.Env import GHC.Tc.Gen.Arrow @@ -67,9 +69,9 @@ import GHC.Types.Name.Reader import GHC.Core.TyCon import GHC.Core.Type import GHC.Tc.Types.Evidence -import GHC.Types.Var.Set import GHC.Builtin.Types import GHC.Builtin.Names +import GHC.Builtin.Uniques ( mkBuiltinUnique ) import GHC.Driver.Session import GHC.Types.SrcLoc import GHC.Utils.Misc @@ -85,6 +87,8 @@ import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUn import Data.Function import Data.List (partition, sortBy, groupBy, intersect) +import GHC.Data.Bag ( unitBag ) + {- ************************************************************************ * * @@ -502,319 +506,30 @@ tcExpr expr@(RecordCon { rcon_con = L loc con_name where orig = OccurrenceOf con_name -{- -Note [Type of a record update] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The main complication with RecordUpd is that we need to explicitly -handle the *non-updated* fields. Consider: - - data T a b c = MkT1 { fa :: a, fb :: (b,c) } - | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c } - | MkT3 { fd :: a } - - upd :: T a b c -> (b',c) -> T a b' c - upd t x = t { fb = x} - -The result type should be (T a b' c) -not (T a b c), because 'b' *is not* mentioned in a non-updated field -not (T a b' c'), because 'c' *is* mentioned in a non-updated field -NB that it's not good enough to look at just one constructor; we must -look at them all; cf #3219 - -After all, upd should be equivalent to: - upd t x = case t of - MkT1 p q -> MkT1 p x - MkT2 a b -> MkT2 p b - MkT3 d -> error ... - -So we need to give a completely fresh type to the result record, -and then constrain it by the fields that are *not* updated ("p" above). -We call these the "fixed" type variables, and compute them in getFixedTyVars. - -Note that because MkT3 doesn't contain all the fields being updated, -its RHS is simply an error, so it doesn't impose any type constraints. -Hence the use of 'relevant_cont'. - -Note [Implicit type sharing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We also take into account any "implicit" non-update fields. For example - data T a b where { MkT { f::a } :: T a a; ... } -So the "real" type of MkT is: forall ab. (a~b) => a -> T a b - -Then consider - upd t x = t { f=x } -We infer the type - upd :: T a b -> a -> T a b - upd (t::T a b) (x::a) - = case t of { MkT (co:a~b) (_:a) -> MkT co x } -We can't give it the more general type - upd :: T a b -> c -> T c b - -Note [Criteria for update] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to allow update for existentials etc, provided the updated -field isn't part of the existential. For example, this should be ok. - data T a where { MkT { f1::a, f2::b->b } :: T a } - f :: T a -> b -> T b - f t b = t { f1=b } - -The criterion we use is this: - - The types of the updated fields - mention only the universally-quantified type variables - of the data constructor - -NB: this is not (quite) the same as being a "naughty" record selector -(See Note [Naughty record selectors]) in GHC.Tc.TyCl), at least -in the case of GADTs. Consider - data T a where { MkT :: { f :: a } :: T [a] } -Then f is not "naughty" because it has a well-typed record selector. -But we don't allow updates for 'f'. (One could consider trying to -allow this, but it makes my head hurt. Badly. And no one has asked -for it.) - -In principle one could go further, and allow - g :: T a -> T a - g t = t { f2 = \x -> x } -because the expression is polymorphic...but that seems a bridge too far. - -Note [Data family example] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - data instance T (a,b) = MkT { x::a, y::b } - ---> - data :TP a b = MkT { a::a, y::b } - coTP a b :: T (a,b) ~ :TP a b - -Suppose r :: T (t1,t2), e :: t3 -Then r { x=e } :: T (t3,t1) - ---> - case r |> co1 of - MkT x y -> MkT e y |> co2 - where co1 :: T (t1,t2) ~ :TP t1 t2 - co2 :: :TP t3 t2 ~ T (t3,t2) -The wrapping with co2 is done by the constructor wrapper for MkT - -Outgoing invariants -~~~~~~~~~~~~~~~~~~~ -In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys): - - * cons are the data constructors to be updated - - * in_inst_tys, out_inst_tys have same length, and instantiate the - *representation* tycon of the data cons. In Note [Data - family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2] - -Note [Mixed Record Field Updates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following pattern synonym. - - data MyRec = MyRec { foo :: Int, qux :: String } - - pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2} - -This allows updates such as the following - - updater :: MyRec -> MyRec - updater a = a {f1 = 1 } - -It would also make sense to allow the following update (which we reject). - - updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two" - -This leads to confusing behaviour when the selectors in fact refer the same -field. - - updater a = a {f1 = 1, foo = 2} ==? ??? - -For this reason, we reject a mixture of pattern synonym and normal record -selectors in the same update block. Although of course we still allow the -following. - - updater a = (a {f1 = 1}) {foo = 2} - - > updater (MyRec 0 "str") - MyRec 2 "str" - --} - -- 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 = Left rbnds }) res_ty = assert (notNull rbnds) $ - do { -- STEP -2: typecheck the record_expr, the record to be updated - (record_expr', record_rho) <- tcScalingUsage Many $ tcInferRho record_expr - -- 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, or 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' } + do { -- Desugar the record update. See Note [Record Updates]. + ; (ds_expr, ds_res_ty, err_ctxt) <- desugarRecordUpd record_expr 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. -- - -- This should definitely *not* typecheck. - - -- 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 . hfbLHS . unLoc) rbinds - upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds - sel_ids = map selectorAmbiguousFieldOcc upd_flds - -- STEP 0 - -- Check that the field names are really field names - -- and they are all field names for proper records or - -- all field names for pattern synonyms. - ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name) - | fld <- rbinds, - -- Excludes class ops - let L loc sel_id = hsRecUpdFieldId (unLoc fld), - not (isRecordSelector sel_id), - let fld_name = idName sel_id ] - ; unless (null bad_guys) (sequence bad_guys >> failM) - -- See Note [Mixed Record Field Updates] - ; let (data_sels, pat_syn_sels) = - partition isDataConRecordSelector sel_ids - ; massert (all isPatSynRecordSelector pat_syn_sels) - ; checkTc ( null data_sels || null pat_syn_sels ) - ( mixedSelectors data_sels pat_syn_sels ) - - -- STEP 1 - -- Figure out the tycon and data cons from the first field name - ; let -- It's OK to use the non-tc splitters here (for a selector) - sel_id : _ = sel_ids - - mtycon :: Maybe TyCon - mtycon = case idDetails sel_id of - RecSelId (RecSelData tycon) _ -> Just tycon - _ -> Nothing - - con_likes :: [ConLike] - con_likes = case idDetails sel_id of - RecSelId (RecSelData tc) _ - -> map RealDataCon (tyConDataCons tc) - RecSelId (RecSelPatSyn ps) _ - -> [PatSynCon ps] - _ -> panic "tcRecordUpd" - -- NB: for a data type family, the tycon is the instance tycon - - relevant_cons = conLikesWithFields con_likes upd_fld_occs - -- A constructor is only relevant to this process if - -- it contains *all* the fields that are being updated - -- Other ones will cause a runtime error if they occur - - -- Step 2 - -- Check that at least one constructor has all the named fields - -- i.e. has an empty set of bad fields returned by badFields - ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes) - - -- Take apart a representative constructor - ; let con1 = assert (not (null relevant_cons) ) head relevant_cons - (con1_tvs, _, _, _prov_theta, req_theta, scaled_con1_arg_tys, _) - = conLikeFullSig con1 - con1_arg_tys = map scaledThing scaled_con1_arg_tys - -- We can safely drop the fields' multiplicities because - -- they are currently always 1: there is no syntax for record - -- fields with other multiplicities yet. This way we don't need - -- to handle it in the rest of the function - con1_flds = map flLabel $ conLikeFieldLabels con1 - con1_tv_tys = mkTyVarTys con1_tvs - con1_res_ty = case mtycon of - Just tc -> mkFamilyTyConApp tc con1_tv_tys - Nothing -> conLikeResTy con1 con1_tv_tys - - -- Check that we're not dealing with a unidirectional pattern - -- synonym - ; checkTc (conLikeHasBuilder con1) $ - nonBidirectionalErr (conLikeName con1) - - -- STEP 3 Note [Criteria for update] - -- Check that each updated field is polymorphic; that is, its type - -- mentions only the universally-quantified variables of the data con - ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys - bad_upd_flds = filter bad_fld flds1_w_tys - con1_tv_set = mkVarSet con1_tvs - bad_fld (fld, ty) = fld `elem` upd_fld_occs && - not (tyCoVarsOfType ty `subVarSet` con1_tv_set) - ; checkTc (null bad_upd_flds) (TcRnFieldUpdateInvalidType bad_upd_flds) - - -- STEP 4 Note [Type of a record update] - -- Figure out types for the scrutinee and result - -- Both are of form (T a b c), with fresh type variables, but with - -- common variables where the scrutinee and result must have the same type - -- These are variables that appear in *any* arg of *any* of the - -- relevant constructors *except* in the updated fields - -- - ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons - is_fixed_tv tv = tv `elemVarSet` fixed_tvs - - mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType) - -- Deals with instantiation of kind variables - -- c.f. GHC.Tc.Utils.TcMType.newMetaTyVars - mk_inst_ty subst (tv, result_inst_ty) - | is_fixed_tv tv -- Same as result type - = return (extendTvSubst subst tv result_inst_ty, result_inst_ty) - | otherwise -- Fresh type, of correct kind - = do { (subst', new_tv) <- newMetaTyVarX subst tv - ; return (subst', mkTyVarTy new_tv) } - - ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs - ; let result_inst_tys = mkTyVarTys con1_tvs' - init_subst = mkEmptyTCvSubst (getTCvInScope result_subst) - - ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst - (con1_tvs `zip` result_inst_tys) - - ; let rec_res_ty = TcType.substTy result_subst con1_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 . HsExprRnThing $ unLoc 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 - - -- STEP 5 - -- Typecheck the bindings - ; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds - - -- STEP 6: Deal with the stupid theta. - -- See Note [The stupid context] in GHC.Core.DataCon. - ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1) - ; instStupidTheta RecordUpdOrigin theta' - - -- Step 7: make a cast for the scrutinee, in the - -- case that it's from a data family - ; let fam_co :: HsWrapper -- RepT t1 .. tn ~R scrut_ty - fam_co | Just tycon <- mtycon - , Just co_con <- tyConFamilyCoercion_maybe tycon - = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys []) - | otherwise - = idHsWrapper - - -- Step 8: Check that the req constraints are satisfied - -- For normal data constructors req_theta is empty but we must do - -- this check for pattern synonyms. - ; let req_theta' = substThetaUnchecked scrut_subst req_theta - ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta' - - -- Phew! - ; let upd_tc = RecordUpdTc { rupd_cons = relevant_cons - , rupd_in_tys = scrut_inst_tys - , rupd_out_tys = result_inst_tys - , rupd_wrap = req_wrap } - expr' = RecordUpd { rupd_expr = mkLHsWrap fam_co $ - mkLHsWrapCo co_scrut record_expr' - , rupd_flds = Left rbinds' - , rupd_ext = upd_tc } - - ; tcWrapResult expr expr' rec_res_ty res_ty } -tcExpr (RecordUpd {}) _ = panic "GHC.Tc.Gen.Expr: tcExpr: The impossible happened!" + -- See Note [Unifying result types in tcRecordUpd]. + -- Test case: T10808. + } +tcExpr (RecordUpd {}) _ = panic "tcExpr: unexpected overloaded-dot RecordUpd" {- ************************************************************************ @@ -1163,33 +878,544 @@ in the other order, the extra signature in f2 is reqd. {- ********************************************************************* * * - Record bindings + Desugaring record update * * ********************************************************************* -} -getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet --- These tyvars must not change across the updates -getFixedTyVars upd_fld_occs univ_tvs cons - = mkVarSet [tv1 | con <- cons - , let (u_tvs, _, eqspec, prov_theta - , req_theta, arg_tys, _) - = conLikeFullSig con - theta = eqSpecPreds eqspec - ++ prov_theta - ++ req_theta - flds = conLikeFieldLabels con - fixed_tvs = exactTyCoVarsOfTypes (map scaledThing fixed_tys) - -- fixed_tys: See Note [Type of a record update] - `unionVarSet` tyCoVarsOfTypes theta - -- Universally-quantified tyvars that - -- appear in any of the *implicit* - -- arguments to the constructor are fixed - -- See Note [Implicit type sharing] - - fixed_tys = [ty | (fl, ty) <- zip flds arg_tys - , not (flLabel fl `elem` upd_fld_occs)] - , (tv1,tv) <- univ_tvs `zip` u_tvs - , tv `elemVarSet` fixed_tvs ] +{- +Note [Type of a record update] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The main complication with RecordUpd is that we need to explicitly +handle the *non-updated* fields. Consider: + + data T a b c = MkT1 { fa :: a, fb :: (b,c) } + | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c } + | MkT3 { fd :: a } + + upd :: T a b c -> (b',c) -> T a b' c + upd t x = t { fb = x} + +The result type should be (T a b' c) +not (T a b c), because 'b' *is not* mentioned in a non-updated field +not (T a b' c'), because 'c' *is* mentioned in a non-updated field +NB that it's not good enough to look at just one constructor; we must +look at them all; cf #3219 + +After all, upd should be equivalent to: + upd t x = case t of + MkT1 p q -> MkT1 p x + MkT2 a b -> MkT2 p b + MkT3 d -> error ... + +So we need to give a completely fresh type to the result record, +and then constrain it by the fields that are *not* updated ("p" above). +We call these the "fixed" type variables, and compute them in getFixedTyVars. + +Note that because MkT3 doesn't contain all the fields being updated, +its RHS is simply an error, so it doesn't impose any type constraints. +Hence the use of 'relevant_cont'. + +Note [Implicit type sharing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We also take into account any "implicit" non-update fields. For example + data T a b where { MkT { f::a } :: T a a; ... } +So the "real" type of MkT is: forall ab. (a~b) => a -> T a b + +Then consider + upd t x = t { f=x } +We infer the type + upd :: T a b -> a -> T a b + upd (t::T a b) (x::a) + = case t of { MkT (co:a~b) (_:a) -> MkT co x } +We can't give it the more general type + upd :: T a b -> c -> T c b + +Note [Criteria for update] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to allow update for existentials etc, provided the updated +field isn't part of the existential. For example, this should be ok. + data T a where { MkT { f1::a, f2::b->b } :: T a } + f :: T a -> b -> T b + f t b = t { f1=b } + +The criterion we use is this: + + The types of the updated fields + mention only the universally-quantified type variables + of the data constructor + +NB: this is not (quite) the same as being a "naughty" record selector +(See Note [Naughty record selectors]) in GHC.Tc.TyCl), at least +in the case of GADTs. Consider + data T a where { MkT :: { f :: a } :: T [a] } +Then f is not "naughty" because it has a well-typed record selector. +But we don't allow updates for 'f'. (One could consider trying to +allow this, but it makes my head hurt. Badly. And no one has asked +for it.) + +In principle one could go further, and allow + g :: T a -> T a + g t = t { f2 = \x -> x } +because the expression is polymorphic...but that seems a bridge too far. + +Note [Data family example] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + data instance T (a,b) = MkT { x::a, y::b } + ---> + data :TP a b = MkT { a::a, y::b } + coTP a b :: T (a,b) ~ :TP a b + +Suppose r :: T (t1,t2), e :: t3 +Then r { x=e } :: T (t3,t1) + ---> + case r |> co1 of + MkT x y -> MkT e y |> co2 + where co1 :: T (t1,t2) ~ :TP t1 t2 + co2 :: :TP t3 t2 ~ T (t3,t2) +The wrapping with co2 is done by the constructor wrapper for MkT + +Outgoing invariants +~~~~~~~~~~~~~~~~~~~ +In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys): + + * cons are the data constructors to be updated + + * in_inst_tys, out_inst_tys have same length, and instantiate the + *representation* tycon of the data cons. In Note [Data + family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2] + +Note [Mixed Record Field Updates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following pattern synonym. + + data MyRec = MyRec { foo :: Int, qux :: String } + + pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2} + +This allows updates such as the following + + updater :: MyRec -> MyRec + updater a = a {f1 = 1 } + +It would also make sense to allow the following update (which we reject). + + updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two" + +This leads to confusing behaviour when the selectors in fact refer the same +field. + + updater a = a {f1 = 1, foo = 2} ==? ??? + +For this reason, we reject a mixture of pattern synonym and normal record +selectors in the same update block. Although of course we still allow the +following. + + updater a = (a {f1 = 1}) {foo = 2} + + > updater (MyRec 0 "str") + MyRec 2 "str" + +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 outlined above, to typecheck a record update via desugaring, we first need +to identify the parent record `TyCon` (`T` above). This can be tricky when several +record types share the same field (with `-XDuplicateRecordFields`). + +Currently, we use the inferred type of the record to help disambiguate the record +fields. For example, in + + ( mempty :: T a b ) { x = 3 } + +the type signature on `mempty` allows us to disambiguate the record `TyCon` to `T`, +when there might be other datatypes with field `x :: Int`. +This complexity is 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 + +However, for the time being, we still need to disambiguate record fields using the +inferred types. This means that, when typechecking a record update via desugaring, +we need to do the following: + + D1. Perform a first typechecking pass on the record expression (`e` in the example above), + to infer the type of the record being updated. + D2. Desugar the record update as described above, using an HsExpansion. + D3. Typecheck the desugared code. + +In (D1), 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 [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 + -> [LHsRecUpdField 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 rbnds res_ty + = do { -- STEP -2: 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 Many $ -- 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 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 . hfbLHS . unLoc) rbinds + upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds + sel_ids = map selectorAmbiguousFieldOcc upd_flds + upd_fld_names = map idName sel_ids + + -- STEP 0 + -- Check that the field names are really field names + -- and they are all field names for proper records or + -- all field names for pattern synonyms. + ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name) + | fld <- rbinds, + -- Excludes class ops + let L loc sel_id = hsRecUpdFieldId (unLoc fld), + not (isRecordSelector sel_id), + let fld_name = idName sel_id ] + ; unless (null bad_guys) (sequence bad_guys >> failM) + -- See Note [Mixed Record Field Updates] + ; let (data_sels, pat_syn_sels) = + partition isDataConRecordSelector sel_ids + ; massert (all isPatSynRecordSelector pat_syn_sels) + ; checkTc ( null data_sels || null pat_syn_sels ) + ( mixedSelectors data_sels pat_syn_sels ) + + -- STEP 1 + -- Figure out the tycon and data cons from the first field name + ; let -- It's OK to use the non-tc splitters here (for a selector) + sel_id : _ = sel_ids + con_likes :: [ConLike] + con_likes = case idDetails sel_id of + RecSelId (RecSelData tc) _ + -> map RealDataCon (tyConDataCons tc) + RecSelId (RecSelPatSyn ps) _ + -> [PatSynCon ps] + _ -> panic "tcRecordUpd" + -- NB: for a data type family, the tycon is the instance tycon + relevant_cons = conLikesWithFields con_likes upd_fld_occs + -- A constructor is only relevant to this process if + -- it contains *all* the fields that are being updated + -- Other ones will cause a runtime error if they occur + + -- STEP 2 + -- Check that at least one constructor has all the named fields + -- i.e. has an empty set of bad fields returned by badFields + ; case relevant_cons of + { [] -> failWithTc (badFieldsUpd rbinds con_likes) + ; relevant_con : _ -> + + -- STEP 3 + -- 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 ... + + do { -- 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 + -- occuring 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 + + ; 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) + (mkVarOccFS (flLabel fld_lbl)) + generatedSrcSpan + in (genVarPat fld_nm, genLHsVar fld_nm) + + -- STEP 4 + -- 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 $ IdSig noExtField 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. -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head @@ -1350,34 +1576,6 @@ tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) , hfbRHS = rhs' , hfbPun = hfbPun fld}))) } -tcRecordUpd - :: ConLike - -> [TcType] -- Expected type for each field - -> [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] - -> TcM [LHsRecUpdField GhcTc] - -tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds - where - fields = map flSelector $ conLikeFieldLabels con_like - flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys - - do_bind :: LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn) - -> TcM (Maybe (LHsRecUpdField GhcTc)) - do_bind (L l fld@(HsFieldBind { hfbLHS = L loc af - , hfbRHS = rhs })) - = do { let lbl = rdrNameAmbiguousFieldOcc af - sel_id = selectorAmbiguousFieldOcc af - f = L loc (FieldOcc (idName sel_id) (L (l2l loc) lbl)) - ; mb <- tcRecordField con_like flds_w_tys f rhs - ; case mb of - Nothing -> return Nothing - Just (f', rhs') -> - return (Just - (L l (fld { hfbLHS - = L loc (Unambiguous - (foExt (unLoc f')) - (L (l2l loc) lbl)) - , hfbRHS = rhs' }))) } tcRecordField :: ConLike -> Assoc Name Type -> LFieldOcc GhcRn -> LHsExpr GhcRn @@ -1386,7 +1584,7 @@ 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 (FRRRecordUpdate (unLoc lbl) (unLoc rhs')) + ; hasFixedRuntimeRep_syntactic (FRRRecordCon (unLoc lbl) (unLoc rhs')) field_ty ; let field_id = mkUserLocal (nameOccName sel_name) (nameUnique sel_name) diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs index dfe332eb08..42704013a7 100644 --- a/compiler/GHC/Tc/Types/Evidence.hs +++ b/compiler/GHC/Tc/Types/Evidence.hs @@ -55,7 +55,6 @@ module GHC.Tc.Types.Evidence ( mkTcKindCo, tcCoercionKind, mkTcCoVarCo, - mkTcFamilyTyConAppCo, isTcReflCo, isTcReflexiveCo, tcCoercionRole, unwrapIP, wrapIP, @@ -158,7 +157,6 @@ mkTcCoherenceRightCo :: Role -> TcType -> TcCoercionN mkTcPhantomCo :: TcCoercionN -> TcType -> TcType -> TcCoercionP mkTcKindCo :: TcCoercion -> TcCoercionN mkTcCoVarCo :: CoVar -> TcCoercion -mkTcFamilyTyConAppCo :: TyCon -> [TcCoercionN] -> TcCoercionN tcCoercionKind :: TcCoercion -> Pair TcType tcCoercionRole :: TcCoercion -> Role @@ -195,7 +193,6 @@ mkTcCoherenceRightCo = mkCoherenceRightCo mkTcPhantomCo = mkPhantomCo mkTcKindCo = mkKindCo mkTcCoVarCo = mkCoVarCo -mkTcFamilyTyConAppCo = mkFamilyTyConAppCo tcCoercionKind = coercionKind tcCoercionRole = coercionRole diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index d088762270..8582d5c549 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -990,10 +990,14 @@ data FixedRuntimeRepOrigin -- 'FixedRuntimeRepOrigin' for that. data FixedRuntimeRepContext + -- | Record fields in record construction must have a fixed runtime + -- representation. + = FRRRecordCon !RdrName !(HsExpr GhcTc) + -- | Record fields in record updates must have a fixed runtime representation. -- -- Test case: RepPolyRecordUpdate. - = FRRRecordUpdate !RdrName !(HsExpr GhcTc) + | FRRRecordUpdate !Name !(HsExpr GhcRn) -- | Variable binders must have a fixed runtime representation. -- @@ -1090,6 +1094,9 @@ data FixedRuntimeRepContext -- which is not fixed. That information is stored in 'FixedRuntimeRepOrigin' -- and is reported separately. pprFixedRuntimeRepContext :: FixedRuntimeRepContext -> SDoc +pprFixedRuntimeRepContext (FRRRecordCon lbl _arg) + = sep [ text "The field", quotes (ppr lbl) + , text "of the record constructor" ] pprFixedRuntimeRepContext (FRRRecordUpdate lbl _arg) = sep [ text "The record update at field" , quotes (ppr lbl) ] diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index eee43e8ed1..6fa47f8b64 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -857,32 +857,6 @@ zonkExpr env expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds }) ; return (expr { rcon_ext = new_con_expr , rcon_flds = new_rbinds }) } --- Record updates via dot syntax are replaced by desugared expressions --- in the renamer. See Note [Rebindable syntax and HsExpansion]. This --- is why we match on 'rupd_flds = Left rbinds' here and panic otherwise. -zonkExpr env (RecordUpd { rupd_flds = Left rbinds - , rupd_expr = expr - , rupd_ext = RecordUpdTc { - rupd_cons = cons - , rupd_in_tys = in_tys - , rupd_out_tys = out_tys - , rupd_wrap = req_wrap }}) - = do { new_expr <- zonkLExpr env expr - ; new_in_tys <- mapM (zonkTcTypeToTypeX env) in_tys - ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys - ; new_rbinds <- zonkRecUpdFields env rbinds - ; (_, new_recwrap) <- zonkCoFn env req_wrap - ; return ( - RecordUpd { - rupd_expr = new_expr - , rupd_flds = Left new_rbinds - , rupd_ext = RecordUpdTc { - rupd_cons = cons - , rupd_in_tys = new_in_tys - , rupd_out_tys = new_out_tys - , rupd_wrap = new_recwrap }}) } -zonkExpr _ (RecordUpd {}) = panic "GHC.Tc.Utils.Zonk: zonkExpr: The impossible happened!" - zonkExpr env (ExprWithTySig _ e ty) = do { e' <- zonkLExpr env e ; return (ExprWithTySig noExtField e' ty) } @@ -1309,16 +1283,6 @@ zonkRecFields env (HsRecFields flds dd) ; return (L l (fld { hfbLHS = new_id , hfbRHS = new_expr })) } -zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTc] - -> TcM [LHsRecUpdField GhcTc] -zonkRecUpdFields env = mapM zonk_rbind - where - zonk_rbind (L l fld) - = do { new_id <- wrapLocMA (zonkFieldOcc env) (hsRecUpdFieldOcc fld) - ; new_expr <- zonkLExpr env (hfbRHS fld) - ; return (L l (fld { hfbLHS = fmap ambiguousFieldOcc new_id - , hfbRHS = new_expr })) } - {- ************************************************************************ * * diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs index a6f27f38e6..306fde89fa 100644 --- a/compiler/GHC/Types/SrcLoc.hs +++ b/compiler/GHC/Types/SrcLoc.hs @@ -61,7 +61,7 @@ module GHC.Types.SrcLoc ( -- ** Predicates on SrcSpan isGoodSrcSpan, isOneLineSpan, isZeroWidthSpan, - containsSpan, + containsSpan, isNoSrcSpan, -- * StringBuffer locations BufPos(..), @@ -448,6 +448,10 @@ isGeneratedSrcSpan :: SrcSpan -> Bool isGeneratedSrcSpan (UnhelpfulSpan UnhelpfulGenerated) = True isGeneratedSrcSpan _ = False +isNoSrcSpan :: SrcSpan -> Bool +isNoSrcSpan (UnhelpfulSpan UnhelpfulNoLocationInfo) = True +isNoSrcSpan _ = False + -- | Create a "bad" 'SrcSpan' that has not location information mkGeneralSrcSpan :: FastString -> SrcSpan mkGeneralSrcSpan = UnhelpfulSpan . UnhelpfulOther diff --git a/compiler/GHC/Unit/Module/ModIface.hs b/compiler/GHC/Unit/Module/ModIface.hs index 5a3cfe71c9..76cfff2b9f 100644 --- a/compiler/GHC/Unit/Module/ModIface.hs +++ b/compiler/GHC/Unit/Module/ModIface.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -128,11 +128,11 @@ data ModIfacePhase -- | Selects a IfaceDecl representation. -- For fully instantiated interfaces we also maintain -- a fingerprint, which is used for recompilation checks. -type family IfaceDeclExts (phase :: ModIfacePhase) where +type family IfaceDeclExts (phase :: ModIfacePhase) = decl | decl -> phase where IfaceDeclExts 'ModIfaceCore = IfaceDecl IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl) -type family IfaceBackendExts (phase :: ModIfacePhase) where +type family IfaceBackendExts (phase :: ModIfacePhase) = bk | bk -> phase where IfaceBackendExts 'ModIfaceCore = () IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend diff --git a/docs/users_guide/9.6.1-notes.rst b/docs/users_guide/9.6.1-notes.rst index 14bf7e2994..cd1ed28550 100644 --- a/docs/users_guide/9.6.1-notes.rst +++ b/docs/users_guide/9.6.1-notes.rst @@ -7,6 +7,58 @@ Version 9.6.1 Language ~~~~~~~~ +- Record updates for GADTs and other existential datatypes are now + fully supported. + + For example: :: + + data D b where + MkD :: { fld1 :: a -> a, fld2 :: a -> (), fld3 :: b } -> D b + + foo :: D b -> D b + foo d = d { fld1 = id, fld2 = const () } + + In this example, we have an existential variable ``a``, and we update + all fields whose type involves ``a`` at once, so the update is valid. + + A side-effect of this change is that GHC now rejects some record updates + involving fields whose types contain type families (these record updates + were previously erroneously accepted). + + Example: :: + + type family F a where + F Int = Char + F Float = Char + + data T b = MkT { x :: [Int], y :: [F b] } + + emptyT :: forall b. T b + emptyT = MkT [] [] + + bar :: T Int + bar = emptyT { x = [3] } + + In this example, we can't infer the type of ``emptyT`` in ``bar``: it could be + ``T Int``, but it could also be ``T Float`` because the type family ``F`` + is not injective and ``T Float ~ T Int``. Indeed, the following typechecks :: + + baz :: T Int + baz = case ( emptyT :: T Float ) of { MkT _ y -> MkT [3] y } + + This means that the type of ``emptyT`` is ambiguous in the definition + of ``bar`` above, and thus GHC rejects the record update: :: + + Couldn't match type `F b0' with `Char' + Expected: [F Int] + Actual: [F b0] + NB: ‘F’ is a non-injective type family + The type variable ‘b0’ is ambiguous + + To fix these issues, add a type signature to the expression that the + record update is applied to (``emptyT`` in the example above), or + add an injectivity annotation to the type family in the case that + the type family is in fact injective. Compiler ~~~~~~~~ diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T index 2db852a35b..9879f2d9b0 100644 --- a/testsuite/tests/patsyn/should_fail/all.T +++ b/testsuite/tests/patsyn/should_fail/all.T @@ -15,7 +15,6 @@ test('records-no-uni-update', normal, compile_fail, ['']) test('records-no-uni-update2', normal, compile_fail, ['']) test('records-mixing-fields', normal, compile_fail, ['']) test('records-exquant', normal, compile_fail, ['']) -test('records-poly-update', normal, compile_fail, ['']) test('records-nofieldselectors', normal, compile_fail, ['']) test('mixed-pat-syn-record-sels', normal, compile_fail, ['']) test('T11039', normal, compile_fail, ['']) diff --git a/testsuite/tests/patsyn/should_fail/records-exquant.stderr b/testsuite/tests/patsyn/should_fail/records-exquant.stderr index b5c3fddcc3..2f3a0f508b 100644 --- a/testsuite/tests/patsyn/should_fail/records-exquant.stderr +++ b/testsuite/tests/patsyn/should_fail/records-exquant.stderr @@ -4,8 +4,3 @@ records-exquant.hs:8:7: error: • In the expression: a (Showable True) In an equation for ‘qux’: qux = a (Showable True) Suggested fix: Use pattern-matching syntax instead - -records-exquant.hs:10:7: error: - • Record update for insufficiently polymorphic field: a :: a - • In the expression: (Showable ()) {a = True} - In an equation for ‘foo’: foo = (Showable ()) {a = True} diff --git a/testsuite/tests/patsyn/should_fail/records-no-uni-update.stderr b/testsuite/tests/patsyn/should_fail/records-no-uni-update.stderr index 71e2a99407..c7e60f1085 100644 --- a/testsuite/tests/patsyn/should_fail/records-no-uni-update.stderr +++ b/testsuite/tests/patsyn/should_fail/records-no-uni-update.stderr @@ -1,5 +1,7 @@ records-no-uni-update.hs:7:7: error: - non-bidirectional pattern synonym ‘Uni’ used in an expression - In the expression: ("a", "b") {a = "b"} - In an equation for ‘foo’: foo = ("a", "b") {a = "b"} + • non-bidirectional pattern synonym ‘Uni’ used in an expression + • In a record update at field ‘a’ + and with pattern synonym ‘Uni’. + In the expression: ("a", "b") {a = "b"} + In an equation for ‘foo’: foo = ("a", "b") {a = "b"} diff --git a/testsuite/tests/patsyn/should_fail/records-poly-update.hs b/testsuite/tests/patsyn/should_fail/records-poly-update.hs deleted file mode 100644 index f488b18bc6..0000000000 --- a/testsuite/tests/patsyn/should_fail/records-poly-update.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Main where - -pattern ReqNoProv :: Show a => a -> Maybe a -pattern ReqNoProv{j} = Just j - -data A = A deriving Show - -p1 = Just True - -p6 = p1 {j = A} - -main = print p6 diff --git a/testsuite/tests/patsyn/should_fail/records-poly-update.stderr b/testsuite/tests/patsyn/should_fail/records-poly-update.stderr deleted file mode 100644 index 44bee9b2c3..0000000000 --- a/testsuite/tests/patsyn/should_fail/records-poly-update.stderr +++ /dev/null @@ -1,6 +0,0 @@ - -records-poly-update.hs:11:14: error: - • Couldn't match expected type ‘Bool’ with actual type ‘A’ - • In the ‘j’ field of a record - In the expression: p1 {j = A} - In an equation for ‘p6’: p6 = p1 {j = A} diff --git a/testsuite/tests/patsyn/should_run/all.T b/testsuite/tests/patsyn/should_run/all.T index 90f577174e..d490157e4a 100644 --- a/testsuite/tests/patsyn/should_run/all.T +++ b/testsuite/tests/patsyn/should_run/all.T @@ -26,3 +26,4 @@ test('T11224', normal, compile_and_run, ['-Wincomplete-patterns -Woverlapping-pa test('T13688', omit_ways(['profasm', 'profthreaded']), multimod_compile_and_run, ['T13688', '-v0']) # Requires UnboxedSums, which GHCi does not support. test('T14228', omit_ways(['ghci']), compile_and_run, ['']) +test('records-poly-update', normal, compile_and_run, ['']) diff --git a/testsuite/tests/patsyn/should_run/records-poly-update.hs b/testsuite/tests/patsyn/should_run/records-poly-update.hs new file mode 100644 index 0000000000..a9c13763c3 --- /dev/null +++ b/testsuite/tests/patsyn/should_run/records-poly-update.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE PatternSynonyms #-} +module Main where + +pattern ReqNoProv :: Show a => a -> Maybe a +pattern ReqNoProv{j} = Just j + +data A = A deriving Show + +p1 = Just True + +-- The record updates in 'p6' is desugared to the following, as per #18802: +-- p6 = case p1 of ReqNoProv x -> ReqNoProv A +-- (Details of this desugaring can be found in Note [Record Updates] in Tc.Gen.Expr) + +p6 = p1 {j = A} + +main = print p6 diff --git a/testsuite/tests/patsyn/should_run/records-poly-update.stdout b/testsuite/tests/patsyn/should_run/records-poly-update.stdout new file mode 100644 index 0000000000..033c0f4ea4 --- /dev/null +++ b/testsuite/tests/patsyn/should_run/records-poly-update.stdout @@ -0,0 +1 @@ +Just A diff --git a/testsuite/tests/pmcheck/should_compile/T12957a.stderr b/testsuite/tests/pmcheck/should_compile/T12957a.stderr new file mode 100644 index 0000000000..6a656ae32f --- /dev/null +++ b/testsuite/tests/pmcheck/should_compile/T12957a.stderr @@ -0,0 +1,25 @@ + +T12957a.hs:25:35: warning: [-Winaccessible-code (in -Wdefault)] + • Inaccessible code in + a pattern with constructor: BFields :: [()] -> Fields 'B, + in a case alternative + Couldn't match type ‘'A’ with ‘'B’ + • In a record update at field ‘list’, + with type constructor ‘Fields’ + and data constructor ‘BFields’. + In the expression: emptyA {list = [a]} + In a record update at field ‘sFields’, + with type constructor ‘S’ + and data constructor ‘S’. + +T12957a.hs:25:35: warning: [-Wdeferred-type-errors (in -Wdefault)] + • Couldn't match type ‘'B’ with ‘'A’ + Expected: Fields 'A + Actual: Fields 'B + • In a record update at field ‘list’, + with type constructor ‘Fields’ + and data constructor ‘BFields’. + In the expression: emptyA {list = [a]} + In a record update at field ‘sFields’, + with type constructor ‘S’ + and data constructor ‘S’. diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T index 9f55966ae8..1af8c91441 100644 --- a/testsuite/tests/pmcheck/should_compile/all.T +++ b/testsuite/tests/pmcheck/should_compile/all.T @@ -104,7 +104,7 @@ test('T11245', [], compile, [overlapping_incomplete]) test('T11336b', [], compile, [overlapping_incomplete]) test('T12949', [], compile, [overlapping_incomplete]) test('T12957', [], compile, [overlapping_incomplete]) -test('T12957a', [], compile, [overlapping_incomplete]) +test('T12957a', [], compile, [overlapping_incomplete+'-fdefer-type-errors']) test('PmExprVars', [], compile, [overlapping_incomplete]) test('CyclicSubst', [], compile, [overlapping_incomplete]) test('CaseOfKnownCon', [], compile, [overlapping_incomplete]) diff --git a/testsuite/tests/rebindable/rebindable11.stderr b/testsuite/tests/rebindable/rebindable11.stderr index 1aaca7af79..5a8acefd9f 100644 --- a/testsuite/tests/rebindable/rebindable11.stderr +++ b/testsuite/tests/rebindable/rebindable11.stderr @@ -46,4 +46,4 @@ rebindable11.hs:19:53: error: • Couldn't match expected type ‘Bool’ with actual type ‘Char’ • In the second argument of ‘(==)’, namely ‘'a'’ In the expression: True == 'a' - In the ‘field’ field of a record + In the expression: if True == 'a' then () else () diff --git a/testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr b/testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr index 157c0403bc..4e5fa9653b 100644 --- a/testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr +++ b/testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr @@ -20,7 +20,10 @@ RepPolyRecordUpdate.hs:13:9: error: a0 :: TYPE c1 Cannot unify ‘rep’ with the type variable ‘c1’ because it is not a concrete ‘RuntimeRep’. - • In the expression: x {fld = meth ()} + • In a record update at field ‘fld’, + with type constructor ‘X’ + and data constructor ‘MkX’. + In the expression: x {fld = meth ()} In an equation for ‘upd’: upd x = x {fld = meth ()} • Relevant bindings include upd :: X b -> X a (bound at RepPolyRecordUpdate.hs:13:1) diff --git a/testsuite/tests/typecheck/should_compile/HardRecordUpdate.hs b/testsuite/tests/typecheck/should_compile/HardRecordUpdate.hs new file mode 100644 index 0000000000..fc32f79bb3 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/HardRecordUpdate.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE GADTs, TypeFamilies #-} + +module HardRecordUpdate where + +import Data.Kind + +type F :: Type -> Type +type family F a where {} + +type G :: Type -> Type -> Type -> Type +data family G a b c +data instance G a b Char where + MkG :: { bar :: F a } -> G a Bool Char + +g :: F Int -> G Float b Char -> G Int b Char +g i r = r { bar = i } diff --git a/testsuite/tests/typecheck/should_compile/T10808.hs b/testsuite/tests/typecheck/should_compile/T10808.hs new file mode 100644 index 0000000000..4f6822d366 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T10808.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TypeFamilies #-} +module T10808 where + +type family F a +type family G a + +data T1 +type instance F T1 = Char +type instance G T1 = Int + +data T2 +type instance F T2 = Bool +type instance G T2 = Int + +data R a = R { x :: F a, y :: G a } + +r1 :: R T1 +r1 = R { x = 'a', y = 2 } + +r2 :: R T2 +r2 = r1 { x = True } -- error: Cannot match T1 with T2 + +r3 :: R T2 +r3 = r1 { x = True, y = y r1 } -- OK diff --git a/testsuite/tests/typecheck/should_compile/T10856.hs b/testsuite/tests/typecheck/should_compile/T10856.hs new file mode 100644 index 0000000000..6d5ff9d34b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T10856.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ExistentialQuantification #-} +module T10856 where + +data Rec a b = Show a => Mk { a :: a, b :: b } + +update :: Show c => c -> Rec a b -> Rec c b +update c r = r { a = c } diff --git a/testsuite/tests/typecheck/should_compile/T16501.hs b/testsuite/tests/typecheck/should_compile/T16501.hs new file mode 100644 index 0000000000..7da53fabfe --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T16501.hs @@ -0,0 +1,22 @@ +{-# Language GADTs #-} -- Only uses Existentials +module T16501 where + +data T where + Str :: Show s => { field :: s } -> T + +val1 :: T +val1 = Str { field = True } + +{- +val2 :: T +val2 = val1 { field = 'a' } + • Record update for insufficiently polymorphic field: field :: s + • In the expression: val1 {field = 'a'} + In an equation for ‘val2’: val2 = val1 {field = 'a'} +-} + +manualUpdate :: Show s => T -> s -> T +manualUpdate (Str _) s = Str s + +val3 :: T +val3 = manualUpdate val1 'a' diff --git a/testsuite/tests/typecheck/should_compile/T18311.hs b/testsuite/tests/typecheck/should_compile/T18311.hs new file mode 100644 index 0000000000..034e48bf81 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T18311.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TypeFamilies, RecordWildCards #-} + +module T18311 where + +type family F a + +type instance F Int = Int +type instance F Bool = Int + +data T a = MkT {x :: F a, y :: a} + + +foo1 :: T Int -> T Bool +foo1 (MkT { x = x }) = MkT { x = x , y = True } + +foo2 :: T Int -> T Bool +foo2 t = t {y = False } + diff --git a/testsuite/tests/typecheck/should_compile/T18802.hs b/testsuite/tests/typecheck/should_compile/T18802.hs new file mode 100644 index 0000000000..df306c6c25 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T18802.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE MonoLocalBinds, ScopedTypeVariables, RankNTypes #-} + +module T18802 where + +-- Check that we handle higher-rank types properly. +data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int } + +foo r = r { f = \ k -> (k 3, k 'x') } + + +-- Check that we handle existentials properly. +class C a where + +data D + = forall ty. C ty + => MkD { fld1 :: !ty + , fld2 :: Bool + } + +g :: D -> D +g d = d { fld2 = False } diff --git a/testsuite/tests/typecheck/should_compile/T18802b.hs b/testsuite/tests/typecheck/should_compile/T18802b.hs new file mode 100644 index 0000000000..fe1c87d608 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T18802b.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE GADTs, DataKinds #-} + +module T18802b where + +data G a where + MkG :: { fld :: Char } -> G Float + +recUpd :: ( Char -> Char ) -> G a -> G a +recUpd f g@(MkG { fld = c }) = g { fld = f c } diff --git a/testsuite/tests/typecheck/should_compile/T21289.hs b/testsuite/tests/typecheck/should_compile/T21289.hs new file mode 100644 index 0000000000..e7536eaaaa --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T21289.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DataKinds, KindSignatures, TypeFamilies #-} +module T21289 where + +type family F (a :: Bool) +type instance F True = Int +type instance F False = Int + +type family G (a :: Bool) +type instance G True = Int +type instance G False = Bool + +data Rec a = MkR { konst :: F a + , change :: G a } + +ch :: Rec True -> Rec False +ch r = r { change = False } diff --git a/testsuite/tests/typecheck/should_compile/T2595.hs b/testsuite/tests/typecheck/should_compile/T2595.hs new file mode 100644 index 0000000000..0bf62b23b3 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2595.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Rank2Types #-} +module Foo where + +data Foo = forall a . Foo { foo :: a -> a, bar :: Int } + +x :: Foo +x = Foo { foo = id, bar = 3 } + +f :: Foo -> Foo +f rec = rec { foo = id } + +g :: Foo -> Foo +g rec = rec { bar = 3 } diff --git a/testsuite/tests/typecheck/should_compile/T3632.hs b/testsuite/tests/typecheck/should_compile/T3632.hs new file mode 100644 index 0000000000..36e7fe6eac --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T3632.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE GADTs #-} +module T3632 where + +import Data.Char ( ord ) + +data T where + MkT :: { f :: a -> Int, x :: a, wombat :: String } -> T + +foo :: T -> T +foo t = t { f = ord, x = '3' } diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index fb9eba2c8d..00d36bd3a4 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -830,3 +830,13 @@ test('T21315', normal, compile, ['-Wredundant-constraints']) test('T21516', normal, compile, ['']) test('T21519', normal, compile, ['']) test('T21519a', normal, compile, ['']) +test('T2595', normal, compile, ['']) +test('T3632', normal, compile, ['']) +test('T10808', normal, compile, ['']) +test('T10856', normal, compile, ['']) +test('T16501', normal, compile, ['']) +test('T18311', normal, compile, ['']) +test('T18802', normal, compile, ['']) +test('T18802b', normal, compile, ['']) +test('T21289', normal, compile, ['']) +test('HardRecordUpdate', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/should_fail/T21158.hs b/testsuite/tests/typecheck/should_fail/T21158.hs new file mode 100644 index 0000000000..282989f5b8 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T21158.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TypeFamilies #-} +module T21158 where + +type family F a + +data T b = MkT { x :: [Int], y :: [F b] } + +emptyT :: T b +emptyT = MkT [] [] + +foo1 :: [Int] -> T b +foo1 newx = emptyT { x = newx } + +foo2 :: [Int] -> T b +foo2 newx = case emptyT of MkT x y -> MkT newx y diff --git a/testsuite/tests/typecheck/should_fail/T21158.stderr b/testsuite/tests/typecheck/should_fail/T21158.stderr new file mode 100644 index 0000000000..88394ad2e9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T21158.stderr @@ -0,0 +1,29 @@ + +T21158.hs:12:14: error: + • Couldn't match type: F b0 + with: F b + Expected: [F b] + Actual: [F b0] + NB: ‘F’ is a non-injective type family + The type variable ‘b0’ is ambiguous + • In a record update at field ‘x’, + with type constructor ‘T’ + and data constructor ‘MkT’. + In the expression: emptyT {x = newx} + In an equation for ‘foo1’: foo1 newx = emptyT {x = newx} + • Relevant bindings include + foo1 :: [Int] -> T b (bound at T21158.hs:12:1) + +T21158.hs:15:49: error: + • Couldn't match type: F b1 + with: F b + Expected: [F b] + Actual: [F b1] + NB: ‘F’ is a non-injective type family + The type variable ‘b1’ is ambiguous + • In the second argument of ‘MkT’, namely ‘y’ + In the expression: MkT newx y + In a case alternative: MkT x y -> MkT newx y + • Relevant bindings include + y :: [F b1] (bound at T21158.hs:15:35) + foo2 :: [Int] -> T b (bound at T21158.hs:15:1) diff --git a/testsuite/tests/typecheck/should_fail/T3323.stderr b/testsuite/tests/typecheck/should_fail/T3323.stderr index 2f8344bb4e..1e77e05318 100644 --- a/testsuite/tests/typecheck/should_fail/T3323.stderr +++ b/testsuite/tests/typecheck/should_fail/T3323.stderr @@ -1,5 +1,34 @@ -T3323.hs:18:7: - Record update for insufficiently polymorphic field: haDevice :: dev - In the expression: h {haDevice = undefined} - In an equation for ‘f’: f h = h {haDevice = undefined} +T3323.hs:18:7: error: + • Could not deduce (GHC.IO.Device.RawIO dev0) + from the context: (GHC.IO.Device.RawIO dev, + GHC.IO.Device.IODevice dev, GHC.IO.BufferedIO.BufferedIO dev, + base-4.16.0.0:Data.Typeable.Internal.Typeable dev) + bound by a pattern with constructor: + Handle__ :: forall dev enc_state dec_state. + (GHC.IO.Device.RawIO dev, GHC.IO.Device.IODevice dev, + GHC.IO.BufferedIO.BufferedIO dev, + base-4.16.0.0:Data.Typeable.Internal.Typeable dev) => + dev + -> HandleType + -> GHC.IORef.IORef (GHC.IO.Buffer.Buffer GHC.Word.Word8) + -> BufferMode + -> GHC.IORef.IORef (dec_state, GHC.IO.Buffer.Buffer GHC.Word.Word8) + -> GHC.IORef.IORef (GHC.IO.Buffer.Buffer GHC.IO.Buffer.CharBufElem) + -> GHC.IORef.IORef (BufferList GHC.IO.Buffer.CharBufElem) + -> Maybe (GHC.IO.Encoding.Types.TextEncoder enc_state) + -> Maybe (GHC.IO.Encoding.Types.TextDecoder dec_state) + -> Maybe GHC.IO.Encoding.Types.TextEncoding + -> Newline + -> Newline + -> Maybe (GHC.MVar.MVar Handle__) + -> Handle__, + in a case alternative + at T3323.hs:18:7-28 + The type variable ‘dev0’ is ambiguous + • In a record update at field ‘haDevice’, + with type constructor ‘Handle__’, + data constructor ‘Handle__’ + and existential variables ‘dev’, ‘enc_state’, ‘dec_state’. + In the expression: h {haDevice = undefined} + In an equation for ‘f’: f h = h {haDevice = undefined} diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index aceaf051c9..83ba2c4414 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -655,3 +655,4 @@ test('T20768_fail', normal, compile_fail, ['']) test('T21327', normal, compile_fail, ['']) test('T21328', normal, compile_fail, ['']) test('T21338', normal, compile_fail, ['']) +test('T21158', normal, compile_fail, ['']) diff --git a/testsuite/tests/typecheck/should_fail/tcfail102.stderr b/testsuite/tests/typecheck/should_fail/tcfail102.stderr index fdfedf7ebb..88b01eea0c 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail102.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail102.stderr @@ -4,10 +4,12 @@ tcfail102.hs:1:14: warning: [-Wdeprecated-flags (in -Wdefault)] tcfail102.hs:9:7: error: • Could not deduce (Integral (Ratio a)) - arising from a record update from the context: Integral a bound by the type signature for: f :: forall a. Integral a => P (Ratio a) -> P (Ratio a) at tcfail102.hs:8:1-45 - • In the expression: x {p = p x} + • In a record update at field ‘p’, + with type constructor ‘P’ + and data constructor ‘P’. + In the expression: x {p = p x} In an equation for ‘f’: f x = x {p = p x} diff --git a/testsuite/tests/typecheck/should_fail/tcfail181.stderr b/testsuite/tests/typecheck/should_fail/tcfail181.stderr index 887c65f574..fdb16ea140 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail181.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail181.stderr @@ -13,5 +13,7 @@ tcfail181.hs:17:9: error: ...plus one instance involving out-of-scope types (use -fprint-potential-instances to see them all) • In the expression: foo + In a record update at field ‘bar’, + with type constructor ‘Something’ + and data constructor ‘Something’. In the expression: foo {bar = return True} - In an equation for ‘wog’: wog x = foo {bar = return True} diff --git a/utils/haddock b/utils/haddock -Subproject 852d097c27271dba90e3c5faed4343104eb34ca +Subproject 4dd5c93bded622a6e2e011dc7e2c8976454b53c |