Sjoerd Visscher pushed to branch wip/T18570 at Glasgow Haskell Compiler / GHC Commits: 7e05307b by Sjoerd Visscher at 2025-06-25T17:26:38+02:00 Fix hole fits - - - - - 4876d312 by Sjoerd Visscher at 2025-06-25T17:31:27+02:00 Remove check for LinearTypes extension - - - - - 7 changed files: - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/TyCl/Utils.hs - testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.stdout - testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr - testsuite/tests/typecheck/should_fail/CommonFieldTypeMismatch.stderr - utils/haddock/html-test/ref/Bug294.html Changes: ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -3541,12 +3541,12 @@ pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc pprHoleFit _ (RawHoleFit sd) = sd pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (TcHoleFit (HoleFit {..})) = hang display 2 provenance - where tyApp = sep $ zipWithEqual pprArg vars hfWrap + where tyApps = concat $ zipWithEqual pprArg vars hfWrap where pprArg b arg = case binderFlag b of - Specified -> text "@" <> pprParendType arg + Specified -> [text "@" <> pprParendType arg] -- Do not print type application for inferred -- variables (#16456) - Inferred -> empty + Inferred -> [] Required -> pprPanic "pprHoleFit: bad Required" (ppr b <+> ppr arg) tyAppVars = sep $ punctuate comma $ @@ -3573,9 +3573,9 @@ pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (TcHoleFit (HoleFit {..})) = IdHFCand id_ -> pprPrefixOcc id_ tyDisp = ppWhen sTy $ dcolon <+> ppr hfType has = not . null - wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars)) + wrapDisp = ppWhen (has tyApps && (sWrp || sWrpVars)) $ text "with" <+> if sWrp || not sTy - then occDisp <+> tyApp + then occDisp <+> sep tyApps else tyAppVars docs = case hfDoc of Just d -> pprHsDocStrings d ===================================== compiler/GHC/Tc/TyCl/PatSyn.hs ===================================== @@ -841,7 +841,7 @@ mkPatSynRecSelBinds :: PatSyn -> FieldSelectors -> [(Id, LHsBind GhcRn)] mkPatSynRecSelBinds ps fields has_sel - = [ mkOneRecordSelector False [PatSynCon ps] (RecSelPatSyn ps) fld_lbl has_sel + = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl has_sel | fld_lbl <- fields ] isUnidirectional :: HsPatSynDir a -> Bool ===================================== compiler/GHC/Tc/TyCl/Utils.hs ===================================== @@ -766,8 +766,7 @@ addTyConsToGblEnv tyclss do { traceTc "tcAddTyCons" $ vcat [ text "tycons" <+> ppr tyclss , text "implicits" <+> ppr implicit_things ] - ; linearEnabled <- xoptM LangExt.LinearTypes - ; gbl_env <- tcRecSelBinds (mkRecSelBinds linearEnabled tyclss) + ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss) ; th_bndrs <- tcTyThBinders implicit_things ; return (gbl_env, th_bndrs) } @@ -850,24 +849,24 @@ tcRecSelBinds sel_bind_prs , let loc = getSrcSpan sel_id ] binds = [(NonRecursive, [bind]) | (_, bind) <- sel_bind_prs] -mkRecSelBinds :: Bool -> [TyCon] -> [(Id, LHsBind GhcRn)] +mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)] -- NB We produce *un-typechecked* bindings, rather like 'deriving' -- This makes life easier, because the later type checking will add -- all necessary type abstractions and applications -mkRecSelBinds allowMultiplicity tycons - = [ mkRecSelBind allowMultiplicity tc fld | tc <- tycons - , fld <- tyConFieldLabels tc ] +mkRecSelBinds tycons + = [ mkRecSelBind tc fld | tc <- tycons + , fld <- tyConFieldLabels tc ] -mkRecSelBind :: Bool -> TyCon -> FieldLabel -> (Id, LHsBind GhcRn) -mkRecSelBind allowMultiplicity tycon fl - = mkOneRecordSelector allowMultiplicity all_cons (RecSelData tycon) fl +mkRecSelBind :: TyCon -> FieldLabel -> (Id, LHsBind GhcRn) +mkRecSelBind tycon fl + = mkOneRecordSelector all_cons (RecSelData tycon) fl FieldSelectors -- See Note [NoFieldSelectors and naughty record selectors] where all_cons = map RealDataCon (tyConDataCons tycon) -mkOneRecordSelector :: Bool -> [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors +mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors -> (Id, LHsBind GhcRn) -mkOneRecordSelector allowMultiplicity all_cons idDetails fl has_sel +mkOneRecordSelector all_cons idDetails fl has_sel = (sel_id, L (noAnnSrcSpan loc) sel_bind) where loc = getSrcSpan sel_name @@ -932,7 +931,7 @@ mkOneRecordSelector allowMultiplicity all_cons idDetails fl has_sel mkVisFunTy sel_mult data_ty $ field_ty non_partial = length all_cons == length cons_w_field -- See Note [Multiplicity and partial selectors] - (mult_tvb, sel_mult) = if allowMultiplicity && non_partial && all_other_fields_unrestricted + (mult_tvb, sel_mult) = if non_partial && all_other_fields_unrestricted then ([mkForAllTyBinder (Invisible InferredSpec) mult_var], mkTyVarTy mult_var) else ([], manyDataConTy) mult_var = mkTyVar (mkSysTvName (mkBuiltinUnique 1) (fsLit "m")) multiplicityTy ===================================== testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.stdout ===================================== @@ -1,5 +1,8 @@ data Main.R = Main.MkR {Main.foo :: GHC.Internal.Types.Int} -Main.foo :: Main.R -> GHC.Internal.Types.Int -Main.foo :: Main.R -> GHC.Internal.Types.Int -Main.foo :: Main.R -> GHC.Internal.Types.Int +Main.foo :: forall {m_0 :: GHC.Internal.Types.Multiplicity} . + Main.R %m_0 -> GHC.Internal.Types.Int +Main.foo :: forall {m_0 :: GHC.Internal.Types.Multiplicity} . + Main.R %m_0 -> GHC.Internal.Types.Int +Main.foo :: forall {m_0 :: GHC.Internal.Types.Multiplicity} . + Main.R %m_0 -> GHC.Internal.Types.Int 42 ===================================== testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr ===================================== @@ -1,22 +1,32 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 82, types: 52, coercions: 29, joins: 0/0} + = {terms: 83, types: 55, coercions: 31, joins: 0/0} --- RHS size: {terms: 3, types: 3, coercions: 0, joins: 0/0} -unsafeToInteger1 :: forall (n :: Nat). Signed n -> Signed n +-- RHS size: {terms: 4, types: 4, coercions: 0, joins: 0/0} +unsafeToInteger1 + :: forall (n :: Nat) (m :: GHC.Internal.Types.Multiplicity). + Signed n %m -> Signed n [GblId, Arity=1, Unf=OtherCon []] -unsafeToInteger1 = \ (@(n :: Nat)) (ds :: Signed n) -> ds +unsafeToInteger1 + = \ (@(n :: Nat)) + (@(m :: GHC.Internal.Types.Multiplicity)) + (ds :: Signed n) -> + ds --- RHS size: {terms: 1, types: 0, coercions: 8, joins: 0/0} -unsafeToInteger :: forall (n :: Nat). Signed n -> Integer +-- RHS size: {terms: 1, types: 0, coercions: 10, joins: 0/0} +unsafeToInteger + :: forall (n :: Nat) {m :: GHC.Internal.Types.Multiplicity}. + Signed n %m -> Integer [GblId[[RecSel]], Arity=1, Unf=OtherCon []] unsafeToInteger = unsafeToInteger1 - `cast` (forall (n :: <Nat>_N). - <Signed n>_R %<Many>_N ->_R OpaqueNoCastWW.N:Signed <n>_P - :: (forall (n :: Nat). Signed n -> Signed n) - ~R# (forall (n :: Nat). Signed n -> Integer)) + `cast` (forall (n :: <Nat>_N) (m :: _N). + <Signed n>_R %<m>_N ->_R OpaqueNoCastWW.N:Signed <n>_P + :: (forall (n :: Nat) (m :: GHC.Internal.Types.Multiplicity). + Signed n %m -> Signed n) + ~R# (forall (n :: Nat) (m :: GHC.Internal.Types.Multiplicity). + Signed n %m -> Integer)) -- RHS size: {terms: 8, types: 7, coercions: 21, joins: 0/0} times [InlPrag=OPAQUE] ===================================== testsuite/tests/typecheck/should_fail/CommonFieldTypeMismatch.stderr ===================================== @@ -1,3 +1,11 @@ -CommonFieldTypeMismatch.hs:3:1: [GHC-91827] - Constructors A1 and A2 give different types for field ‘fld’ - In the data type declaration for ‘A’ +CommonFieldTypeMismatch.hs:3:1: error: [GHC-91827] + • Constructors A1 and A2 give different types for field ‘fld’ + • In the data type declaration for ‘A’ + +CommonFieldTypeMismatch.hs:4:8: error: [GHC-83865] + • Couldn't match type ‘[Char]’ with ‘Int’ + Expected: Int + Actual: String + • In the expression: fld + In an equation for ‘fld’: fld A2 {fld = fld} = fld + ===================================== utils/haddock/html-test/ref/Bug294.html ===================================== @@ -159,9 +159,13 @@ ><p class="src" ><a id="v:problemField" class="def" >problemField :: TO :: forall {m :: Multiplicity}. TO <a href="#" title="Bug294" >A -> %m -> <a href="#" title="Bug294" >A</a > <a href="#" class="selflink" >#<p class="src" ><a id="v:problemField-39-" class="def" >problemField' :: DO :: forall {m :: Multiplicity}. DO <a href="#" title="Bug294" >A -> %m -> <a href="#" title="Bug294" >A</a > <a href="#" class="selflink" >#