[Git][ghc/ghc][wip/sol/remove-ddump-json] 20 commits: README: Add note on ghc.nix
by Simon Hengel (＠sol) 10 Aug '25
by Simon Hengel (＠sol) 10 Aug '25
10 Aug '25
Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC
Commits:
69cc16ca by Marc Scholten at 2025-08-06T15:51:28-04:00
README: Add note on ghc.nix
- - - - -
93a2f450 by Daniel Díaz at 2025-08-06T15:52:14-04:00
Link to the "Strict Bindings" docs from the linear types docs
Strict Bidings are relevant for the kinds of multiplicity annotations
linear lets support.
- - - - -
246b7853 by Matthew Pickering at 2025-08-07T06:58:30-04:00
level imports: Check the level of exported identifiers
The level imports specification states that exported identifiers have to
be at level 0. This patch adds the requird level checks that all
explicitly mentioned identifiers occur at level 0.
For implicit export specifications (T(..) and module B), only level 0
identifiers are selected for re-export.
ghc-proposal: https://github.com/ghc-proposals/ghc-proposals/pull/705
Fixes #26090
- - - - -
358bc4fc by fendor at 2025-08-07T06:59:12-04:00
Bump GHC on darwin CI to 9.10.1
- - - - -
1903ae35 by Matthew Pickering at 2025-08-07T12:21:10+01:00
ipe: Place strings and metadata into specific .ipe section
By placing the .ipe metadata into a specific section it can be stripped
from the final binary if desired.
```
objcopy --remove-section .ipe <binary>
upx <binary>
```
Towards #21766
- - - - -
c80dd91c by Matthew Pickering at 2025-08-07T12:22:42+01:00
ipe: Place magic word at the start of entries in the .ipe section
The magic word "IPE\nIPE\n" is placed at the start of .ipe sections,
then if the section is stripped, we can check whether the section starts
with the magic word or not to determine whether there is metadata
present or not.
Towards #21766
- - - - -
cab42666 by Matthew Pickering at 2025-08-07T12:22:42+01:00
ipe: Use stable IDs for IPE entries
IPEs have historically been indexed and reported by their address.
This makes it impossible to compare profiles between runs, since the
addresses may change (due to ASLR) and also makes it tricky to separate
out the IPE map from the binary.
This small patch adds a stable identifier for each IPE entry.
The stable identifier is a single 64 bit word. The high-bits are a
per-module identifier and the low bits identify which entry in each
module.
1. When a node is added into the IPE buffer it is assigned a unique
identifier from an incrementing global counter.
2. Each entry already has an index by it's position in the
`IpeBufferListNode`.
The two are combined together by the `IPE_ENTRY_KEY` macro.
Info table profiling uses the stable identifier rather than the address
of the info table.
The benefits of this change are:
* Profiles from different runs can be easily compared
* The metadata can be extracted from the binary (via the eventlog for
example) and then stripped from the executable.
Fixes #21766
- - - - -
2860a9a5 by Simon Peyton Jones at 2025-08-07T20:29:18-04:00
In TcSShortCut, typechecker plugins should get empty Givens
Solving in TcShortCut mode means /ignoring the Givens/. So we
should not pass them to typechecker plugins!
Fixes #26258.
This is a fixup to the earlier MR:
commit 1bd12371feacc52394a0e660ef9349f9e8ee1c06
Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com>
Date: Mon Jul 21 10:04:49 2025 +0100
Improve treatment of SPECIALISE pragmas -- again!
- - - - -
2157db2d by sterni at 2025-08-08T15:32:39-04:00
hadrian: enable terminfo if --with-curses-* flags are given
The GHC make build system used to support WITH_TERMINFO in ghc.mk which
allowed controlling whether to build GHC with terminfo or not. hadrian
has replaced this with a system where this is effectively controlled by
the cross-compiling setting (the default WITH_TERMINFO value was bassed
on CrossCompiling, iirc).
This behavior is undesireable in some cases and there is not really a
good way to work around it. Especially for downstream packagers,
modifying this via UserSettings is not really feasible since such a
source file has to be kept in sync with Settings/Default.hs manually
since it can't import Settings.Default or any predefined Flavour
definitions.
To avoid having to add a new setting to cfg/system.config and/or a new
configure flag (though I'm happy to implement both if required), I've
chosen to take --with-curses-* being set explicitly as an indication
that the user wants to have terminfo enabled. This would work for
Nixpkgs which sets these flags [1] as well as haskell.nix [2] (which
goes to some extreme measures [3] [4] to force terminfo in all scenarios).
In general, I'm an advocate for making the GHC build be the same for
native and cross insofar it is possible since it makes packaging GHC and
Haskell related things while still supporting cross much less
compilicated. A more minimal GHC with reduced dependencies should
probably be a specific flavor, not the default.
Partially addresses #26288 by forcing terminfo to be built if the user
explicitly passes configure flags related to it. However, it isn't built
by default when cross-compiling yet nor is there an explicit way to
control the package being built.
[1]: https://github.com/NixOS/nixpkgs/blob/3a7266fcefcb9ce353df49ba3f292d0644376…
[2]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
[3]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
[4]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
- - - - -
b3c31488 by David Feuer at 2025-08-08T15:33:21-04:00
Add default QuasiQuoters
Add `defaultQuasiQuoter` and `namedDefaultQuasiQuoter` to make it easier
to write `QuasiQuoters` that give helpful error messages when they're
used in inappropriate contexts.
Closes #24434.
- - - - -
397763da by Simon Hengel at 2025-08-10T06:12:02+07:00
Refactoring: Don't misuse `MCDiagnostic` for lint messages
`MCDiagnostic` is meant to be used for compiler diagnostics.
Any code that creates `MCDiagnostic` directly, without going through
`GHC.Driver.Errors.printMessage`, side steps `-fdiagnostics-as-json`
(see e.g. !14475, !14492 !14548).
To avoid this in the future I want to control more narrowly who creates
`MCDiagnostic` (see #24113).
Some parts of the compiler use `MCDiagnostic` purely for formatting
purposes, without creating any real compiler diagnostics. This change
introduces a helper function, `formatDiagnostic`, that can be used in
such cases instead of constructing `MCDiagnostic`.
- - - - -
c6392ebb by Simon Hengel at 2025-08-10T06:12:02+07:00
Rename MCDiagnostic to UnsafeMCDiagnostic
- - - - -
1fee223a by Simon Hengel at 2025-08-10T06:12:02+07:00
Remove -ddump-json (fixes #24113)
- - - - -
8873732c by Simon Hengel at 2025-08-10T06:12:02+07:00
Add SrcSpan to MCDiagnostic
- - - - -
f60aac7a by Simon Hengel at 2025-08-10T06:12:02+07:00
Refactoring: More consistently use logOutput, logInfo, fatalErrorMsg
- - - - -
c6b49448 by Simon Hengel at 2025-08-10T06:12:02+07:00
Get rid of mkLocMessage
- - - - -
34d6baea by Simon Hengel at 2025-08-10T06:12:02+07:00
Add Message data type
- - - - -
1f5a353e by Simon Hengel at 2025-08-10T06:12:02+07:00
Get rid of MessageClass
- - - - -
4c776200 by Simon Hengel at 2025-08-10T06:12:02+07:00
Rename DiagnosticMessage to GenericDiagnosticMessage
- - - - -
b6f47d1e by Simon Hengel at 2025-08-10T09:34:48+07:00
Remove JSON logging
- - - - -
78 changed files:
- .gitlab/darwin/toolchain.nix
- README.md
- compiler/GHC/Cmm.hs
- compiler/GHC/CmmToAsm/PPC/Ppr.hs
- compiler/GHC/CmmToAsm/Ppr.hs
- compiler/GHC/CmmToLlvm/Data.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Errors.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Monad.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Pipeline/LogQueue.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Debugger.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/StgToCmm/InfoTableProv.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Types/SourceError.hs
- compiler/GHC/Utils/Error.hs
- compiler/GHC/Utils/Logger.hs
- docs/users_guide/debug-info.rst
- docs/users_guide/debugging.rst
- docs/users_guide/exts/linear_types.rst
- docs/users_guide/exts/strict.rst
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Exception.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- libraries/template-haskell/Language/Haskell/TH/Quote.hs
- libraries/template-haskell/changelog.md
- rts/IPE.c
- rts/ProfHeap.c
- rts/eventlog/EventLog.c
- rts/include/rts/IPE.h
- testsuite/tests/driver/T16167.stderr
- − testsuite/tests/driver/T16167.stdout
- testsuite/tests/driver/all.T
- testsuite/tests/driver/json2.stderr
- − testsuite/tests/driver/json_dump.hs
- − testsuite/tests/driver/json_dump.stderr
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- testsuite/tests/rts/ipe/ipeMap.c
- testsuite/tests/rts/ipe/ipe_lib.c
- + testsuite/tests/splice-imports/DodgyLevelExport.hs
- + testsuite/tests/splice-imports/DodgyLevelExport.stderr
- + testsuite/tests/splice-imports/DodgyLevelExportA.hs
- + testsuite/tests/splice-imports/LevelImportExports.hs
- + testsuite/tests/splice-imports/LevelImportExports.stdout
- + testsuite/tests/splice-imports/LevelImportExportsA.hs
- testsuite/tests/splice-imports/Makefile
- + testsuite/tests/splice-imports/ModuleExport.hs
- + testsuite/tests/splice-imports/ModuleExport.stderr
- + testsuite/tests/splice-imports/ModuleExportA.hs
- + testsuite/tests/splice-imports/ModuleExportB.hs
- + testsuite/tests/splice-imports/T26090.hs
- + testsuite/tests/splice-imports/T26090.stderr
- + testsuite/tests/splice-imports/T26090A.hs
- testsuite/tests/splice-imports/all.T
- utils/check-exact/Main.hs
- utils/check-exact/Preprocess.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/42b5dedbd311deb03c020557d389c1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/42b5dedbd311deb03c020557d389c1…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T23162-spj] Start to extend to equalities
by Simon Peyton Jones (＠simonpj) 09 Aug '25
by Simon Peyton Jones (＠simonpj) 09 Aug '25
09 Aug '25
Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC
Commits:
02401833 by Simon Peyton Jones at 2025-08-10T00:14:42+01:00
Start to extend to equalities
- - - - -
4 changed files:
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/FunDeps.hs
- compiler/GHC/Tc/Solver/Monad.hs
Changes:
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -21,7 +21,7 @@ import GHC.Tc.Types.Constraint
import GHC.Tc.Types.CtLoc
import GHC.Tc.Types.Origin
import GHC.Tc.Types.EvTerm( evCallStack )
-import GHC.Tc.Solver.FunDeps( doDictFunDepImprovement )
+import GHC.Tc.Solver.FunDeps( tryDictFunDeps )
import GHC.Tc.Solver.InertSet
import GHC.Tc.Solver.Monad
import GHC.Tc.Solver.Types
@@ -95,7 +95,7 @@ solveDict dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = tys })
-- Try fundeps /after/ tryInstances:
-- see (DFL2) in Note [Do fundeps last]
- ; doDictFunDepImprovement dict_ct
+ ; tryDictFunDeps dict_ct
; simpleStage (updInertDicts dict_ct)
; stopWithStage (dictCtEvidence dict_ct) "Kept inert DictCt" }
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -16,9 +16,8 @@ import GHC.Tc.Solver.Irred( solveIrred )
import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance )
import GHC.Tc.Solver.Rewrite
import GHC.Tc.Solver.Monad
-import GHC.Tc.Solver.FunDeps( unifyAndEmitFunDepWanteds )
+import GHC.Tc.Solver.FunDeps( tryEqFunDeps )
import GHC.Tc.Solver.InertSet
-import GHC.Tc.Solver.Types( findFunEqsByTyCon )
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.CtLoc
@@ -26,7 +25,6 @@ import GHC.Tc.Types.Origin
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.TcType
import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe )
-import GHC.Tc.Instance.FunDeps( FunDepEqn(..) )
import qualified GHC.Tc.Utils.Monad as TcM
import GHC.Core.Type
@@ -36,21 +34,15 @@ import GHC.Core.DataCon ( dataConName )
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking
import GHC.Core.Coercion
-import GHC.Core.Coercion.Axiom
import GHC.Core.Reduction
-import GHC.Core.Unify( tcUnifyTyForInjectivity )
-import GHC.Core.FamInstEnv ( FamInstEnvs, FamInst(..), apartnessCheck
- , lookupFamInstEnvByTyCon )
+import GHC.Core.FamInstEnv ( FamInstEnvs )
import GHC.Core
-
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set( anyVarSet )
import GHC.Types.Name.Reader
import GHC.Types.Basic
-import GHC.Builtin.Types.Literals ( tryInteractTopFam, tryInteractInertFam )
-
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
@@ -120,9 +112,9 @@ solveEquality ev eq_rel ty1 ty2
Left irred_ct -> do { tryQCsIrredEqCt irred_ct
; solveIrred irred_ct } ;
- Right eq_ct -> do { tryInertEqs eq_ct
- ; tryFunDeps eq_ct
- ; tryQCsEqCt eq_ct
+ Right eq_ct -> do { tryInertEqs eq_ct
+ ; tryEqFunDeps eq_ct
+ ; tryQCsEqCt eq_ct
; simpleStage (updInertEqs eq_ct)
; stopWithStage (eqCtEvidence eq_ct) "Kept inert EqCt" } } }
@@ -2025,7 +2017,7 @@ canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs
evCoercion (mkNomReflCo final_rhs)
-- Kick out any constraints that can now be rewritten
- ; kickOutAfterUnification [tv]
+ ; recordUnification tv
; return (Stop new_ev (text "Solved by unification")) }
@@ -2996,456 +2988,3 @@ lovely quantified constraint. Alas!
This test arranges to ignore the instance-based solution under these
(rare) circumstances. It's sad, but I really don't see what else we can do.
-}
-
-
-{-
-**********************************************************************
-* *
- Functional dependencies for type families
-* *
-**********************************************************************
-
-Note [Reverse order of fundep equations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this scenario (from dependent/should_fail/T13135_simple):
-
- type Sig :: Type -> Type
- data Sig a = SigFun a (Sig a)
-
- type SmartFun :: forall (t :: Type). Sig t -> Type
- type family SmartFun sig = r | r -> sig where
- SmartFun @Type (SigFun @Type a sig) = a -> SmartFun @Type sig
-
- [W] SmartFun @kappa sigma ~ (Int -> Bool)
-
-The injectivity of SmartFun allows us to produce two new equalities:
-
- [W] w1 :: Type ~ kappa
- [W] w2 :: SigFun @Type Int beta ~ sigma
-
-for some fresh (beta :: SigType). The second Wanted here is actually
-heterogeneous: the LHS has type Sig Type while the RHS has type Sig kappa.
-Of course, if we solve the first wanted first, the second becomes homogeneous.
-
-When looking for injectivity-inspired equalities, we work left-to-right,
-producing the two equalities in the order written above. However, these
-equalities are then passed into wrapUnifierTcS, which will fail, adding these
-to the work list. However, crucially, the work list operates like a *stack*.
-So, because we add w1 and then w2, we process w2 first. This is silly: solving
-w1 would unlock w2. So we make sure to add equalities to the work
-list in left-to-right order, which requires a few key calls to 'reverse'.
-
-This treatment is also used for class-based functional dependencies, although
-we do not have a program yet known to exhibit a loop there. It just seems
-like the right thing to do.
-
-When this was originally conceived, it was necessary to avoid a loop in T13135.
-That loop is now avoided by continuing with the kind equality (not the type
-equality) in canEqCanLHSHetero (see Note [Equalities with heterogeneous kinds]).
-However, the idea of working left-to-right still seems worthwhile, and so the calls
-to 'reverse' remain.
-
-Note [Improvement orientation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See also Note [Fundeps with instances, and equality orientation], which describes
-the Exact Same Problem, with the same solution, but for functional dependencies.
-
-A very delicate point is the orientation of equalities
-arising from injectivity improvement (#12522). Suppose we have
- type family F x = t | t -> x
- type instance F (a, Int) = (Int, G a)
-where G is injective; and wanted constraints
-
- [W] F (alpha, beta) ~ (Int, <some type>)
-
-The injectivity will give rise to constraints
-
- [W] gamma1 ~ alpha
- [W] Int ~ beta
-
-The fresh unification variable gamma1 comes from the fact that we
-can only do "partial improvement" here; see Section 5.2 of
-"Injective type families for Haskell" (HS'15).
-
-Now, it's very important to orient the equations this way round,
-so that the fresh unification variable will be eliminated in
-favour of alpha. If we instead had
- [W] alpha ~ gamma1
-then we would unify alpha := gamma1; and kick out the wanted
-constraint. But when we substitute it back in, it'd look like
- [W] F (gamma1, beta) ~ fuv
-and exactly the same thing would happen again! Infinite loop.
-
-This all seems fragile, and it might seem more robust to avoid
-introducing gamma1 in the first place, in the case where the
-actual argument (alpha, beta) partly matches the improvement
-template. But that's a bit tricky, esp when we remember that the
-kinds much match too; so it's easier to let the normal machinery
-handle it. Instead we are careful to orient the new
-equality with the template on the left. Delicate, but it works.
-
--}
-
---------------------
-
-tryFunDeps :: EqCt -> SolverStage ()
-tryFunDeps work_item@(EqCt { eq_lhs = lhs, eq_ev = ev, eq_eq_rel = eq_rel })
- | NomEq <- eq_rel
- , TyFamLHS tc args <- lhs
- = Stage $
- do { inerts <- getInertCans
- ; imp1 <- improveLocalFunEqs inerts tc args work_item
- ; imp2 <- improveTopFunEqs tc args work_item
- ; if (imp1 || imp2)
- then startAgainWith (mkNonCanonical ev)
- else continueWith () }
- | otherwise
- = nopStage ()
-
---------------------
-improveTopFunEqs :: TyCon -> [TcType] -> EqCt -> TcS Bool
--- TyCon is definitely a type family
--- See Note [FunDep and implicit parameter reactions]
-improveTopFunEqs fam_tc args (EqCt { eq_ev = ev, eq_rhs = rhs_ty })
- | isGiven ev = improveGivenTopFunEqs fam_tc args ev rhs_ty
- | otherwise = improveWantedTopFunEqs fam_tc args ev rhs_ty
-
-improveGivenTopFunEqs :: TyCon -> [TcType] -> CtEvidence -> Xi -> TcS Bool
--- TyCon is definitely a type family
--- Work-item is a Given
-improveGivenTopFunEqs fam_tc args ev rhs_ty
- | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
- = do { traceTcS "improveGivenTopFunEqs" (ppr fam_tc <+> ppr args $$ ppr ev $$ ppr rhs_ty)
- ; emitNewGivens (ctEvLoc ev) $
- [ (Nominal, new_co)
- | (ax, _) <- tryInteractTopFam ops fam_tc args rhs_ty
- , let new_co = mkAxiomCo ax [given_co] ]
- ; return False } -- False: no unifications
- | otherwise
- = return False
- where
- given_co :: Coercion = ctEvCoercion ev
-
-improveWantedTopFunEqs :: TyCon -> [TcType] -> CtEvidence -> Xi -> TcS Bool
--- TyCon is definitely a type family
--- Work-item is a Wanted
-improveWantedTopFunEqs fam_tc args ev rhs_ty
- = do { eqns <- improve_wanted_top_fun_eqs fam_tc args rhs_ty
- ; traceTcS "improveTopFunEqs" (vcat [ text "lhs:" <+> ppr fam_tc <+> ppr args
- , text "rhs:" <+> ppr rhs_ty
- , text "eqns:" <+> ppr eqns ])
- ; unifyFunDeps ev Nominal $ \uenv ->
- uPairsTcM (bump_depth uenv) (reverse eqns) }
- -- Missing that `reverse` causes T13135 and T13135_simple to loop.
- -- See Note [Reverse order of fundep equations]
-
- where
- bump_depth env = env { u_loc = bumpCtLocDepth (u_loc env) }
- -- ToDo: this location is wrong; it should be FunDepOrigin2
- -- See #14778
-
-improve_wanted_top_fun_eqs :: TyCon -> [TcType] -> Xi
- -> TcS [TypeEqn]
--- TyCon is definitely a type family
-improve_wanted_top_fun_eqs fam_tc lhs_tys rhs_ty
- | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
- = return (map snd $ tryInteractTopFam ops fam_tc lhs_tys rhs_ty)
-
- -- ToDo: use ideas in #23162 for closed type families; injectivity only for open
-
- -- See Note [Type inference for type families with injectivity]
- -- Open, so look for inj
- | Injective inj_args <- tyConInjectivityInfo fam_tc
- = do { fam_envs <- getFamInstEnvs
- ; top_eqns <- improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty
- ; let local_eqns = improve_injective_wanted_famfam inj_args fam_tc lhs_tys rhs_ty
- ; traceTcS "improve_wanted_top_fun_eqs" $
- vcat [ ppr fam_tc, text "local_eqns" <+> ppr local_eqns, text "top_eqns" <+> ppr top_eqns ]
- -- xxx ToDo: this does both local and top => bug?
- ; return (local_eqns ++ top_eqns) }
-
- | otherwise -- No injectivity
- = return []
-
-improve_injective_wanted_top :: FamInstEnvs -> [Bool] -> TyCon -> [TcType] -> Xi -> TcS [TypeEqn]
--- Interact with top-level instance declarations
--- See Section 5.2 in the Injective Type Families paper
-improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty
- = concatMapM do_one branches
- where
- branches :: [CoAxBranch]
- branches | isOpenTypeFamilyTyCon fam_tc
- , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc
- = concatMap (fromBranches . coAxiomBranches . fi_axiom) fam_insts
-
- | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc
- = fromBranches (coAxiomBranches ax)
-
- | otherwise
- = []
-
- do_one :: CoAxBranch -> TcS [TypeEqn]
- do_one branch@(CoAxBranch { cab_tvs = branch_tvs, cab_lhs = branch_lhs_tys, cab_rhs = branch_rhs })
- | let in_scope1 = in_scope `extendInScopeSetList` branch_tvs
- , Just subst <- tcUnifyTyForInjectivity False in_scope1 branch_rhs rhs_ty
- -- False: matching, not unifying
- = do { let inSubst tv = tv `elemVarEnv` getTvSubstEnv subst
- unsubstTvs = filterOut inSubst branch_tvs
- -- The order of unsubstTvs is important; it must be
- -- in telescope order e.g. (k:*) (a:k)
-
- ; (_subst_tvs, subst1) <- instFlexiX subst unsubstTvs
- -- If the current substitution bind [k -> *], and
- -- one of the un-substituted tyvars is (a::k), we'd better
- -- be sure to apply the current substitution to a's kind.
- -- Hence instFlexiX. #13135 was an example.
-
- ; traceTcS "improve_inj_top" $
- vcat [ text "branch_rhs" <+> ppr branch_rhs
- , text "rhs_ty" <+> ppr rhs_ty
- , text "subst" <+> ppr subst
- , text "subst1" <+> ppr subst1 ]
- ; if apartnessCheck (substTys subst1 branch_lhs_tys) branch
- then do { traceTcS "improv_inj_top1" (ppr branch_lhs_tys)
- ; return (mkInjectivityEqns inj_args (map (substTy subst1) branch_lhs_tys) lhs_tys) }
- -- NB: The fresh unification variables (from unsubstTvs) are on the left
- -- See Note [Improvement orientation]
- else do { traceTcS "improve_inj_top2" empty; return [] } }
- | otherwise
- = do { traceTcS "improve_inj_top:fail" (ppr branch_rhs $$ ppr rhs_ty $$ ppr in_scope $$ ppr branch_tvs)
- ; return [] }
-
- in_scope = mkInScopeSet (tyCoVarsOfType rhs_ty)
-
-
-improve_injective_wanted_famfam :: [Bool] -> TyCon -> [TcType] -> Xi -> [TypeEqn]
--- Interact with itself, specifically F s1 s2 ~ F t1 t2
-improve_injective_wanted_famfam inj_args fam_tc lhs_tys rhs_ty
- | Just (tc, rhs_tys) <- tcSplitTyConApp_maybe rhs_ty
- , tc == fam_tc
- = mkInjectivityEqns inj_args lhs_tys rhs_tys
- | otherwise
- = []
-
-mkInjectivityEqns :: [Bool] -> [TcType] -> [TcType] -> [TypeEqn]
--- When F s1 s2 s3 ~ F t1 t2 t3, and F has injectivity info [True,False,True]
--- return the equations [Pair s1 t1, Pair s3 t3]
-mkInjectivityEqns inj_args lhs_args rhs_args
- = [ Pair lhs_arg rhs_arg | (True, lhs_arg, rhs_arg) <- zip3 inj_args lhs_args rhs_args ]
-
----------------------------------------------
-improveLocalFunEqs :: InertCans
- -> TyCon -> [TcType] -> EqCt -- F args ~ rhs
- -> TcS Bool
--- Emit equalities from interaction between two equalities
-improveLocalFunEqs inerts fam_tc args (EqCt { eq_ev = work_ev, eq_rhs = rhs })
- | isGiven work_ev = improveGivenLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs
- | otherwise = improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs
- where
- funeqs = inert_funeqs inerts
- funeqs_for_tc :: [EqCt] -- Mixture of Given and Wanted
- funeqs_for_tc = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc
- , funeq_ct <- equal_ct_list
- , NomEq == eq_eq_rel funeq_ct ]
- -- Representational equalities don't interact
- -- with type family dependencies
-
-
-improveGivenLocalFunEqs :: [EqCt] -- Inert items, mixture of Given and Wanted
- -> TyCon -> [TcType] -> CtEvidence -> Xi -- Work item (Given)
- -> TcS Bool -- Always False (no unifications)
--- Emit equalities from interaction between two Given type-family equalities
--- e.g. (x+y1~z, x+y2~z) => (y1 ~ y2)
-improveGivenLocalFunEqs funeqs_for_tc fam_tc work_args work_ev work_rhs
- | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
- = do { mapM_ (do_one ops) funeqs_for_tc
- ; return False } -- False: no unifications
- | otherwise
- = return False
- where
- given_co :: Coercion = ctEvCoercion work_ev
-
- do_one :: BuiltInSynFamily -> EqCt -> TcS ()
- -- Used only work-item is Given
- do_one ops EqCt { eq_ev = inert_ev, eq_lhs = inert_lhs, eq_rhs = inert_rhs }
- | isGiven inert_ev -- Given/Given interaction
- , TyFamLHS _ inert_args <- inert_lhs -- Inert item is F inert_args ~ inert_rhs
- , work_rhs `tcEqType` inert_rhs -- Both RHSs are the same
- , -- So we have work_ev : F work_args ~ rhs
- -- inert_ev : F inert_args ~ rhs
- let pairs :: [(CoAxiomRule, TypeEqn)]
- pairs = tryInteractInertFam ops fam_tc work_args inert_args
- , not (null pairs)
- = do { traceTcS "improveGivenLocalFunEqs" (vcat[ ppr fam_tc <+> ppr work_args
- , text "work_ev" <+> ppr work_ev
- , text "inert_ev" <+> ppr inert_ev
- , ppr work_rhs
- , ppr pairs ])
- ; emitNewGivens (ctEvLoc inert_ev) (map mk_ax_co pairs) }
- -- This CtLoc for the new Givens doesn't reflect the
- -- fact that it's a combination of Givens, but I don't
- -- this that matters.
- where
- inert_co = ctEvCoercion inert_ev
- mk_ax_co (ax,_) = (Nominal, mkAxiomCo ax [combined_co])
- where
- combined_co = given_co `mkTransCo` mkSymCo inert_co
- -- given_co :: F work_args ~ rhs
- -- inert_co :: F inert_args ~ rhs
- -- the_co :: F work_args ~ F inert_args
-
- do_one _ _ = return ()
-
-improveWantedLocalFunEqs
- :: [EqCt] -- Inert items (Given and Wanted)
- -> TyCon -> [TcType] -> CtEvidence -> Xi -- Work item (Wanted)
- -> TcS Bool -- True <=> some unifications
--- Emit improvement equalities for a Wanted constraint, by comparing
--- the current work item with inert CFunEqs (both Given and Wanted)
--- E.g. x + y ~ z, x + y' ~ z => [W] y ~ y'
---
--- See Note [FunDep and implicit parameter reactions]
-improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs
- | null improvement_eqns
- = return False
- | otherwise
- = do { traceTcS "interactFunEq improvements: " $
- vcat [ text "Eqns:" <+> ppr improvement_eqns
- , text "Candidates:" <+> ppr funeqs_for_tc ]
- ; unifyAndEmitFunDepWanteds work_ev improvement_eqns }
- where
- work_loc = ctEvLoc work_ev
- work_pred = ctEvPred work_ev
- fam_inj_info = tyConInjectivityInfo fam_tc
-
- --------------------
- improvement_eqns :: [FunDepEqn (CtLoc, RewriterSet)]
- improvement_eqns
- | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
- = -- Try built-in families, notably for arithmethic
- concatMap (do_one_built_in ops rhs) funeqs_for_tc
-
- | Injective injective_args <- fam_inj_info
- = -- Try improvement from type families with injectivity annotations
- concatMap (do_one_injective injective_args rhs) funeqs_for_tc
-
- | otherwise
- = []
-
- --------------------
- do_one_built_in ops rhs (EqCt { eq_lhs = TyFamLHS _ iargs, eq_rhs = irhs, eq_ev = inert_ev })
- | irhs `tcEqType` rhs
- = mk_fd_eqns inert_ev (map snd $ tryInteractInertFam ops fam_tc args iargs)
- | otherwise
- = []
- do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc) -- TyVarLHS
-
- --------------------
- -- See Note [Type inference for type families with injectivity]
- do_one_injective inj_args rhs (EqCt { eq_lhs = TyFamLHS _ inert_args
- , eq_rhs = irhs, eq_ev = inert_ev })
- | rhs `tcEqType` irhs
- = mk_fd_eqns inert_ev $ mkInjectivityEqns inj_args args inert_args
- | otherwise
- = []
-
- do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) -- TyVarLHS
-
- --------------------
- mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn (CtLoc, RewriterSet)]
- mk_fd_eqns inert_ev eqns
- | null eqns = []
- | otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns
- , fd_loc = (loc, inert_rewriters) } ]
- where
- initial_loc -- start with the location of the Wanted involved
- | isGiven work_ev = inert_loc
- | otherwise = work_loc
- eqn_orig = InjTFOrigin1 work_pred (ctLocOrigin work_loc) (ctLocSpan work_loc)
- inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc)
- eqn_loc = setCtLocOrigin initial_loc eqn_orig
- inert_pred = ctEvPred inert_ev
- inert_loc = ctEvLoc inert_ev
- inert_rewriters = ctEvRewriters inert_ev
- loc = eqn_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`
- ctl_depth work_loc }
-
-{- Note [Type inference for type families with injectivity]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have a type family with an injectivity annotation:
- type family F a b = r | r -> b
-
-Then if we have an equality like F s1 t1 ~ F s2 t2,
-we can use the injectivity to get a new Wanted constraint on
-the injective argument
- [W] t1 ~ t2
-
-That in turn can help GHC solve constraints that would otherwise require
-guessing. For example, consider the ambiguity check for
- f :: F Int b -> Int
-We get the constraint
- [W] F Int b ~ F Int beta
-where beta is a unification variable. Injectivity lets us pick beta ~ b.
-
-Injectivity information is also used at the call sites. For example:
- g = f True
-gives rise to
- [W] F Int b ~ Bool
-from which we can derive b. This requires looking at the defining equations of
-a type family, ie. finding equation with a matching RHS (Bool in this example)
-and inferring values of type variables (b in this example) from the LHS patterns
-of the matching equation. For closed type families we have to perform
-additional apartness check for the selected equation to check that the selected
-is guaranteed to fire for given LHS arguments.
-
-These new constraints are Wanted constraints, but we will not use the evidence.
-We could go further and offer evidence from decomposing injective type-function
-applications, but that would require new evidence forms, and an extension to
-FC, so we don't do that right now (Dec 14).
-
-We generate these Wanteds in three places, depending on how we notice the
-injectivity.
-
-1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and
-described in Note [Decomposing type family applications] in GHC.Tc.Solver.Equality
-
-2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these
-constraints rewrites the other, as they have different LHSs. This is done
-in improveLocalFunEqs, called during the interactWithInertsStage.
-
-3. When we have [W] F tys ~ T and an equation for F that looks like F tys' = T.
-This is done in improve_top_fun_eqs, called from the top-level reactions stage.
-
-See also Note [Injective type families] in GHC.Core.TyCon
-
-Note [Cache-caused loops]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-It is very dangerous to cache a rewritten wanted family equation as 'solved' in our
-solved cache (which is the default behaviour or xCtEvidence), because the interaction
-may not be contributing towards a solution. Here is an example:
-
-Initial inert set:
- [W] g1 : F a ~ beta1
-Work item:
- [W] g2 : F a ~ beta2
-The work item will react with the inert yielding the _same_ inert set plus:
- (i) Will set g2 := g1 `cast` g3
- (ii) Will add to our solved cache that [S] g2 : F a ~ beta2
- (iii) Will emit [W] g3 : beta1 ~ beta2
-Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2
-and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it
-will set
- g1 := g ; sym g3
-and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but
-remember that we have this in our solved cache, and it is ... g2! In short we
-created the evidence loop:
-
- g2 := g1 ; g3
- g3 := refl
- g1 := g2 ; sym g3
-
-To avoid this situation we do not cache as solved any workitems (or inert)
-which did not really made a 'step' towards proving some goal. Solved's are
-just an optimization so we don't lose anything in terms of completeness of
-solving.
--}
=====================================
compiler/GHC/Tc/Solver/FunDeps.hs
=====================================
@@ -4,7 +4,8 @@
-- | Solving Class constraints CDictCan
module GHC.Tc.Solver.FunDeps (
unifyAndEmitFunDepWanteds,
- doDictFunDepImprovement,
+ tryDictFunDeps,
+ tryEqFunDeps
) where
import GHC.Prelude
@@ -12,25 +13,34 @@ import GHC.Prelude
import {-# SOURCE #-} GHC.Tc.Solver.Solve( solveSimpleWanteds )
import GHC.Tc.Instance.FunDeps
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.CtLoc
-import GHC.Tc.Types.Origin
import GHC.Tc.Solver.InertSet
import GHC.Tc.Solver.Monad
import GHC.Tc.Solver.Types
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Unify( UnifyEnv(..) )
import GHC.Tc.Utils.Monad as TcM
+import GHC.Tc.Types.Evidence
+import GHC.Tc.Types.Constraint
+import GHC.Tc.Types.CtLoc
+import GHC.Tc.Types.Origin
import GHC.Core.Type
-import GHC.Core.InstEnv ( ClsInst(..) )
-import GHC.Core.Coercion.Axiom( TypeEqn )
-
+import GHC.Core.FamInstEnv
+import GHC.Core.Coercion
+import GHC.Core.Predicate( EqRel(..) )
+import GHC.Core.TyCon
+import GHC.Core.Unify( tcUnifyTyForInjectivity )
+import GHC.Core.InstEnv( ClsInst(..) )
+import GHC.Core.Coercion.Axiom
+
+import GHC.Builtin.Types.Literals( tryInteractTopFam, tryInteractInertFam )
import GHC.Types.Name
import GHC.Types.Var.Set
+import GHC.Types.Var.Env
import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Utils.Misc( filterOut )
import GHC.Data.Bag
import GHC.Data.Pair
@@ -41,7 +51,7 @@ import Control.Monad
{- *********************************************************************
* *
-* Functional dependencies, instantiation of equations
+* Functional dependencies for dictionaries
* *
************************************************************************
@@ -296,24 +306,24 @@ as the fundeps.
#7875 is a case in point.
-}
-doDictFunDepImprovement :: DictCt -> SolverStage ()
--- (doDictFunDepImprovement inst_envs cts)
+tryDictFunDeps :: DictCt -> SolverStage ()
+-- (tryDictFunDeps inst_envs cts)
-- * Generate the fundeps from interacting the
-- top-level `inst_envs` with the constraints `cts`
-- * Do the unifications and return any unsolved constraints
-- See Note [Fundeps with instances, and equality orientation]
--- doLocalFunDepImprovement does StartAgain if there
+-- doLocalFunDeps does StartAgain if there
-- are any fundeps: see (DFL1) in Note [Do fundeps last]
-doDictFunDepImprovement dict_ct
- = do { doDictFunDepImprovementLocal dict_ct
- ; doDictFunDepImprovementTop dict_ct }
+tryDictFunDeps dict_ct
+ = do { tryDictFunDepsLocal dict_ct
+ ; tryDictFunDepsTop dict_ct }
-doDictFunDepImprovementLocal :: DictCt -> SolverStage ()
+tryDictFunDepsLocal :: DictCt -> SolverStage ()
-- Using functional dependencies, interact the DictCt with the
-- inert Givens and Wanteds, to produce new equalities
-doDictFunDepImprovementLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev })
+tryDictFunDepsLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev })
| isGiven work_ev
= -- If work_ev is Given, there could in principle be some inert Wanteds
-- but in practice there never are because we solve Givens first
@@ -323,11 +333,11 @@ doDictFunDepImprovementLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev })
= Stage $
do { inerts <- getInertCans
- ; traceTcS "doDictFunDepImprovementLocal {" (ppr dict_ct)
+ ; traceTcS "tryDictFunDepsLocal {" (ppr dict_ct)
; imp <- solveFunDeps $
foldM do_interaction emptyCts $
findDictsByClass (inert_dicts inerts) cls
- ; traceTcS "doDictFunDepImprovementLocal }" (text "imp =" <+> ppr imp)
+ ; traceTcS "tryDictFunDepsLocal }" (text "imp =" <+> ppr imp)
; if imp then startAgainWith (CDictCan dict_ct)
else continueWith () }
@@ -350,7 +360,7 @@ doDictFunDepImprovementLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev })
improveFromAnother (deriv_loc, inert_rewriters)
inert_pred work_pred
- ; traceTcS "doDictFunDepImprovementLocal item" $
+ ; traceTcS "tryDictFunDepsLocal item" $
vcat [ ppr work_ev, ppr new_eqs2 ]
; return (new_eqs1 `unionBags` new_eqs2) }
@@ -369,17 +379,17 @@ doDictFunDepImprovementLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev })
(ctLocOrigin inert_loc)
(ctLocSpan inert_loc)
-doDictFunDepImprovementTop :: DictCt -> SolverStage ()
-doDictFunDepImprovementTop dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis })
+tryDictFunDepsTop :: DictCt -> SolverStage ()
+tryDictFunDepsTop dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis })
= Stage $
do { inst_envs <- getInstEnvs
- ; traceTcS "doDictFunDepImprovementTop {" (ppr dict_ct)
+ ; traceTcS "tryDictFunDepsTop {" (ppr dict_ct)
; let eqns :: [FunDepEqn (CtLoc, RewriterSet)]
eqns = improveFromInstEnv inst_envs mk_ct_loc cls xis
; imp <- solveFunDeps $
unifyFunDepWanteds_new ev eqns
- ; traceTcS "doDictFunDepImprovementTop }" (text "imp =" <+> ppr imp)
+ ; traceTcS "tryDictFunDepsTop }" (text "imp =" <+> ppr imp)
; if imp then startAgainWith (CDictCan dict_ct)
else continueWith () }
@@ -469,6 +479,464 @@ The bottom line: since we have no evidence for them, we should ignore Given/Give
and Given/instance fundeps entirely.
-}
+
+
+{-
+**********************************************************************
+* *
+ Functional dependencies for type families
+* *
+**********************************************************************
+
+Note [Reverse order of fundep equations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this scenario (from dependent/should_fail/T13135_simple):
+
+ type Sig :: Type -> Type
+ data Sig a = SigFun a (Sig a)
+
+ type SmartFun :: forall (t :: Type). Sig t -> Type
+ type family SmartFun sig = r | r -> sig where
+ SmartFun @Type (SigFun @Type a sig) = a -> SmartFun @Type sig
+
+ [W] SmartFun @kappa sigma ~ (Int -> Bool)
+
+The injectivity of SmartFun allows us to produce two new equalities:
+
+ [W] w1 :: Type ~ kappa
+ [W] w2 :: SigFun @Type Int beta ~ sigma
+
+for some fresh (beta :: SigType). The second Wanted here is actually
+heterogeneous: the LHS has type Sig Type while the RHS has type Sig kappa.
+Of course, if we solve the first wanted first, the second becomes homogeneous.
+
+When looking for injectivity-inspired equalities, we work left-to-right,
+producing the two equalities in the order written above. However, these
+equalities are then passed into wrapUnifierTcS, which will fail, adding these
+to the work list. However, crucially, the work list operates like a *stack*.
+So, because we add w1 and then w2, we process w2 first. This is silly: solving
+w1 would unlock w2. So we make sure to add equalities to the work
+list in left-to-right order, which requires a few key calls to 'reverse'.
+
+This treatment is also used for class-based functional dependencies, although
+we do not have a program yet known to exhibit a loop there. It just seems
+like the right thing to do.
+
+When this was originally conceived, it was necessary to avoid a loop in T13135.
+That loop is now avoided by continuing with the kind equality (not the type
+equality) in canEqCanLHSHetero (see Note [Equalities with heterogeneous kinds]).
+However, the idea of working left-to-right still seems worthwhile, and so the calls
+to 'reverse' remain.
+
+Note [Improvement orientation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also Note [Fundeps with instances, and equality orientation], which describes
+the Exact Same Problem, with the same solution, but for functional dependencies.
+
+A very delicate point is the orientation of equalities
+arising from injectivity improvement (#12522). Suppose we have
+ type family F x = t | t -> x
+ type instance F (a, Int) = (Int, G a)
+where G is injective; and wanted constraints
+
+ [W] F (alpha, beta) ~ (Int, <some type>)
+
+The injectivity will give rise to constraints
+
+ [W] gamma1 ~ alpha
+ [W] Int ~ beta
+
+The fresh unification variable gamma1 comes from the fact that we
+can only do "partial improvement" here; see Section 5.2 of
+"Injective type families for Haskell" (HS'15).
+
+Now, it's very important to orient the equations this way round,
+so that the fresh unification variable will be eliminated in
+favour of alpha. If we instead had
+ [W] alpha ~ gamma1
+then we would unify alpha := gamma1; and kick out the wanted
+constraint. But when we substitute it back in, it'd look like
+ [W] F (gamma1, beta) ~ fuv
+and exactly the same thing would happen again! Infinite loop.
+
+---> ToDo: all this fragility has gone away! Fix the Note! <---
+
+This all seems fragile, and it might seem more robust to avoid
+introducing gamma1 in the first place, in the case where the
+actual argument (alpha, beta) partly matches the improvement
+template. But that's a bit tricky, esp when we remember that the
+kinds much match too; so it's easier to let the normal machinery
+handle it. Instead we are careful to orient the new
+equality with the template on the left. Delicate, but it works.
+
+-}
+
+--------------------
+tryEqFunDeps :: EqCt -> SolverStage ()
+tryEqFunDeps work_item@(EqCt { eq_lhs = lhs, eq_eq_rel = eq_rel })
+ | NomEq <- eq_rel
+ , TyFamLHS tc args <- lhs
+ = do { improveLocalFunEqs tc args work_item
+ ; improveTopFunEqs tc args work_item }
+ | otherwise
+ = nopStage ()
+
+--------------------
+improveTopFunEqs :: TyCon -> [TcType] -> EqCt -> SolverStage ()
+-- TyCon is definitely a type family
+-- See Note [FunDep and implicit parameter reactions]
+improveTopFunEqs fam_tc args eq_ct@(EqCt { eq_ev = ev, eq_rhs = rhs_ty })
+ = Stage $
+ do { imp <- if isGiven ev
+ then improveGivenTopFunEqs fam_tc args ev rhs_ty
+ else improveWantedTopFunEqs fam_tc args ev rhs_ty
+ ; if imp then startAgainWith (CEqCan eq_ct)
+ else continueWith () }
+
+improveGivenTopFunEqs :: TyCon -> [TcType] -> CtEvidence -> Xi -> TcS Bool
+-- TyCon is definitely a type family
+-- Work-item is a Given
+improveGivenTopFunEqs fam_tc args ev rhs_ty
+ | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
+ = do { traceTcS "improveGivenTopFunEqs" (ppr fam_tc <+> ppr args $$ ppr ev $$ ppr rhs_ty)
+ ; emitNewGivens (ctEvLoc ev) $
+ [ (Nominal, new_co)
+ | (ax, _) <- tryInteractTopFam ops fam_tc args rhs_ty
+ , let new_co = mkAxiomCo ax [given_co] ]
+ ; return False } -- False: no unifications
+ | otherwise
+ = return False
+ where
+ given_co :: Coercion = ctEvCoercion ev
+
+improveWantedTopFunEqs :: TyCon -> [TcType] -> CtEvidence -> Xi -> TcS Bool
+-- TyCon is definitely a type family
+-- Work-item is a Wanted
+improveWantedTopFunEqs fam_tc args ev rhs_ty
+ = do { eqns <- improve_wanted_top_fun_eqs fam_tc args rhs_ty
+ ; traceTcS "improveTopFunEqs" (vcat [ text "lhs:" <+> ppr fam_tc <+> ppr args
+ , text "rhs:" <+> ppr rhs_ty
+ , text "eqns:" <+> ppr eqns ])
+ ; unifyFunDeps ev Nominal $ \uenv ->
+ uPairsTcM (bump_depth uenv) (reverse eqns) }
+ -- Missing that `reverse` causes T13135 and T13135_simple to loop.
+ -- See Note [Reverse order of fundep equations]
+
+ where
+ bump_depth env = env { u_loc = bumpCtLocDepth (u_loc env) }
+ -- ToDo: this location is wrong; it should be FunDepOrigin2
+ -- See #14778
+
+improve_wanted_top_fun_eqs :: TyCon -> [TcType] -> Xi
+ -> TcS [TypeEqn]
+-- TyCon is definitely a type family
+improve_wanted_top_fun_eqs fam_tc lhs_tys rhs_ty
+ | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
+ = return (map snd $ tryInteractTopFam ops fam_tc lhs_tys rhs_ty)
+
+ -- ToDo: use ideas in #23162 for closed type families; injectivity only for open
+
+ -- See Note [Type inference for type families with injectivity]
+ -- Open, so look for inj
+ | Injective inj_args <- tyConInjectivityInfo fam_tc
+ = do { fam_envs <- getFamInstEnvs
+ ; top_eqns <- improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty
+ ; let local_eqns = improve_injective_wanted_famfam inj_args fam_tc lhs_tys rhs_ty
+ ; traceTcS "improve_wanted_top_fun_eqs" $
+ vcat [ ppr fam_tc, text "local_eqns" <+> ppr local_eqns, text "top_eqns" <+> ppr top_eqns ]
+ -- xxx ToDo: this does both local and top => bug?
+ ; return (local_eqns ++ top_eqns) }
+
+ | otherwise -- No injectivity
+ = return []
+
+improve_injective_wanted_top :: FamInstEnvs -> [Bool] -> TyCon -> [TcType] -> Xi -> TcS [TypeEqn]
+-- Interact with top-level instance declarations
+-- See Section 5.2 in the Injective Type Families paper
+improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty
+ = concatMapM do_one branches
+ where
+ branches :: [CoAxBranch]
+ branches | isOpenTypeFamilyTyCon fam_tc
+ , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc
+ = concatMap (fromBranches . coAxiomBranches . fi_axiom) fam_insts
+
+ | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc
+ = fromBranches (coAxiomBranches ax)
+
+ | otherwise
+ = []
+
+ do_one :: CoAxBranch -> TcS [TypeEqn]
+ do_one branch@(CoAxBranch { cab_tvs = branch_tvs, cab_lhs = branch_lhs_tys, cab_rhs = branch_rhs })
+ | let in_scope1 = in_scope `extendInScopeSetList` branch_tvs
+ , Just subst <- tcUnifyTyForInjectivity False in_scope1 branch_rhs rhs_ty
+ -- False: matching, not unifying
+ = do { let inSubst tv = tv `elemVarEnv` getTvSubstEnv subst
+ unsubstTvs = filterOut inSubst branch_tvs
+ -- The order of unsubstTvs is important; it must be
+ -- in telescope order e.g. (k:*) (a:k)
+
+ ; (_subst_tvs, subst1) <- instFlexiX subst unsubstTvs
+ -- If the current substitution bind [k -> *], and
+ -- one of the un-substituted tyvars is (a::k), we'd better
+ -- be sure to apply the current substitution to a's kind.
+ -- Hence instFlexiX. #13135 was an example.
+
+ ; traceTcS "improve_inj_top" $
+ vcat [ text "branch_rhs" <+> ppr branch_rhs
+ , text "rhs_ty" <+> ppr rhs_ty
+ , text "subst" <+> ppr subst
+ , text "subst1" <+> ppr subst1 ]
+ ; if apartnessCheck (substTys subst1 branch_lhs_tys) branch
+ then do { traceTcS "improv_inj_top1" (ppr branch_lhs_tys)
+ ; return (mkInjectivityEqns inj_args (map (substTy subst1) branch_lhs_tys) lhs_tys) }
+ -- NB: The fresh unification variables (from unsubstTvs) are on the left
+ -- See Note [Improvement orientation]
+ else do { traceTcS "improve_inj_top2" empty; return [] } }
+ | otherwise
+ = do { traceTcS "improve_inj_top:fail" (ppr branch_rhs $$ ppr rhs_ty $$ ppr in_scope $$ ppr branch_tvs)
+ ; return [] }
+
+ in_scope = mkInScopeSet (tyCoVarsOfType rhs_ty)
+
+
+improve_injective_wanted_famfam :: [Bool] -> TyCon -> [TcType] -> Xi -> [TypeEqn]
+-- Interact with itself, specifically F s1 s2 ~ F t1 t2
+improve_injective_wanted_famfam inj_args fam_tc lhs_tys rhs_ty
+ | Just (tc, rhs_tys) <- tcSplitTyConApp_maybe rhs_ty
+ , tc == fam_tc
+ = mkInjectivityEqns inj_args lhs_tys rhs_tys
+ | otherwise
+ = []
+
+mkInjectivityEqns :: [Bool] -> [TcType] -> [TcType] -> [TypeEqn]
+-- When F s1 s2 s3 ~ F t1 t2 t3, and F has injectivity info [True,False,True]
+-- return the equations [Pair s1 t1, Pair s3 t3]
+mkInjectivityEqns inj_args lhs_args rhs_args
+ = [ Pair lhs_arg rhs_arg | (True, lhs_arg, rhs_arg) <- zip3 inj_args lhs_args rhs_args ]
+
+---------------------------------------------
+improveLocalFunEqs :: TyCon -> [TcType] -> EqCt -- F args ~ rhs
+ -> SolverStage ()
+-- Emit equalities from interaction between two equalities
+improveLocalFunEqs fam_tc args eq_ct@(EqCt { eq_ev = work_ev, eq_rhs = rhs })
+ = Stage $
+ do { inerts <- getInertCans
+ ; let my_funeqs = get_my_funeqs inerts
+ ; imp <- if isGiven work_ev
+ then improveGivenLocalFunEqs my_funeqs fam_tc args work_ev rhs
+ else improveWantedLocalFunEqs my_funeqs fam_tc args work_ev rhs
+ ; if imp then startAgainWith (CEqCan eq_ct)
+ else continueWith () }
+ where
+ get_my_funeqs :: InertCans -> [EqCt] -- Mixture of Given and Wanted
+ get_my_funeqs (IC { inert_funeqs = funeqs })
+ = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc
+ , funeq_ct <- equal_ct_list
+ , NomEq == eq_eq_rel funeq_ct ]
+ -- Representational equalities don't interact
+ -- with type family dependencies
+
+improveGivenLocalFunEqs :: [EqCt] -- Inert items, mixture of Given and Wanted
+ -> TyCon -> [TcType] -> CtEvidence -> Xi -- Work item (Given)
+ -> TcS Bool -- Always False (no unifications)
+-- Emit equalities from interaction between two Given type-family equalities
+-- e.g. (x+y1~z, x+y2~z) => (y1 ~ y2)
+improveGivenLocalFunEqs funeqs_for_tc fam_tc work_args work_ev work_rhs
+ | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
+ = do { mapM_ (do_one ops) funeqs_for_tc
+ ; return False } -- False: no unifications
+ | otherwise
+ = return False
+ where
+ given_co :: Coercion = ctEvCoercion work_ev
+
+ do_one :: BuiltInSynFamily -> EqCt -> TcS ()
+ -- Used only work-item is Given
+ do_one ops EqCt { eq_ev = inert_ev, eq_lhs = inert_lhs, eq_rhs = inert_rhs }
+ | isGiven inert_ev -- Given/Given interaction
+ , TyFamLHS _ inert_args <- inert_lhs -- Inert item is F inert_args ~ inert_rhs
+ , work_rhs `tcEqType` inert_rhs -- Both RHSs are the same
+ , -- So we have work_ev : F work_args ~ rhs
+ -- inert_ev : F inert_args ~ rhs
+ let pairs :: [(CoAxiomRule, TypeEqn)]
+ pairs = tryInteractInertFam ops fam_tc work_args inert_args
+ , not (null pairs)
+ = do { traceTcS "improveGivenLocalFunEqs" (vcat[ ppr fam_tc <+> ppr work_args
+ , text "work_ev" <+> ppr work_ev
+ , text "inert_ev" <+> ppr inert_ev
+ , ppr work_rhs
+ , ppr pairs ])
+ ; emitNewGivens (ctEvLoc inert_ev) (map mk_ax_co pairs) }
+ -- This CtLoc for the new Givens doesn't reflect the
+ -- fact that it's a combination of Givens, but I don't
+ -- this that matters.
+ where
+ inert_co = ctEvCoercion inert_ev
+ mk_ax_co (ax,_) = (Nominal, mkAxiomCo ax [combined_co])
+ where
+ combined_co = given_co `mkTransCo` mkSymCo inert_co
+ -- given_co :: F work_args ~ rhs
+ -- inert_co :: F inert_args ~ rhs
+ -- the_co :: F work_args ~ F inert_args
+
+ do_one _ _ = return ()
+
+improveWantedLocalFunEqs
+ :: [EqCt] -- Inert items (Given and Wanted)
+ -> TyCon -> [TcType] -> CtEvidence -> Xi -- Work item (Wanted)
+ -> TcS Bool -- True <=> some unifications
+-- Emit improvement equalities for a Wanted constraint, by comparing
+-- the current work item with inert CFunEqs (both Given and Wanted)
+-- E.g. x + y ~ z, x + y' ~ z => [W] y ~ y'
+--
+-- See Note [FunDep and implicit parameter reactions]
+improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs
+ | null improvement_eqns
+ = return False
+ | otherwise
+ = do { traceTcS "interactFunEq improvements: " $
+ vcat [ text "Eqns:" <+> ppr improvement_eqns
+ , text "Candidates:" <+> ppr funeqs_for_tc ]
+ ; unifyAndEmitFunDepWanteds work_ev improvement_eqns }
+ where
+ work_loc = ctEvLoc work_ev
+ work_pred = ctEvPred work_ev
+ fam_inj_info = tyConInjectivityInfo fam_tc
+
+ --------------------
+ improvement_eqns :: [FunDepEqn (CtLoc, RewriterSet)]
+ improvement_eqns
+ | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
+ = -- Try built-in families, notably for arithmethic
+ concatMap (do_one_built_in ops rhs) funeqs_for_tc
+
+ | Injective injective_args <- fam_inj_info
+ = -- Try improvement from type families with injectivity annotations
+ concatMap (do_one_injective injective_args rhs) funeqs_for_tc
+
+ | otherwise
+ = []
+
+ --------------------
+ do_one_built_in ops rhs (EqCt { eq_lhs = TyFamLHS _ iargs, eq_rhs = irhs, eq_ev = inert_ev })
+ | irhs `tcEqType` rhs
+ = mk_fd_eqns inert_ev (map snd $ tryInteractInertFam ops fam_tc args iargs)
+ | otherwise
+ = []
+ do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc) -- TyVarLHS
+
+ --------------------
+ -- See Note [Type inference for type families with injectivity]
+ do_one_injective inj_args rhs (EqCt { eq_lhs = TyFamLHS _ inert_args
+ , eq_rhs = irhs, eq_ev = inert_ev })
+ | rhs `tcEqType` irhs
+ = mk_fd_eqns inert_ev $ mkInjectivityEqns inj_args args inert_args
+ | otherwise
+ = []
+
+ do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) -- TyVarLHS
+
+ --------------------
+ mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn (CtLoc, RewriterSet)]
+ mk_fd_eqns inert_ev eqns
+ | null eqns = []
+ | otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns
+ , fd_loc = (loc, inert_rewriters) } ]
+ where
+ initial_loc -- start with the location of the Wanted involved
+ | isGiven work_ev = inert_loc
+ | otherwise = work_loc
+ eqn_orig = InjTFOrigin1 work_pred (ctLocOrigin work_loc) (ctLocSpan work_loc)
+ inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc)
+ eqn_loc = setCtLocOrigin initial_loc eqn_orig
+ inert_pred = ctEvPred inert_ev
+ inert_loc = ctEvLoc inert_ev
+ inert_rewriters = ctEvRewriters inert_ev
+ loc = eqn_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`
+ ctl_depth work_loc }
+
+{- Note [Type inference for type families with injectivity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have a type family with an injectivity annotation:
+ type family F a b = r | r -> b
+
+Then if we have an equality like F s1 t1 ~ F s2 t2,
+we can use the injectivity to get a new Wanted constraint on
+the injective argument
+ [W] t1 ~ t2
+
+That in turn can help GHC solve constraints that would otherwise require
+guessing. For example, consider the ambiguity check for
+ f :: F Int b -> Int
+We get the constraint
+ [W] F Int b ~ F Int beta
+where beta is a unification variable. Injectivity lets us pick beta ~ b.
+
+Injectivity information is also used at the call sites. For example:
+ g = f True
+gives rise to
+ [W] F Int b ~ Bool
+from which we can derive b. This requires looking at the defining equations of
+a type family, ie. finding equation with a matching RHS (Bool in this example)
+and inferring values of type variables (b in this example) from the LHS patterns
+of the matching equation. For closed type families we have to perform
+additional apartness check for the selected equation to check that the selected
+is guaranteed to fire for given LHS arguments.
+
+These new constraints are Wanted constraints, but we will not use the evidence.
+We could go further and offer evidence from decomposing injective type-function
+applications, but that would require new evidence forms, and an extension to
+FC, so we don't do that right now (Dec 14).
+
+We generate these Wanteds in three places, depending on how we notice the
+injectivity.
+
+1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and
+described in Note [Decomposing type family applications] in GHC.Tc.Solver.Equality
+
+2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these
+constraints rewrites the other, as they have different LHSs. This is done
+in improveLocalFunEqs, called during the interactWithInertsStage.
+
+3. When we have [W] F tys ~ T and an equation for F that looks like F tys' = T.
+This is done in improve_top_fun_eqs, called from the top-level reactions stage.
+
+See also Note [Injective type families] in GHC.Core.TyCon
+
+Note [Cache-caused loops]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+It is very dangerous to cache a rewritten wanted family equation as 'solved' in our
+solved cache (which is the default behaviour or xCtEvidence), because the interaction
+may not be contributing towards a solution. Here is an example:
+
+Initial inert set:
+ [W] g1 : F a ~ beta1
+Work item:
+ [W] g2 : F a ~ beta2
+The work item will react with the inert yielding the _same_ inert set plus:
+ (i) Will set g2 := g1 `cast` g3
+ (ii) Will add to our solved cache that [S] g2 : F a ~ beta2
+ (iii) Will emit [W] g3 : beta1 ~ beta2
+Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2
+and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it
+will set
+ g1 := g ; sym g3
+and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but
+remember that we have this in our solved cache, and it is ... g2! In short we
+created the evidence loop:
+
+ g2 := g1 ; g3
+ g3 := refl
+ g1 := g2 ; sym g3
+
+To avoid this situation we do not cache as solved any workitems (or inert)
+which did not really made a 'step' towards proving some goal. Solved's are
+just an optimization so we don't lose anything in terms of completeness of
+solving.
+-}
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -67,9 +67,6 @@ module GHC.Tc.Solver.Monad (
getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
tcLookupClass, tcLookupId, tcLookupTyCon,
- getUnifiedRef,
-
-
-- Inerts
updInertSet, updInertCans,
getHasGivenEqs, setInertCans,
@@ -84,7 +81,7 @@ module GHC.Tc.Solver.Monad (
lookupInertDict,
-- The Model
- kickOutAfterUnification, kickOutRewritable,
+ recordUnification, recordUnifications, kickOutRewritable,
-- Inert Safe Haskell safe-overlap failures
insertSafeOverlapFailureTcS,
@@ -212,8 +209,6 @@ import Control.Monad
import Data.Foldable hiding ( foldr1 )
import Data.IORef
import Data.List ( mapAccumL )
-import Data.List.NonEmpty ( nonEmpty )
-import qualified Data.List.NonEmpty as NE
import GHC.Types.SrcLoc
import GHC.Rename.Env
import GHC.LanguageExtensions as LangExt
@@ -450,33 +445,6 @@ kickOutRewritable ko_spec new_fr
, text "kicked_out =" <+> ppr kicked_out
, text "Residual inerts =" <+> ppr ics' ]) } }
-kickOutAfterUnification :: [TcTyVar] -> TcS ()
-kickOutAfterUnification tv_list
- = case nonEmpty tv_list of
- Nothing -> return ()
- Just tvs -> do { traceTcS "kickOutAfterUnification" (ppr min_tv_lvl $$ ppr tv_list)
- ; setUnificationFlagTo min_tv_lvl }
- where
- min_tv_lvl = foldr1 minTcLevel (NE.map tcTyVarLevel tvs)
-
-{-
- { let tv_set = mkVarSet tv_list
-
- ; n_kicked <- kickOutRewritable (KOAfterUnify tv_set) (Given, NomEq)
- -- Given because the tv := xi is given; NomEq because
- -- only nominal equalities are solved by unification
-
- -- Set the unification flag if we have done outer unifications
- -- that might affect an earlier implication constraint
- ; let min_tv_lvl = foldr1 minTcLevel (NE.map tcTyVarLevel tvs)
- ; ambient_lvl <- getTcLevel
- ; when (ambient_lvl `strictlyDeeperThan` min_tv_lvl) $
- setUnificationFlagTo min_tv_lvl
-
- ; traceTcS "kickOutAfterUnification" (ppr tvs $$ text "n_kicked =" <+> ppr n_kicked)
- ; return n_kicked }
--}
-
kickOutAfterFillingCoercionHole :: CoercionHole -> TcS ()
-- See Wrinkle (URW2) in Note [Unify only if the rewriter set is empty]
-- in GHC.Tc.Solver.Equality
@@ -940,11 +908,6 @@ data TcSEnv
= TcSEnv {
tcs_ev_binds :: EvBindsVar,
- tcs_unified :: IORef Int,
- -- The number of unification variables we have filled
- -- The important thing is whether it is non-zero, so it
- -- could equally well be a Bool instead of an Int.
-
tcs_unif_lvl :: IORef (Maybe TcLevel),
-- The Unification Level Flag
-- Outermost level at which we have unified a meta tyvar
@@ -1131,8 +1094,7 @@ runTcSWithEvBinds' :: TcSMode
-> TcS a
-> TcM a
runTcSWithEvBinds' mode ev_binds_var thing_inside
- = do { unified_var <- TcM.newTcRef 0
- ; step_count <- TcM.newTcRef 0
+ = do { step_count <- TcM.newTcRef 0
-- Make a fresh, empty inert set
-- Subtle point: see (TGE6) in Note [Tracking Given equalities]
@@ -1143,7 +1105,6 @@ runTcSWithEvBinds' mode ev_binds_var thing_inside
; wl_var <- TcM.newTcRef emptyWorkList
; unif_lvl_var <- TcM.newTcRef Nothing
; let env = TcSEnv { tcs_ev_binds = ev_binds_var
- , tcs_unified = unified_var
, tcs_unif_lvl = unif_lvl_var
, tcs_count = step_count
, tcs_inerts = inert_var
@@ -1354,9 +1315,6 @@ setTcSMode :: TcSMode -> TcS a -> TcS a
setTcSMode mode thing_inside
= TcS (\env -> unTcS thing_inside (env { tcs_mode = mode }))
-getUnifiedRef :: TcS (IORef Int)
-getUnifiedRef = TcS (return . tcs_unified)
-
-- Getter of inerts and worklist
getInertSetRef :: TcS (IORef InertSet)
getInertSetRef = TcS (return . tcs_inerts)
@@ -1817,13 +1775,11 @@ produced the same Derived constraint.)
unifyTyVar :: TcTyVar -> TcType -> TcS ()
-- Unify a meta-tyvar with a type
--- We keep track of how many unifications have happened in tcs_unified,
---
-- We should never unify the same variable twice!
unifyTyVar tv ty
= assertPpr (isMetaTyVar tv) (ppr tv) $
do { liftZonkTcS (TcM.writeMetaTyVar tv ty) -- Produces a trace message
- ; setUnificationFlagTo (tcTyVarLevel tv) }
+ ; recordUnification tv }
reportUnifications :: TcS a -> TcS (Bool, a)
-- Record whether any unifications are done by thing_inside
@@ -1887,6 +1843,18 @@ getUnificationFlag
-> do { TcM.writeTcRef ref Nothing
; return True } }
+recordUnification :: TcTyVar -> TcS ()
+recordUnification tv = setUnificationFlagTo (tcTyVarLevel tv)
+
+recordUnifications :: [TcTyVar] -> TcS ()
+recordUnifications tvs
+ = case tvs of
+ [] -> return ()
+ (tv:tvs) -> do { traceTcS "recordUnifications" (ppr min_tv_lvl $$ ppr tvs)
+ ; setUnificationFlagTo min_tv_lvl }
+ where
+ min_tv_lvl = foldr (minTcLevel . tcTyVarLevel) (tcTyVarLevel tv) tvs
+
setUnificationFlagTo :: TcLevel -> TcS ()
-- (setUnificationFlag i) sets the unification level to (Just i)
-- unless it already is (Just j) where j <= i
@@ -2251,8 +2219,8 @@ unifyForAllBody :: CtEvidence -> Role -> (UnifyEnv -> TcM a)
unifyForAllBody ev role unify_body
= do { (res, cts, unified) <- wrapUnifierX ev role unify_body
- -- Kick out any inert constraint that we have unified
- ; kickOutAfterUnification unified
+ -- Record the unificaions we have done
+ ; recordUnifications unified
; return (res, cts) }
@@ -2271,6 +2239,9 @@ wrapUnifierTcS :: CtEvidence -> Role
wrapUnifierTcS ev role do_unifications
= do { (res, cts, unified) <- wrapUnifierX ev role do_unifications
+ -- Record the unificaions we have done
+ ; recordUnifications unified
+
-- Emit the deferred constraints
-- See Note [Work-list ordering] in GHC.Tc.Solved.Equality
--
@@ -2280,17 +2251,13 @@ wrapUnifierTcS ev role do_unifications
; unless (isEmptyBag cts) $
updWorkListTcS (extendWorkListChildEqs ev cts)
- -- And kick out any inert constraint that we have unified
- ; kickOutAfterUnification unified
-
; return (res, cts, unified) }
wrapUnifierX :: CtEvidence -> Role
-> (UnifyEnv -> TcM a) -- Some calls to uType
-> TcS (a, Bag Ct, [TcTyVar])
wrapUnifierX ev role do_unifications
- = do { unif_count_ref <- getUnifiedRef
- ; given_eq_lvl <- getInnermostGivenEqLevel
+ = do { given_eq_lvl <- getInnermostGivenEqLevel
; wrapTcS $
do { defer_ref <- TcM.newTcRef emptyBag
; unified_ref <- TcM.newTcRef []
@@ -2308,12 +2275,6 @@ wrapUnifierX ev role do_unifications
; cts <- TcM.readTcRef defer_ref
; unified <- TcM.readTcRef unified_ref
-
- -- Don't forget to update the count of variables
- -- unified, lest we forget to iterate (#24146)
- ; unless (null unified) $
- TcM.updTcRef unif_count_ref (+ (length unified))
-
; return (res, cts, unified) } }
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0240183357637242886b779215b04ff…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0240183357637242886b779215b04ff…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/warning-for-last-and-init] 3 commits: Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial
by Bodigrim (＠Bodigrim) 09 Aug '25
by Bodigrim (＠Bodigrim) 09 Aug '25
09 Aug '25
Bodigrim pushed to branch wip/warning-for-last-and-init at Glasgow Haskell Compiler / GHC
Commits:
c5ec5732 by Mike Pilgrem at 2025-08-09T00:48:51+01:00
Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial
Also corrects the warning for `tail` to refer to `Data.List.uncons` (like the existing warning for `head`).
In module `Settings.Warnings`, applies `-Wno-unrecognised-warning-flags` `-Wno-x-partial` to the `Cabal`, `filepath`, `hsc2hs`, `hpc`, `parsec`, `text` and `time` packages (outside GHC's repository).
Also bumps submodules.
- - - - -
31ddd232 by Andrew Lelechenko at 2025-08-09T00:48:51+01:00
Wibble
- - - - -
d108f076 by Andrew Lelechenko at 2025-08-09T11:07:28+01:00
Wobble
- - - - -
26 changed files:
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Driver/Session/Units.hs
- compiler/GHC/Prelude/Basic.hs
- ghc/GHCi/UI.hs
- ghc/Main.hs
- hadrian/src/Settings/Warnings.hs
- libraries/Cabal
- libraries/filepath
- libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
- libraries/ghc-internal/src/GHC/Internal/Float.hs
- libraries/ghc-internal/src/GHC/Internal/List.hs
- libraries/ghc-internal/src/GHC/Internal/System/IO.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs
- libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs
- testsuite/tests/driver/j-space/jspace.hs
- testsuite/tests/rts/KeepCafsBase.hs
- utils/check-exact/Main.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
- utils/ghc-pkg/Main.hs
- utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
- utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
- utils/hpc
- utils/hsc2hs
Changes:
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -112,8 +112,7 @@ import GHC.Utils.Misc
import Data.ByteString ( ByteString )
import Data.Function ( on )
-import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL )
-import qualified Data.List as Partial ( init, last )
+import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL, unsnoc )
import Data.Ord ( comparing )
import Control.Monad ( guard )
import qualified Data.Set as Set
@@ -1871,10 +1870,10 @@ app_ok fun_ok primop_ok fun args
PrimOpId op _
| primOpIsDiv op
- , Lit divisor <- Partial.last args
+ , Just (initArgs, Lit divisor) <- unsnoc args
-- there can be 2 args (most div primops) or 3 args
-- (WordQuotRem2Op), hence the use of last/init
- -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) (Partial.init args)
+ -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) initArgs
-- Special case for dividing operations that fail
-- In general they are NOT ok-for-speculation
-- (which primop_ok will catch), but they ARE OK
=====================================
compiler/GHC/Driver/Session/Units.hs
=====================================
@@ -2,6 +2,8 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE TupleSections #-}
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
module GHC.Driver.Session.Units (initMake, initMulti) where
-- The official GHC API
=====================================
compiler/GHC/Prelude/Basic.hs
=====================================
@@ -2,8 +2,8 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# OPTIONS_GHC -O2 #-} -- See Note [-O2 Prelude]
--- See Note [Proxies for head and tail]
-{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-}
+-- See Note [Proxies for partial list functions]
+{-# OPTIONS_GHC -Wno-x-partial #-}
-- | Custom minimal GHC "Prelude"
--
@@ -24,7 +24,7 @@ module GHC.Prelude.Basic
, bit
, shiftL, shiftR
, setBit, clearBit
- , head, tail, unzip
+ , head, tail, init, last, unzip
, strictGenericLength
) where
@@ -59,7 +59,7 @@ NoImplicitPrelude. There are two motivations for this:
-}
import qualified Prelude
-import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, unzip)
+import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, init, last, unzip)
import Control.Applicative (Applicative(..))
import Data.Foldable as X (Foldable (elem, foldMap, foldl, foldl', foldr, length, null, product, sum))
import Data.Foldable1 as X hiding (head, last)
@@ -118,24 +118,35 @@ setBit = \ x i -> x Bits..|. bit i
clearBit :: (Num a, Bits.Bits a) => a -> Int -> a
clearBit = \ x i -> x Bits..&. Bits.complement (bit i)
-{- Note [Proxies for head and tail]
+{- Note [Proxies for partial list functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Prelude.head and Prelude.tail have recently acquired {-# WARNING in "x-partial" #-},
+Prelude.head, Prelude.tail, Prelude.init and Prelude.last
+have recently acquired {-# WARNING in "x-partial" #-},
but the GHC codebase uses them fairly extensively and insists on building warning-free.
Thus, instead of adding {-# OPTIONS_GHC -Wno-x-partial #-} to every module which
employs them, we define warning-less proxies and export them from GHC.Prelude.
-}
--- See Note [Proxies for head and tail]
+-- See Note [Proxies for partial list functions]
head :: HasCallStack => [a] -> a
head = Prelude.head
{-# INLINE head #-}
--- See Note [Proxies for head and tail]
+-- See Note [Proxies for partial list functions]
tail :: HasCallStack => [a] -> [a]
tail = Prelude.tail
{-# INLINE tail #-}
+-- See Note [Proxies for partial list functions]
+init :: HasCallStack => [a] -> [a]
+init = Prelude.init
+{-# INLINE init #-}
+
+-- See Note [Proxies for partial list functions]
+last :: HasCallStack => [a] -> a
+last = Prelude.last
+{-# INLINE last #-}
+
{- |
The 'genericLength' function defined in base can't be specialised due to the
NOINLINE pragma.
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -12,6 +12,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
+{-# OPTIONS_GHC -Wno-x-partial #-}
{-# OPTIONS -fno-warn-name-shadowing #-}
-- This module does a lot of it
=====================================
ghc/Main.hs
=====================================
@@ -3,6 +3,7 @@
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
+{-# OPTIONS_GHC -Wno-x-partial #-}
-----------------------------------------------------------------------------
--
=====================================
hadrian/src/Settings/Warnings.hs
=====================================
@@ -72,7 +72,10 @@ ghcWarningsArgs = do
, package terminfo ? pure [ "-Wno-unused-imports", "-Wno-deriving-typeable" ]
, package stm ? pure [ "-Wno-deriving-typeable" ]
, package osString ? pure [ "-Wno-deriving-typeable", "-Wno-unused-imports" ]
- , package parsec ? pure [ "-Wno-deriving-typeable" ]
+ , package parsec ? pure [ "-Wno-deriving-typeable"
+ , "-Wno-x-partial"
+ -- https://github.com/haskell/parsec/issues/194
+ ]
, package cabal ? pure [ "-Wno-deriving-typeable", "-Wno-incomplete-record-selectors" ]
-- The -Wno-incomplete-record-selectors is due to
@@ -80,7 +83,9 @@ ghcWarningsArgs = do
-- If that ticket is fixed, bwe can remove the flag again
, package cabalSyntax ? pure [ "-Wno-deriving-typeable" ]
- , package time ? pure [ "-Wno-deriving-typeable" ]
+ , package time ? pure [ "-Wno-deriving-typeable"
+ , "-Wno-x-partial" -- Awaiting time-1.15 release
+ ]
, package transformers ? pure [ "-Wno-unused-matches"
, "-Wno-unused-imports"
, "-Wno-redundant-constraints"
=====================================
libraries/Cabal
=====================================
@@ -1 +1 @@
-Subproject commit 703582f80f6d7f0c914ef4b885affcfc7b7b6ec8
+Subproject commit 9a343d137bcc5ae97a8d6e7a670dd4fb67ea7294
=====================================
libraries/filepath
=====================================
@@ -1 +1 @@
-Subproject commit cbcd0ccf92f47e6c10fb9cc513a7b26facfc19fe
+Subproject commit 62e71a8f512a0f2a477d8004751ccf2420b8ac28
=====================================
libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
=====================================
@@ -13,7 +13,7 @@ import GHC.Boot.TH.PprLib
import GHC.Boot.TH.Syntax
import Data.Word ( Word8 )
import Data.Char ( toLower, chr )
-import Data.List ( intersperse )
+import Data.List ( intersperse, unsnoc )
import GHC.Show ( showMultiLineString )
import GHC.Lexeme( isVarSymChar )
import Data.Ratio ( numerator, denominator )
@@ -214,9 +214,10 @@ pprExp i (MDoE m ss_) = parensIf (i > noPrec) $
pprStms [s] = ppr s
pprStms ss = braces (semiSep ss)
-pprExp _ (CompE []) = text "<<Empty CompExp>>"
-- This will probably break with fixity declarations - would need a ';'
-pprExp _ (CompE ss) =
+pprExp _ (CompE ss) = case unsnoc ss of
+ Nothing -> text "<<Empty CompExp>>"
+ Just (ss', s) ->
if null ss'
-- If there are no statements in a list comprehension besides the last
-- one, we simply treat it like a normal list.
@@ -225,8 +226,6 @@ pprExp _ (CompE ss) =
<+> bar
<+> commaSep ss'
<> text "]"
- where s = last ss
- ss' = init ss
pprExp _ (ArithSeqE d) = ppr d
pprExp _ (ListE es) = brackets (commaSep es)
pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e
=====================================
libraries/ghc-internal/src/GHC/Internal/Float.hs
=====================================
@@ -13,6 +13,9 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+-- For init in formatRealFloatAlt
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : GHC.Internal.Float
=====================================
libraries/ghc-internal/src/GHC/Internal/List.hs
=====================================
@@ -190,12 +190,18 @@ tail :: HasCallStack => [a] -> [a]
tail (_:xs) = xs
tail [] = errorEmptyList "tail"
-{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'GHC.Internal.Data.List.uncons' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
+{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'Data.List.uncons' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
-- | \(\mathcal{O}(n)\). Extract the last element of a list, which must be
-- finite and non-empty.
--
--- WARNING: This function is partial. Consider using 'unsnoc' instead.
+-- To disable the warning about partiality put
+-- @{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}@
+-- at the top of the file. To disable it throughout a package put the same
+-- options into @ghc-options@ section of Cabal file. To disable it in GHCi
+-- put @:set -Wno-x-partial -Wno-unrecognised-warning-flags@ into @~/.ghci@
+-- config file. See also the
+-- [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides….
--
-- ==== __Examples__
--
@@ -218,10 +224,18 @@ last xs = foldl (\_ x -> x) lastError xs
lastError :: HasCallStack => a
lastError = errorEmptyList "last"
+{-# WARNING in "x-partial" last "This is a partial function, it throws an error on empty lists. Use 'Data.List.unsnoc' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
+
-- | \(\mathcal{O}(n)\). Return all the elements of a list except the last one.
-- The list must be non-empty.
--
--- WARNING: This function is partial. Consider using 'unsnoc' instead.
+-- To disable the warning about partiality put
+-- @{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}@
+-- at the top of the file. To disable it throughout a package put the same
+-- options into @ghc-options@ section of Cabal file. To disable it in GHCi
+-- put @:set -Wno-x-partial -Wno-unrecognised-warning-flags@ into @~/.ghci@
+-- config file. See also the
+-- [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides….
--
-- ==== __Examples__
--
@@ -240,6 +254,8 @@ init (x:xs) = init' x xs
where init' _ [] = []
init' y (z:zs) = y : init' z zs
+{-# WARNING in "x-partial" init "This is a partial function, it throws an error on empty lists. Use 'Data.List.unsnoc' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
+
-- | \(\mathcal{O}(1)\). Test whether a list is empty.
--
-- >>> null []
=====================================
libraries/ghc-internal/src/GHC/Internal/System/IO.hs
=====================================
@@ -840,11 +840,12 @@ output_flags = std_flags
where
-- XXX bits copied from System.FilePath, since that's not available here
- combine a b
- | null b = a
- | null a = b
- | pathSeparator [last a] = a ++ b
- | otherwise = a ++ [pathSeparatorChar] ++ b
+ combine a [] = a
+ combine a b = case unsnoc a of
+ Nothing -> b
+ Just (_, lastA)
+ | pathSeparator [lastA] -> a ++ b
+ | otherwise -> a ++ [pathSeparatorChar] ++ b
tempCounter :: IORef Int
tempCounter = unsafePerformIO $ newIORef 0
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
=====================================
@@ -54,6 +54,7 @@ import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence)
import GHC.Internal.Data.Data hiding (Fixity(..))
import GHC.Internal.Data.NonEmpty (NonEmpty(..))
import GHC.Internal.Data.Traversable
+import GHC.Internal.List (unsnoc)
import GHC.Internal.Word
import GHC.Internal.Generics (Generic)
import GHC.Internal.IORef
@@ -73,7 +74,7 @@ import GHC.Internal.Control.Monad.Fix
import GHC.Internal.Control.Exception
import GHC.Internal.Num
import GHC.Internal.IO.Unsafe
-import GHC.Internal.List (dropWhile, break, replicate, reverse, last)
+import GHC.Internal.List (dropWhile, break, replicate, reverse)
import GHC.Internal.MVar
import GHC.Internal.IO.Exception
import GHC.Internal.Unicode
@@ -82,6 +83,16 @@ import qualified GHC.Internal.Types as Kind (Type)
import GHC.Internal.ForeignSrcLang
import GHC.Internal.LanguageExtensions
+#ifdef BOOTSTRAP_TH
+#if MIN_VERSION_base(4,19,0)
+import Data.List (unsnoc)
+#else
+import Data.Maybe (maybe)
+unsnoc :: [a] -> Maybe ([a], a)
+unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing
+#endif
+#endif
+
-----------------------------------------------------
--
-- The Quasi class
@@ -1296,7 +1307,7 @@ mkName str
-- (i.e. non-empty, starts with capital, all alpha)
is_rev_mod_name rev_mod_str
| (compt, rest) <- break (== '.') rev_mod_str
- , not (null compt), isUpper (last compt), all is_mod_char compt
+ , Just (_, lastCompt) <- unsnoc compt, isUpper lastCompt, all is_mod_char compt
= case rest of
[] -> True
(_dot : rest') -> is_rev_mod_name rest'
=====================================
libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs
=====================================
@@ -104,7 +104,7 @@ module System.FilePath.Posix
import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper)
import Data.Maybe(isJust)
-import Data.List(stripPrefix, isSuffixOf)
+import Data.List(stripPrefix, isSuffixOf, uncons, unsnoc)
import System.Environment(getEnv)
@@ -203,14 +203,20 @@ isExtSeparator = (== extSeparator)
splitSearchPath :: String -> [FilePath]
splitSearchPath = f
where
- f xs = case break isSearchPathSeparator xs of
- (pre, [] ) -> g pre
- (pre, _:post) -> g pre ++ f post
-
- g "" = ["." | isPosix]
- g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x]
- g x = [x]
-
+ f xs = let (pre, post) = break isSearchPathSeparator xs
+ in case uncons post of
+ Nothing -> g pre
+ Just (_, t) -> g pre ++ f t
+
+ g x = case uncons x of
+ Nothing -> ["." | isPosix]
+ Just (h, t)
+ | h == '"'
+ , Just{} <- uncons t -- >= 2
+ , isWindows
+ , Just (i, l) <- unsnoc t
+ , l == '"' -> [i]
+ | otherwise -> [x]
-- | Get a list of 'FilePath's in the $PATH variable.
getSearchPath :: IO [FilePath]
@@ -233,12 +239,17 @@ getSearchPath = fmap splitSearchPath (getEnv "PATH")
-- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred")
-- > splitExtension "file/path.txt/" == ("file/path.txt/","")
splitExtension :: FilePath -> (String, String)
-splitExtension x = case nameDot of
- "" -> (x,"")
- _ -> (dir ++ init nameDot, extSeparator : ext)
- where
- (dir,file) = splitFileName_ x
- (nameDot,ext) = breakEnd isExtSeparator file
+splitExtension x = case unsnoc nameDot of
+ -- Imagine x = "no-dots", then nameDot = ""
+ Nothing -> (x, mempty)
+ Just (initNameDot, _)
+ -- Imagine x = "\\shared.with.dots\no-dots"
+ | isWindows && null (dropDrive nameDot) -> (x, mempty)
+ -- Imagine x = "dir.with.dots/no-dots"
+ | any isPathSeparator ext -> (x, mempty)
+ | otherwise -> (initNameDot, extSeparator : ext)
+ where
+ (nameDot, ext) = breakEnd isExtSeparator x
-- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise.
--
@@ -594,9 +605,13 @@ replaceBaseName pth nam = combineAlways a (nam <.> ext)
-- > hasTrailingPathSeparator "test" == False
-- > hasTrailingPathSeparator "test/" == True
hasTrailingPathSeparator :: FilePath -> Bool
-hasTrailingPathSeparator "" = False
-hasTrailingPathSeparator x = isPathSeparator (last x)
+hasTrailingPathSeparator = isJust . getTrailingPathSeparator
+getTrailingPathSeparator :: FilePath -> Maybe Char
+getTrailingPathSeparator x = case unsnoc x of
+ Just (_, lastX)
+ | isPathSeparator lastX -> Just lastX
+ _ -> Nothing
hasLeadingPathSeparator :: FilePath -> Bool
hasLeadingPathSeparator "" = False
@@ -619,12 +634,12 @@ addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pat
-- > Windows: dropTrailingPathSeparator "\\" == "\\"
-- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x
dropTrailingPathSeparator :: FilePath -> FilePath
-dropTrailingPathSeparator x =
- if hasTrailingPathSeparator x && not (isDrive x)
- then let x' = dropWhileEnd isPathSeparator x
- in if null x' then [last x] else x'
- else x
-
+dropTrailingPathSeparator x = case getTrailingPathSeparator x of
+ Just lastX
+ | not (isDrive x)
+ -> let x' = dropWhileEnd isPathSeparator x
+ in if null x' then [lastX] else x'
+ _ -> x
-- | Get the directory name, move up one level.
--
@@ -863,28 +878,37 @@ makeRelative root path
-- > Posix: normalise "bob/fred/." == "bob/fred/"
-- > Posix: normalise "//home" == "/home"
normalise :: FilePath -> FilePath
-normalise path = result ++ [pathSeparator | addPathSeparator]
- where
- (drv,pth) = splitDrive path
- result = joinDrive' (normaliseDrive drv) (f pth)
+normalise filepath =
+ result <>
+ (if addPathSeparator
+ then [pathSeparator]
+ else mempty)
+ where
+ (drv,pth) = splitDrive filepath
+
+ result = joinDrive' (normaliseDrive drv) (f pth)
- joinDrive' "" "" = "."
- joinDrive' d p = joinDrive d p
+ joinDrive' d p
+ = if null d && null p
+ then "."
+ else joinDrive d p
- addPathSeparator = isDirPath pth
- && not (hasTrailingPathSeparator result)
- && not (isRelativeDrive drv)
+ addPathSeparator = isDirPath pth
+ && not (hasTrailingPathSeparator result)
+ && not (isRelativeDrive drv)
- isDirPath xs = hasTrailingPathSeparator xs
- || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs)
+ isDirPath xs = hasTrailingPathSeparator xs || case unsnoc xs of
+ Nothing -> False
+ Just (initXs, lastXs) -> lastXs == '.' && hasTrailingPathSeparator initXs
- f = joinPath . dropDots . propSep . splitDirectories
+ f = joinPath . dropDots . propSep . splitDirectories
- propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs
- | otherwise = x : xs
- propSep [] = []
+ propSep (x:xs)
+ | all isPathSeparator x = [pathSeparator] : xs
+ | otherwise = x : xs
+ propSep [] = []
- dropDots = filter ("." /=)
+ dropDots = filter ("." /=)
normaliseDrive :: FilePath -> FilePath
normaliseDrive "" = ""
=====================================
libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs
=====================================
@@ -104,7 +104,7 @@ module System.FilePath.Windows
import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper)
import Data.Maybe(isJust)
-import Data.List(stripPrefix, isSuffixOf)
+import Data.List(stripPrefix, isSuffixOf, uncons, unsnoc)
import System.Environment(getEnv)
@@ -203,14 +203,20 @@ isExtSeparator = (== extSeparator)
splitSearchPath :: String -> [FilePath]
splitSearchPath = f
where
- f xs = case break isSearchPathSeparator xs of
- (pre, [] ) -> g pre
- (pre, _:post) -> g pre ++ f post
-
- g "" = ["." | isPosix]
- g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x]
- g x = [x]
-
+ f xs = let (pre, post) = break isSearchPathSeparator xs
+ in case uncons post of
+ Nothing -> g pre
+ Just (_, t) -> g pre ++ f t
+
+ g x = case uncons x of
+ Nothing -> ["." | isPosix]
+ Just (h, t)
+ | h == '"'
+ , Just{} <- uncons t -- >= 2
+ , isWindows
+ , Just (i, l) <- unsnoc t
+ , l == '"' -> [i]
+ | otherwise -> [x]
-- | Get a list of 'FilePath's in the $PATH variable.
getSearchPath :: IO [FilePath]
@@ -233,12 +239,17 @@ getSearchPath = fmap splitSearchPath (getEnv "PATH")
-- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred")
-- > splitExtension "file/path.txt/" == ("file/path.txt/","")
splitExtension :: FilePath -> (String, String)
-splitExtension x = case nameDot of
- "" -> (x,"")
- _ -> (dir ++ init nameDot, extSeparator : ext)
- where
- (dir,file) = splitFileName_ x
- (nameDot,ext) = breakEnd isExtSeparator file
+splitExtension x = case unsnoc nameDot of
+ -- Imagine x = "no-dots", then nameDot = ""
+ Nothing -> (x, mempty)
+ Just (initNameDot, _)
+ -- Imagine x = "\\shared.with.dots\no-dots"
+ | isWindows && null (dropDrive nameDot) -> (x, mempty)
+ -- Imagine x = "dir.with.dots/no-dots"
+ | any isPathSeparator ext -> (x, mempty)
+ | otherwise -> (initNameDot, extSeparator : ext)
+ where
+ (nameDot, ext) = breakEnd isExtSeparator x
-- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise.
--
@@ -594,9 +605,13 @@ replaceBaseName pth nam = combineAlways a (nam <.> ext)
-- > hasTrailingPathSeparator "test" == False
-- > hasTrailingPathSeparator "test/" == True
hasTrailingPathSeparator :: FilePath -> Bool
-hasTrailingPathSeparator "" = False
-hasTrailingPathSeparator x = isPathSeparator (last x)
+hasTrailingPathSeparator = isJust . getTrailingPathSeparator
+getTrailingPathSeparator :: FilePath -> Maybe Char
+getTrailingPathSeparator x = case unsnoc x of
+ Just (_, lastX)
+ | isPathSeparator lastX -> Just lastX
+ _ -> Nothing
hasLeadingPathSeparator :: FilePath -> Bool
hasLeadingPathSeparator "" = False
@@ -619,12 +634,12 @@ addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pat
-- > Windows: dropTrailingPathSeparator "\\" == "\\"
-- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x
dropTrailingPathSeparator :: FilePath -> FilePath
-dropTrailingPathSeparator x =
- if hasTrailingPathSeparator x && not (isDrive x)
- then let x' = dropWhileEnd isPathSeparator x
- in if null x' then [last x] else x'
- else x
-
+dropTrailingPathSeparator x = case getTrailingPathSeparator x of
+ Just lastX
+ | not (isDrive x)
+ -> let x' = dropWhileEnd isPathSeparator x
+ in if null x' then [lastX] else x'
+ _ -> x
-- | Get the directory name, move up one level.
--
@@ -863,28 +878,37 @@ makeRelative root path
-- > Posix: normalise "bob/fred/." == "bob/fred/"
-- > Posix: normalise "//home" == "/home"
normalise :: FilePath -> FilePath
-normalise path = result ++ [pathSeparator | addPathSeparator]
- where
- (drv,pth) = splitDrive path
- result = joinDrive' (normaliseDrive drv) (f pth)
+normalise filepath =
+ result <>
+ (if addPathSeparator
+ then [pathSeparator]
+ else mempty)
+ where
+ (drv,pth) = splitDrive filepath
+
+ result = joinDrive' (normaliseDrive drv) (f pth)
- joinDrive' "" "" = "."
- joinDrive' d p = joinDrive d p
+ joinDrive' d p
+ = if null d && null p
+ then "."
+ else joinDrive d p
- addPathSeparator = isDirPath pth
- && not (hasTrailingPathSeparator result)
- && not (isRelativeDrive drv)
+ addPathSeparator = isDirPath pth
+ && not (hasTrailingPathSeparator result)
+ && not (isRelativeDrive drv)
- isDirPath xs = hasTrailingPathSeparator xs
- || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs)
+ isDirPath xs = hasTrailingPathSeparator xs || case unsnoc xs of
+ Nothing -> False
+ Just (initXs, lastXs) -> lastXs == '.' && hasTrailingPathSeparator initXs
- f = joinPath . dropDots . propSep . splitDirectories
+ f = joinPath . dropDots . propSep . splitDirectories
- propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs
- | otherwise = x : xs
- propSep [] = []
+ propSep (x:xs)
+ | all isPathSeparator x = [pathSeparator] : xs
+ | otherwise = x : xs
+ propSep [] = []
- dropDots = filter ("." /=)
+ dropDots = filter ("." /=)
normaliseDrive :: FilePath -> FilePath
normaliseDrive "" = ""
=====================================
testsuite/tests/driver/j-space/jspace.hs
=====================================
@@ -7,7 +7,7 @@ import System.Environment
import GHC.Driver.Env.Types
import GHC.Profiling
import System.Mem
-import Data.List (isPrefixOf)
+import Data.List (isPrefixOf, unsnoc)
import Control.Monad
import System.Exit
import GHC.Platform
@@ -41,7 +41,9 @@ initGhcM xs = do
requestHeapCensus
performGC
[ys] <- filter (isPrefixOf (ghcUnitId <> ":GHC.Unit.Module.ModDetails.ModDetails")) . lines <$> readFile "jspace.hp"
- let (n :: Int) = read (last (words ys))
+ let (n :: Int) = case unsnoc (words ys) of
+ Nothing -> error "input is unexpectedly empty"
+ Just (_, lst) -> read lst
-- The output should be 50 * 8 * word_size (i.e. 3600, or 1600 on 32-bit architectures):
-- the test contains DEPTH + WIDTH + 2 = 50 modules J, H_0, .., H_DEPTH, W_1, .., W_WIDTH,
-- and each ModDetails contains 1 (info table) + 8 word-sized fields.
=====================================
testsuite/tests/rts/KeepCafsBase.hs
=====================================
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
module KeepCafsBase (x) where
x :: Int
=====================================
utils/check-exact/Main.hs
=====================================
@@ -6,6 +6,7 @@
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-x-partial #-}
import Data.Data
import Data.List (intercalate)
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -96,6 +96,7 @@ import GHC.Data.FastString
import GHC.Types.SrcLoc
import Data.Data
+import Data.List (unsnoc)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe
@@ -212,8 +213,9 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (AnnSig (EpUniTok dca u) mp md) ns (
where
-- we want DPs for the distance from the end of the ns to the
-- AnnDColon, and to the start of the ty
- rd = case last ns of
- L (EpAnn anc' _ _) _ -> epaLocationRealSrcSpan anc'
+ rd = case unsnoc ns of
+ Nothing -> error "unexpected empty list in 'ns' variable"
+ Just (_, L (EpAnn anc' _ _) _) -> epaLocationRealSrcSpan anc'
dca' = case dca of
EpaSpan ss@(RealSrcSpan r _) -> (EpaDelta ss (ss2delta (ss2posEnd rd) r) [])
_ -> dca
@@ -294,7 +296,7 @@ setEntryDP (L (EpAnn (EpaSpan ss@(RealSrcSpan r _)) an cs) a) dp
where
cs'' = setPriorComments cs []
csd = L (EpaDelta ss dp NoComments) c:commentOrigDeltas cs'
- lc = last $ (L ca c:cs')
+ lc = NE.last (L ca c :| cs')
delta = case getLoc lc of
EpaSpan (RealSrcSpan rr _) -> ss2delta (ss2pos rr) r
EpaSpan _ -> (SameLine 0)
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -37,7 +37,7 @@ import GHC.Base (NonEmpty(..))
import GHC.Parser.Lexer (allocateComments)
import Data.Data hiding ( Fixity )
-import Data.List (sortBy, partition)
+import Data.List (sortBy, partition, unsnoc)
import qualified Data.Map.Strict as Map
import Debug.Trace
@@ -734,8 +734,9 @@ ghead info [] = error $ "ghead "++info++" []"
ghead _info (h:_) = h
glast :: String -> [a] -> a
-glast info [] = error $ "glast " ++ info ++ " []"
-glast _info h = last h
+glast info xs = case unsnoc xs of
+ Nothing -> error $ "glast " ++ info ++ " []"
+ Just (_, lst) -> lst
gtail :: String -> [a] -> [a]
gtail info [] = error $ "gtail " ++ info ++ " []"
=====================================
utils/ghc-pkg/Main.hs
=====================================
@@ -8,7 +8,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -Wno-orphans -Wno-x-partial #-}
-- Fine if this comes from make/Hadrian or the pre-built base.
#include <ghcplatform.h>
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs
=====================================
@@ -1,6 +1,6 @@
module GHC.Toolchain.CheckArm ( findArmIsa ) where
-import Data.List (isInfixOf)
+import Data.List (isInfixOf, unsnoc)
import Data.Maybe (catMaybes)
import Control.Monad.IO.Class
import System.Process
@@ -76,8 +76,7 @@ findArmIsa cc = do
_ -> throwE $ "unexpected output from test program: " ++ out
lastLine :: String -> String
-lastLine "" = ""
-lastLine s = last $ lines s
+lastLine = maybe "" snd . unsnoc . lines
-- | Raspbian unfortunately makes some extremely questionable packaging
-- decisions, configuring gcc to compile for ARMv6 despite the fact that the
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
=====================================
@@ -755,7 +755,7 @@ ppHtmlIndex
divAlphabet
<< unordList
( map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $
- [ [c] | c <- initialChars, any ((== c) . toUpper . head . fst) index
+ [ [c] | c <- initialChars, any (maybe False ((== c) . toUpper . fst) . List.uncons . fst) index
]
++ [merged_name]
)
@@ -772,7 +772,7 @@ ppHtmlIndex
writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)
where
html = indexPage True (Just c) index_part
- index_part = [(n, stuff) | (n, stuff) <- this_ix, toUpper (head n) == c]
+ index_part = [(n, stuff) | (n@(headN : _), stuff) <- this_ix, toUpper headN == c]
index :: [(String, Map GHC.Name [(Module, Bool)])]
index = sortBy cmp (Map.toAscList full_index)
=====================================
utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
=====================================
@@ -30,7 +30,7 @@ import Control.Arrow (first)
import Control.Monad
import Data.Char (chr, isAlpha, isSpace, isUpper)
import Data.Functor (($>))
-import Data.List (elemIndex, intercalate, intersperse, unfoldr)
+import Data.List (elemIndex, intercalate, intersperse, unfoldr, unsnoc)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid
import qualified Data.Set as Set
@@ -870,10 +870,10 @@ codeblock =
DocCodeBlock . parseParagraph . dropSpaces
<$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@")
where
- dropSpaces xs =
- case splitByNl xs of
- [] -> xs
- ys -> case T.uncons (last ys) of
+ dropSpaces xs = let ys = splitByNl xs in
+ case unsnoc ys of
+ Nothing -> xs
+ Just (_, lastYs) -> case T.uncons lastYs of
Just (' ', _) -> case mapM dropSpace ys of
Nothing -> xs
Just zs -> T.intercalate "\n" zs
=====================================
utils/hpc
=====================================
@@ -1 +1 @@
-Subproject commit 5923da3fe77993b7afc15b5163cffcaa7da6ecf5
+Subproject commit dd43f7e139d7a4f4908d1e8af35a75939f763ef1
=====================================
utils/hsc2hs
=====================================
@@ -1 +1 @@
-Subproject commit fe3990b9f35000427b016a79330d9f195587cad8
+Subproject commit 2059c961fc28bbfd0cafdbef96d5d21f1d911b53
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b0bc00e399a947203ca49d88efbe9a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b0bc00e399a947203ca49d88efbe9a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sol/remove-ddump-json] 10 commits: Refactoring: Don't misuse `MCDiagnostic` for lint messages
by Simon Hengel (＠sol) 09 Aug '25
by Simon Hengel (＠sol) 09 Aug '25
09 Aug '25
Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC
Commits:
f99e4bae by Simon Hengel at 2025-08-09T16:50:20+07:00
Refactoring: Don't misuse `MCDiagnostic` for lint messages
`MCDiagnostic` is meant to be used for compiler diagnostics.
Any code that creates `MCDiagnostic` directly, without going through
`GHC.Driver.Errors.printMessage`, side steps `-fdiagnostics-as-json`
(see e.g. !14475, !14492 !14548).
To avoid this in the future I want to control more narrowly who creates
`MCDiagnostic` (see #24113).
Some parts of the compiler use `MCDiagnostic` purely for formatting
purposes, without creating any real compiler diagnostics. This change
introduces a helper function, `formatDiagnostic`, that can be used in
such cases instead of constructing `MCDiagnostic`.
- - - - -
a5393c7b by Simon Hengel at 2025-08-09T16:50:40+07:00
Rename MCDiagnostic to UnsafeMCDiagnostic
- - - - -
3b67a005 by Simon Hengel at 2025-08-09T16:50:40+07:00
Remove -ddump-json (fixes #24113)
- - - - -
e06295d3 by Simon Hengel at 2025-08-09T16:50:40+07:00
Add SrcSpan to MCDiagnostic
- - - - -
8c0d0320 by Simon Hengel at 2025-08-09T16:50:40+07:00
Refactoring: More consistently use logOutput, logInfo, fatalErrorMsg
- - - - -
e61d74f4 by Simon Hengel at 2025-08-09T16:50:40+07:00
Get rid of mkLocMessage
- - - - -
26fe025d by Simon Hengel at 2025-08-09T16:50:40+07:00
Add Message data type
- - - - -
0fe6bd7f by Simon Hengel at 2025-08-09T16:50:40+07:00
Get rid of MessageClass
- - - - -
8e45d9f3 by Simon Hengel at 2025-08-09T16:50:40+07:00
Rename DiagnosticMessage to GenericDiagnosticMessage
- - - - -
42b5dedb by Simon Hengel at 2025-08-09T16:50:40+07:00
Remove JSON logging
- - - - -
36 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Errors.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Monad.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Pipeline/LogQueue.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Debugger.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Types/SourceError.hs
- compiler/GHC/Utils/Error.hs
- compiler/GHC/Utils/Logger.hs
- docs/users_guide/debugging.rst
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Exception.hs
- testsuite/tests/driver/T16167.stderr
- − testsuite/tests/driver/T16167.stdout
- testsuite/tests/driver/all.T
- testsuite/tests/driver/json2.stderr
- − testsuite/tests/driver/json_dump.hs
- − testsuite/tests/driver/json_dump.stderr
- utils/check-exact/Main.hs
- utils/check-exact/Preprocess.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f3a82a3d650fe6703cf0369ecf31e5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f3a82a3d650fe6703cf0369ecf31e5…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sol/lint-messages] Refactoring: Don't misuse `MCDiagnostic` for lint messages
by Simon Hengel (＠sol) 09 Aug '25
by Simon Hengel (＠sol) 09 Aug '25
09 Aug '25
Simon Hengel pushed to branch wip/sol/lint-messages at Glasgow Haskell Compiler / GHC
Commits:
f99e4bae by Simon Hengel at 2025-08-09T16:50:20+07:00
Refactoring: Don't misuse `MCDiagnostic` for lint messages
`MCDiagnostic` is meant to be used for compiler diagnostics.
Any code that creates `MCDiagnostic` directly, without going through
`GHC.Driver.Errors.printMessage`, side steps `-fdiagnostics-as-json`
(see e.g. !14475, !14492 !14548).
To avoid this in the future I want to control more narrowly who creates
`MCDiagnostic` (see #24113).
Some parts of the compiler use `MCDiagnostic` purely for formatting
purposes, without creating any real compiler diagnostics. This change
introduces a helper function, `formatDiagnostic`, that can be used in
such cases instead of constructing `MCDiagnostic`.
- - - - -
4 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Utils/Error.hs
Changes:
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -3418,7 +3418,7 @@ addMsg show_context env msgs msg
[] -> noSrcSpan
(s:_) -> s
!diag_opts = le_diagOpts env
- mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) msg_span
+ mk_msg msg = mkLintWarning diag_opts msg_span
(msg $$ context)
addLoc :: LintLocInfo -> LintM a -> LintM a
=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -107,7 +107,6 @@ import GHC.Core.Type
import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel, isMarkedCbv )
import GHC.Types.CostCentre ( isCurrentCCS )
-import GHC.Types.Error ( DiagnosticReason(WarningWithoutFlag) )
import GHC.Types.Id
import GHC.Types.Var.Set
import GHC.Types.Name ( getSrcLoc, nameIsLocalOrFrom )
@@ -116,7 +115,7 @@ import GHC.Types.SrcLoc
import GHC.Utils.Logger
import GHC.Utils.Outputable
-import GHC.Utils.Error ( mkLocMessage, DiagOpts )
+import GHC.Utils.Error ( DiagOpts )
import qualified GHC.Utils.Error as Err
import GHC.Unit.Module ( Module )
@@ -540,7 +539,7 @@ addErr diag_opts errs_so_far msg locs
= errs_so_far `snocBag` mk_msg locs
where
mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
- in mkLocMessage (Err.mkMCDiagnostic diag_opts WarningWithoutFlag Nothing)
+ in Err.mkLintWarning diag_opts
l (hdr $$ msg)
mk_msg [] = msg
=====================================
compiler/GHC/Types/Error.hs
=====================================
@@ -72,6 +72,7 @@ module GHC.Types.Error
, pprMessageBag
, mkLocMessage
, mkLocMessageWarningGroups
+ , formatDiagnostic
, getCaretDiagnostic
, jsonDiagnostic
@@ -495,11 +496,11 @@ data MessageClass
-- ^ Diagnostics from the compiler. This constructor is very powerful as
-- it allows the construction of a 'MessageClass' with a completely
-- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such,
- -- users are encouraged to use the 'mkMCDiagnostic' smart constructor
+ -- users are encouraged to use higher level primitives
-- instead. Use this constructor directly only if you need to construct
-- and manipulate diagnostic messages directly, for example inside
-- 'GHC.Utils.Error'. In all the other circumstances, /especially/ when
- -- emitting compiler diagnostics, use the smart constructor.
+ -- emitting compiler diagnostics, use higher level primitives.
--
-- The @Maybe 'DiagnosticCode'@ field carries a code (if available) for
-- this diagnostic. If you are creating a message not tied to any
@@ -656,32 +657,51 @@ mkLocMessageWarningGroups
-> SrcSpan -- ^ location
-> SDoc -- ^ message
-> SDoc
- -- Always print the location, even if it is unhelpful. Error messages
- -- are supposed to be in a standard format, and one without a location
- -- would look strange. Better to say explicitly "<no location info>".
mkLocMessageWarningGroups show_warn_groups msg_class locn msg
- = sdocOption sdocColScheme $ \col_scheme ->
- let locn' = sdocOption sdocErrorSpans $ \case
- True -> ppr locn
- False -> ppr (srcSpanStart locn)
-
+ = case msg_class of
+ MCDiagnostic severity reason code -> formatDiagnostic show_warn_groups locn severity reason code msg
+ _ -> sdocOption sdocColScheme $ \col_scheme ->
+ let
msg_colour = getMessageClassColour msg_class col_scheme
- col = coloured msg_colour . text
msg_title = coloured msg_colour $
case msg_class of
- MCDiagnostic SevError _ _ -> text "error"
- MCDiagnostic SevWarning _ _ -> text "warning"
MCFatal -> text "fatal"
_ -> empty
+ in formatLocMessageWarningGroups locn msg_title empty empty msg
+
+formatDiagnostic
+ :: Bool -- ^ Print warning groups?
+ -> SrcSpan -- ^ location
+ -> Severity
+ -> ResolvedDiagnosticReason
+ -> Maybe DiagnosticCode
+ -> SDoc -- ^ message
+ -> SDoc
+formatDiagnostic show_warn_groups locn severity reason code msg
+ = sdocOption sdocColScheme $ \col_scheme ->
+ let
+ msg_colour :: Col.PprColour
+ msg_colour = getSeverityColour severity col_scheme
+
+ col :: String -> SDoc
+ col = coloured msg_colour . text
+
+ msg_title :: SDoc
+ msg_title = coloured msg_colour $
+ case severity of
+ SevError -> text "error"
+ SevWarning -> text "warning"
+ SevIgnore -> empty
+
+ warning_flag_doc :: SDoc
warning_flag_doc =
- case msg_class of
- MCDiagnostic sev reason _code
- | Just msg <- flag_msg sev (resolvedDiagnosticReason reason)
- -> brackets msg
- _ -> empty
+ case flag_msg severity (resolvedDiagnosticReason reason) of
+ Nothing -> empty
+ Just msg -> brackets msg
+ ppr_with_hyperlink :: DiagnosticCode -> SDoc
ppr_with_hyperlink code =
-- this is a bit hacky, but we assume that if the terminal supports colors
-- then it should also support links
@@ -691,10 +711,11 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg
then ppr $ LinkedDiagCode code
else ppr code
+ code_doc :: SDoc
code_doc =
- case msg_class of
- MCDiagnostic _ _ (Just code) -> brackets (ppr_with_hyperlink code)
- _ -> empty
+ case code of
+ Just code -> brackets (ppr_with_hyperlink code)
+ Nothing -> empty
flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc
flag_msg SevIgnore _ = Nothing
@@ -725,13 +746,35 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg
vcat [ text "locn:" <+> ppr locn
, text "msg:" <+> ppr msg ]
+ warn_flag_grp :: [WarningGroup] -> SDoc
warn_flag_grp groups
| show_warn_groups, not (null groups)
= text $ "(in " ++ intercalate ", " (map (("-W"++) . warningGroupName) groups) ++ ")"
| otherwise = empty
+ in formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg
+
+formatLocMessageWarningGroups
+ :: SrcSpan -- ^ location
+ -> SDoc -- ^ title
+ -> SDoc -- ^ diagnostic code
+ -> SDoc -- ^ warning groups
+ -> SDoc -- ^ message
+ -> SDoc
+formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg
+ = sdocOption sdocColScheme $ \col_scheme ->
+ let
+ -- Always print the location, even if it is unhelpful. Error messages
+ -- are supposed to be in a standard format, and one without a location
+ -- would look strange. Better to say explicitly "<no location info>".
+ locn' :: SDoc
+ locn' = sdocOption sdocErrorSpans $ \case
+ True -> ppr locn
+ False -> ppr (srcSpanStart locn)
+
-- Add prefixes, like Foo.hs:34: warning:
-- <the warning message>
+ header :: SDoc
header = locn' <> colon <+>
msg_title <> colon <+>
code_doc <+> warning_flag_doc
@@ -741,11 +784,16 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg
msg)
getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour
-getMessageClassColour (MCDiagnostic SevError _reason _code) = Col.sError
-getMessageClassColour (MCDiagnostic SevWarning _reason _code) = Col.sWarning
+getMessageClassColour (MCDiagnostic severity _reason _code) = getSeverityColour severity
getMessageClassColour MCFatal = Col.sFatal
getMessageClassColour _ = const mempty
+getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
+getSeverityColour severity = case severity of
+ SevError -> Col.sError
+ SevWarning -> Col.sWarning
+ SevIgnore -> const mempty
+
getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc
getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
getCaretDiagnostic msg_class (RealSrcSpan span _) =
=====================================
compiler/GHC/Utils/Error.hs
=====================================
@@ -32,7 +32,7 @@ module GHC.Utils.Error (
emptyMessages, mkDecorated, mkLocMessage,
mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope,
mkErrorMsgEnvelope,
- mkMCDiagnostic, diagReasonSeverity,
+ mkLintWarning, diagReasonSeverity,
mkPlainError,
mkPlainDiagnostic,
@@ -160,12 +160,10 @@ diag_reason_severity opts reason = fmap ResolvedDiagnosticReason $ case reason o
ErrorWithoutFlag
-> (SevError, reason)
--- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the
--- 'DiagOpts'.
-mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
-mkMCDiagnostic opts reason code = MCDiagnostic sev reason' code
+mkLintWarning :: DiagOpts -> SrcSpan -> SDoc -> SDoc
+mkLintWarning opts span = formatDiagnostic True span severity reason Nothing
where
- (sev, reason') = diag_reason_severity opts reason
+ (severity, reason) = diag_reason_severity opts WarningWithoutFlag
--
-- Creating MsgEnvelope(s)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f99e4baee82989bf2fd49cdae241d55…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f99e4baee82989bf2fd49cdae241d55…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/warning-for-last-and-init] 2 commits: Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial
by Bodigrim (＠Bodigrim) 08 Aug '25
by Bodigrim (＠Bodigrim) 08 Aug '25
08 Aug '25
Bodigrim pushed to branch wip/warning-for-last-and-init at Glasgow Haskell Compiler / GHC
Commits:
b85020f5 by Mike Pilgrem at 2025-08-08T23:24:01+01:00
Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial
Also corrects the warning for `tail` to refer to `Data.List.uncons` (like the existing warning for `head`).
In module `Settings.Warnings`, applies `-Wno-unrecognised-warning-flags` `-Wno-x-partial` to the `Cabal`, `filepath`, `hsc2hs`, `hpc`, `parsec`, `text` and `time` packages (outside GHC's repository).
Also bumps submodules.
- - - - -
b0bc00e3 by Andrew Lelechenko at 2025-08-08T23:28:52+01:00
Wibble
- - - - -
25 changed files:
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Driver/Session/Units.hs
- compiler/GHC/Prelude/Basic.hs
- ghc/GHCi/UI.hs
- ghc/Main.hs
- hadrian/src/Settings/Warnings.hs
- libraries/Cabal
- libraries/filepath
- libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
- libraries/ghc-internal/src/GHC/Internal/Float.hs
- libraries/ghc-internal/src/GHC/Internal/List.hs
- libraries/ghc-internal/src/GHC/Internal/System/IO.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs
- libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs
- testsuite/tests/driver/j-space/jspace.hs
- testsuite/tests/rts/KeepCafsBase.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
- utils/ghc-pkg/Main.hs
- utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
- utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
- utils/hpc
- utils/hsc2hs
Changes:
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -112,8 +112,7 @@ import GHC.Utils.Misc
import Data.ByteString ( ByteString )
import Data.Function ( on )
-import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL )
-import qualified Data.List as Partial ( init, last )
+import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL, unsnoc )
import Data.Ord ( comparing )
import Control.Monad ( guard )
import qualified Data.Set as Set
@@ -1871,10 +1870,10 @@ app_ok fun_ok primop_ok fun args
PrimOpId op _
| primOpIsDiv op
- , Lit divisor <- Partial.last args
+ , Just (initArgs, Lit divisor) <- unsnoc args
-- there can be 2 args (most div primops) or 3 args
-- (WordQuotRem2Op), hence the use of last/init
- -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) (Partial.init args)
+ -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) initArgs
-- Special case for dividing operations that fail
-- In general they are NOT ok-for-speculation
-- (which primop_ok will catch), but they ARE OK
=====================================
compiler/GHC/Driver/Session/Units.hs
=====================================
@@ -2,6 +2,8 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE TupleSections #-}
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
module GHC.Driver.Session.Units (initMake, initMulti) where
-- The official GHC API
=====================================
compiler/GHC/Prelude/Basic.hs
=====================================
@@ -2,8 +2,8 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# OPTIONS_GHC -O2 #-} -- See Note [-O2 Prelude]
--- See Note [Proxies for head and tail]
-{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-}
+-- See Note [Proxies for partial list functions]
+{-# OPTIONS_GHC -Wno-x-partial #-}
-- | Custom minimal GHC "Prelude"
--
@@ -24,7 +24,7 @@ module GHC.Prelude.Basic
, bit
, shiftL, shiftR
, setBit, clearBit
- , head, tail, unzip
+ , head, tail, init, last, unzip
, strictGenericLength
) where
@@ -59,7 +59,7 @@ NoImplicitPrelude. There are two motivations for this:
-}
import qualified Prelude
-import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, unzip)
+import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, init, last, unzip)
import Control.Applicative (Applicative(..))
import Data.Foldable as X (Foldable (elem, foldMap, foldl, foldl', foldr, length, null, product, sum))
import Data.Foldable1 as X hiding (head, last)
@@ -118,24 +118,35 @@ setBit = \ x i -> x Bits..|. bit i
clearBit :: (Num a, Bits.Bits a) => a -> Int -> a
clearBit = \ x i -> x Bits..&. Bits.complement (bit i)
-{- Note [Proxies for head and tail]
+{- Note [Proxies for partial list functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Prelude.head and Prelude.tail have recently acquired {-# WARNING in "x-partial" #-},
+Prelude.head, Prelude.tail, Prelude.init and Prelude.last
+have recently acquired {-# WARNING in "x-partial" #-},
but the GHC codebase uses them fairly extensively and insists on building warning-free.
Thus, instead of adding {-# OPTIONS_GHC -Wno-x-partial #-} to every module which
employs them, we define warning-less proxies and export them from GHC.Prelude.
-}
--- See Note [Proxies for head and tail]
+-- See Note [Proxies for partial list functions]
head :: HasCallStack => [a] -> a
head = Prelude.head
{-# INLINE head #-}
--- See Note [Proxies for head and tail]
+-- See Note [Proxies for partial list functions]
tail :: HasCallStack => [a] -> [a]
tail = Prelude.tail
{-# INLINE tail #-}
+-- See Note [Proxies for partial list functions]
+init :: HasCallStack => [a] -> [a]
+init = Prelude.init
+{-# INLINE init #-}
+
+-- See Note [Proxies for partial list functions]
+last :: HasCallStack => [a] -> a
+last = Prelude.last
+{-# INLINE last #-}
+
{- |
The 'genericLength' function defined in base can't be specialised due to the
NOINLINE pragma.
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -133,7 +133,7 @@ import Data.Char
import Data.Function
import qualified Data.Foldable as Foldable
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
-import Data.List ( find, intercalate, intersperse,
+import Data.List ( find, intercalate, intersperse, unsnoc,
isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) )
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as S
@@ -2402,9 +2402,9 @@ setContextAfterLoad keep_ctxt (Just graph) = do
[] ->
let graph' = flattenSCCs $ filterToposortToModules $
GHC.topSortModuleGraph True (GHC.mkModuleGraph loaded_graph) Nothing
- in case graph' of
- [] -> setContextKeepingPackageModules keep_ctxt []
- xs -> load_this (last xs)
+ in case unsnoc graph' of
+ Nothing -> setContextKeepingPackageModules keep_ctxt []
+ Just (_, lst) -> load_this lst
(m:_) ->
load_this m
where
=====================================
ghc/Main.hs
=====================================
@@ -88,7 +88,7 @@ import System.Exit
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except (throwE, runExceptT)
-import Data.List ( isPrefixOf, partition, intercalate )
+import Data.List ( isPrefixOf, partition, intercalate, unsnoc )
import Prelude
import qualified Data.List.NonEmpty as NE
@@ -115,8 +115,7 @@ main = do
argv0 <- getArgs
let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
- mbMinusB | null minusB_args = Nothing
- | otherwise = Just (drop 2 (last minusB_args))
+ mbMinusB = drop 2 . snd <$> unsnoc minusB_args
let argv2 = map (mkGeneralLocated "on the commandline") argv1
=====================================
hadrian/src/Settings/Warnings.hs
=====================================
@@ -72,7 +72,10 @@ ghcWarningsArgs = do
, package terminfo ? pure [ "-Wno-unused-imports", "-Wno-deriving-typeable" ]
, package stm ? pure [ "-Wno-deriving-typeable" ]
, package osString ? pure [ "-Wno-deriving-typeable", "-Wno-unused-imports" ]
- , package parsec ? pure [ "-Wno-deriving-typeable" ]
+ , package parsec ? pure [ "-Wno-deriving-typeable"
+ , "-Wno-x-partial"
+ -- https://github.com/haskell/parsec/issues/194
+ ]
, package cabal ? pure [ "-Wno-deriving-typeable", "-Wno-incomplete-record-selectors" ]
-- The -Wno-incomplete-record-selectors is due to
@@ -80,7 +83,9 @@ ghcWarningsArgs = do
-- If that ticket is fixed, bwe can remove the flag again
, package cabalSyntax ? pure [ "-Wno-deriving-typeable" ]
- , package time ? pure [ "-Wno-deriving-typeable" ]
+ , package time ? pure [ "-Wno-deriving-typeable"
+ , "-Wno-x-partial" -- Awaiting time-1.15 release
+ ]
, package transformers ? pure [ "-Wno-unused-matches"
, "-Wno-unused-imports"
, "-Wno-redundant-constraints"
=====================================
libraries/Cabal
=====================================
@@ -1 +1 @@
-Subproject commit 703582f80f6d7f0c914ef4b885affcfc7b7b6ec8
+Subproject commit 9a343d137bcc5ae97a8d6e7a670dd4fb67ea7294
=====================================
libraries/filepath
=====================================
@@ -1 +1 @@
-Subproject commit cbcd0ccf92f47e6c10fb9cc513a7b26facfc19fe
+Subproject commit 62e71a8f512a0f2a477d8004751ccf2420b8ac28
=====================================
libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
=====================================
@@ -13,7 +13,7 @@ import GHC.Boot.TH.PprLib
import GHC.Boot.TH.Syntax
import Data.Word ( Word8 )
import Data.Char ( toLower, chr )
-import Data.List ( intersperse )
+import Data.List ( intersperse, unsnoc )
import GHC.Show ( showMultiLineString )
import GHC.Lexeme( isVarSymChar )
import Data.Ratio ( numerator, denominator )
@@ -214,9 +214,10 @@ pprExp i (MDoE m ss_) = parensIf (i > noPrec) $
pprStms [s] = ppr s
pprStms ss = braces (semiSep ss)
-pprExp _ (CompE []) = text "<<Empty CompExp>>"
-- This will probably break with fixity declarations - would need a ';'
-pprExp _ (CompE ss) =
+pprExp _ (CompE ss) = case unsnoc ss of
+ Nothing -> text "<<Empty CompExp>>"
+ Just (ss', s) ->
if null ss'
-- If there are no statements in a list comprehension besides the last
-- one, we simply treat it like a normal list.
@@ -225,8 +226,6 @@ pprExp _ (CompE ss) =
<+> bar
<+> commaSep ss'
<> text "]"
- where s = last ss
- ss' = init ss
pprExp _ (ArithSeqE d) = ppr d
pprExp _ (ListE es) = brackets (commaSep es)
pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e
=====================================
libraries/ghc-internal/src/GHC/Internal/Float.hs
=====================================
@@ -13,6 +13,9 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+-- For init in formatRealFloatAlt
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : GHC.Internal.Float
=====================================
libraries/ghc-internal/src/GHC/Internal/List.hs
=====================================
@@ -190,12 +190,18 @@ tail :: HasCallStack => [a] -> [a]
tail (_:xs) = xs
tail [] = errorEmptyList "tail"
-{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'GHC.Internal.Data.List.uncons' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
+{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'Data.List.uncons' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
-- | \(\mathcal{O}(n)\). Extract the last element of a list, which must be
-- finite and non-empty.
--
--- WARNING: This function is partial. Consider using 'unsnoc' instead.
+-- To disable the warning about partiality put
+-- @{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}@
+-- at the top of the file. To disable it throughout a package put the same
+-- options into @ghc-options@ section of Cabal file. To disable it in GHCi
+-- put @:set -Wno-x-partial -Wno-unrecognised-warning-flags@ into @~/.ghci@
+-- config file. See also the
+-- [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides….
--
-- ==== __Examples__
--
@@ -218,10 +224,18 @@ last xs = foldl (\_ x -> x) lastError xs
lastError :: HasCallStack => a
lastError = errorEmptyList "last"
+{-# WARNING in "x-partial" last "This is a partial function, it throws an error on empty lists. Use 'Data.List.unsnoc' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
+
-- | \(\mathcal{O}(n)\). Return all the elements of a list except the last one.
-- The list must be non-empty.
--
--- WARNING: This function is partial. Consider using 'unsnoc' instead.
+-- To disable the warning about partiality put
+-- @{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}@
+-- at the top of the file. To disable it throughout a package put the same
+-- options into @ghc-options@ section of Cabal file. To disable it in GHCi
+-- put @:set -Wno-x-partial -Wno-unrecognised-warning-flags@ into @~/.ghci@
+-- config file. See also the
+-- [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides….
--
-- ==== __Examples__
--
@@ -240,6 +254,8 @@ init (x:xs) = init' x xs
where init' _ [] = []
init' y (z:zs) = y : init' z zs
+{-# WARNING in "x-partial" init "This is a partial function, it throws an error on empty lists. Use 'Data.List.unsnoc' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
+
-- | \(\mathcal{O}(1)\). Test whether a list is empty.
--
-- >>> null []
=====================================
libraries/ghc-internal/src/GHC/Internal/System/IO.hs
=====================================
@@ -840,11 +840,12 @@ output_flags = std_flags
where
-- XXX bits copied from System.FilePath, since that's not available here
- combine a b
- | null b = a
- | null a = b
- | pathSeparator [last a] = a ++ b
- | otherwise = a ++ [pathSeparatorChar] ++ b
+ combine a [] = a
+ combine a b = case unsnoc a of
+ Nothing -> b
+ Just (_, lastA)
+ | pathSeparator [lastA] -> a ++ b
+ | otherwise -> a ++ [pathSeparatorChar] ++ b
tempCounter :: IORef Int
tempCounter = unsafePerformIO $ newIORef 0
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
=====================================
@@ -54,6 +54,7 @@ import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence)
import GHC.Internal.Data.Data hiding (Fixity(..))
import GHC.Internal.Data.NonEmpty (NonEmpty(..))
import GHC.Internal.Data.Traversable
+import GHC.Internal.List (unsnoc)
import GHC.Internal.Word
import GHC.Internal.Generics (Generic)
import GHC.Internal.IORef
@@ -73,7 +74,7 @@ import GHC.Internal.Control.Monad.Fix
import GHC.Internal.Control.Exception
import GHC.Internal.Num
import GHC.Internal.IO.Unsafe
-import GHC.Internal.List (dropWhile, break, replicate, reverse, last)
+import GHC.Internal.List (dropWhile, break, replicate, reverse)
import GHC.Internal.MVar
import GHC.Internal.IO.Exception
import GHC.Internal.Unicode
@@ -82,6 +83,16 @@ import qualified GHC.Internal.Types as Kind (Type)
import GHC.Internal.ForeignSrcLang
import GHC.Internal.LanguageExtensions
+#ifdef BOOTSTRAP_TH
+#if MIN_VERSION_base(4,19,0)
+import Data.List (unsnoc)
+#else
+import Data.Maybe (maybe)
+unsnoc :: [a] -> Maybe ([a], a)
+unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing
+#endif
+#endif
+
-----------------------------------------------------
--
-- The Quasi class
@@ -1296,7 +1307,7 @@ mkName str
-- (i.e. non-empty, starts with capital, all alpha)
is_rev_mod_name rev_mod_str
| (compt, rest) <- break (== '.') rev_mod_str
- , not (null compt), isUpper (last compt), all is_mod_char compt
+ , Just (_, lastCompt) <- unsnoc compt, isUpper lastCompt, all is_mod_char compt
= case rest of
[] -> True
(_dot : rest') -> is_rev_mod_name rest'
=====================================
libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs
=====================================
@@ -104,7 +104,7 @@ module System.FilePath.Posix
import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper)
import Data.Maybe(isJust)
-import Data.List(stripPrefix, isSuffixOf)
+import Data.List(stripPrefix, isSuffixOf, uncons, unsnoc)
import System.Environment(getEnv)
@@ -203,14 +203,20 @@ isExtSeparator = (== extSeparator)
splitSearchPath :: String -> [FilePath]
splitSearchPath = f
where
- f xs = case break isSearchPathSeparator xs of
- (pre, [] ) -> g pre
- (pre, _:post) -> g pre ++ f post
-
- g "" = ["." | isPosix]
- g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x]
- g x = [x]
-
+ f xs = let (pre, post) = break isSearchPathSeparator xs
+ in case uncons post of
+ Nothing -> g pre
+ Just (_, t) -> g pre ++ f t
+
+ g x = case uncons x of
+ Nothing -> ["." | isPosix]
+ Just (h, t)
+ | h == '"'
+ , Just{} <- uncons t -- >= 2
+ , isWindows
+ , Just (i, l) <- unsnoc t
+ , l == '"' -> [i]
+ | otherwise -> [x]
-- | Get a list of 'FilePath's in the $PATH variable.
getSearchPath :: IO [FilePath]
@@ -233,12 +239,17 @@ getSearchPath = fmap splitSearchPath (getEnv "PATH")
-- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred")
-- > splitExtension "file/path.txt/" == ("file/path.txt/","")
splitExtension :: FilePath -> (String, String)
-splitExtension x = case nameDot of
- "" -> (x,"")
- _ -> (dir ++ init nameDot, extSeparator : ext)
- where
- (dir,file) = splitFileName_ x
- (nameDot,ext) = breakEnd isExtSeparator file
+splitExtension x = case unsnoc nameDot of
+ -- Imagine x = "no-dots", then nameDot = ""
+ Nothing -> (x, mempty)
+ Just (initNameDot, _)
+ -- Imagine x = "\\shared.with.dots\no-dots"
+ | isWindows && null (dropDrive nameDot) -> (x, mempty)
+ -- Imagine x = "dir.with.dots/no-dots"
+ | any isPathSeparator ext -> (x, mempty)
+ | otherwise -> (initNameDot, extSeparator : ext)
+ where
+ (nameDot, ext) = breakEnd isExtSeparator x
-- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise.
--
@@ -594,9 +605,13 @@ replaceBaseName pth nam = combineAlways a (nam <.> ext)
-- > hasTrailingPathSeparator "test" == False
-- > hasTrailingPathSeparator "test/" == True
hasTrailingPathSeparator :: FilePath -> Bool
-hasTrailingPathSeparator "" = False
-hasTrailingPathSeparator x = isPathSeparator (last x)
+hasTrailingPathSeparator = isJust . getTrailingPathSeparator
+getTrailingPathSeparator :: FilePath -> Maybe Char
+getTrailingPathSeparator x = case unsnoc x of
+ Just (_, lastX)
+ | isPathSeparator lastX -> Just lastX
+ _ -> Nothing
hasLeadingPathSeparator :: FilePath -> Bool
hasLeadingPathSeparator "" = False
@@ -619,12 +634,12 @@ addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pat
-- > Windows: dropTrailingPathSeparator "\\" == "\\"
-- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x
dropTrailingPathSeparator :: FilePath -> FilePath
-dropTrailingPathSeparator x =
- if hasTrailingPathSeparator x && not (isDrive x)
- then let x' = dropWhileEnd isPathSeparator x
- in if null x' then [last x] else x'
- else x
-
+dropTrailingPathSeparator x = case getTrailingPathSeparator x of
+ Just lastX
+ | not (isDrive x)
+ -> let x' = dropWhileEnd isPathSeparator x
+ in if null x' then [lastX] else x'
+ _ -> x
-- | Get the directory name, move up one level.
--
@@ -863,28 +878,37 @@ makeRelative root path
-- > Posix: normalise "bob/fred/." == "bob/fred/"
-- > Posix: normalise "//home" == "/home"
normalise :: FilePath -> FilePath
-normalise path = result ++ [pathSeparator | addPathSeparator]
- where
- (drv,pth) = splitDrive path
- result = joinDrive' (normaliseDrive drv) (f pth)
+normalise filepath =
+ result <>
+ (if addPathSeparator
+ then [pathSeparator]
+ else mempty)
+ where
+ (drv,pth) = splitDrive filepath
+
+ result = joinDrive' (normaliseDrive drv) (f pth)
- joinDrive' "" "" = "."
- joinDrive' d p = joinDrive d p
+ joinDrive' d p
+ = if null d && null p
+ then "."
+ else joinDrive d p
- addPathSeparator = isDirPath pth
- && not (hasTrailingPathSeparator result)
- && not (isRelativeDrive drv)
+ addPathSeparator = isDirPath pth
+ && not (hasTrailingPathSeparator result)
+ && not (isRelativeDrive drv)
- isDirPath xs = hasTrailingPathSeparator xs
- || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs)
+ isDirPath xs = hasTrailingPathSeparator xs || case unsnoc xs of
+ Nothing -> False
+ Just (initXs, lastXs) -> lastXs == '.' && hasTrailingPathSeparator initXs
- f = joinPath . dropDots . propSep . splitDirectories
+ f = joinPath . dropDots . propSep . splitDirectories
- propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs
- | otherwise = x : xs
- propSep [] = []
+ propSep (x:xs)
+ | all isPathSeparator x = [pathSeparator] : xs
+ | otherwise = x : xs
+ propSep [] = []
- dropDots = filter ("." /=)
+ dropDots = filter ("." /=)
normaliseDrive :: FilePath -> FilePath
normaliseDrive "" = ""
=====================================
libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs
=====================================
@@ -104,7 +104,7 @@ module System.FilePath.Windows
import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper)
import Data.Maybe(isJust)
-import Data.List(stripPrefix, isSuffixOf)
+import Data.List(stripPrefix, isSuffixOf, uncons, unsnoc)
import System.Environment(getEnv)
@@ -203,14 +203,20 @@ isExtSeparator = (== extSeparator)
splitSearchPath :: String -> [FilePath]
splitSearchPath = f
where
- f xs = case break isSearchPathSeparator xs of
- (pre, [] ) -> g pre
- (pre, _:post) -> g pre ++ f post
-
- g "" = ["." | isPosix]
- g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x]
- g x = [x]
-
+ f xs = let (pre, post) = break isSearchPathSeparator xs
+ in case uncons post of
+ Nothing -> g pre
+ Just (_, t) -> g pre ++ f t
+
+ g x = case uncons x of
+ Nothing -> ["." | isPosix]
+ Just (h, t)
+ | h == '"'
+ , Just{} <- uncons t -- >= 2
+ , isWindows
+ , Just (i, l) <- unsnoc t
+ , l == '"' -> [i]
+ | otherwise -> [x]
-- | Get a list of 'FilePath's in the $PATH variable.
getSearchPath :: IO [FilePath]
@@ -233,12 +239,17 @@ getSearchPath = fmap splitSearchPath (getEnv "PATH")
-- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred")
-- > splitExtension "file/path.txt/" == ("file/path.txt/","")
splitExtension :: FilePath -> (String, String)
-splitExtension x = case nameDot of
- "" -> (x,"")
- _ -> (dir ++ init nameDot, extSeparator : ext)
- where
- (dir,file) = splitFileName_ x
- (nameDot,ext) = breakEnd isExtSeparator file
+splitExtension x = case unsnoc nameDot of
+ -- Imagine x = "no-dots", then nameDot = ""
+ Nothing -> (x, mempty)
+ Just (initNameDot, _)
+ -- Imagine x = "\\shared.with.dots\no-dots"
+ | isWindows && null (dropDrive nameDot) -> (x, mempty)
+ -- Imagine x = "dir.with.dots/no-dots"
+ | any isPathSeparator ext -> (x, mempty)
+ | otherwise -> (initNameDot, extSeparator : ext)
+ where
+ (nameDot, ext) = breakEnd isExtSeparator x
-- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise.
--
@@ -594,9 +605,13 @@ replaceBaseName pth nam = combineAlways a (nam <.> ext)
-- > hasTrailingPathSeparator "test" == False
-- > hasTrailingPathSeparator "test/" == True
hasTrailingPathSeparator :: FilePath -> Bool
-hasTrailingPathSeparator "" = False
-hasTrailingPathSeparator x = isPathSeparator (last x)
+hasTrailingPathSeparator = isJust . getTrailingPathSeparator
+getTrailingPathSeparator :: FilePath -> Maybe Char
+getTrailingPathSeparator x = case unsnoc x of
+ Just (_, lastX)
+ | isPathSeparator lastX -> Just lastX
+ _ -> Nothing
hasLeadingPathSeparator :: FilePath -> Bool
hasLeadingPathSeparator "" = False
@@ -619,12 +634,12 @@ addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pat
-- > Windows: dropTrailingPathSeparator "\\" == "\\"
-- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x
dropTrailingPathSeparator :: FilePath -> FilePath
-dropTrailingPathSeparator x =
- if hasTrailingPathSeparator x && not (isDrive x)
- then let x' = dropWhileEnd isPathSeparator x
- in if null x' then [last x] else x'
- else x
-
+dropTrailingPathSeparator x = case getTrailingPathSeparator x of
+ Just lastX
+ | not (isDrive x)
+ -> let x' = dropWhileEnd isPathSeparator x
+ in if null x' then [lastX] else x'
+ _ -> x
-- | Get the directory name, move up one level.
--
@@ -863,28 +878,37 @@ makeRelative root path
-- > Posix: normalise "bob/fred/." == "bob/fred/"
-- > Posix: normalise "//home" == "/home"
normalise :: FilePath -> FilePath
-normalise path = result ++ [pathSeparator | addPathSeparator]
- where
- (drv,pth) = splitDrive path
- result = joinDrive' (normaliseDrive drv) (f pth)
+normalise filepath =
+ result <>
+ (if addPathSeparator
+ then [pathSeparator]
+ else mempty)
+ where
+ (drv,pth) = splitDrive filepath
+
+ result = joinDrive' (normaliseDrive drv) (f pth)
- joinDrive' "" "" = "."
- joinDrive' d p = joinDrive d p
+ joinDrive' d p
+ = if null d && null p
+ then "."
+ else joinDrive d p
- addPathSeparator = isDirPath pth
- && not (hasTrailingPathSeparator result)
- && not (isRelativeDrive drv)
+ addPathSeparator = isDirPath pth
+ && not (hasTrailingPathSeparator result)
+ && not (isRelativeDrive drv)
- isDirPath xs = hasTrailingPathSeparator xs
- || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs)
+ isDirPath xs = hasTrailingPathSeparator xs || case unsnoc xs of
+ Nothing -> False
+ Just (initXs, lastXs) -> lastXs == '.' && hasTrailingPathSeparator initXs
- f = joinPath . dropDots . propSep . splitDirectories
+ f = joinPath . dropDots . propSep . splitDirectories
- propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs
- | otherwise = x : xs
- propSep [] = []
+ propSep (x:xs)
+ | all isPathSeparator x = [pathSeparator] : xs
+ | otherwise = x : xs
+ propSep [] = []
- dropDots = filter ("." /=)
+ dropDots = filter ("." /=)
normaliseDrive :: FilePath -> FilePath
normaliseDrive "" = ""
=====================================
testsuite/tests/driver/j-space/jspace.hs
=====================================
@@ -7,7 +7,7 @@ import System.Environment
import GHC.Driver.Env.Types
import GHC.Profiling
import System.Mem
-import Data.List (isPrefixOf)
+import Data.List (isPrefixOf, unsnoc)
import Control.Monad
import System.Exit
import GHC.Platform
@@ -41,7 +41,9 @@ initGhcM xs = do
requestHeapCensus
performGC
[ys] <- filter (isPrefixOf (ghcUnitId <> ":GHC.Unit.Module.ModDetails.ModDetails")) . lines <$> readFile "jspace.hp"
- let (n :: Int) = read (last (words ys))
+ let (n :: Int) = case unsnoc (words ys) of
+ Nothing -> error "input is unexpectedly empty"
+ Just (_, lst) -> read lst
-- The output should be 50 * 8 * word_size (i.e. 3600, or 1600 on 32-bit architectures):
-- the test contains DEPTH + WIDTH + 2 = 50 modules J, H_0, .., H_DEPTH, W_1, .., W_WIDTH,
-- and each ModDetails contains 1 (info table) + 8 word-sized fields.
=====================================
testsuite/tests/rts/KeepCafsBase.hs
=====================================
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
module KeepCafsBase (x) where
x :: Int
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -96,6 +96,7 @@ import GHC.Data.FastString
import GHC.Types.SrcLoc
import Data.Data
+import Data.List (unsnoc)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe
@@ -212,8 +213,9 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (AnnSig (EpUniTok dca u) mp md) ns (
where
-- we want DPs for the distance from the end of the ns to the
-- AnnDColon, and to the start of the ty
- rd = case last ns of
- L (EpAnn anc' _ _) _ -> epaLocationRealSrcSpan anc'
+ rd = case unsnoc ns of
+ Nothing -> error "unexpected empty list in 'ns' variable"
+ Just (_, L (EpAnn anc' _ _) _) -> epaLocationRealSrcSpan anc'
dca' = case dca of
EpaSpan ss@(RealSrcSpan r _) -> (EpaDelta ss (ss2delta (ss2posEnd rd) r) [])
_ -> dca
@@ -294,7 +296,7 @@ setEntryDP (L (EpAnn (EpaSpan ss@(RealSrcSpan r _)) an cs) a) dp
where
cs'' = setPriorComments cs []
csd = L (EpaDelta ss dp NoComments) c:commentOrigDeltas cs'
- lc = last $ (L ca c:cs')
+ lc = NE.last (L ca c :| cs')
delta = case getLoc lc of
EpaSpan (RealSrcSpan rr _) -> ss2delta (ss2pos rr) r
EpaSpan _ -> (SameLine 0)
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -37,7 +37,7 @@ import GHC.Base (NonEmpty(..))
import GHC.Parser.Lexer (allocateComments)
import Data.Data hiding ( Fixity )
-import Data.List (sortBy, partition)
+import Data.List (sortBy, partition, unsnoc)
import qualified Data.Map.Strict as Map
import Debug.Trace
@@ -734,8 +734,9 @@ ghead info [] = error $ "ghead "++info++" []"
ghead _info (h:_) = h
glast :: String -> [a] -> a
-glast info [] = error $ "glast " ++ info ++ " []"
-glast _info h = last h
+glast info xs = case unsnoc xs of
+ Nothing -> error $ "glast " ++ info ++ " []"
+ Just (_, lst) -> lst
gtail :: String -> [a] -> [a]
gtail info [] = error $ "gtail " ++ info ++ " []"
=====================================
utils/ghc-pkg/Main.hs
=====================================
@@ -8,7 +8,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -Wno-orphans -Wno-x-partial #-}
-- Fine if this comes from make/Hadrian or the pre-built base.
#include <ghcplatform.h>
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs
=====================================
@@ -1,6 +1,6 @@
module GHC.Toolchain.CheckArm ( findArmIsa ) where
-import Data.List (isInfixOf)
+import Data.List (isInfixOf, unsnoc)
import Data.Maybe (catMaybes)
import Control.Monad.IO.Class
import System.Process
@@ -76,8 +76,7 @@ findArmIsa cc = do
_ -> throwE $ "unexpected output from test program: " ++ out
lastLine :: String -> String
-lastLine "" = ""
-lastLine s = last $ lines s
+lastLine = maybe "" snd . unsnoc . lines
-- | Raspbian unfortunately makes some extremely questionable packaging
-- decisions, configuring gcc to compile for ARMv6 despite the fact that the
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
=====================================
@@ -755,7 +755,7 @@ ppHtmlIndex
divAlphabet
<< unordList
( map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $
- [ [c] | c <- initialChars, any ((== c) . toUpper . head . fst) index
+ [ [c] | c <- initialChars, any (maybe False ((== c) . toUpper . fst) . List.uncons . fst) index
]
++ [merged_name]
)
@@ -772,7 +772,7 @@ ppHtmlIndex
writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)
where
html = indexPage True (Just c) index_part
- index_part = [(n, stuff) | (n, stuff) <- this_ix, toUpper (head n) == c]
+ index_part = [(n, stuff) | (n@(headN : _), stuff) <- this_ix, toUpper headN == c]
index :: [(String, Map GHC.Name [(Module, Bool)])]
index = sortBy cmp (Map.toAscList full_index)
=====================================
utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
=====================================
@@ -30,7 +30,7 @@ import Control.Arrow (first)
import Control.Monad
import Data.Char (chr, isAlpha, isSpace, isUpper)
import Data.Functor (($>))
-import Data.List (elemIndex, intercalate, intersperse, unfoldr)
+import Data.List (elemIndex, intercalate, intersperse, unfoldr, unsnoc)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid
import qualified Data.Set as Set
@@ -870,10 +870,10 @@ codeblock =
DocCodeBlock . parseParagraph . dropSpaces
<$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@")
where
- dropSpaces xs =
- case splitByNl xs of
- [] -> xs
- ys -> case T.uncons (last ys) of
+ dropSpaces xs = let ys = splitByNl xs in
+ case unsnoc ys of
+ Nothing -> xs
+ Just (_, lastYs) -> case T.uncons lastYs of
Just (' ', _) -> case mapM dropSpace ys of
Nothing -> xs
Just zs -> T.intercalate "\n" zs
=====================================
utils/hpc
=====================================
@@ -1 +1 @@
-Subproject commit 5923da3fe77993b7afc15b5163cffcaa7da6ecf5
+Subproject commit dd43f7e139d7a4f4908d1e8af35a75939f763ef1
=====================================
utils/hsc2hs
=====================================
@@ -1 +1 @@
-Subproject commit fe3990b9f35000427b016a79330d9f195587cad8
+Subproject commit 2059c961fc28bbfd0cafdbef96d5d21f1d911b53
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9d61b626957312096a38acbfc50c69…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9d61b626957312096a38acbfc50c69…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fix-26109] Apply 1 suggestion(s) to 1 file(s)
by recursion-ninja (＠recursion-ninja) 08 Aug '25
by recursion-ninja (＠recursion-ninja) 08 Aug '25
08 Aug '25
recursion-ninja pushed to branch wip/fix-26109 at Glasgow Haskell Compiler / GHC
Commits:
01be20d3 by recursion-ninja at 2025-08-08T21:44:56+00:00
Apply 1 suggestion(s) to 1 file(s)
Co-authored-by: Andreas Klebinger <klebinger.andreas(a)gmx.at>
- - - - -
1 changed file:
- compiler/GHC/CmmToLlvm/CodeGen.hs
Changes:
=====================================
compiler/GHC/CmmToLlvm/CodeGen.hs
=====================================
@@ -243,7 +243,7 @@ genCall (PrimTarget op@(MO_BSwap w)) [dst] args =
genCallSimpleCast w op dst args
-- Handle Pdep and Pext that (may) require using a type with a larger bit-width
--- than the specified but width. This register width-extension is particualarly
+-- than the specified bit width. This register width-extension is particualarly
-- necessary for W8 and W16.
genCall (PrimTarget op@(MO_Pdep w)) [dst] args =
genCallCastWithMinWidthOf W32 w op dst args
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/01be20d3762af6fe8df718cb86788c2…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/01be20d3762af6fe8df718cb86788c2…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fix-26109] 7 commits: ipe: Place strings and metadata into specific .ipe section
by recursion-ninja (＠recursion-ninja) 08 Aug '25
by recursion-ninja (＠recursion-ninja) 08 Aug '25
08 Aug '25
recursion-ninja pushed to branch wip/fix-26109 at Glasgow Haskell Compiler / GHC
Commits:
1903ae35 by Matthew Pickering at 2025-08-07T12:21:10+01:00
ipe: Place strings and metadata into specific .ipe section
By placing the .ipe metadata into a specific section it can be stripped
from the final binary if desired.
```
objcopy --remove-section .ipe <binary>
upx <binary>
```
Towards #21766
- - - - -
c80dd91c by Matthew Pickering at 2025-08-07T12:22:42+01:00
ipe: Place magic word at the start of entries in the .ipe section
The magic word "IPE\nIPE\n" is placed at the start of .ipe sections,
then if the section is stripped, we can check whether the section starts
with the magic word or not to determine whether there is metadata
present or not.
Towards #21766
- - - - -
cab42666 by Matthew Pickering at 2025-08-07T12:22:42+01:00
ipe: Use stable IDs for IPE entries
IPEs have historically been indexed and reported by their address.
This makes it impossible to compare profiles between runs, since the
addresses may change (due to ASLR) and also makes it tricky to separate
out the IPE map from the binary.
This small patch adds a stable identifier for each IPE entry.
The stable identifier is a single 64 bit word. The high-bits are a
per-module identifier and the low bits identify which entry in each
module.
1. When a node is added into the IPE buffer it is assigned a unique
identifier from an incrementing global counter.
2. Each entry already has an index by it's position in the
`IpeBufferListNode`.
The two are combined together by the `IPE_ENTRY_KEY` macro.
Info table profiling uses the stable identifier rather than the address
of the info table.
The benefits of this change are:
* Profiles from different runs can be easily compared
* The metadata can be extracted from the binary (via the eventlog for
example) and then stripped from the executable.
Fixes #21766
- - - - -
2860a9a5 by Simon Peyton Jones at 2025-08-07T20:29:18-04:00
In TcSShortCut, typechecker plugins should get empty Givens
Solving in TcShortCut mode means /ignoring the Givens/. So we
should not pass them to typechecker plugins!
Fixes #26258.
This is a fixup to the earlier MR:
commit 1bd12371feacc52394a0e660ef9349f9e8ee1c06
Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com>
Date: Mon Jul 21 10:04:49 2025 +0100
Improve treatment of SPECIALISE pragmas -- again!
- - - - -
2157db2d by sterni at 2025-08-08T15:32:39-04:00
hadrian: enable terminfo if --with-curses-* flags are given
The GHC make build system used to support WITH_TERMINFO in ghc.mk which
allowed controlling whether to build GHC with terminfo or not. hadrian
has replaced this with a system where this is effectively controlled by
the cross-compiling setting (the default WITH_TERMINFO value was bassed
on CrossCompiling, iirc).
This behavior is undesireable in some cases and there is not really a
good way to work around it. Especially for downstream packagers,
modifying this via UserSettings is not really feasible since such a
source file has to be kept in sync with Settings/Default.hs manually
since it can't import Settings.Default or any predefined Flavour
definitions.
To avoid having to add a new setting to cfg/system.config and/or a new
configure flag (though I'm happy to implement both if required), I've
chosen to take --with-curses-* being set explicitly as an indication
that the user wants to have terminfo enabled. This would work for
Nixpkgs which sets these flags [1] as well as haskell.nix [2] (which
goes to some extreme measures [3] [4] to force terminfo in all scenarios).
In general, I'm an advocate for making the GHC build be the same for
native and cross insofar it is possible since it makes packaging GHC and
Haskell related things while still supporting cross much less
compilicated. A more minimal GHC with reduced dependencies should
probably be a specific flavor, not the default.
Partially addresses #26288 by forcing terminfo to be built if the user
explicitly passes configure flags related to it. However, it isn't built
by default when cross-compiling yet nor is there an explicit way to
control the package being built.
[1]: https://github.com/NixOS/nixpkgs/blob/3a7266fcefcb9ce353df49ba3f292d0644376…
[2]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
[3]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
[4]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
- - - - -
b3c31488 by David Feuer at 2025-08-08T15:33:21-04:00
Add default QuasiQuoters
Add `defaultQuasiQuoter` and `namedDefaultQuasiQuoter` to make it easier
to write `QuasiQuoters` that give helpful error messages when they're
used in inappropriate contexts.
Closes #24434.
- - - - -
767d6516 by Recursion Ninja at 2025-08-08T17:38:37-04:00
Resolving issues #20645 and #26109
Correctly sign extending and casting smaller bit width types for LLVM operations:
- bitReverse8#
- bitReverse16#
- bitReverse32#
- byteSwap16#
- byteSwap32#
- pdep8#
- pdep16#
- pext8#
- pext16#
- - - - -
32 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Cmm.hs
- compiler/GHC/CmmToAsm/PPC/Ppr.hs
- compiler/GHC/CmmToAsm/Ppr.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/CmmToLlvm/Data.hs
- compiler/GHC/StgToCmm/InfoTableProv.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
- docs/users_guide/debug-info.rst
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- libraries/template-haskell/Language/Haskell/TH/Quote.hs
- libraries/template-haskell/changelog.md
- rts/IPE.c
- rts/ProfHeap.c
- rts/eventlog/EventLog.c
- rts/include/rts/IPE.h
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- + testsuite/tests/llvm/should_run/T20645.hs
- + testsuite/tests/llvm/should_run/T20645.stdout
- testsuite/tests/llvm/should_run/all.T
- testsuite/tests/numeric/should_run/foundation.hs
- testsuite/tests/rts/ipe/ipeMap.c
- testsuite/tests/rts/ipe/ipe_lib.c
- utils/genprimopcode/Lexer.x
- utils/genprimopcode/Main.hs
- utils/genprimopcode/Parser.y
- utils/genprimopcode/ParserM.hs
- utils/genprimopcode/Syntax.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3a9ec9d90a4228702fe995cd989769…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3a9ec9d90a4228702fe995cd989769…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fix-26109] 2 commits: Moving 'LowerBitsAreDefined' out of the autogenerated portion of the file
by recursion-ninja (＠recursion-ninja) 08 Aug '25
by recursion-ninja (＠recursion-ninja) 08 Aug '25
08 Aug '25
recursion-ninja pushed to branch wip/fix-26109 at Glasgow Haskell Compiler / GHC
Commits:
a522e725 by Recursion Ninja at 2025-08-08T13:33:17-04:00
Moving 'LowerBitsAreDefined' out of the autogenerated portion of the file
- - - - -
3a9ec9d9 by Recursion Ninja at 2025-08-08T16:49:26-04:00
Partial extension of 'genprimopcode' to support 'LowerBitsAreDefined'
- - - - -
7 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- testsuite/tests/numeric/should_run/foundation.hs
- utils/genprimopcode/Lexer.x
- utils/genprimopcode/Main.hs
- utils/genprimopcode/Parser.y
- utils/genprimopcode/ParserM.hs
- utils/genprimopcode/Syntax.hs
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -148,6 +148,7 @@ defaults
vector = []
deprecated_msg = {} -- A non-empty message indicates deprecation
div_like = False -- Second argument expected to be non zero - used for tests
+ defined_bits = Nothing -- The number of bits the operation is defined for (if not all bits)
-- Note [When do out-of-line primops go in primops.txt.pp]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1065,8 +1066,10 @@ primop CtzOp "ctz#" GenPrimOp Word# -> Word#
primop BSwap16Op "byteSwap16#" GenPrimOp Word# -> Word#
{Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. }
+ with defined_bits = 16
primop BSwap32Op "byteSwap32#" GenPrimOp Word# -> Word#
{Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. }
+ with defined_bits = 32
primop BSwap64Op "byteSwap64#" GenPrimOp Word64# -> Word64#
{Swap bytes in a 64 bits of a word.}
primop BSwapOp "byteSwap#" GenPrimOp Word# -> Word#
@@ -1074,10 +1077,13 @@ primop BSwapOp "byteSwap#" GenPrimOp Word# -> Word#
primop BRev8Op "bitReverse8#" GenPrimOp Word# -> Word#
{Reverse the order of the bits in a 8-bit word.}
+ with defined_bits = 8
primop BRev16Op "bitReverse16#" GenPrimOp Word# -> Word#
{Reverse the order of the bits in a 16-bit word.}
+ with defined_bits = 16
primop BRev32Op "bitReverse32#" GenPrimOp Word# -> Word#
{Reverse the order of the bits in a 32-bit word.}
+ with defined_bits = 32
primop BRev64Op "bitReverse64#" GenPrimOp Word64# -> Word64#
{Reverse the order of the bits in a 64-bit word.}
primop BRevOp "bitReverse#" GenPrimOp Word# -> Word#
=====================================
testsuite/tests/numeric/should_run/foundation.hs
=====================================
@@ -409,6 +409,33 @@ instance TestPrimop (Word# -> Int# -> Word#) where
testPrimop s l r = Property s $ \(uWord -> a1) (uInt -> a2) -> (wWord (l a1 a2)) === wWord (r a1 a2)
-}
+-- | A special data-type for representing functions where,
+-- since only some number of the lower bits are defined,
+-- testing for strict equality in the undefined upper bits is not appropriate!
+-- Without using this data-type, false-positive failures will be reported
+-- when the undefined bit regions do not match, even though the equality of bits
+-- in this undefined region has no bearing on correctness.
+data LowerBitsAreDefined =
+ LowerBitsAreDefined
+ { definedLowerWidth :: Word
+ -- ^ The (strictly-non-negative) number of least-significant bits
+ -- for which the attached function is defined.
+ , undefinedBehavior :: (Word# -> Word#)
+ -- ^ Function with undefined behavior for some of its most significant bits.
+ }
+
+instance TestPrimop LowerBitsAreDefined where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) ->
+ let -- Create a mask to unset all bits in the undefined area,
+ -- leaving set bits only in the area of defined behavior.
+ -- Since the upper bits are undefined,
+ -- if the function defines behavior for the lower N bits,
+ -- then /only/ the lower N bits are preserved,
+ -- and the upper WORDSIZE - N bits are discarded.
+ mask = bit (fromEnum (definedLowerWidth r)) - 1
+ valL = wWord# (undefinedBehavior l x0) .&. mask
+ valR = wWord# (undefinedBehavior r x0) .&. mask
+ in valL === valR
twoNonZero :: (a -> a -> b) -> a -> NonZero a -> b
twoNonZero f x (NonZero y) = f x y
@@ -673,34 +700,6 @@ testPrimops = Group "primop"
, testPrimop "narrow32Word#" Primop.narrow32Word# Wrapper.narrow32Word#
]
--- | A special data-type for representing functions where,
--- since only some number of the lower bits are defined,
--- testing for strict equality in the undefined upper bits is not appropriate!
--- Without using this data-type, false-positive failures will be reported
--- when the undefined bit regions do not match, even though the equality of bits
--- in this undefined region has no bearing on correctness.
-data LowerBitsAreDefined =
- LowerBitsAreDefined
- { definedLowerWidth :: Word
- -- ^ The (strictly-non-negative) number of least-significant bits
- -- for which the attached function is defined.
- , undefinedBehavior :: (Word# -> Word#)
- -- ^ Function with undefined behavior for some of its most significant bits.
- }
-
-instance TestPrimop LowerBitsAreDefined where
- testPrimop s l r = Property s $ \ (uWord#-> x0) ->
- let -- Create a mask to unset all bits in the undefined area,
- -- leaving set bits only in the area of defined behavior.
- -- Since the upper bits are undefined,
- -- if the function defines behavior for the lower N bits,
- -- then /only/ the lower N bits are preserved,
- -- and the upper WORDSIZE - N bits are discarded.
- mask = bit (fromEnum (definedLowerWidth r)) - 1
- valL = wWord# (undefinedBehavior l x0) .&. mask
- valR = wWord# (undefinedBehavior r x0) .&. mask
- in valL === valR
-
instance TestPrimop (Char# -> Char# -> Int#) where
testPrimop s l r = Property s $ \ (uChar#-> x0) (uChar#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
=====================================
utils/genprimopcode/Lexer.x
=====================================
@@ -56,6 +56,7 @@ words :-
<0> "CanFail" { mkT TCanFail }
<0> "ThrowsException" { mkT TThrowsException }
<0> "ReadWriteEffect" { mkT TReadWriteEffect }
+ <0> "defined_bits" { mkT TDefinedBits }
<0> "can_fail_warning" { mkT TCanFailWarnFlag }
<0> "DoNotWarnCanFail" { mkT TDoNotWarnCanFail }
<0> "WarnIfEffectIsCanFail" { mkT TWarnIfEffectIsCanFail }
=====================================
utils/genprimopcode/Main.hs
=====================================
@@ -10,6 +10,7 @@ module Main where
import Parser
import Syntax
+import Control.Applicative (asum)
import Data.Char
import Data.List (union, intersperse, intercalate, nub, sort)
import Data.Maybe ( catMaybes, mapMaybe )
@@ -753,7 +754,14 @@ gen_foundation_tests (Info _ entries)
= let testPrimOpHow = if is_divLikeOp po
then "testPrimopDivLike"
else "testPrimop"
- in Just $ intercalate " " [testPrimOpHow, "\"" ++ poName ++ "\"", wrap "Primop" poName, wrap "Wrapper" poName]
+ withDefinedBits qName = case mb_defined_bits po of
+ Nothing -> qName
+ Just bs -> concat ["(", show bs, " `LowerBitsAreDefined` ", qName, ")"]
+ in Just $ intercalate " "
+ [ testPrimOpHow
+ , "\"" ++ poName ++ "\""
+ , withDefinedBits $ wrap "Primop" poName
+ , withDefinedBits $ wrap "Wrapper" poName]
| otherwise = Nothing
@@ -771,6 +779,17 @@ gen_foundation_tests (Info _ entries)
divableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#"
,"Int8#", "Int16#", "Int32#", "Int64#"]
+
+ mb_defined_bits :: Entry -> Maybe Word
+ mb_defined_bits op@(PrimOpSpec{}) =
+ let opOpts = opts op
+ getDefBits :: Option -> Maybe Word
+ getDefBits (OptionDefinedBits x) = x
+ getDefBits _ = Nothing
+ in asum $ getDefBits <$> opOpts
+ mb_defined_bits _ = Nothing
+
+
------------------------------------------------------------------
-- Create PrimOpInfo text from PrimOpSpecs -----------------------
------------------------------------------------------------------
=====================================
utils/genprimopcode/Parser.y
=====================================
@@ -50,6 +50,7 @@ import AccessOps
CanFail { TCanFail }
ThrowsException { TThrowsException }
ReadWriteEffect { TReadWriteEffect }
+ defined_bits { TDefinedBits }
can_fail_warning { TCanFailWarnFlag }
DoNotWarnCanFail { TDoNotWarnCanFail }
WarnIfEffectIsCanFail { TWarnIfEffectIsCanFail }
@@ -81,13 +82,14 @@ pOptions : pOption pOptions { $1 : $2 }
| {- empty -} { [] }
pOption :: { Option }
-pOption : lowerName '=' false { OptionFalse $1 }
- | lowerName '=' true { OptionTrue $1 }
- | lowerName '=' pStuffBetweenBraces { OptionString $1 $3 }
- | lowerName '=' integer { OptionInteger $1 $3 }
- | vector '=' pVectorTemplate { OptionVector $3 }
- | fixity '=' pInfix { OptionFixity $3 }
- | effect '=' pEffect { OptionEffect $3 }
+pOption : lowerName '=' false { OptionFalse $1 }
+ | lowerName '=' true { OptionTrue $1 }
+ | lowerName '=' pStuffBetweenBraces { OptionString $1 $3 }
+ | lowerName '=' integer { OptionInteger $1 $3 }
+ | vector '=' pVectorTemplate { OptionVector $3 }
+ | fixity '=' pInfix { OptionFixity $3 }
+ | effect '=' pEffect { OptionEffect $3 }
+ | defined_bits '=' pGoodBits { OptionDefinedBits $3 }
| can_fail_warning '=' pPrimOpCanFailWarnFlag { OptionCanFailWarnFlag $3 }
pInfix :: { Maybe Fixity }
@@ -102,6 +104,10 @@ pEffect : NoEffect { NoEffect }
| ThrowsException { ThrowsException }
| ReadWriteEffect { ReadWriteEffect }
+pGoodBits :: { Maybe Word }
+pGoodBits : integer { Just $ toEnum $1 }
+ | nothing { Nothing }
+
pPrimOpCanFailWarnFlag :: { PrimOpCanFailWarnFlag }
pPrimOpCanFailWarnFlag : DoNotWarnCanFail { DoNotWarnCanFail }
| WarnIfEffectIsCanFail { WarnIfEffectIsCanFail }
=====================================
utils/genprimopcode/ParserM.hs
=====================================
@@ -116,6 +116,7 @@ data Token = TEOF
| TCanFail
| TThrowsException
| TReadWriteEffect
+ | TDefinedBits
| TCanFailWarnFlag
| TDoNotWarnCanFail
| TWarnIfEffectIsCanFail
=====================================
utils/genprimopcode/Syntax.hs
=====================================
@@ -76,6 +76,7 @@ data Option
| OptionFixity (Maybe Fixity) -- fixity = infix{,l,r} <int> | Nothing
| OptionEffect PrimOpEffect -- effect = NoEffect | DoNotSpeculate | CanFail | ThrowsException | ReadWriteEffect | FallibleReadWriteEffect
| OptionCanFailWarnFlag PrimOpCanFailWarnFlag -- can_fail_warning = DoNotWarnCanFail | WarnIfEffectIsCanFail | YesWarnCanFail
+ | OptionDefinedBits (Maybe Word) -- defined_bits = Just 16 | Nothing
deriving Show
-- categorises primops
@@ -196,6 +197,7 @@ get_attrib_name (OptionVector _) = "vector"
get_attrib_name (OptionFixity _) = "fixity"
get_attrib_name (OptionEffect _) = "effect"
get_attrib_name (OptionCanFailWarnFlag _) = "can_fail_warning"
+get_attrib_name (OptionDefinedBits _) = "defined_bits"
lookup_attrib :: String -> [Option] -> Maybe Option
lookup_attrib _ [] = Nothing
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/224fb5bd5e724226e1f9a2783cbf1c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/224fb5bd5e724226e1f9a2783cbf1c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/warning-for-last-and-init] 7 commits: ipe: Place strings and metadata into specific .ipe section
by Bodigrim (＠Bodigrim) 08 Aug '25
by Bodigrim (＠Bodigrim) 08 Aug '25
08 Aug '25
Bodigrim pushed to branch wip/warning-for-last-and-init at Glasgow Haskell Compiler / GHC
Commits:
1903ae35 by Matthew Pickering at 2025-08-07T12:21:10+01:00
ipe: Place strings and metadata into specific .ipe section
By placing the .ipe metadata into a specific section it can be stripped
from the final binary if desired.
```
objcopy --remove-section .ipe <binary>
upx <binary>
```
Towards #21766
- - - - -
c80dd91c by Matthew Pickering at 2025-08-07T12:22:42+01:00
ipe: Place magic word at the start of entries in the .ipe section
The magic word "IPE\nIPE\n" is placed at the start of .ipe sections,
then if the section is stripped, we can check whether the section starts
with the magic word or not to determine whether there is metadata
present or not.
Towards #21766
- - - - -
cab42666 by Matthew Pickering at 2025-08-07T12:22:42+01:00
ipe: Use stable IDs for IPE entries
IPEs have historically been indexed and reported by their address.
This makes it impossible to compare profiles between runs, since the
addresses may change (due to ASLR) and also makes it tricky to separate
out the IPE map from the binary.
This small patch adds a stable identifier for each IPE entry.
The stable identifier is a single 64 bit word. The high-bits are a
per-module identifier and the low bits identify which entry in each
module.
1. When a node is added into the IPE buffer it is assigned a unique
identifier from an incrementing global counter.
2. Each entry already has an index by it's position in the
`IpeBufferListNode`.
The two are combined together by the `IPE_ENTRY_KEY` macro.
Info table profiling uses the stable identifier rather than the address
of the info table.
The benefits of this change are:
* Profiles from different runs can be easily compared
* The metadata can be extracted from the binary (via the eventlog for
example) and then stripped from the executable.
Fixes #21766
- - - - -
2860a9a5 by Simon Peyton Jones at 2025-08-07T20:29:18-04:00
In TcSShortCut, typechecker plugins should get empty Givens
Solving in TcShortCut mode means /ignoring the Givens/. So we
should not pass them to typechecker plugins!
Fixes #26258.
This is a fixup to the earlier MR:
commit 1bd12371feacc52394a0e660ef9349f9e8ee1c06
Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com>
Date: Mon Jul 21 10:04:49 2025 +0100
Improve treatment of SPECIALISE pragmas -- again!
- - - - -
2157db2d by sterni at 2025-08-08T15:32:39-04:00
hadrian: enable terminfo if --with-curses-* flags are given
The GHC make build system used to support WITH_TERMINFO in ghc.mk which
allowed controlling whether to build GHC with terminfo or not. hadrian
has replaced this with a system where this is effectively controlled by
the cross-compiling setting (the default WITH_TERMINFO value was bassed
on CrossCompiling, iirc).
This behavior is undesireable in some cases and there is not really a
good way to work around it. Especially for downstream packagers,
modifying this via UserSettings is not really feasible since such a
source file has to be kept in sync with Settings/Default.hs manually
since it can't import Settings.Default or any predefined Flavour
definitions.
To avoid having to add a new setting to cfg/system.config and/or a new
configure flag (though I'm happy to implement both if required), I've
chosen to take --with-curses-* being set explicitly as an indication
that the user wants to have terminfo enabled. This would work for
Nixpkgs which sets these flags [1] as well as haskell.nix [2] (which
goes to some extreme measures [3] [4] to force terminfo in all scenarios).
In general, I'm an advocate for making the GHC build be the same for
native and cross insofar it is possible since it makes packaging GHC and
Haskell related things while still supporting cross much less
compilicated. A more minimal GHC with reduced dependencies should
probably be a specific flavor, not the default.
Partially addresses #26288 by forcing terminfo to be built if the user
explicitly passes configure flags related to it. However, it isn't built
by default when cross-compiling yet nor is there an explicit way to
control the package being built.
[1]: https://github.com/NixOS/nixpkgs/blob/3a7266fcefcb9ce353df49ba3f292d0644376…
[2]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
[3]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
[4]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
- - - - -
b3c31488 by David Feuer at 2025-08-08T15:33:21-04:00
Add default QuasiQuoters
Add `defaultQuasiQuoter` and `namedDefaultQuasiQuoter` to make it easier
to write `QuasiQuoters` that give helpful error messages when they're
used in inappropriate contexts.
Closes #24434.
- - - - -
9d61b626 by Mike Pilgrem at 2025-08-08T21:32:40+01:00
Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial
Also corrects the warning for `tail` to refer to `Data.List.uncons` (like the existing warning for `head`).
In module `Settings.Warnings`, applies `-Wno-unrecognised-warning-flags` `-Wno-x-partial` to the `Cabal`, `filepath`, `hsc2hs`, `hpc`, `parsec`, `text` and `time` packages (outside GHC's repository).
- - - - -
46 changed files:
- compiler/GHC/Cmm.hs
- compiler/GHC/CmmToAsm/PPC/Ppr.hs
- compiler/GHC/CmmToAsm/Ppr.hs
- compiler/GHC/CmmToLlvm/Data.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Driver/Session/Units.hs
- compiler/GHC/Prelude/Basic.hs
- compiler/GHC/StgToCmm/InfoTableProv.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
- docs/users_guide/debug-info.rst
- ghc/GHCi/UI.hs
- ghc/Main.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
- hadrian/src/Settings/Warnings.hs
- libraries/Cabal
- libraries/filepath
- libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
- libraries/ghc-internal/src/GHC/Internal/Float.hs
- libraries/ghc-internal/src/GHC/Internal/List.hs
- libraries/ghc-internal/src/GHC/Internal/System/IO.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- libraries/template-haskell/Language/Haskell/TH/Quote.hs
- libraries/template-haskell/changelog.md
- libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs
- libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs
- rts/IPE.c
- rts/ProfHeap.c
- rts/eventlog/EventLog.c
- rts/include/rts/IPE.h
- testsuite/tests/driver/j-space/jspace.hs
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- testsuite/tests/rts/KeepCafsBase.hs
- testsuite/tests/rts/ipe/ipeMap.c
- testsuite/tests/rts/ipe/ipe_lib.c
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
- utils/ghc-pkg/Main.hs
- utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
- utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
- utils/hpc
- utils/hsc2hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f477db5713add8656ae37b3ef8023a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f477db5713add8656ae37b3ef8023a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0