[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: haddock: Remove unused pragmata, qualify usages of Data.List functions, add...
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Jun 20 21:18:56 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
b007b87d by Hécate Kleidukos at 2024-06-20T17:18:27-04:00
haddock: Remove unused pragmata, qualify usages of Data.List functions, add more sanity checking flags by default
This commit enables some extensions and GHC flags in the cabal file in a way
that allows us to reduce the amount of prologuing on top of each file.
We also prefix the usage of some List functions that removes ambiguity
when they are also exported from the Prelude, like foldl'.
In general, this has the effect of pointing out more explicitly
that a linked list is used.
Metric Increase:
haddock.Cabal
haddock.base
haddock.compiler
- - - - -
3cc2ccd0 by Arnaud Spiwack at 2024-06-20T17:18:27-04:00
Add test case for #23586
- - - - -
fcb838e2 by Arnaud Spiwack at 2024-06-20T17:18:27-04:00
When matching functions in rewrite rules: ignore multiplicity
When matching a template variable to an expression, we check that it
has the same type as the matched expression. But if the variable `f` has
type `A -> B` while the expression `e` has type `A %1 -> B`, the match was
previously rejected.
A principled solution would have `f` substituted by `\(%Many x) -> e
x` or some other appropriate coercion. But since linearity is not
properly checked in Core, we can be cheeky and simply ignore
multiplicity while matching. Much easier.
This has forced a change in the linter which, when `-dlinear-core-lint`
is off, must consider that `a -> b` and `a %1 -> b` are equal. This is
achieved by adding an argument to configure the behaviour of
`nonDetCmpTypeX` and modify `ensureEqTys` to call to the new behaviour
which ignores multiplicities when comparing two `FunTy`.
Fixes #24725.
- - - - -
7392a012 by Simon Peyton Jones at 2024-06-20T17:18:27-04:00
Faster type equality
This MR speeds up type equality, triggered by perf regressions that
showed up when fixing #24725 by parameterising type equality over
whether to ignore multiplicity.
The changes are:
* Do not use `nonDetCmpType` for type /equality/. Instead use a specialised
type-equality function, which we have always had!
`nonDetCmpType` remains, but I did not invest effort in refactoring
or optimising it.
* Type equality is parameterised by
- whether to expand synonyms
- whether to respect multiplicities
- whether it has a RnEnv2 environment
In this MR I systematically specialise it for static values of these
parameters. Much more direct and predictable than before. See
Note [Specialising type equality]
* We want to avoid comparing kinds if possible. I refactored how this
happens, at least for `eqType`.
See Note [Casts and coercions in type comparison]
* To make Lint fast, we want to avoid allocating a thunk for <msg> in
ensureEqTypes ty1 ty2 <msg>
because the test almost always succeeds, and <msg> isn't needed.
See Note [INLINE ensureEqTys]
Metric Decrease:
T13386
T5030
- - - - -
25 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Multiplicity.hs
- compiler/GHC/Core/TyCo/Compare.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/Tc/Utils/TcType.hs
- + testsuite/tests/simplCore/should_run/T23586.hs
- + testsuite/tests/simplCore/should_run/T23586.stdout
- testsuite/tests/simplCore/should_run/all.T
- utils/haddock/haddock-api/haddock-api.cabal
- utils/haddock/haddock-api/src/Haddock.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface.hs
- utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Options.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
- utils/haddock/haddock-library/fixtures/Fixtures.hs
- utils/haddock/haddock-library/haddock-library.cabal
- utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
- utils/haddock/haddock-library/src/Documentation/Haddock/Parser/Monad.hs
- utils/haddock/haddock.cabal
Changes:
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -53,7 +53,7 @@ import GHC.Core.Predicate( isCoVarType )
import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
import GHC.Core.TyCo.Rep -- checks validity of types/coercions
-import GHC.Core.TyCo.Compare ( eqType, eqForAllVis )
+import GHC.Core.TyCo.Compare ( eqType, eqTypes, eqTypeIgnoringMultiplicity, eqForAllVis )
import GHC.Core.TyCo.Subst
import GHC.Core.TyCo.FVs
import GHC.Core.TyCo.Ppr
@@ -2807,7 +2807,7 @@ lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches
extra_checks
| isNewTyCon tc
- = do { CoAxBranch { cab_tvs = tvs
+ = do { CoAxBranch { cab_tvs = ax_tvs
, cab_eta_tvs = eta_tvs
, cab_cvs = cvs
, cab_roles = roles
@@ -2815,14 +2815,10 @@ lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches
<- case branch_list of
[branch] -> return branch
_ -> failWithL (text "multi-branch axiom with newtype")
- ; let ax_lhs = mkInfForAllTys tvs $
- mkTyConApp tc lhs_tys
- nt_tvs = takeList tvs (tyConTyVars tc)
- -- axiom may be eta-reduced: Note [Newtype eta] in GHC.Core.TyCon
- nt_lhs = mkInfForAllTys nt_tvs $
- mkTyConApp tc (mkTyVarTys nt_tvs)
- -- See Note [Newtype eta] in GHC.Core.TyCon
- ; lintL (ax_lhs `eqType` nt_lhs)
+
+ -- The LHS of the axiom is (N lhs_tys)
+ -- We expect it to be (N ax_tvs)
+ ; lintL (mkTyVarTys ax_tvs `eqTypes` lhs_tys)
(text "Newtype axiom LHS does not match newtype definition")
; lintL (null cvs)
(text "Newtype axiom binds coercion variables")
@@ -2831,7 +2827,7 @@ lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches
(text "Newtype axiom has eta-tvs")
; lintL (ax_role == Representational)
(text "Newtype axiom role not representational")
- ; lintL (roles `equalLength` tvs)
+ ; lintL (roles `equalLength` ax_tvs)
(text "Newtype axiom roles list is the wrong length." $$
text "roles:" <+> sep (map ppr roles))
; lintL (roles == takeList roles (tyConRoles tc))
@@ -3098,84 +3094,93 @@ we behave as follows (#15057, #T15664):
Note [Linting linearity]
~~~~~~~~~~~~~~~~~~~~~~~~
-Core understands linear types: linearity is checked with the flag
-`-dlinear-core-lint`. Why not make `-dcore-lint` check linearity? Because
-optimisation passes are not (yet) guaranteed to maintain linearity. They should
-do so semantically (GHC is careful not to duplicate computation) but it is much
-harder to ensure that the statically-checkable constraints of Linear Core are
-maintained. The current Linear Core is described in the wiki at:
+Lint ignores linearity unless `-dlinear-core-lint` is set. For why, see below.
+
+But first, "ignore linearity" specifically means two things. When ignoring linearity:
+* In `ensureEqTypes`, use `eqTypeIgnoringMultiplicity`
+* In `ensureSubMult`, do nothing
+
+But why make `-dcore-lint` ignore linearity? Because optimisation passes are
+not (yet) guaranteed to maintain linearity. They should do so semantically (GHC
+is careful not to duplicate computation) but it is much harder to ensure that
+the statically-checkable constraints of Linear Core are maintained. The current
+Linear Core is described in the wiki at:
https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation.
-Why don't the optimisation passes maintain the static types of Linear Core?
-Because doing so would cripple some important optimisations. Here is an
-example:
+Here are some examples of how the optimiser can break linearity checking. Other
+examples are documented in the linear-type implementation wiki page
+[https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation#core-to-core-passes]
- data T = MkT {-# UNPACK #-} !Int
+* EXAMPLE 1: the binder swap transformation
+ Consider
-The wrapper for MkT is
+ data T = MkT {-# UNPACK #-} !Int
- $wMkT :: Int %1 -> T
- $wMkT n = case %1 n of
- I# n' -> MkT n'
+ The wrapper for MkT is
-This introduces, in particular, a `case %1` (this is not actual Haskell or Core
-syntax), where the `%1` means that the `case` expression consumes its scrutinee
-linearly.
+ $wMkT :: Int %1 -> T
+ $wMkT n = case %1 n of
+ I# n' -> MkT n'
-Now, `case %1` interacts with the binder swap optimisation in a non-trivial
-way. Take a slightly modified version of the code for $wMkT:
+ This introduces, in particular, a `case %1` (this is not actual Haskell or
+ Core syntax), where the `%1` means that the `case` expression consumes its
+ scrutinee linearly.
- case %1 x of z {
- I# n' -> (x, n')
- }
+ Now, `case %1` interacts with the binder swap optimisation in a non-trivial
+ way. Take a slightly modified version of the code for $wMkT:
-Binder-swap wants to change this to
+ case %1 x of z {
+ I# n' -> (x, n')
+ }
- case %1 x of z {
- I# n' -> let x = z in (x, n')
- }
+ Binder-swap changes this to
-Now, this is not something that a linear type checker usually considers
-well-typed. It is not something that `-dlinear-core-lint` considers to be
-well-typed either. But it's only because `-dlinear-core-lint` is not good
-enough. However, making `-dlinear-core-lint` recognise this expression as valid
-is not obvious. There are many such interactions between a linear type system
-and GHC optimisations documented in the linear-type implementation wiki page
-[https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation#core-to-core-passes].
+ case %1 x of z {
+ I# n' -> let x = z in (x, n')
+ }
-PRINCIPLE: The type system bends to the optimisation, not the other way around.
+ This is rejected by `-dlinear-core-lint` because 1/ n' must be used linearly
+ 2/ `-dlinear-core-lint` recognises a use of `z` as a use of `n'`. So it sees
+ two uses of n' where there should be a single one.
+
+* EXAMPLE 2: letrec
+ Some optimisations can create a letrec which uses a variable
+ linearly, e.g.
+
+ letrec f True = f False
+ f False = x
+ in f True
+
+ uses 'x' linearly, but this is not seen by the linter, which considers,
+ conservatively, that a letrec always has multiplicity Many (in particular
+ that every captured free variable must have multiplicity Many). This issue
+ is discussed in ticket #18694.
-In the original linear-types implementation, we had tried to make every
-optimisation pass produce code that passes `-dlinear-core-lint`. It had proved
-very difficult. And we kept finding corner case after corner case. Plus, we
-used to restrict transformations when `-dlinear-core-lint` couldn't typecheck
-the result. There are still occurrences of such restrictions in the code. But
-our current stance is that such restrictions can be removed.
+* EXAMPLE 3: rewrite rules
+ Ignoring linearity means in particular that `a -> b` and `a %1 -> b` must be
+ treated the same by rewrite rules (see also Note [Rewrite rules ignore
+ multiplicities in FunTy] in GHC.Core.Unify). Consider
-For instance, some optimisations can create a letrec which uses a variable
-linearly, e.g.
+ m :: Bool -> A
+ m' :: (Bool -> Bool) -> A
+ {- RULES "ex" forall f. m (f True) = m' f -}
- letrec f True = f False
- f False = x
- in f True
+ f :: Bool %1 -> A
+ x = m (f True)
-uses 'x' linearly, but this is not seen by the linter. This issue is discussed
-in ticket #18694.
+ The rule "ex" must match . So the linter must accept `m' f`.
-Plus in many cases, in order to make a transformation compatible with linear
-linting, we ended up restricting to avoid producing patterns that were not
-recognised as linear by the linter. This violates the above principle.
+Historical note: In the original linear-types implementation, we had tried to
+make every optimisation pass produce code that passes `-dlinear-core-lint`. It
+had proved very difficult. We kept finding corner case after corner
+case. Furthermore, to attempt to achieve that goal we ended up restricting
+transformations when `-dlinear-core-lint` couldn't typecheck the result.
In the future, we may be able to lint the linearity of the output of
-Core-to-Core passes (#19165). But right now, we can't. Therefore, in virtue of
-the principle above, after the desguarer, the optimiser should take no special
-pains to preserve linearity (in the type system sense).
+Core-to-Core passes (#19165). But this shouldn't be done at the expense of
+producing efficient code. Therefore we lay the following principle.
-In general the optimiser tries hard not to lose sharing, so it probably doesn't
-actually make linear things non-linear. We postulate that any program
-transformation which breaks linearity would negatively impact performance, and
-therefore wouldn't be suitable for an optimiser. An alternative to linting
-linearity after each pass is to prove this statement.
+PRINCIPLE: The type system bends to the optimisation, not the other way around.
There is a useful discussion at https://gitlab.haskell.org/ghc/ghc/-/issues/22123
@@ -3483,7 +3488,25 @@ ensureEqTys :: LintedType -> LintedType -> SDoc -> LintM ()
-- check ty2 is subtype of ty1 (ie, has same structure but usage
-- annotations need only be consistent, not equal)
-- Assumes ty1,ty2 are have already had the substitution applied
-ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg
+{-# INLINE ensureEqTys #-} -- See Note [INLINE ensureEqTys]
+ensureEqTys ty1 ty2 msg
+ = do { flags <- getLintFlags
+ ; lintL (eq_type flags ty1 ty2) msg }
+
+eq_type :: LintFlags -> Type -> Type -> Bool
+-- When `-dlinear-core-lint` is off, then consider `a -> b` and `a %1 -> b` to
+-- be equal. See Note [Linting linearity].
+eq_type flags ty1 ty2 | lf_check_linearity flags = eqType ty1 ty2
+ | otherwise = eqTypeIgnoringMultiplicity ty1 ty2
+
+{- Note [INLINE ensureEqTys]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To make Lint fast, we want to avoid allocating a thunk for <msg> in
+ ensureEqTypes ty1 ty2 <msg>
+because the test almost always succeeds, and <msg> isn't needed.
+So we INLINE `ensureEqTys`. This actually make a difference of
+1-2% when compiling programs with -dcore-lint.
+-}
ensureSubUsage :: Usage -> Mult -> SDoc -> LintM ()
ensureSubUsage Bottom _ _ = return ()
=====================================
compiler/GHC/Core/Multiplicity.hs
=====================================
@@ -30,7 +30,9 @@ module GHC.Core.Multiplicity
, IsSubmult(..)
, submult
, mapScaledType
- , pprArrowWithMultiplicity ) where
+ , pprArrowWithMultiplicity
+ , MultiplicityFlag(..)
+ ) where
import GHC.Prelude
@@ -395,3 +397,8 @@ pprArrowWithMultiplicity af pp_mult
| otherwise
= ppr (funTyFlagTyCon af)
+-- | In Core, without `-dlinear-core-lint`, some function must ignore
+-- multiplicities. See Note [Linting linearity] in GHC.Core.Lint.
+data MultiplicityFlag
+ = RespectMultiplicities
+ | IgnoreMultiplicities
=====================================
compiler/GHC/Core/TyCo/Compare.hs
=====================================
@@ -7,15 +7,17 @@
-- | Type equality and comparison
module GHC.Core.TyCo.Compare (
- -- * Type comparison
- eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX,
- nonDetCmpTypesX, nonDetCmpTc,
+ -- * Type equality
+ eqType, eqTypeIgnoringMultiplicity, eqTypeX, eqTypes,
eqVarBndrs,
pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck,
tcEqTyConApps,
mayLookIdentical,
+ -- * Type comparison
+ nonDetCmpType,
+
-- * Visiblity comparision
eqForAllVis, cmpForAllVis
@@ -29,10 +31,12 @@ import GHC.Core.Type( typeKind, coreView, tcSplitAppTyNoView_maybe, splitAppTyNo
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.FVs
import GHC.Core.TyCon
+import GHC.Core.Multiplicity( MultiplicityFlag(..) )
import GHC.Types.Var
import GHC.Types.Unique
import GHC.Types.Var.Env
+import GHC.Types.Var.Set
import GHC.Utils.Outputable
import GHC.Utils.Misc
@@ -52,7 +56,11 @@ so it currently sits "on top of" GHC.Core.Type.
{- *********************************************************************
* *
- Type equality
+ Type equality
+
+ We don't use (==) from class Eq, partly so that we know where
+ type equality is called, and partly because there are multiple
+ variants.
* *
********************************************************************* -}
@@ -72,6 +80,93 @@ that needs to be updated.
* See Historical Note [Typechecker equality vs definitional equality]
below
+Note [Casts and coercions in type comparision]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As (EQTYPE) in Note [Non-trivial definitional equality] says, our
+general plan, implemented by `fullEq`, is:
+ (1) ignore both casts and coercions when comparing types,
+ (2) instead, compare the /kinds/ of the two types,
+ as well as the types themselves
+
+If possible we want to avoid step (2), comparing the kinds; doing so involves
+calling `typeKind` and doing another comparision.
+
+When can we avoid doing so? Answer: we can certainly avoid doing so if the
+types we are comparing have no casts or coercions. But we can do better.
+Consider
+ eqType (TyConApp T [s1, ..., sn]) (TyConApp T [t1, .., tn])
+We are going to call (eqType s1 t1), (eqType s2 t2) etc.
+
+The kinds of `s1` and `t1` must be equal, because these TyConApps are well-kinded,
+and both TyConApps are headed by the same T. So the first recursive call to `eqType`
+certainly doesn't need to check kinds. If that call returns False, we stop. Otherwise,
+we know that `s1` and `t1` are themselves equal (not just their kinds). This
+makes the kinds of `s2` and `t2` to be equal, because those kinds come from the
+kind of T instantiated with `s1` and `t1` -- which are the same. Thus we do not
+need to check the kinds of `s2` and `t2`. By induction, we don't need to check
+the kinds of *any* of the types in a TyConApp, and we also do not need to check
+the kinds of the TyConApps themselves.
+
+Conclusion:
+
+* casts and coercions under a TyConApp don't matter -- even including type synonyms
+
+* In step (2), use `hasCasts` to tell if there are any casts to worry about. It
+ does not look very deep, because TyConApps and FunTys are so common, and it
+ doesn't allocate. The only recursive cases are AppTy and ForAllTy.
+
+Alternative implementation. Instead of `hasCasts`, we could make the
+generic_eq_type function return
+ data EqResult = NotEq | EqWithNoCasts | EqWithCasts
+Practically free; but stylistically I prefer useing `hasCasts`:
+ * `generic_eq_type` can just uses familiar booleans
+ * There is a lot more branching with the three-value variant.
+ * It separates concerns. No need to think about cast-tracking when doing the
+ equality comparison.
+ * Indeed sometimes we omit the kind check unconditionally, so tracking it is just wasted
+ work.
+I did try both; there was no perceptible perf difference so I chose `hasCasts` version.
+
+Note [Equality on AppTys]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+In our cast-ignoring equality, we want to say that the following two
+are equal:
+
+ (Maybe |> co) (Int |> co') ~? Maybe Int
+
+But the left is an AppTy while the right is a TyConApp. The solution is
+to use splitAppTyNoView_maybe to break up the TyConApp into its pieces and
+then continue. Easy to do, but also easy to forget to do.
+
+Note [Comparing nullary type synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the task of testing equality between two 'Type's of the form
+
+ TyConApp tc []
+
+where @tc@ is a type synonym. A naive way to perform this comparison these
+would first expand the synonym and then compare the resulting expansions.
+
+However, this is obviously wasteful and the RHS of @tc@ may be large; it is
+much better to rather compare the TyCons directly. Consequently, before
+expanding type synonyms in type comparisons we first look for a nullary
+TyConApp and simply compare the TyCons if we find one. Of course, if we find
+that the TyCons are *not* equal then we still need to perform the expansion as
+their RHSs may still be equal.
+
+We perform this optimisation in a number of places:
+
+ * GHC.Core.Types.eqType
+ * GHC.Core.Types.nonDetCmpType
+ * GHC.Core.Unify.unify_ty
+ * GHC.Tc.Solver.Equality.can_eq_nc'
+ * TcUnify.uType
+
+This optimisation is especially helpful for the ubiquitous GHC.Types.Type,
+since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications
+whenever possible. See Note [Using synonyms to compress types] in
+GHC.Core.Type for details.
+
Note [Type comparisons using object pointer comparisons]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Quite often we substitute the type from a definition site into
@@ -81,6 +176,21 @@ The type of every `x` will often be represented by a single object
in the heap. We can take advantage of this by shortcutting the equality
check if two types are represented by the same pointer under the hood.
In some cases this reduces compiler allocations by ~2%.
+
+See Note [Pointer comparison operations] in GHC.Builtin.primops.txt.pp
+
+Note [Respecting multiplicity when comparing types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generally speaking, we respect multiplicities (i.e. the linear part of the type
+system) when comparing types. Doing so is of course crucial during typechecking.
+
+But for reasons described in Note [Linting linearity] in GHC.Core.Lint, it is hard
+to ensure that Core is always type-correct when it comes to linearity. So
+* `eqTypeIgnoringMultiplicity` provides a way to compare types that /ignores/ multiplicities
+* We use this multiplicity-blind comparison very occasionally, notably
+ - in Core Lint: see Note [Linting linearity] in GHC.Core.Lint
+ - in rule matching: see Note [Rewrite rules ignore multiplicities in FunTy]
+ in GHC.Core.Unify
-}
@@ -88,21 +198,12 @@ tcEqKind :: HasDebugCallStack => Kind -> Kind -> Bool
tcEqKind = tcEqType
tcEqType :: HasDebugCallStack => Type -> Type -> Bool
--- ^ tcEqType implements typechecker equality
--- It behaves just like eqType, but is implemented
--- differently (for now)
-tcEqType ty1 ty2
- = tcEqTypeNoSyns ki1 ki2
- && tcEqTypeNoSyns ty1 ty2
- where
- ki1 = typeKind ty1
- ki2 = typeKind ty2
+tcEqType = eqType
-- | Just like 'tcEqType', but will return True for types of different kinds
-- as long as their non-coercion structure is identical.
tcEqTypeNoKindCheck :: Type -> Type -> Bool
-tcEqTypeNoKindCheck ty1 ty2
- = tcEqTypeNoSyns ty1 ty2
+tcEqTypeNoKindCheck = eqTypeNoKindCheck
-- | Check whether two TyConApps are the same; if the number of arguments
-- are different, just checks the common prefix of arguments.
@@ -114,175 +215,220 @@ tcEqTyConApps tc1 args1 tc2 args2
-- any difference in the kinds of later arguments would show up
-- as differences in earlier (dependent) arguments
-{-
-Note [Specialising tc_eq_type]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The type equality predicates in Type are hit pretty hard during typechecking.
-Consequently we take pains to ensure that these paths are compiled to
-efficient, minimally-allocating code.
-
-To this end we place an INLINE on tc_eq_type, ensuring that it is inlined into
-its publicly-visible interfaces (e.g. tcEqType). In addition to eliminating
-some dynamic branches, this allows the simplifier to eliminate the closure
-allocations that would otherwise be necessary to capture the two boolean "mode"
-flags. This reduces allocations by a good fraction of a percent when compiling
-Cabal.
-See #19226.
--}
-
-mayLookIdentical :: Type -> Type -> Bool
--- | Returns True if the /visible/ part of the types
--- might look equal, even if they are really unequal (in the invisible bits)
---
--- This function is very similar to tc_eq_type but it is much more
--- heuristic. Notably, it is always safe to return True, even with types
--- that might (in truth) be unequal -- this affects error messages only
--- (Originally there were one function with an extra flag, but the result
--- was hard to understand.)
-mayLookIdentical orig_ty1 orig_ty2
- = go orig_env orig_ty1 orig_ty2
- where
- orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2]
-
- go :: RnEnv2 -> Type -> Type -> Bool
- -- See Note [Comparing nullary type synonyms]
- go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = True
-
- go env t1 t2 | Just t1' <- coreView t1 = go env t1' t2
- go env t1 t2 | Just t2' <- coreView t2 = go env t1 t2'
-
- go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2
- go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2
- go env (CastTy t1 _) t2 = go env t1 t2
- go env t1 (CastTy t2 _) = go env t1 t2
- go _ (CoercionTy {}) (CoercionTy {}) = True
-
- go env (ForAllTy (Bndr tv1 vis1) ty1)
- (ForAllTy (Bndr tv2 vis2) ty2)
- = vis1 `eqForAllVis` vis2 -- See Note [ForAllTy and type equality]
- && go (rnBndr2 env tv1 tv2) ty1 ty2
- -- Visible stuff only: ignore kinds of binders
-
- -- If we have (forall (r::RunTimeRep). ty1 ~ blah) then respond
- -- with True. Reason: the type pretty-printer defaults RuntimeRep
- -- foralls (see Ghc.Iface.Type.hideNonStandardTypes). That can make,
- -- say (forall r. TYPE r -> Type) into (Type -> Type), so it looks the
- -- same as a very different type (#24553). By responding True, we
- -- tell GHC (see calls of mayLookIdentical) to display without defaulting.
- -- See Note [Showing invisible bits of types in error messages]
- -- in GHC.Tc.Errors.Ppr
- go _ (ForAllTy b _) _ | isDefaultableBndr b = True
- go _ _ (ForAllTy b _) | isDefaultableBndr b = True
+-- | Type equality on lists of types, looking through type synonyms
+eqTypes :: [Type] -> [Type] -> Bool
+eqTypes [] [] = True
+eqTypes (t1:ts1) (t2:ts2) = eqType t1 t2 && eqTypes ts1 ts2
+eqTypes _ _ = False
- go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2)
- = go env arg1 arg2 && go env res1 res2 && go env w1 w2
- -- Visible stuff only: ignore agg kinds
+eqVarBndrs :: HasCallStack => RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2
+-- Check that the var lists are the same length
+-- and have matching kinds; if so, extend the RnEnv2
+-- Returns Nothing if they don't match
+eqVarBndrs env [] []
+ = Just env
+eqVarBndrs env (tv1:tvs1) (tv2:tvs2)
+ | eqTypeX env (varType tv1) (varType tv2)
+ = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2
+eqVarBndrs _ _ _= Nothing
- -- See Note [Equality on AppTys] in GHC.Core.Type
- go env (AppTy s1 t1) ty2
- | Just (s2, t2) <- tcSplitAppTyNoView_maybe ty2
- = go env s1 s2 && go env t1 t2
- go env ty1 (AppTy s2 t2)
- | Just (s1, t1) <- tcSplitAppTyNoView_maybe ty1
- = go env s1 s2 && go env t1 t2
+initRnEnv :: Type -> Type -> RnEnv2
+initRnEnv ta tb = mkRnEnv2 $ mkInScopeSet $
+ tyCoVarsOfType ta `unionVarSet` tyCoVarsOfType tb
- go env (TyConApp tc1 ts1) (TyConApp tc2 ts2)
- = tc1 == tc2 && gos env (tyConBinders tc1) ts1 ts2
+eqTypeNoKindCheck :: Type -> Type -> Bool
+eqTypeNoKindCheck ty1 ty2 = eq_type_expand_respect ty1 ty2
- go _ _ _ = False
-
- gos :: RnEnv2 -> [TyConBinder] -> [Type] -> [Type] -> Bool
- gos _ _ [] [] = True
- gos env bs (t1:ts1) (t2:ts2)
- | (invisible, bs') <- case bs of
- [] -> (False, [])
- (b:bs) -> (isInvisibleTyConBinder b, bs)
- = (invisible || go env t1 t2) && gos env bs' ts1 ts2
-
- gos _ _ _ _ = False
+-- | Type equality comparing both visible and invisible arguments,
+-- expanding synonyms and respecting multiplicities.
+eqType :: HasCallStack => Type -> Type -> Bool
+eqType ta tb = fullEq eq_type_expand_respect ta tb
+-- | Compare types with respect to a (presumably) non-empty 'RnEnv2'.
+eqTypeX :: HasCallStack => RnEnv2 -> Type -> Type -> Bool
+eqTypeX env ta tb = fullEq (eq_type_expand_respect_x env) ta tb
--- | Type equality comparing both visible and invisible arguments and expanding
--- type synonyms.
-tcEqTypeNoSyns :: Type -> Type -> Bool
-tcEqTypeNoSyns ta tb = tc_eq_type False ta tb
+eqTypeIgnoringMultiplicity :: Type -> Type -> Bool
+-- See Note [Respecting multiplicity when comparing types]
+eqTypeIgnoringMultiplicity ta tb = fullEq eq_type_expand_ignore ta tb
-- | Like 'pickyEqTypeVis', but returns a Bool for convenience
pickyEqType :: Type -> Type -> Bool
-- Check when two types _look_ the same, _including_ synonyms.
-- So (pickyEqType String [Char]) returns False
-- This ignores kinds and coercions, because this is used only for printing.
-pickyEqType ty1 ty2 = tc_eq_type True ty1 ty2
+pickyEqType ta tb = eq_type_keep_respect ta tb
--- | Real worker for 'tcEqType'. No kind check!
-tc_eq_type :: Bool -- ^ True <=> do not expand type synonyms
- -> Type -> Type
- -> Bool
--- Flags False, False is the usual setting for tc_eq_type
--- See Note [Computing equality on types] in Type
-{-# INLINE tc_eq_type #-} -- See Note [Specialising tc_eq_type].
-tc_eq_type keep_syns orig_ty1 orig_ty2
- = go orig_env orig_ty1 orig_ty2
- where
- orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2]
+{- Note [Specialising type equality]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The type equality predicates in Type are hit pretty hard by GHC. Consequently
+we take pains to ensure that these paths are compiled to efficient,
+minimally-allocating code. Plan:
- go :: RnEnv2 -> Type -> Type -> Bool
- -- See Note [Comparing nullary type synonyms]
- go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = True
+* The main workhorse is `inline_generic_eq_type_x`. It is /non-recursive/
+ and is marked INLINE.
- go env t1 t2 | not keep_syns, Just t1' <- coreView t1 = go env t1' t2
- go env t1 t2 | not keep_syns, Just t2' <- coreView t2 = go env t1 t2'
+* `inline_generic_eq_type_x` has various parameters that control what it does:
+ * syn_flag::SynFlag whether type synonyms are expanded or kept.
+ * mult_flag::MultiplicityFlag whether multiplicities are ignored or respected
+ * mb_env::Maybe RnEnv2 an optional RnEnv2.
- go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2
- go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2
- go env (CastTy t1 _) t2 = go env t1 t2
- go env t1 (CastTy t2 _) = go env t1 t2
- go _ (CoercionTy {}) (CoercionTy {}) = True
+* `inline_generic_eq_type_x` has a handful of call sites, namely the ones
+ in `eq_type_expand_respect`, `eq_type_expand_repect_x` etc. It inlines
+ at all these sites, specialising to the data values passed for the
+ control parameters.
- go env (ForAllTy (Bndr tv1 vis1) ty1)
- (ForAllTy (Bndr tv2 vis2) ty2)
- = vis1 `eqForAllVis` vis2 -- See Note [ForAllTy and type equality]
- && go env (varType tv1) (varType tv2)
- && go (rnBndr2 env tv1 tv2) ty1 ty2
+* All /other/ calls to `inline_generic_eq_type_x` go via
+ generic_eq_type_x = inline_generic_eq_type_x
+ {-# NOINLNE generic_eq_type_x #-}
+ The idea is that all calls to `generic_eq_type_x` are specialised by the
+ RULES, so this NOINLINE version is seldom, if ever, actually called.
+
+* For each of specialised copy of `inline_generic_eq_type_x, there is a
+ corresponding rewrite RULE that rewrites a call to (generic_eq_type_x args)
+ into the appropriate specialied version.
+
+See #19226.
+-}
+
+-- | This flag controls whether we expand synonyms during comparison
+data SynFlag = ExpandSynonyms | KeepSynonyms
+
+eq_type_expand_respect, eq_type_expand_ignore, eq_type_keep_respect
+ :: Type -> Type -> Bool
+eq_type_expand_respect_x, eq_type_expand_ignore_x, eq_type_keep_respect_x
+ :: RnEnv2 -> Type -> Type -> Bool
+
+eq_type_expand_respect = inline_generic_eq_type_x ExpandSynonyms RespectMultiplicities Nothing
+eq_type_expand_respect_x env = inline_generic_eq_type_x ExpandSynonyms RespectMultiplicities (Just env)
+eq_type_expand_ignore = inline_generic_eq_type_x ExpandSynonyms IgnoreMultiplicities Nothing
+eq_type_expand_ignore_x env = inline_generic_eq_type_x ExpandSynonyms IgnoreMultiplicities (Just env)
+eq_type_keep_respect = inline_generic_eq_type_x KeepSynonyms RespectMultiplicities Nothing
+eq_type_keep_respect_x env = inline_generic_eq_type_x KeepSynonyms RespectMultiplicities (Just env)
+
+{-# RULES
+"eqType1" generic_eq_type_x ExpandSynonyms RespectMultiplicities Nothing
+ = eq_type_expand_respect
+"eqType2" forall env. generic_eq_type_x ExpandSynonyms RespectMultiplicities (Just env)
+ = eq_type_expand_respect_x env
+"eqType3" generic_eq_type_x ExpandSynonyms IgnoreMultiplicities Nothing
+ = eq_type_expand_ignore
+"eqType4" forall env. generic_eq_type_x ExpandSynonyms IgnoreMultiplicities (Just env)
+ = eq_type_expand_ignore_x env
+"eqType5" generic_eq_type_x KeepSynonyms RespectMultiplicities Nothing
+ = eq_type_keep_respect
+"eqType6" forall env. generic_eq_type_x KeepSynonyms RespectMultiplicities (Just env)
+ = eq_type_keep_respect_x env
+ #-}
+
+-- ---------------------------------------------------------------
+-- | Real worker for 'eqType'. No kind check!
+-- Inline it at the (handful of local) call sites
+-- The "generic" bit refers to the flag paramerisation
+-- See Note [Specialising type equality].
+generic_eq_type_x, inline_generic_eq_type_x
+ :: SynFlag -> MultiplicityFlag -> Maybe RnEnv2 -> Type -> Type -> Bool
+
+{-# NOINLINE generic_eq_type_x #-}
+generic_eq_type_x = inline_generic_eq_type_x
+-- See Note [Computing equality on types] in Type
+
+{-# INLINE inline_generic_eq_type_x #-}
+-- This non-recursive function can inline at its (few) call sites. The
+-- recursion goes via generic_eq_type_x, which is the loop-breaker.
+inline_generic_eq_type_x syn_flag mult_flag mb_env
+ = \ t1 t2 -> t1 `seq` t2 `seq`
+ let go = generic_eq_type_x syn_flag mult_flag mb_env
+ -- Abbreviation for recursive calls
+ in case (t1,t2) of
+ _ | 1# <- reallyUnsafePtrEquality# t1 t2 -> True
+ -- See Note [Type comparisons using object pointer comparisons]
+
+ (TyConApp tc1 [], TyConApp tc2 []) | tc1 == tc2 -> True
+ -- See Note [Comparing nullary type synonyms]
+
+ _ | ExpandSynonyms <- syn_flag, Just t1' <- coreView t1 -> go t1' t2
+ | ExpandSynonyms <- syn_flag, Just t2' <- coreView t2 -> go t1 t2'
+
+ (TyVarTy tv1, TyVarTy tv2)
+ -> case mb_env of
+ Nothing -> tv1 == tv2
+ Just env -> rnOccL env tv1 == rnOccR env tv2
+
+ (LitTy lit1, LitTy lit2) -> lit1 == lit2
+ (CastTy t1' _, _) -> go t1' t2 -- Ignore casts
+ (_, CastTy t2' _) -> go t1 t2' -- Ignore casts
+ (CoercionTy {}, CoercionTy {}) -> True -- Ignore coercions
-- Make sure we handle all FunTy cases since falling through to the
-- AppTy case means that tcSplitAppTyNoView_maybe may see an unzonked
-- kind variable, which causes things to blow up.
-- See Note [Equality on FunTys] in GHC.Core.TyCo.Rep: we must check
-- kinds here
- go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2)
- = go env (typeKind arg1) (typeKind arg2) &&
- go env (typeKind res1) (typeKind res2) &&
- go env arg1 arg2 && go env res1 res2 && go env w1 w2
+ (FunTy _ w1 arg1 res1, FunTy _ w2 arg2 res2)
+ -> fullEq go arg1 arg2
+ && fullEq go res1 res2
+ && (case mult_flag of
+ RespectMultiplicities -> go w1 w2
+ IgnoreMultiplicities -> True)
-- See Note [Equality on AppTys] in GHC.Core.Type
- go env (AppTy s1 t1) ty2
- | Just (s2, t2) <- tcSplitAppTyNoView_maybe ty2
- = go env s1 s2 && go env t1 t2
- go env ty1 (AppTy s2 t2)
- | Just (s1, t1) <- tcSplitAppTyNoView_maybe ty1
- = go env s1 s2 && go env t1 t2
-
- go env (TyConApp tc1 ts1) (TyConApp tc2 ts2)
- = tc1 == tc2 && gos env ts1 ts2
-
- go _ _ _ = False
-
- gos _ [] [] = True
- gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2
- gos _ _ _ = False
+ (AppTy s1 t1', _)
+ | Just (s2, t2') <- tcSplitAppTyNoView_maybe t2
+ -> go s1 s2 && go t1' t2'
+ (_, AppTy s2 t2')
+ | Just (s1, t1') <- tcSplitAppTyNoView_maybe t1
+ -> go s1 s2 && go t1' t2'
+
+ (TyConApp tc1 ts1, TyConApp tc2 ts2)
+ | tc1 == tc2 -> gos ts1 ts2
+ | otherwise -> False
+ where
+ gos [] [] = True
+ gos (t1:ts1) (t2:ts2) = go t1 t2 && gos ts1 ts2
+ gos _ _ = False
+
+ (ForAllTy (Bndr tv1 vis1) body1, ForAllTy (Bndr tv2 vis2) body2)
+ -> case mb_env of
+ Nothing -> generic_eq_type_x syn_flag mult_flag
+ (Just (initRnEnv t1 t2)) t1 t2
+ Just env
+ | vis1 `eqForAllVis` vis2 -- See Note [ForAllTy and type equality]
+ -> go (varType tv1) (varType tv2) -- Always do kind-check
+ && generic_eq_type_x syn_flag mult_flag
+ (Just (rnBndr2 env tv1 tv2)) body1 body2
+ | otherwise
+ -> False
+
+ _ -> False
+
+fullEq :: (Type -> Type -> Bool) -> Type -> Type -> Bool
+-- Do "full equality" including the kind check
+-- See Note [Casts and coercions in type comparision]
+{-# INLINE fullEq #-}
+fullEq eq ty1 ty2
+ = case eq ty1 ty2 of
+ False -> False
+ True | hasCasts ty1 || hasCasts ty2
+ -> eq (typeKind ty1) (typeKind ty2)
+ | otherwise
+ -> True
+
+hasCasts :: Type -> Bool
+-- Fast, does not look deep, does not allocate
+hasCasts (CastTy {}) = True
+hasCasts (CoercionTy {}) = True
+hasCasts (AppTy t1 t2) = hasCasts t1 || hasCasts t2
+hasCasts (ForAllTy _ ty) = hasCasts ty
+hasCasts _ = False -- TyVarTy, TyConApp, FunTy, LitTy
-isDefaultableBndr :: ForAllTyBinder -> Bool
--- This function should line up with the defaulting done
--- by GHC.Iface.Type.defaultIfaceTyVarsOfKind
--- See Note [Showing invisible bits of types in error messages]
--- in GHC.Tc.Errors.Ppr
-isDefaultableBndr (Bndr tv vis)
- = isInvisibleForAllTyFlag vis && is_defaultable (tyVarKind tv)
- where
- is_defaultable ki = isLevityTy ki || isRuntimeRepTy ki || isMultiplicityTy ki
+{- *********************************************************************
+* *
+ Comparing ForAllTyFlags
+* *
+********************************************************************* -}
-- | Do these denote the same level of visibility? 'Required'
-- arguments are visible, others are not. So this function
@@ -442,91 +588,13 @@ is more finer-grained than definitional equality in two places:
************************************************************************
* *
Comparison for types
- (We don't use instances so that we know where it happens)
+
+ Not so heavily used, less carefully optimised
* *
************************************************************************
-Note [Equality on AppTys]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-In our cast-ignoring equality, we want to say that the following two
-are equal:
-
- (Maybe |> co) (Int |> co') ~? Maybe Int
-
-But the left is an AppTy while the right is a TyConApp. The solution is
-to use splitAppTyNoView_maybe to break up the TyConApp into its pieces and
-then continue. Easy to do, but also easy to forget to do.
-
-Note [Comparing nullary type synonyms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider the task of testing equality between two 'Type's of the form
-
- TyConApp tc []
-
-where @tc@ is a type synonym. A naive way to perform this comparison these
-would first expand the synonym and then compare the resulting expansions.
-
-However, this is obviously wasteful and the RHS of @tc@ may be large; it is
-much better to rather compare the TyCons directly. Consequently, before
-expanding type synonyms in type comparisons we first look for a nullary
-TyConApp and simply compare the TyCons if we find one. Of course, if we find
-that the TyCons are *not* equal then we still need to perform the expansion as
-their RHSs may still be equal.
-
-We perform this optimisation in a number of places:
-
- * GHC.Core.Types.eqType
- * GHC.Core.Types.nonDetCmpType
- * GHC.Core.Unify.unify_ty
- * GHC.Tc.Solver.Equality.can_eq_nc'
- * TcUnify.uType
-
-This optimisation is especially helpful for the ubiquitous GHC.Types.Type,
-since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications
-whenever possible. See Note [Using synonyms to compress types] in
-GHC.Core.Type for details.
-
--}
-
-eqType :: Type -> Type -> Bool
--- ^ Type equality on source types. Does not look through @newtypes@,
--- 'PredType's or type families, but it does look through type synonyms.
--- This first checks that the kinds of the types are equal and then
--- checks whether the types are equal, ignoring casts and coercions.
--- (The kind check is a recursive call, but since all kinds have type
--- @Type@, there is no need to check the types of kinds.)
--- See also Note [Non-trivial definitional equality] in "GHC.Core.TyCo.Rep".
-eqType t1 t2 = isEqual $ nonDetCmpType t1 t2
- -- It's OK to use nonDetCmpType here and eqType is deterministic,
- -- nonDetCmpType does equality deterministically
-
--- | Compare types with respect to a (presumably) non-empty 'RnEnv2'.
-eqTypeX :: RnEnv2 -> Type -> Type -> Bool
-eqTypeX env t1 t2 = isEqual $ nonDetCmpTypeX env t1 t2
- -- It's OK to use nonDetCmpType here and eqTypeX is deterministic,
- -- nonDetCmpTypeX does equality deterministically
-
--- | Type equality on lists of types, looking through type synonyms
--- but not newtypes.
-eqTypes :: [Type] -> [Type] -> Bool
-eqTypes tys1 tys2 = isEqual $ nonDetCmpTypes tys1 tys2
- -- It's OK to use nonDetCmpType here and eqTypes is deterministic,
- -- nonDetCmpTypes does equality deterministically
-
-eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2
--- Check that the var lists are the same length
--- and have matching kinds; if so, extend the RnEnv2
--- Returns Nothing if they don't match
-eqVarBndrs env [] []
- = Just env
-eqVarBndrs env (tv1:tvs1) (tv2:tvs2)
- | eqTypeX env (varType tv1) (varType tv2)
- = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2
-eqVarBndrs _ _ _= Nothing
-
-- Now here comes the real worker
-{-
Note [nonDetCmpType nondeterminism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX
@@ -538,6 +606,7 @@ See Note [Unique Determinism] for more details.
-}
nonDetCmpType :: Type -> Type -> Ordering
+{-# INLINE nonDetCmpType #-}
nonDetCmpType !t1 !t2
-- See Note [Type comparisons using object pointer comparisons]
| 1# <- reallyUnsafePtrEquality# t1 t2
@@ -549,12 +618,6 @@ nonDetCmpType t1 t2
= nonDetCmpTypeX rn_env t1 t2
where
rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2]))
-{-# INLINE nonDetCmpType #-}
-
-nonDetCmpTypes :: [Type] -> [Type] -> Ordering
-nonDetCmpTypes ts1 ts2 = nonDetCmpTypesX rn_env ts1 ts2
- where
- rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2)))
-- | An ordering relation between two 'Type's (known below as @t1 :: k1@
-- and @t2 :: k2@)
@@ -569,6 +632,7 @@ data TypeOrdering = TLT -- ^ @t1 < t2@
nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse
-- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep
-- See Note [Computing equality on types]
+ -- Always respects multiplicities, unlike eqType
nonDetCmpTypeX env orig_t1 orig_t2 =
case go env orig_t1 orig_t2 of
-- If there are casts then we also need to do a comparison of
@@ -661,13 +725,6 @@ nonDetCmpTypeX env orig_t1 orig_t2 =
gos _ _ [] = TGT
gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2
--------------
-nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering
-nonDetCmpTypesX _ [] [] = EQ
-nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2 S.<>
- nonDetCmpTypesX env tys1 tys2
-nonDetCmpTypesX _ [] _ = LT
-nonDetCmpTypesX _ _ [] = GT
-------------
-- | Compare two 'TyCon's.
@@ -680,4 +737,91 @@ nonDetCmpTc tc1 tc2
u2 = tyConUnique tc2
+{- *********************************************************************
+* *
+ mayLookIdentical
+* *
+********************************************************************* -}
+
+mayLookIdentical :: Type -> Type -> Bool
+-- | Returns True if the /visible/ part of the types
+-- might look equal, even if they are really unequal (in the invisible bits)
+--
+-- This function is very similar to tc_eq_type but it is much more
+-- heuristic. Notably, it is always safe to return True, even with types
+-- that might (in truth) be unequal -- this affects error messages only
+-- (Originally this test was done by eqType with an extra flag, but the result
+-- was hard to understand.)
+mayLookIdentical orig_ty1 orig_ty2
+ = go orig_env orig_ty1 orig_ty2
+ where
+ orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2]
+
+ go :: RnEnv2 -> Type -> Type -> Bool
+ -- See Note [Comparing nullary type synonyms]
+ go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = True
+
+ go env t1 t2 | Just t1' <- coreView t1 = go env t1' t2
+ go env t1 t2 | Just t2' <- coreView t2 = go env t1 t2'
+
+ go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2
+ go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2
+ go env (CastTy t1 _) t2 = go env t1 t2
+ go env t1 (CastTy t2 _) = go env t1 t2
+ go _ (CoercionTy {}) (CoercionTy {}) = True
+
+ go env (ForAllTy (Bndr tv1 vis1) ty1)
+ (ForAllTy (Bndr tv2 vis2) ty2)
+ = vis1 `eqForAllVis` vis2 -- See Note [ForAllTy and type equality]
+ && go (rnBndr2 env tv1 tv2) ty1 ty2
+ -- Visible stuff only: ignore kinds of binders
+
+ -- If we have (forall (r::RunTimeRep). ty1 ~ blah) then respond
+ -- with True. Reason: the type pretty-printer defaults RuntimeRep
+ -- foralls (see Ghc.Iface.Type.hideNonStandardTypes). That can make,
+ -- say (forall r. TYPE r -> Type) into (Type -> Type), so it looks the
+ -- same as a very different type (#24553). By responding True, we
+ -- tell GHC (see calls of mayLookIdentical) to display without defaulting.
+ -- See Note [Showing invisible bits of types in error messages]
+ -- in GHC.Tc.Errors.Ppr
+ go _ (ForAllTy b _) _ | isDefaultableBndr b = True
+ go _ _ (ForAllTy b _) | isDefaultableBndr b = True
+
+ go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2)
+ = go env arg1 arg2 && go env res1 res2 && go env w1 w2
+ -- Visible stuff only: ignore agg kinds
+
+ -- See Note [Equality on AppTys] in GHC.Core.Type
+ go env (AppTy s1 t1) ty2
+ | Just (s2, t2) <- tcSplitAppTyNoView_maybe ty2
+ = go env s1 s2 && go env t1 t2
+ go env ty1 (AppTy s2 t2)
+ | Just (s1, t1) <- tcSplitAppTyNoView_maybe ty1
+ = go env s1 s2 && go env t1 t2
+
+ go env (TyConApp tc1 ts1) (TyConApp tc2 ts2)
+ = tc1 == tc2 && gos env (tyConBinders tc1) ts1 ts2
+
+ go _ _ _ = False
+
+ gos :: RnEnv2 -> [TyConBinder] -> [Type] -> [Type] -> Bool
+ gos _ _ [] [] = True
+ gos env bs (t1:ts1) (t2:ts2)
+ | (invisible, bs') <- case bs of
+ [] -> (False, [])
+ (b:bs) -> (isInvisibleTyConBinder b, bs)
+ = (invisible || go env t1 t2) && gos env bs' ts1 ts2
+
+ gos _ _ _ _ = False
+
+
+isDefaultableBndr :: ForAllTyBinder -> Bool
+-- This function should line up with the defaulting done
+-- by GHC.Iface.Type.defaultIfaceTyVarsOfKind
+-- See Note [Showing invisible bits of types in error messages]
+-- in GHC.Tc.Errors.Ppr
+isDefaultableBndr (Bndr tv vis)
+ = isInvisibleForAllTyFlag vis && is_defaultable (tyVarKind tv)
+ where
+ is_defaultable ki = isLevityTy ki || isRuntimeRepTy ki || isMultiplicityTy ki
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -350,14 +350,24 @@ This kind instantiation only happens in TyConApp currently.
Note [Non-trivial definitional equality]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Is Int |> <*> the same as Int? YES! In order to reduce headaches,
-we decide that any reflexive casts in types are just ignored.
-(Indeed they must be. See Note [Respecting definitional equality].)
-More generally, the `eqType` function, which defines Core's type equality
-relation, ignores casts and coercion arguments, as long as the
-two types have the same kind. This allows us to be a little sloppier
-in keeping track of coercions, which is a good thing. It also means
-that eqType does not depend on eqCoercion, which is also a good thing.
+Is ((IO |> co1) Int |> co2) equal to (IO Int)?
+Assume
+ co1 :: (Type->Type) ~ (Type->Wombat)
+ co2 :: Wombat ~ Type
+Well, yes. The casts are just getting in the way.
+See also Note [Respecting definitional equality].
+
+So we do this:
+
+(EQTYPE)
+ The `eqType` function, which defines Core's type equality relation,
+ - /ignores/ casts, and
+ - /ignores/ coercion arguments
+ - /provided/ two types have the same kind
+
+This allows us to be a little sloppier in keeping track of coercions, which is a
+good thing. It also means that eqType does not depend on eqCoercion, which is
+also a good thing.
Why is this sensible? That is, why is something different than α-equivalence
appropriate for the implementation of eqType?
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -1366,6 +1366,8 @@ funTyConAppTy_maybe :: FunTyFlag -> Type -> Type -> Type
funTyConAppTy_maybe af mult arg res
| Just arg_rep <- getRuntimeRep_maybe arg
, Just res_rep <- getRuntimeRep_maybe res
+ -- If you're changing the lines below, you'll probably want to adapt the
+ -- `fUNTyCon` case of GHC.Core.Unify.unify_ty correspondingly.
, let args | isFUNArg af = [mult, arg_rep, res_rep, arg, res]
| otherwise = [ arg_rep, res_rep, arg, res]
= Just $ (funTyFlagTyCon af, args)
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -54,6 +54,8 @@ import GHC.Data.FastString
import Data.List ( mapAccumL )
import Control.Monad
import qualified Data.Semigroup as S
+import GHC.Builtin.Types.Prim (fUNTyCon)
+import GHC.Core.Multiplicity
{-
@@ -211,6 +213,7 @@ tc_match_tys_x bind_me match_kis (Subst in_scope id_env tv_env cv_env) tys1 tys2
False -- Matching, not unifying
False -- Not an injectivity check
match_kis
+ RespectMultiplicities
(mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of
Unifiable (tv_env', cv_env')
-> Just $ Subst in_scope id_env tv_env' cv_env'
@@ -229,6 +232,8 @@ ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target
-- See Note [Kind coercions in Unify]
= case tc_unify_tys (matchBindFun tmpl_tvs) False False
True -- <-- this means to match the kinds
+ IgnoreMultiplicities
+ -- See Note [Rewrite rules ignore multiplicities in FunTy]
rn_env tenv emptyCvSubstEnv [tmpl] [target] of
Unifiable (tenv', _) -> Just tenv'
_ -> Nothing
@@ -394,6 +399,40 @@ types are apart. This has practical consequences for the ability for closed
type family applications to reduce. See test case
indexed-types/should_compile/Overlap14.
+Note [Rewrite rules ignore multiplicities in FunTy]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following (higher-order) rule:
+
+m :: Bool -> Bool -> Bool
+{-# RULES "m" forall f. m (f True) = f #-}
+
+let x = m ((,) @Bool @Bool True True)
+
+The rewrite rule expects an `f :: Bool -> Bool`, but `(,) @Bool @Bool True ::
+Bool %1 -> Bool` is linear (see Note [Data constructors are linear by default]
+in GHC.Core.Multiplicity) Should the rule match? Yes! According to the
+principles laid out in Note [Linting linearity] in GHC.Core.Lint, optimisation
+shouldn't be constrained by linearity.
+
+However, when matching the template variable `f` to `(,) True`, we do check that
+their types unify (see Note [Matching variable types] in GHC.Core.Rules). So
+when unifying types for the sake of rule-matching, the unification algorithm
+must be able to ignore multiplicities altogether.
+
+How is this done?
+ (1) The `um_arr_mult` field of `UMEnv` recordsw when we are doing rule-matching,
+ and hence want to ignore multiplicities.
+ (2) The field is set to True in by `ruleMatchTyKiX`.
+ (3) It is consulted when matching `FunTy` in `unify_ty`.
+
+Wrinkle in (3). In `unify_tc_app`, in `unify_ty`, `FunTy` is handled as if it
+was a regular type constructor. In this case, and when the types being unified
+are *function* arrows, but not constraint arrows, then the first argument is a
+multiplicity.
+
+We select this situation by comparing the type constructor with fUNTyCon. In
+this case, and this case only, we can safely drop the first argument (using the
+tail function) and unify the rest.
-}
-- | Simple unification of two types; all type variables are bindable
@@ -421,7 +460,7 @@ tcUnifyTyWithTFs :: Bool -- ^ True <=> do two-way unification;
-- The code is incorporated with the standard unifier for convenience, but
-- its operation should match the specification in the paper.
tcUnifyTyWithTFs twoWay in_scope t1 t2
- = case tc_unify_tys alwaysBindFun twoWay True False
+ = case tc_unify_tys alwaysBindFun twoWay True False RespectMultiplicities
rn_env emptyTvSubstEnv emptyCvSubstEnv
[t1] [t2] of
Unifiable (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst
@@ -530,7 +569,7 @@ tc_unify_tys_fg :: Bool
-> [Type] -> [Type]
-> UnifyResult
tc_unify_tys_fg match_kis bind_fn tys1 tys2
- = do { (env, _) <- tc_unify_tys bind_fn True False match_kis rn_env
+ = do { (env, _) <- tc_unify_tys bind_fn True False match_kis RespectMultiplicities rn_env
emptyTvSubstEnv emptyCvSubstEnv
tys1 tys2
; return $ niFixSubst in_scope env }
@@ -544,6 +583,7 @@ tc_unify_tys :: BindFun
-> AmIUnifying -- ^ True <=> unify; False <=> match
-> Bool -- ^ True <=> doing an injectivity check
-> Bool -- ^ True <=> treat the kinds as well
+ -> MultiplicityFlag -- ^ see Note [Rewrite rules ignore multiplicities in FunTy] in GHC.Core.Unify
-> RnEnv2
-> TvSubstEnv -- ^ substitution to extend
-> CvSubstEnv
@@ -560,7 +600,7 @@ tc_unify_tys :: BindFun
-- pair equal. Yet, we still don't need a separate pass to unify the kinds
-- of these types, so it's appropriate to use the Ty variant of unification.
-- See also Note [tcMatchTy vs tcMatchTyKi].
-tc_unify_tys bind_fn unif inj_check match_kis rn_env tv_env cv_env tys1 tys2
+tc_unify_tys bind_fn unif inj_check match_kis match_mults rn_env tv_env cv_env tys1 tys2
= initUM tv_env cv_env $
do { when match_kis $
unify_tys env kis1 kis2
@@ -571,6 +611,7 @@ tc_unify_tys bind_fn unif inj_check match_kis rn_env tv_env cv_env tys1 tys2
, um_skols = emptyVarSet
, um_unif = unif
, um_inj_tf = inj_check
+ , um_arr_mult = match_mults
, um_rn_env = rn_env }
kis1 = map typeKind tys1
@@ -1144,7 +1185,7 @@ unify_ty env ty1 ty2 _kco
, Just (tc2, tys2) <- mb_tc_app2
, tc1 == tc2
= do { massertPpr (isInjectiveTyCon tc1 Nominal) (ppr tc1)
- ; unify_tys env tys1 tys2
+ ; unify_tc_app tc1 tys1 tys2
}
-- TYPE and CONSTRAINT are not Apart
@@ -1175,6 +1216,21 @@ unify_ty env ty1 ty2 _kco
mb_tc_app1 = splitTyConApp_maybe ty1
mb_tc_app2 = splitTyConApp_maybe ty2
+ unify_tc_app tc tys1 tys2
+ | tc == fUNTyCon
+ , IgnoreMultiplicities <- um_arr_mult env
+ , (_mult1 : no_mult_tys1) <- tys1
+ , (_mult2 : no_mult_tys2) <- tys2
+ = -- We're comparing function arrow types here (not constraint arrow
+ -- types!), and they have at least one argument, which is the arrow's
+ -- multiplicity annotation. The flag `um_arr_mult` instructs us to
+ -- ignore multiplicities in this very case. This is a little tricky: see
+ -- point (3) in Note [Rewrite rules ignore multiplicities in FunTy].
+ unify_tys env no_mult_tys1 no_mult_tys2
+
+ | otherwise
+ = unify_tys env tys1 tys2
+
-- Applications need a bit of care!
-- They can match FunTy and TyConApp, so use splitAppTy_maybe
-- NB: we've already dealt with type variables,
@@ -1410,6 +1466,10 @@ data UMEnv
-- Checking for injectivity?
-- See (end of) Note [Specification of unification]
+ , um_arr_mult :: MultiplicityFlag
+ -- Whether to unify multiplicity arguments when unifying arrows.
+ -- See Note [Rewrite rules ignore multiplicities in FunTy]
+
, um_rn_env :: RnEnv2
-- Renaming InTyVars to OutTyVars; this eliminates
-- shadowing, and lines up matching foralls on the left
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -96,7 +96,7 @@ module GHC.Tc.Utils.TcType (
-- Re-exported from GHC.Core.TyCo.Compare
-- mainly just for back-compat reasons
- eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX,
+ eqType, eqTypes, nonDetCmpType, eqTypeX,
pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, mayLookIdentical,
tcEqTyConApps, eqForAllVis, eqVarBndrs,
=====================================
testsuite/tests/simplCore/should_run/T23586.hs
=====================================
@@ -0,0 +1,45 @@
+{-# LANGUAGE LinearTypes #-}
+
+module Main where
+
+-- These rules are clearly nonsensical, so that we can observe the result of
+-- their firing.
+{-# RULES "test/match" forall f. mark (f True) = (False, False) #-}
+{-# RULES "test/core" forall f. mark (f False) = ensure_many f #-}
+
+-- Tests that constructors are matched by higher-order rules (as originally
+-- reported)
+g = mark (True, True)
+
+-- Tests that linear functions are matched by higher-order rules (as was
+-- understood to be the root cause of the issue)
+h = mark (d True)
+
+-- Tests that a matched linear function can be used where a non-linear function
+-- is expected, and that the result passes the linter. This wasn't part of the
+-- original report, but a first fix to #23586 was incorrect because this rule
+-- produced Core which was rejected by the linter.
+-- See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12648#note_565803 .
+i = mark (d False)
+
+main :: IO ()
+main = do
+ print g
+ print h
+ print i
+
+
+-- Helpers below
+
+mark :: a -> a
+mark x = x
+{-# NOINLINE mark #-}
+
+d :: Bool %1 -> (Bool, Bool)
+d True = (True, True)
+d False = (False, False)
+{-# NOINLINE d #-}
+
+ensure_many :: (Bool -> (Bool, Bool)) -> (Bool, Bool)
+ensure_many f = (False, True)
+{-# NOINLINE ensure_many #-}
=====================================
testsuite/tests/simplCore/should_run/T23586.stdout
=====================================
@@ -0,0 +1,3 @@
+(False,False)
+(False,False)
+(False,True)
=====================================
testsuite/tests/simplCore/should_run/all.T
=====================================
@@ -114,3 +114,4 @@ test('T23184', normal, compile_and_run, ['-O'])
test('T23134', normal, compile_and_run, ['-O0 -fcatch-nonexhaustive-cases'])
test('T23289', normal, compile_and_run, [''])
test('T23056', [only_ways(['ghci-opt'])], ghci_script, ['T23056.script'])
+test('T23586', normal, compile_and_run, ['-O -dcore-lint'])
=====================================
utils/haddock/haddock-api/haddock-api.cabal
=====================================
@@ -43,8 +43,29 @@ source-repository head
location: https://gitlab.haskell.org/ghc/ghc.git
subdir: utils/haddock/haddock-api
+common extensions
+ default-extensions:
+ LambdaCase
+ NoStarIsType
+ OverloadedRecordDot
+ StrictData
+ TypeApplications
+ TypeOperators
+
+ default-language: Haskell2010
+
+common ghc-options
+ ghc-options:
+ -Wall -Wcompat -Widentities -Wincomplete-record-updates
+ -Wincomplete-uni-patterns -Wredundant-constraints
+ -fhide-source-paths -Wno-unused-do-bind -fshow-hole-constraints
+ -Wno-unticked-promoted-constructors -Werror=unused-imports
+ -fdicts-strict -Wunused-packages -funbox-strict-fields
+ -Wnoncanonical-monad-instances -Wmissing-home-modules
+
library
- default-language: Haskell2010
+ import: extensions
+ import: ghc-options
-- this package typically supports only single major versions
build-depends: base >= 4.16 && < 4.21
@@ -69,19 +90,6 @@ library
, transformers
hs-source-dirs: src
-
- ghc-options: -funbox-strict-fields -O2
- -Wall
- -Wcompat
- -Wcompat-unqualified-imports
- -Widentities
- -Wredundant-constraints
- -Wnoncanonical-monad-instances
- -Wmissing-home-modules
- -Wincomplete-uni-patterns
- -Wincomplete-record-updates
-
-
exposed-modules:
Documentation.Haddock
@@ -131,10 +139,10 @@ library
Paths_haddock_api
test-suite spec
+ import: extensions
+ import: ghc-options
type: exitcode-stdio-1.0
- default-language: Haskell2010
main-is: Spec.hs
- ghc-options: -Wall
hs-source-dirs:
test
@@ -201,7 +209,6 @@ test-suite spec
, exceptions
, filepath
, ghc-boot
- , ghc-boot-th
, mtl
, transformers
=====================================
utils/haddock/haddock-api/src/Haddock.hs
=====================================
@@ -5,7 +5,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock
@@ -50,9 +49,9 @@ import Control.DeepSeq (force)
import Control.Monad hiding (forM_)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Bifunctor (second)
-import Data.Foldable (forM_, foldl')
+import Data.Foldable (forM_)
import Data.Traversable (for)
-import Data.List (find, isPrefixOf, nub)
+import qualified Data.List as List
import Control.Exception
import Data.Maybe
import Data.IORef
@@ -256,7 +255,7 @@ withTempOutputDir action = do
-- | Create warnings about potential misuse of -optghc
optGhcWarnings :: [String] -> [String]
-optGhcWarnings = map format . filter (isPrefixOf "-optghc")
+optGhcWarnings = map format . filter (List.isPrefixOf "-optghc")
where
format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"]
@@ -449,7 +448,7 @@ render log' dflags unit_state flags sinceQual qual ifaces packages extSrcMap = d
let withQuickjump = Flag_QuickJumpIndex `elem` flags
withBaseURL = isJust
- . find (\flag -> case flag of
+ . List.find (\flag -> case flag of
Flag_BaseURL base_url ->
base_url /= "." && base_url /= "./"
_ -> False
@@ -481,7 +480,7 @@ render log' dflags unit_state flags sinceQual qual ifaces packages extSrcMap = d
ppJsonIndex odir sourceUrls' opt_wiki_urls
unicode Nothing qual
ifaces
- ( nub
+ ( List.nub
. map fst
. filter ((== Visible) . piVisibility . snd)
$ packages)
@@ -612,7 +611,7 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do
++ if needHieFiles
then [Opt_WriteHie] -- Generate .hie-files
else []
- dynflags' = (foldl' gopt_set dynflags extra_opts)
+ dynflags' = (List.foldl' gopt_set dynflags extra_opts)
{ backend = noBackend
, ghcMode = CompManager
, ghcLink = NoLink
@@ -626,7 +625,7 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do
unsetPatternMatchWarnings :: DynFlags -> DynFlags
unsetPatternMatchWarnings dflags =
- foldl' wopt_unset dflags pattern_match_warnings
+ List.foldl' wopt_unset dflags pattern_match_warnings
where
pattern_match_warnings =
[ Opt_WarnIncompletePatterns
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
=====================================
@@ -50,9 +50,10 @@ import Control.DeepSeq (force)
import Control.Monad (unless, when)
import Data.Bifunctor (bimap)
import qualified Data.ByteString.Builder as Builder
+import qualified Data.List as List
import Data.Char (isSpace, toUpper)
import Data.Either (partitionEithers)
-import Data.Foldable (foldl', traverse_)
+import Data.Foldable (traverse_)
import Data.List (intersperse, isPrefixOf, sortBy)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
@@ -305,12 +306,15 @@ bodyHtml
body
<< [ divPackageHeader
<< [ nonEmptySectionName << doctitle
- , unordList (catMaybes [
- srcButton maybe_source_url iface,
- wikiButton maybe_wiki_url (ifaceMod <$> iface),
- contentsButton maybe_contents_url,
- indexButton maybe_index_url])
- ! [theclass "links", identifier "page-menu"]
+ , unordList
+ ( catMaybes
+ [ srcButton maybe_source_url iface
+ , wikiButton maybe_wiki_url (ifaceMod <$> iface)
+ , contentsButton maybe_contents_url
+ , indexButton maybe_index_url
+ ]
+ )
+ ! [theclass "links", identifier "page-menu"]
]
, divContent << pageContent
, divFooter
@@ -777,7 +781,7 @@ ppHtmlIndex
-- that export that entity. Each of the modules exports the entity
-- in a visible or invisible way (hence the Bool).
full_index :: Map String (Map GHC.Name [(Module, Bool)])
- full_index = foldl' f Map.empty ifaces
+ full_index = List.foldl' f Map.empty ifaces
where
f
:: Map String (Map Name [(Module, Bool)])
@@ -791,7 +795,7 @@ ppHtmlIndex
getIfaceIndex :: InstalledInterface -> Map String (Map Name [(Module, Bool)])
getIfaceIndex iface =
- foldl' f Map.empty (instExports iface)
+ List.foldl' f Map.empty (instExports iface)
where
f
:: Map String (Map Name [(Module, Bool)])
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
=====================================
@@ -54,6 +54,8 @@ module Haddock.Backends.Xhtml.Layout
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
+import GHC hiding (anchor)
+import GHC.Types.Name (nameOccName)
import Haddock.Backends.Xhtml.DocMarkup
import Haddock.Backends.Xhtml.Types
import Haddock.Backends.Xhtml.Utils
@@ -61,9 +63,6 @@ import Haddock.Types
import Haddock.Utils (makeAnchorId, nameAnchorId)
import Text.XHtml hiding (name, quote, title)
-import GHC hiding (anchor)
-import GHC.Types.Name (nameOccName)
-
--------------------------------------------------------------------------------
-- * Sections of the document
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -31,10 +31,11 @@ module Haddock.GhcUtils where
import Control.Arrow
import Data.Char (isSpace)
-import Data.Foldable (foldl', toList)
+import Data.Foldable (toList)
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Set as Set
+import qualified Data.List as List
import Haddock.Types (DocName, DocNameI, XRecCond)
@@ -771,7 +772,7 @@ typeNames ty = go ty Set.empty
TyVarTy{} -> acc
AppTy t1 t2 -> go t2 $ go t1 acc
FunTy _ _ t1 t2 -> go t2 $ go t1 acc
- TyConApp tcon args -> foldl' (\s t' -> go t' s) (Set.insert (getName tcon) acc) args
+ TyConApp tcon args -> List.foldl' (\s t' -> go t' s) (Set.insert (getName tcon) acc) args
ForAllTy bndr t' -> go t' $ go (tyVarKind (binderVar bndr)) acc
LitTy _ -> acc
CastTy t' _ -> go t' acc
=====================================
utils/haddock/haddock-api/src/Haddock/Interface.hs
=====================================
@@ -1,8 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE TupleSections #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface
@@ -47,7 +45,7 @@ import Haddock.Types
import Haddock.Utils (Verbosity (..), normal, out, verbose)
import Control.Monad
-import Data.List (foldl', isPrefixOf)
+import Data.List (isPrefixOf)
import Data.Traversable (for)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
@@ -71,11 +69,11 @@ import GHC.Types.Name.Occurrence (emptyOccEnv)
import GHC.Unit.Module.Graph (ModuleGraphNode (..))
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.ModSummary (isBootSummary)
-import GHC.Utils.Outputable ((<+>), pprModuleName)
+import GHC.Utils.Outputable (Outputable, (<+>), pprModuleName)
import GHC.Utils.Error (withTiming)
import GHC.Unit.Home.ModInfo
import GHC.Tc.Utils.Env (lookupGlobal_maybe)
-import GHC.Utils.Outputable (Outputable)
+import qualified Data.List as List
#if defined(mingw32_HOST_OS)
import System.IO
@@ -327,15 +325,15 @@ processModule verbosity modSummary flags ifaceMap instIfaceMap = do
-- The interfaces are passed in in topologically sorted order, but we start
-- by reversing the list so we can do a foldl.
buildHomeLinks :: [Interface] -> LinkEnv
-buildHomeLinks ifaces = foldl' upd Map.empty (reverse ifaces)
+buildHomeLinks ifaces = List.foldl' upd Map.empty (reverse ifaces)
where
upd old_env iface
| OptHide `elem` ifaceOptions iface =
old_env
| OptNotHome `elem` ifaceOptions iface =
- foldl' keep_old old_env exported_names
+ List.foldl' keep_old old_env exported_names
| otherwise =
- foldl' keep_new old_env exported_names
+ List.foldl' keep_new old_env exported_names
where
exported_names = ifaceVisibleExports iface ++ map getName (ifaceInstances iface)
mdl = ifaceMod iface
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs
=====================================
@@ -1,8 +1,5 @@
{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -31,13 +28,13 @@ import Haddock.Types
import Control.Applicative ((<|>))
import Control.Arrow hiding ((<+>))
import Control.DeepSeq (force)
-import Data.Foldable (foldl', toList)
-import Data.List (sortBy)
+import Data.Foldable (toList)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
import Data.Ord (comparing)
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
+import qualified Data.List as List
import GHC
import GHC.Builtin.Types (unrestrictedFunTyConName)
@@ -168,7 +165,7 @@ attachOrphanInstances
attachOrphanInstances expInfo getInstDoc cls_instances fam_index =
[ (synifyInstHead i famInsts, getInstDoc n, (L (getSrcSpan n) n), nameModule_maybe n)
| let is = [(instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i)]
- , (i@(_, _, cls, tys), n) <- sortBy (comparing $ first instHead) is
+ , (i@(_, _, cls, tys), n) <- List.sortBy (comparing $ first instHead) is
, not $ isInstanceHidden expInfo (getName cls) tys
, let famInsts = getFamInsts expInfo fam_index getInstDoc cls tys
]
@@ -205,7 +202,7 @@ attachToExportItem cls_index fam_index index expInfo getInstDoc getFixity export
, spanNameE n synFamInst (L (locA eSpan) (tcdName d))
, mb_mdl
)
- | i <- sortBy (comparing instFam) fam_instances
+ | i <- List.sortBy (comparing instFam) fam_instances
, let n = getName i
, not $ isNameHidden expInfo (fi_fam i)
, not $ any (isTypeHidden expInfo) (fi_tys i)
@@ -220,7 +217,7 @@ attachToExportItem cls_index fam_index index expInfo getInstDoc getFixity export
, mb_mdl
)
| let is = [(instanceSig i, getName i) | i <- cls_instances]
- , (i@(_, _, cls, tys), n) <- sortBy (comparing $ first instHead) is
+ , (i@(_, _, cls, tys), n) <- List.sortBy (comparing $ first instHead) is
, not $ isInstanceHidden expInfo (getName cls) tys
, let synClsInst = synifyInstHead i famInsts
famInsts = getFamInsts expInfo fam_index getInstDoc cls tys
@@ -251,7 +248,7 @@ attachToExportItem cls_index fam_index index expInfo getInstDoc getFixity export
}
where
fixities :: [(Name, Fixity)]
- !fixities = force . Map.toList $ foldl' f Map.empty all_names
+ !fixities = force . Map.toList $ List.foldl' f Map.empty all_names
f :: Map.Map Name Fixity -> Name -> Map.Map Name Fixity
f !fs n = Map.alter (<|> getFixity n) n fs
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
=====================================
@@ -2,17 +2,13 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
=====================================
utils/haddock/haddock-api/src/Haddock/Options.hs
=====================================
@@ -563,10 +563,12 @@ readIfaceArgs flags = [parseIfaceOption s | Flag_ReadInterface s <- flags]
(src, ',' : rest') ->
let src' = case src of
"" -> Nothing
- _ -> Just src
- docPaths = DocPaths { docPathsHtml = fpath
- , docPathsSources = src'
- }
+ _ -> Just src
+ docPaths =
+ DocPaths
+ { docPathsHtml = fpath
+ , docPathsSources = src'
+ }
in case break (== ',') rest' of
(visibility, ',' : file)
| visibility == "hidden" ->
=====================================
utils/haddock/haddock-api/src/Haddock/Types.hs
=====================================
@@ -1,4 +1,3 @@
-{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
@@ -78,9 +77,12 @@ type SubMap = Map Name [Name]
type DeclMap = Map Name DeclMapEntry
type InstMap = Map RealSrcSpan Name
type FixMap = Map Name Fixity
-data DocPaths = DocPaths { docPathsHtml :: FilePath -- ^ path to HTML Haddocks
- , docPathsSources :: Maybe FilePath -- ^ path to hyperlinked sources
- }
+data DocPaths = DocPaths
+ { docPathsHtml :: FilePath
+ -- ^ path to HTML Haddocks
+ , docPathsSources :: Maybe FilePath
+ -- ^ path to hyperlinked sources
+ }
type WarningMap = Map Name (Doc Name)
-----------------------------------------------------------------------------
=====================================
utils/haddock/haddock-library/fixtures/Fixtures.hs
=====================================
@@ -8,7 +8,7 @@ import Control.Applicative ((<|>))
import Control.Exception (IOException, catch)
import Control.Monad (when)
import Data.Foldable (traverse_)
-import Data.List (foldl')
+import qualified Data.List as List
import Data.Traversable (for)
import GHC.Generics (Generic)
import System.Directory (getDirectoryContents)
@@ -86,7 +86,7 @@ runFixtures fixtures = do
input <- readFile i
return (parseString input)
ediffGolden goldenFixture name o readDoc
- case foldl' combineResults (Result 0 0) results of
+ case List.foldl' combineResults (Result 0 0) results of
Result s t -> do
putStrLn $ "Fixtures: success " ++ show s ++ "; total " ++ show t
when (s /= t) exitFailure
=====================================
utils/haddock/haddock-library/haddock-library.cabal
=====================================
@@ -29,8 +29,21 @@ source-repository head
location: https://gitlab.haskell.org/ghc/ghc.git
subdir: utils/haddock/haddock-library
-common lib-defaults
- default-language: Haskell2010
+common extensions
+ default-extensions:
+ NoStarIsType
+ StrictData
+
+ default-language: Haskell2010
+
+common ghc-options
+ ghc-options:
+ -Wall -Wcompat -Widentities -Wincomplete-record-updates
+ -Wincomplete-uni-patterns -Wredundant-constraints
+ -fhide-source-paths -Wno-unused-do-bind -fshow-hole-constraints
+ -Wno-unticked-promoted-constructors -Werror=unused-imports
+ -fdicts-strict -Wunused-packages -funbox-strict-fields
+ -Wnoncanonical-monad-instances -Wmissing-home-modules
build-depends:
, base >= 4.10 && < 4.21
@@ -38,13 +51,9 @@ common lib-defaults
, text ^>= 1.2.3.0 || ^>= 2.0 || ^>= 2.1
, parsec ^>= 3.1.13.0
- ghc-options: -funbox-strict-fields
- -Wall
- -Wcompat
- -Wnoncanonical-monad-instances
-
library
- import: lib-defaults
+ import: extensions
+ import: ghc-options
hs-source-dirs: src
@@ -60,7 +69,8 @@ library
Documentation.Haddock.Parser.Identifier
test-suite spec
- import: lib-defaults
+ import: extensions
+ import: ghc-options
type: exitcode-stdio-1.0
main-is: Spec.hs
hs-source-dirs:
@@ -94,10 +104,10 @@ test-suite spec
, hspec-discover:hspec-discover >= 2.4.4 && < 2.12
test-suite fixtures
+ import: extensions
+ import: ghc-options
type: exitcode-stdio-1.0
- default-language: Haskell2010
main-is: Fixtures.hs
- ghc-options: -Wall
hs-source-dirs: fixtures
build-depends:
-- intra-package dependency
=====================================
utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
=====================================
@@ -28,7 +28,7 @@ import Control.Applicative
import Control.Arrow (first)
import Control.Monad
import Data.Char (chr, isAlpha, isSpace, isUpper)
-import Data.List (elemIndex, intercalate, unfoldr, intersperse)
+import Data.List (elemIndex, intercalate, intersperse, unfoldr)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid
import qualified Data.Set as Set
=====================================
utils/haddock/haddock-library/src/Documentation/Haddock/Parser/Monad.hs
=====================================
@@ -34,7 +34,7 @@ import Control.Applicative as App
import Control.Monad (mfilter)
import Data.Bits (Bits (..))
import Data.Char (ord)
-import Data.List (foldl')
+import qualified Data.List as List
import Data.String (IsString (..))
import Documentation.Haddock.Types (MetaSince (..))
@@ -146,13 +146,13 @@ scan f st = do
-- | Parse a decimal number.
decimal :: Integral a => Parser a
-decimal = foldl' step 0 `fmap` Parsec.many1 Parsec.digit
+decimal = List.foldl' step 0 `fmap` Parsec.many1 Parsec.digit
where
step a c = a * 10 + fromIntegral (ord c - 48)
-- | Parse a hexadecimal number.
hexadecimal :: (Integral a, Bits a) => Parser a
-hexadecimal = foldl' step 0 `fmap` Parsec.many1 Parsec.hexDigit
+hexadecimal = List.foldl' step 0 `fmap` Parsec.many1 Parsec.hexDigit
where
step a c
| w >= 48 && w <= 57 = (a `shiftL` 4) .|. fromIntegral (w - 48)
=====================================
utils/haddock/haddock.cabal
=====================================
@@ -69,11 +69,28 @@ source-repository head
location: https://gitlab.haskell.org/ghc/ghc.git
subdir: utils/haddock
+common extensions
+ default-extensions:
+ NoStarIsType
+ OverloadedRecordDot
+ StrictData
+
+ default-language: Haskell2010
+
+common ghc-options
+ ghc-options:
+ -Wall -Wcompat -Widentities -Wincomplete-record-updates
+ -Wincomplete-uni-patterns -Wredundant-constraints
+ -fhide-source-paths -Wno-unused-do-bind -fshow-hole-constraints
+ -Wno-unticked-promoted-constructors -Werror=unused-imports
+ -fdicts-strict -Wunused-packages -funbox-strict-fields
+ -Wnoncanonical-monad-instances -Wmissing-home-modules
+
executable haddock
- default-language: Haskell2010
+ import: extensions
+ import: ghc-options
main-is: Main.hs
hs-source-dirs: driver
- ghc-options: -funbox-strict-fields -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -O2
if flag(threaded)
ghc-options: -threaded
@@ -93,7 +110,6 @@ executable haddock
array,
xhtml >= 3000.2 && < 3000.3,
ghc-boot,
- ghc-boot-th,
ghc == 9.11.*,
bytestring,
parsec,
@@ -162,38 +178,41 @@ executable haddock
build-depends: haddock-api == 2.30.0
test-suite html-test
+ import: extensions
+ import: ghc-options
type: exitcode-stdio-1.0
-- This tells cabal that this test depends on the executable
-- component 'haddock' from this very same package, as well
-- as adding the build-folder where the `haddock`
-- executable can be found in front of $PATH
build-tool-depends: haddock:haddock
- default-language: Haskell2010
main-is: Main.hs
hs-source-dirs: html-test
build-depends: base, filepath, haddock-test == 0.0.1
test-suite hypsrc-test
+ import: extensions
+ import: ghc-options
type: exitcode-stdio-1.0
build-tool-depends: haddock:haddock
- default-language: Haskell2010
main-is: Main.hs
hs-source-dirs: hypsrc-test
build-depends: base, filepath, haddock-test == 0.0.1
- ghc-options: -Wall -fwarn-tabs
test-suite latex-test
+ import: extensions
+ import: ghc-options
type: exitcode-stdio-1.0
build-tool-depends: haddock:haddock
- default-language: Haskell2010
main-is: Main.hs
hs-source-dirs: latex-test
build-depends: base, filepath, haddock-test == 0.0.1
test-suite hoogle-test
+ import: extensions
+ import: ghc-options
type: exitcode-stdio-1.0
build-tool-depends: haddock:haddock
- default-language: Haskell2010
main-is: Main.hs
hs-source-dirs: hoogle-test
build-depends: base, filepath, haddock-test == 0.0.1
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d6e5be07f5a6da39d4b749fd51c479fb4dbde176...7392a0120b1d38e022108eb47e55f19f2d4e1ad3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d6e5be07f5a6da39d4b749fd51c479fb4dbde176...7392a0120b1d38e022108eb47e55f19f2d4e1ad3
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240620/e5a5bbf1/attachment-0001.html>
More information about the ghc-commits
mailing list