[Git][ghc/ghc][wip/az/T23885-unicode-funtycon] 10 commits: Make STG rewriter produce updatable closures
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Fri Sep 8 18:44:48 UTC 2023
Alan Zimmerman pushed to branch wip/az/T23885-unicode-funtycon at Glasgow Haskell Compiler / GHC
Commits:
3930d793 by Jaro Reinders at 2023-09-06T18:42:55-04:00
Make STG rewriter produce updatable closures
- - - - -
0104221a by Krzysztof Gogolewski at 2023-09-06T18:43:32-04:00
configure: update message to use hadrian (#22616)
- - - - -
b34f8586 by Alan Zimmerman at 2023-09-07T10:58:38-04:00
EPA: Incorrect locations for UserTyVar with '@'
In T13343.hs, the location for the @ is not within the span of the
surrounding UserTyVar.
type Bad @v = (forall (v1 :: RuntimeRep) (a1 :: TYPE v). a1) :: TYPE v
Widen it so it is captured.
Closes #23887
- - - - -
8046f020 by Finley McIlwaine at 2023-09-07T10:59:15-04:00
Bump haddock submodule to fix #23920
Removes the fake export of `FUN` from Prelude. Fixes #23920.
Bumps haddock submodule.
- - - - -
e0aa8c6e by Krzysztof Gogolewski at 2023-09-07T11:00:03-04:00
Fix wrong role in mkSelCo_maybe
In the Lint failure in #23938, we start with a coercion Refl :: T a ~R T a,
and call mkSelCo (SelTyCon 1 nominal) Refl.
The function incorrectly returned Refl :: a ~R a. The returned role
should be nominal, according to the SelCo rule:
co : (T s1..sn) ~r0 (T t1..tn)
r = tyConRole tc r0 i
----------------------------------
SelCo (SelTyCon i r) : si ~r ti
In this test case, r is nominal while r0 is representational.
- - - - -
1d92f2df by Gergő Érdi at 2023-09-08T04:04:30-04:00
If we have multiple defaulting plugins, then we should zonk in between them
after any defaulting has taken place, to avoid a defaulting plugin seeing
a metavariable that has already been filled.
Fixes #23821.
- - - - -
eaee4d29 by Gergő Érdi at 2023-09-08T04:04:30-04:00
Improvements to the documentation of defaulting plugins
Based on @simonpj's draft and comments in !11117
- - - - -
ede3df27 by Alan Zimmerman at 2023-09-08T04:05:06-04:00
EPA: Incorrect span for LWarnDec GhcPs
The code (from T23465.hs)
{-# WARNInG in "x-c" e "d" #-}
e = e
gives an incorrect span for the LWarnDecl GhcPs
Closes #23892
It also fixes the Test23465/Test23464 mixup
- - - - -
a0ccef7a by Krzysztof Gogolewski at 2023-09-08T04:05:42-04:00
Valid hole fits: don't suggest unsafeCoerce (#17940)
- - - - -
c04b455f by Alan Zimmerman at 2023-09-08T18:27:36+01:00
EPA: track unicode version for unrestrictedFunTyCon
Closes #23885
Updates haddock submodule
- - - - -
30 changed files:
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Stg/InferTags/Rewrite.hs
- compiler/GHC/Tc/Errors/Hole.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Types.hs
- configure.ac
- docs/users_guide/extending_ghc.rst
- testsuite/tests/printer/Makefile
- − testsuite/tests/printer/Test23464.hs
- + testsuite/tests/printer/Test23465.hs
- + testsuite/tests/printer/Test23885.hs
- + testsuite/tests/printer/Test23887.hs
- testsuite/tests/printer/all.T
- + testsuite/tests/simplCore/should_compile/T23938.hs
- + testsuite/tests/simplCore/should_compile/T23938A.hs
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/simplStg/should_run/T23783.hs
- + testsuite/tests/simplStg/should_run/T23783a.hs
- testsuite/tests/simplStg/should_run/all.T
- + testsuite/tests/typecheck/should_fail/T17940.hs
- + testsuite/tests/typecheck/should_fail/T17940.stderr
- testsuite/tests/typecheck/should_fail/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/haddock
Changes:
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -1148,8 +1148,12 @@ mkSelCo_maybe cs co
Pair ty1 ty2 = coercionKind co
go cs co
- | Just (ty, r) <- isReflCo_maybe co
- = Just (mkReflCo r (getNthFromType cs ty))
+ | Just (ty, _co_role) <- isReflCo_maybe co
+ = let new_role = coercionRole (SelCo cs co)
+ in Just (mkReflCo new_role (getNthFromType cs ty))
+ -- The role of the result (new_role) does not have to
+ -- be equal to _co_role, the role of co, per Note [SelCo].
+ -- This was revealed by #23938.
go SelForAll (ForAllCo { fco_kind = kind_co })
= Just kind_co
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -1268,7 +1268,7 @@ type instance XXWarnDecl (GhcPass _) = DataConCantHappen
instance OutputableBndrId p
=> Outputable (WarnDecls (GhcPass p)) where
ppr (Warnings ext decls)
- = ftext src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"
+ = ftext src <+> vcat (punctuate semi (map ppr decls)) <+> text "#-}"
where src = case ghcPass @p of
GhcPs | (_, SourceText src) <- ext -> src
GhcRn | SourceText src <- ext -> src
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -464,9 +464,12 @@ hsScopedKvs (L _ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndr
hsScopedKvs _ = []
---------------------
+hsTyVarLName :: HsTyVarBndr flag (GhcPass p) -> LIdP (GhcPass p)
+hsTyVarLName (UserTyVar _ _ n) = n
+hsTyVarLName (KindedTyVar _ _ n _) = n
+
hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
-hsTyVarName (UserTyVar _ _ (L _ n)) = n
-hsTyVarName (KindedTyVar _ _ (L _ n) _) = n
+hsTyVarName = unLoc . hsTyVarLName
hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName = hsTyVarName . unLoc
@@ -488,10 +491,12 @@ hsAllLTyVarNames (HsQTvs { hsq_ext = kvs
, hsq_explicit = tvs })
= kvs ++ hsLTyVarNames tvs
-hsLTyVarLocName :: LHsTyVarBndr flag (GhcPass p) -> LocatedN (IdP (GhcPass p))
-hsLTyVarLocName (L l a) = L (l2l l) (hsTyVarName a)
+hsLTyVarLocName :: Anno (IdGhcP p) ~ SrcSpanAnnN
+ => LHsTyVarBndr flag (GhcPass p) -> LocatedN (IdP (GhcPass p))
+hsLTyVarLocName (L _ a) = hsTyVarLName a
-hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]
+hsLTyVarLocNames :: Anno (IdGhcP p) ~ SrcSpanAnnN
+ => LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]
hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
-- | Get the kind signature of a type, ignoring parentheses:
=====================================
compiler/GHC/Parser.y
=====================================
@@ -773,9 +773,9 @@ identifier :: { LocatedN RdrName }
| qvarop { $1 }
| qconop { $1 }
| '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }
+ (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) }
| '->' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnnRArrow (glAA $1) []) }
+ (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) }
-----------------------------------------------------------------------------
-- Backpack stuff
@@ -2002,8 +2002,8 @@ warnings :: { OrdList (LWarnDecl GhcPs) }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
warning :: { OrdList (LWarnDecl GhcPs) }
: warning_category namelist strings
- {% fmap unitOL $ acsA (\cs -> sLL $2 $>
- (Warning (EpAnn (glR $2) (fst $ unLoc $3) cs) (unLoc $2)
+ {% fmap unitOL $ acsA (\cs -> L (comb3 $1 $2 $3)
+ (Warning (EpAnn (glMR $1 $2) (fst $ unLoc $3) cs) (unLoc $2)
(WarningTxt $1 NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }
deprecations :: { OrdList (LWarnDecl GhcPs) }
@@ -3662,7 +3662,7 @@ ntgtycon :: { LocatedN RdrName } -- A "general" qualified tycon, excluding unit
| '(#' bars '#)' {% amsrn (sLL $1 $> $ getRdrName (sumTyCon (snd $2 + 1)))
(NameAnnBars NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }
| '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }
+ (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) }
| '[' ']' {% amsrn (sLL $1 $> $ listTyCon_RDR)
(NameAnnOnly NameSquare (glAA $1) (glAA $2) []) }
@@ -3744,7 +3744,8 @@ otycon :: { LocatedN RdrName }
op :: { LocatedN RdrName } -- used in infix decls
: varop { $1 }
| conop { $1 }
- | '->' { sL1n $1 $ getRdrName unrestrictedFunTyCon }
+ | '->' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
+ (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) }
varop :: { LocatedN RdrName }
: varsym { $1 }
@@ -4300,6 +4301,10 @@ glN = getLocA
glR :: Located a -> Anchor
glR la = Anchor (realSrcSpan $ getLoc la) UnchangedAnchor
+glMR :: Maybe (Located a) -> Located b -> Anchor
+glMR (Just la) _ = glR la
+glMR _ la = glR la
+
glAA :: Located a -> EpaLocation
glAA = srcSpan2e . getLoc
@@ -4554,5 +4559,4 @@ adaptWhereBinds (Just (L l (b, mc))) = L l (b, maybe emptyComments id mc)
combineHasLocs :: (HasLoc a, HasLoc b) => a -> b -> SrcSpan
combineHasLocs a b = combineSrcSpans (getHasLoc a) (getHasLoc b)
-
}
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -759,7 +759,10 @@ data NameAnn
}
-- | Used for @->@, as an identifier
| NameAnnRArrow {
+ nann_unicode :: Bool,
+ nann_mopen :: Maybe EpaLocation,
nann_name :: EpaLocation,
+ nann_mclose :: Maybe EpaLocation,
nann_trailing :: [TrailingAnn]
}
-- | Used for an item with a leading @'@. The annotation for
@@ -1029,6 +1032,10 @@ instance HasLoc (Located a) where
instance HasLoc (GenLocated (SrcSpanAnn' a) e) where
getHasLoc (L (SrcSpanAnn _ l) _) = l
+instance (HasLoc a) => (HasLoc (Maybe a)) where
+ getHasLoc (Just a) = getHasLoc a
+ getHasLoc Nothing = noSrcSpan
+
getHasLocList :: HasLoc a => [a] -> SrcSpan
getHasLocList [] = noSrcSpan
getHasLocList xs = foldl1' combineSrcSpans $ map getHasLoc xs
@@ -1039,7 +1046,7 @@ realSrcSpan :: SrcSpan -> RealSrcSpan
realSrcSpan (RealSrcSpan s _) = s
realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary
where
- l = mkRealSrcLoc (fsLit "foo") (-1) (-1)
+ l = mkRealSrcLoc (fsLit "realSrcSpan") (-1) (-1)
srcSpan2e :: SrcSpan -> EpaLocation
srcSpan2e (RealSrcSpan s mb) = EpaSpan s mb
@@ -1432,8 +1439,8 @@ instance Outputable NameAnn where
= text "NameAnnBars" <+> ppr a <+> ppr o <+> ppr n <+> ppr b <+> ppr t
ppr (NameAnnOnly a o c t)
= text "NameAnnOnly" <+> ppr a <+> ppr o <+> ppr c <+> ppr t
- ppr (NameAnnRArrow n t)
- = text "NameAnnRArrow" <+> ppr n <+> ppr t
+ ppr (NameAnnRArrow u o n c t)
+ = text "NameAnnRArrow" <+> ppr u <+> ppr o <+> ppr n <+> ppr c <+> ppr t
ppr (NameAnnQuote q n t)
= text "NameAnnQuote" <+> ppr q <+> ppr n <+> ppr t
ppr (NameAnnTrailing t)
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -963,19 +963,30 @@ checkTyVars pp_what equals_or_where tc tparms
= let
an = (reverse ops) ++ cps
in
- return (L (widenLocatedAn (l Semi.<> annt) an)
- (KindedTyVar (addAnns (annk Semi.<> ann) an cs) bvis (L lv tv) k))
+ return (L (widenLocatedAn (l Semi.<> annt) (for_widening bvis:an))
+ (KindedTyVar (addAnns (annk Semi.<> ann Semi.<> for_widening_ann bvis) an cs)
+ bvis (L lv tv) k))
chk ops cps cs bvis (L l (HsTyVar ann _ (L ltv tv)))
| isRdrTyVar tv
= let
an = (reverse ops) ++ cps
in
- return (L (widenLocatedAn l an)
- (UserTyVar (addAnns ann an cs) bvis (L ltv tv)))
+ return (L (widenLocatedAn l (for_widening bvis:an))
+ (UserTyVar (addAnns (ann Semi.<> for_widening_ann bvis) an cs)
+ bvis (L ltv tv)))
chk _ _ _ _ t@(L loc _)
= addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
(PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where)
+ -- Return an AddEpAnn for use in widenLocatedAn. The AnnKeywordId is not used.
+ for_widening :: HsBndrVis GhcPs -> AddEpAnn
+ for_widening (HsBndrInvisible (L (TokenLoc loc) _)) = AddEpAnn AnnAnyclass loc
+ for_widening _ = AddEpAnn AnnAnyclass (EpaDelta (SameLine 0) [])
+
+ for_widening_ann :: HsBndrVis GhcPs -> EpAnn [AddEpAnn]
+ for_widening_ann (HsBndrInvisible (L (TokenLoc (EpaSpan r _mb)) _)) = EpAnn (realSpanAsAnchor r) [] emptyComments
+ for_widening_ann _ = EpAnnNotUsed
+
whereDots, equalsDots :: SDoc
-- Second argument to checkTyVars
=====================================
compiler/GHC/Stg/InferTags/Rewrite.hs
=====================================
@@ -368,7 +368,10 @@ rewriteRhs (_id, _tagSig) (StgRhsCon ccs con cn ticks args typ) = {-# SCC rewrit
fvs <- fvArgs args
-- lcls <- getFVs
-- pprTraceM "RhsClosureConversion" (ppr (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) $$ text "lcls:" <> ppr lcls)
- return $! (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) typ
+
+ -- We mark the closure updatable to retain sharing in the case that
+ -- conExpr is an infinite recursive data type. See #23783.
+ return $! (StgRhsClosure fvs ccs Updatable [] $! conExpr) typ
rewriteRhs _binding (StgRhsClosure fvs ccs flag args body typ) = do
withBinders NotTopLevel args $
withClosureLcls fvs $
=====================================
compiler/GHC/Tc/Errors/Hole.hs
=====================================
@@ -48,7 +48,7 @@ import GHC.Core.DataCon
import GHC.Core.Predicate( Pred(..), classifyPredType, eqRelRole )
import GHC.Types.Name
import GHC.Types.Name.Reader
-import GHC.Builtin.Names ( gHC_ERR )
+import GHC.Builtin.Names ( gHC_ERR, uNSAFE_COERCE )
import GHC.Types.Id
import GHC.Types.Var.Set
import GHC.Types.Var.Env
@@ -823,8 +823,8 @@ tcFilterHoleFits limit typed_hole ht@(hole_ty, _) candidates =
_ -> discard_it }
_ -> discard_it }
where
- -- We want to filter out undefined and the likes from GHC.Err
- not_trivial id = nameModule_maybe (idName id) /= Just gHC_ERR
+ -- We want to filter out undefined and the likes from GHC.Err (#17940)
+ not_trivial id = nameModule_maybe (idName id) `notElem` [Just gHC_ERR, Just uNSAFE_COERCE]
lookup :: HoleFitCandidate -> TcM (Maybe (Id, Type))
lookup (IdHFCand id) = return (Just (id, idType id))
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -3577,6 +3577,48 @@ beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs:
* Defaulting and disambiguation *
* *
*********************************************************************************
+
+Note [Defaulting plugins]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Defaulting plugins enable extending or overriding the defaulting
+behaviour. In `applyDefaulting`, before the built-in defaulting
+mechanism runs, the loaded defaulting plugins are passed the
+`WantedConstraints` and get a chance to propose defaulting assignments
+based on them.
+
+Proposals are represented as `[DefaultingProposal]` with each proposal
+consisting of a type variable to fill-in, the list of defaulting types to
+try in order, and a set of constraints to check at each try. This is
+the same representation (albeit in a nicely packaged-up data type) as
+the candidates generated by the built-in defaulting mechanism, so the
+actual trying of proposals is done by the same `disambigGroup` function.
+
+Wrinkle (DP1): The role of `WantedConstraints`
+
+ Plugins are passed `WantedConstraints` that can perhaps be
+ progressed on by defaulting. But a defaulting plugin is not a solver
+ plugin, its job is to provide defaulting proposals, i.e. mappings of
+ type variable to types. How do plugins know which type variables
+ they are supposed to default?
+
+ The `WantedConstraints` passed to the defaulting plugin are zonked
+ beforehand to ensure all remaining metavariables are unfilled. Thus,
+ the `WantedConstraints` serve a dual purpose: they are both the
+ constraints of the given context that can act as hints to the
+ defaulting, as well as the containers of the type variables under
+ consideration for defaulting.
+
+Wrinkle (DP2): Interactions between defaulting mechanisms
+
+ In the general case, we have multiple defaulting plugins loaded and
+ there is also the built-in defaulting mechanism. In this case, we
+ have to be careful to keep the `WantedConstraints` passed to the
+ plugins up-to-date by zonking between successful defaulting
+ rounds. Otherwise, two plugins might come up with a defaulting
+ proposal for the same metavariable; if the first one is accepted by
+ `disambigGroup` (thus the meta gets filled), the second proposal
+ becomes invalid (see #23821 for an example).
+
-}
applyDefaultingRules :: WantedConstraints -> TcS Bool
@@ -3593,20 +3635,16 @@ applyDefaultingRules wanteds
; tcg_env <- TcS.getGblEnv
; let plugins = tcg_defaulting_plugins tcg_env
- ; plugin_defaulted <- if null plugins then return [] else
+ -- Run any defaulting plugins
+ -- See Note [Defaulting plugins] for an overview
+ ; (wanteds, plugin_defaulted) <- if null plugins then return (wanteds, []) else
do {
; traceTcS "defaultingPlugins {" (ppr wanteds)
- ; defaultedGroups <- mapM (run_defaulting_plugin wanteds) plugins
+ ; (wanteds, defaultedGroups) <- mapAccumLM run_defaulting_plugin wanteds plugins
; traceTcS "defaultingPlugins }" (ppr defaultedGroups)
- ; return defaultedGroups
+ ; return (wanteds, defaultedGroups)
}
- -- If a defaulting plugin solves a tyvar, some of the wanteds
- -- will have filled-in metavars by now (see #23281). So we
- -- re-zonk to make sure the built-in defaulting rules don't try
- -- to solve the same metavars.
- ; wanteds <- if or plugin_defaulted then TcS.zonkWC wanteds else pure wanteds
-
; let groups = findDefaultableGroups info wanteds
; traceTcS "applyDefaultingRules {" $
@@ -3629,8 +3667,14 @@ applyDefaultingRules wanteds
groups
; traceTcS "defaultingPlugin " $ ppr defaultedGroups
; case defaultedGroups of
- [] -> return False
- _ -> return True
+ [] -> return (wanteds, False)
+ _ -> do
+ -- If a defaulting plugin solves any tyvars, some of the wanteds
+ -- will have filled-in metavars by now (see wrinkle DP2 of
+ -- Note [Defaulting plugins]). So we re-zonk to make sure later
+ -- defaulting doesn't try to solve the same metavars.
+ wanteds' <- TcS.zonkWC wanteds
+ return (wanteds', True)
}
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -1066,7 +1066,12 @@ instance Outputable DefaultingProposal where
<+> ppr (deProposals p)
<+> ppr (deProposalCts p)
-type FillDefaulting = WantedConstraints -> TcPluginM [DefaultingProposal]
+type FillDefaulting
+ = WantedConstraints
+ -- Zonked constraints containing the unfilled metavariables that
+ -- can be defaulted. See wrinkle (DP1) of Note [Defaulting plugins]
+ -- in GHC.Tc.Solver
+ -> TcPluginM [DefaultingProposal]
-- | A plugin for controlling defaulting.
data DefaultingPlugin = forall s. DefaultingPlugin
=====================================
configure.ac
=====================================
@@ -1313,13 +1313,17 @@ echo "----------------------------------------------------------------------
"
echo "\
-For a standard build of GHC (fully optimised with profiling), type (g)make.
+For a standard build of GHC (fully optimised with profiling), type
+ ./hadrian/build
-To make changes to the default build configuration, copy the file
-mk/build.mk.sample to mk/build.mk, and edit the settings in there.
+You can customise the build with flags such as
+ ./hadrian/build -j --flavour=devel2 [--freeze1]
+
+To make changes to the default build configuration, see the file
+ hadrian/src/UserSettings.hs
For more information on how to configure your GHC build, see
- https://gitlab.haskell.org/ghc/ghc/wikis/building
+ https://gitlab.haskell.org/ghc/ghc/-/wikis/building/hadrian
"]
# Currently we don't validate the /host/ GHC toolchain because configure
=====================================
docs/users_guide/extending_ghc.rst
=====================================
@@ -1378,18 +1378,36 @@ Defaulting plugins have a single access point in the `GHC.Tc.Types` module
-- ^ Clean up after the plugin, when exiting the type-checker.
}
-
-The plugin gets a combination of wanted constraints which can be most easily
-broken down into simple wanted constraints with ``approximateWC``. The result of
-running the plugin should be a ``[DefaultingProposal]``: a list of types that
-should be attempted for the given type variables that are ambiguous in a given
-context. GHC will check if one of the proposals is acceptable in the given
-context and then default to it. The most robust context to return in ``deProposalCts``
-is the list of all wanted constraints that mention the variables you are defaulting.
-If you leave out a constraint, the default will be accepted, and then potentially
-result in a type checker error if it is incompatible with one of the constraints
-you left out. This can be a useful way of forcing a default and reporting errors
-to the user.
+The plugin has type ``WantedConstraints -> [DefaultingProposal]``.
+
+* It is given the currently unsolved constraints.
+* It returns a list of independent "defaulting proposals".
+* Each proposal of type ``DefaultingProposal`` specifies:
+ * ``deProposals``: specifies a list,
+ in priority order, of sets of type variable assignments
+ * ``deProposalCts :: [Ct]`` gives a set of constraints (always a
+ subset of the incoming ``WantedConstraints``) to use as a
+ criterion for acceptance
+
+After calling the plugin, GHC executes each ``DefaultingProposal`` in
+turn. To "execute" a proposal, GHC tries each of the proposed type
+assignments in ``deProposals`` in turn:
+
+* It assigns the proposed types to the type variables, and then tries to
+ solve ``deProposalCts``
+* If those constraints are completely solved by the assignment, GHC
+ accepts the assignment and moves on to the next ``DefaultingProposal``
+* If not, GHC tries the next assignment in ``deProposals``.
+
+The plugin can assume that the incoming constraints are fully
+"zonked" (see :ghc-wiki:`the Wiki page on zonking <zonking>`).
+
+The most robust ``deProposalCts`` to provide is the list of all wanted
+constraints that mention the variable you are defaulting. If you leave
+out a constraint, the default may be accepted, and then potentially
+result in a type checker error if it is incompatible with one of the
+constraints you left out. This can be a useful way of forcing a
+default and reporting errors to the user.
There is an example of defaulting lifted types in the GHC test suite. In the
`testsuite/tests/plugins/` directory see `defaulting-plugin/` for the
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -796,7 +796,18 @@ Test22771:
$(CHECK_PPR) $(LIBDIR) Test22771.hs
$(CHECK_EXACT) $(LIBDIR) Test22771.hs
-.PHONY: Test23464
+.PHONY: Test23465
Test23465:
- $(CHECK_PPR) $(LIBDIR) Test23464.hs
- $(CHECK_EXACT) $(LIBDIR) Test23464.hs
+ $(CHECK_PPR) $(LIBDIR) Test23465.hs
+ $(CHECK_EXACT) $(LIBDIR) Test23465.hs
+
+.PHONY: Test23887
+Test23887:
+ $(CHECK_PPR) $(LIBDIR) Test23887.hs
+ $(CHECK_EXACT) $(LIBDIR) Test23887.hs
+
+.PHONY: Test23885
+Test23885:
+ # ppr is not currently unicode aware
+ # $(CHECK_PPR) $(LIBDIR) Test23885.hs
+ $(CHECK_EXACT) $(LIBDIR) Test23885.hs
=====================================
testsuite/tests/printer/Test23464.hs deleted
=====================================
@@ -1,4 +0,0 @@
-module T23465 {-# WaRNING in "x-a" "b" #-} where
-
-{-# WARNInG in "x-c" e "d" #-}
-e = e
=====================================
testsuite/tests/printer/Test23465.hs
=====================================
@@ -0,0 +1,14 @@
+module Test23465 {-# WaRNING in "x-a" "b" #-} where
+
+{-# WARNInG in "x-c" e "d" #-}
+e = e
+
+{-# WARNInG
+ in "x-f" f "fw" ;
+ in "x-f" g "gw"
+#-}
+f = f
+g = g
+
+{-# WARNinG h "hw" #-}
+h = h
=====================================
testsuite/tests/printer/Test23885.hs
=====================================
@@ -0,0 +1,25 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE UnicodeSyntax #-}
+module Test23885 where
+
+import Control.Monad (Monad(..), join, ap)
+import Data.Monoid (Monoid(..))
+import Data.Semigroup (Semigroup(..))
+
+class Monoidy to comp id m | m to → comp id where
+ munit :: id `to` m
+ mjoin :: (m `comp` m) `to` m
+
+newtype Sum a = Sum a deriving Show
+instance Num a ⇒ Monoidy (→) (,) () (Sum a) where
+ munit _ = Sum 0
+ mjoin (Sum x, Sum y) = Sum $ x + y
+
+data NT f g = NT { runNT :: ∀ α. f α → g α }
=====================================
testsuite/tests/printer/Test23887.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE PolyKinds #-}
+module Test23887 where
+-- based on T13343.hs
+import GHC.Exts
+
+type Bad :: forall v . TYPE v
+type Bad @v = (forall (v1 :: RuntimeRep) (a1 :: TYPE v). a1) :: TYPE v
+
+-- Note v /= v1.
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -191,4 +191,6 @@ test('T20531_red_ticks', extra_files(['T20531_defs.hs']), ghci_script, ['T20531_
test('HsDocTy', [ignore_stderr, req_ppr_deps], makefile_test, ['HsDocTy'])
test('Test22765', [ignore_stderr, req_ppr_deps], makefile_test, ['Test22765'])
test('Test22771', [ignore_stderr, req_ppr_deps], makefile_test, ['Test22771'])
-test('Test23464', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23464'])
+test('Test23465', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23465'])
+test('Test23887', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23887'])
+test('Test23885', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23885'])
=====================================
testsuite/tests/simplCore/should_compile/T23938.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE MagicHash #-}
+module T23938 where
+
+import T23938A
+import Control.Monad.ST
+
+genIndexes :: () -> ST RealWorld (GVector RealWorld (T Int))
+genIndexes = new f
=====================================
testsuite/tests/simplCore/should_compile/T23938A.hs
=====================================
@@ -0,0 +1,60 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+
+module T23938A where
+
+import GHC.Exts
+import GHC.ST
+import Data.Kind
+
+class Monad m => PrimMonad m where
+ type PrimState m
+ primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
+
+instance PrimMonad (ST s) where
+ type PrimState (ST s) = s
+ primitive = ST
+ {-# INLINE primitive #-}
+
+{-# INLINE stToPrim #-}
+stToPrim (ST m) = primitive m
+
+data family MVector s a
+data instance MVector s Int = MyVector (MutableByteArray# s)
+
+data T (x :: Type)
+
+data family GVector s a
+data instance GVector s (T a) = MV_2 (MVector s a)
+
+new :: (PrimMonad m) => CVector a -> () -> m (GVector (PrimState m) (T a))
+{-# INLINE new #-}
+new e _ = stToPrim (unsafeNew e >>= \v -> ini e v >> return v)
+
+ini :: CVector a -> GVector s (T a) -> ST s ()
+ini e (MV_2 as) = basicInitialize e as
+
+unsafeNew :: (PrimMonad m) => CVector a -> m (GVector (PrimState m) (T a))
+{-# INLINE unsafeNew #-}
+unsafeNew e = stToPrim (basicUnsafeNew e >>= \(!z) -> pure (MV_2 z))
+
+data CVector a = CVector {
+ basicUnsafeNew :: forall s. ST s (MVector s a),
+ basicInitialize :: forall s. MVector s a -> ST s ()
+}
+
+f :: CVector Int
+f = CVector {
+ basicUnsafeNew = ST (\s -> case newByteArray# 4# s of
+ (# s', a #) -> (# s', MyVector a #)),
+
+ basicInitialize = \(MyVector dst) ->
+ ST (\s -> case setByteArray# dst 0# 0# 0# s of s' -> (# s', () #))
+}
+{-# INLINE f #-}
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -497,3 +497,4 @@ test('T23567', [extra_files(['T23567A.hs'])], multimod_compile, ['T23567', '-O -
# The -ddump-simpl of T22404 should have no let-bindings
test('T22404', [only_ways(['optasm']), check_errmsg(r'let') ], compile, ['-ddump-simpl -dsuppress-uniques'])
test('T23864', normal, compile, ['-O -dcore-lint -package ghc -Wno-gadt-mono-local-binds'])
+test('T23938', [extra_files(['T23938A.hs'])], multimod_compile, ['T23938', '-O -v0'])
=====================================
testsuite/tests/simplStg/should_run/T23783.hs
=====================================
@@ -0,0 +1,18 @@
+module Main where
+import T23783a
+import GHC.Conc
+
+expensive :: Int -> Int
+{-# OPAQUE expensive #-}
+expensive x = x
+
+{-# OPAQUE f #-}
+f xs = let ys = expensive xs
+ h zs = let t = wombat t ys in ys `seq` (zs, t, ys)
+ in h
+
+main :: IO ()
+main = do
+ setAllocationCounter 100000
+ enableAllocationLimit
+ case f 0 () of (_, t, _) -> seqT 16 t `seq` pure ()
=====================================
testsuite/tests/simplStg/should_run/T23783a.hs
=====================================
@@ -0,0 +1,8 @@
+module T23783a where
+import Debug.Trace
+data T a = MkT (T a) (T a) !a !Int
+wombat t x = MkT t t x 2
+
+seqT :: Int -> T a -> ()
+seqT 0 _ = ()
+seqT n (MkT x y _ _) = seqT (n - 1) x `seq` seqT (n - 1) y `seq` ()
=====================================
testsuite/tests/simplStg/should_run/all.T
=====================================
@@ -20,3 +20,4 @@ test('T13536a',
test('inferTags001', normal, multimod_compile_and_run, ['inferTags001', 'inferTags001_a'])
test('T22042', [extra_files(['T22042a.hs']),only_ways('normal'),unless(have_dynamic(), skip)], makefile_test, ['T22042'])
+test('T23783', normal, multimod_compile_and_run, ['T23783', '-O -v0'])
\ No newline at end of file
=====================================
testsuite/tests/typecheck/should_fail/T17940.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE MagicHash #-}
+module T17940 where
+
+import GHC.Exts
+
+index# :: ByteArray# -> Int# -> Word8#
+index# a i = _ (indexWord8Array# a i)
=====================================
testsuite/tests/typecheck/should_fail/T17940.stderr
=====================================
@@ -0,0 +1,17 @@
+
+T17940.hs:7:14: error: [GHC-88464]
+ • Found hole: _ :: Word8# -> Word8#
+ • In the expression: _ (indexWord8Array# a i)
+ In an equation for ‘index#’: index# a i = _ (indexWord8Array# a i)
+ • Relevant bindings include
+ i :: Int# (bound at T17940.hs:7:10)
+ a :: ByteArray# (bound at T17940.hs:7:8)
+ index# :: ByteArray# -> Int# -> Word8# (bound at T17940.hs:7:1)
+ Valid hole fits include
+ notWord8# :: Word8# -> Word8#
+ (imported from ‘GHC.Exts’ at T17940.hs:4:1-15
+ (and originally defined in ‘GHC.Prim’))
+ coerce :: forall a b. Coercible a b => a -> b
+ with coerce @Word8# @Word8#
+ (imported from ‘GHC.Exts’ at T17940.hs:4:1-15
+ (and originally defined in ‘GHC.Prim’))
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -700,3 +700,4 @@ test('T22684', normal, compile_fail, [''])
test('T23514a', normal, compile_fail, [''])
test('T22478c', normal, compile_fail, [''])
test('T23776', normal, compile, ['']) # to become an error in GHC 9.12
+test('T17940', normal, compile_fail, [''])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -617,6 +617,15 @@ markEpAnnLMS' (EpAnn anc a cs) l kw (Just str) = do
-- ---------------------------------------------------------------------
+markLToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)
+ => Located (HsToken tok) -> EP w m (Located (HsToken tok))
+markLToken (L (RealSrcSpan aa mb) t) = do
+ epaLoc'<- printStringAtAA (EpaSpan aa mb) (symbolVal (Proxy @tok))
+ case epaLoc' of
+ EpaSpan aa' mb' -> return (L (RealSrcSpan aa' mb') t)
+ _ -> return (L (RealSrcSpan aa mb ) t)
+markLToken (L lt t) = return (L lt t)
+
markToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)
=> LHsToken tok GhcPs -> EP w m (LHsToken tok GhcPs)
markToken (L NoTokenLoc t) = return (L NoTokenLoc t)
@@ -1411,11 +1420,12 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where
exact (L (SrcSpanAnn an l) (WarningTxt mb_cat src ws)) = do
an0 <- markAnnOpenP an src "{-# WARNING"
+ mb_cat' <- markAnnotated mb_cat
an1 <- markEpAnnL an0 lapr_rest AnnOpenS
ws' <- markAnnotated ws
an2 <- markEpAnnL an1 lapr_rest AnnCloseS
an3 <- markAnnCloseP an2
- return (L (SrcSpanAnn an3 l) (WarningTxt mb_cat src ws'))
+ return (L (SrcSpanAnn an3 l) (WarningTxt mb_cat' src ws'))
exact (L (SrcSpanAnn an l) (DeprecatedTxt src ws)) = do
an0 <- markAnnOpenP an src "{-# DEPRECATED"
@@ -1425,6 +1435,25 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where
an3 <- markAnnCloseP an2
return (L (SrcSpanAnn an3 l) (DeprecatedTxt src ws'))
+instance ExactPrint InWarningCategory where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ = a
+
+ exact (InWarningCategory tkIn source (L l wc)) = do
+ tkIn' <- markLToken tkIn
+ L _ (_,wc') <- markAnnotated (L l (source, wc))
+ return (InWarningCategory tkIn' source (L l wc'))
+
+instance ExactPrint (SourceText, WarningCategory) where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ = a
+
+ exact (st, WarningCategory wc) = do
+ case st of
+ NoSourceText -> printStringAdvance $ "\"" ++ (unpackFS wc) ++ "\""
+ SourceText src -> printStringAdvance $ (unpackFS src)
+ return (st, WarningCategory wc)
+
-- ---------------------------------------------------------------------
instance ExactPrint (ImportDecl GhcPs) where
@@ -1748,19 +1777,20 @@ instance ExactPrint (WarnDecl GhcPs) where
getAnnotationEntry (Warning an _ _) = fromAnn an
setAnnotationAnchor (Warning an a b) anc cs = Warning (setAnchorEpa an anc cs) a b
- exact (Warning an lns txt) = do
+ exact (Warning an lns (WarningTxt mb_cat src ls )) = do
+ mb_cat' <- markAnnotated mb_cat
lns' <- markAnnotated lns
an0 <- markEpAnnL an lidl AnnOpenS -- "["
- txt' <-
- case txt of
- WarningTxt mb_cat src ls -> do
- ls' <- markAnnotated ls
- return (WarningTxt mb_cat src ls')
- DeprecatedTxt src ls -> do
- ls' <- markAnnotated ls
- return (DeprecatedTxt src ls')
+ ls' <- markAnnotated ls
an1 <- markEpAnnL an0 lidl AnnCloseS -- "]"
- return (Warning an1 lns' txt')
+ return (Warning an1 lns' (WarningTxt mb_cat' src ls'))
+
+ exact (Warning an lns (DeprecatedTxt src ls)) = do
+ lns' <- markAnnotated lns
+ an0 <- markEpAnnL an lidl AnnOpenS -- "["
+ ls' <- markAnnotated ls
+ an1 <- markEpAnnL an0 lidl AnnCloseS -- "]"
+ return (Warning an1 lns' (DeprecatedTxt src ls'))
-- ---------------------------------------------------------------------
@@ -1783,7 +1813,6 @@ instance ExactPrint FastString where
-- exact fs = printStringAdvance (show (unpackFS fs))
exact fs = printStringAdvance (unpackFS fs) >> return fs
-
-- ---------------------------------------------------------------------
instance ExactPrint (RuleDecls GhcPs) where
@@ -3122,7 +3151,6 @@ instance (ExactPrint body)
-- ---------------------------------------------------------------------
--- instance ExactPrint (HsRecUpdField GhcPs q) where
instance (ExactPrint (LocatedA body))
=> ExactPrint (HsFieldBind (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs)) (LocatedA body)) where
getAnnotationEntry x = fromAnn (hfbAnn x)
@@ -4079,7 +4107,7 @@ instance ExactPrint (LocatedN RdrName) where
NameAnn a o l c t -> do
mn <- markName a o (Just (l,n)) c
case mn of
- (o', (Just (l',_n)), c') -> do -- (o', (Just (l',n')), c')
+ (o', (Just (l',_n)), c') -> do
t' <- markTrailing t
return (NameAnn a o' l' c' t')
_ -> error "ExactPrint (LocatedN RdrName)"
@@ -4101,10 +4129,23 @@ instance ExactPrint (LocatedN RdrName) where
(o',_,c') <- markName a o Nothing c
t' <- markTrailing t
return (NameAnnOnly a o' c' t')
- NameAnnRArrow nl t -> do
- (AddEpAnn _ nl') <- markKwC NoCaptureComments (AddEpAnn AnnRarrow nl)
+ NameAnnRArrow unicode o nl c t -> do
+ o' <- case o of
+ Just o0 -> do
+ (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn AnnOpenP o0)
+ return (Just o')
+ Nothing -> return Nothing
+ (AddEpAnn _ nl') <-
+ if unicode
+ then markKwC NoCaptureComments (AddEpAnn AnnRarrowU nl)
+ else markKwC NoCaptureComments (AddEpAnn AnnRarrow nl)
+ c' <- case c of
+ Just c0 -> do
+ (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn AnnCloseP c0)
+ return (Just c')
+ Nothing -> return Nothing
t' <- markTrailing t
- return (NameAnnRArrow nl' t')
+ return (NameAnnRArrow unicode o' nl' c' t')
NameAnnQuote q name t -> do
debugM $ "NameAnnQuote"
(AddEpAnn _ q') <- markKwC NoCaptureComments (AddEpAnn AnnSimpleQuote q)
=====================================
utils/check-exact/Main.hs
=====================================
@@ -36,10 +36,10 @@ import GHC.Data.FastString
-- ---------------------------------------------------------------------
_tt :: IO ()
-_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_build/stage1/lib/"
+-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_build/stage1/lib/"
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib/"
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
--- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
+_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
-- "../../testsuite/tests/ghc-api/exactprint/RenameCase1.hs" (Just changeRenameCase1)
-- "../../testsuite/tests/ghc-api/exactprint/LayoutLet2.hs" (Just changeLayoutLet2)
@@ -205,7 +205,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/printer/Test16279.hs" Nothing
-- "../../testsuite/tests/printer/HsDocTy.hs" Nothing
-- "../../testsuite/tests/printer/Test22765.hs" Nothing
- "../../testsuite/tests/printer/Test22771.hs" Nothing
+ -- "../../testsuite/tests/printer/Test22771.hs" Nothing
+ "../../testsuite/tests/printer/Test23465.hs" Nothing
-- cloneT does not need a test, function can be retired
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 394920426d99cee7822d5854bc83bbaab4970c7a
+Subproject commit d073163aacdb321c4020d575fc417a9b2368567a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d3cae4bbcfcd8ae7df79b6ed2f96f41fada28260...c04b455f96839d986adfe99fadef32a4465ba08b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d3cae4bbcfcd8ae7df79b6ed2f96f41fada28260...c04b455f96839d986adfe99fadef32a4465ba08b
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230908/a4ef9bbe/attachment-0001.html>
More information about the ghc-commits
mailing list