ghc-lib-parser 0.20220901 → 0.20221001

raw patch · 155 files changed

+4616/−3363 lines, 155 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• compiler/ClosureTypes.h +2/−1
• compiler/GHC/Builtin/Names.hs +8/−8
• compiler/GHC/Builtin/PrimOps.hs +1/−1
• compiler/GHC/Builtin/Types.hs +12/−11
• compiler/GHC/Builtin/Types/Prim.hs +18/−1
• compiler/GHC/Builtin/Uniques.hs +1/−1
• compiler/GHC/Cmm/CLabel.hs +19/−18
• compiler/GHC/Cmm/Node.hs +4/−3
• compiler/GHC/Cmm/Reg.hs +1/−1
• compiler/GHC/Cmm/Switch.hs +6/−7
• compiler/GHC/Core.hs +21/−48
• compiler/GHC/Core/Coercion.hs +8/−13
• compiler/GHC/Core/Coercion/Axiom.hs +1/−1
• compiler/GHC/Core/DataCon.hs +8/−2
• compiler/GHC/Core/FamInstEnv.hs +5/−5
• compiler/GHC/Core/InstEnv.hs +4/−4
• compiler/GHC/Core/Lint.hs +139/−48
• compiler/GHC/Core/Make.hs +3/−3
• compiler/GHC/Core/Multiplicity.hs +1/−1
• compiler/GHC/Core/Opt/Arity.hs +14/−24
• compiler/GHC/Core/Opt/ConstantFold.hs +3/−3
• compiler/GHC/Core/Opt/Monad.hs +5/−9
• compiler/GHC/Core/Opt/OccurAnal.hs +8/−8
• compiler/GHC/Core/Opt/Pipeline/Types.hs +4/−2
• compiler/GHC/Core/Opt/Simplify/Env.hs +2/−2
• compiler/GHC/Core/Opt/Simplify/Iteration.hs +16/−25
• compiler/GHC/Core/Opt/Simplify/Utils.hs +9/−13
• compiler/GHC/Core/Opt/Stats.hs +11/−11
• compiler/GHC/Core/PatSyn.hs +1/−1
• compiler/GHC/Core/Ppr.hs +0/−5
• compiler/GHC/Core/RoughMap.hs +3/−3
• compiler/GHC/Core/Rules.hs +3/−3
• compiler/GHC/Core/SimpleOpt.hs +2/−2
• compiler/GHC/Core/Subst.hs +1/−1
• compiler/GHC/Core/Tidy.hs +1/−1
• compiler/GHC/Core/TyCo/FVs.hs +2/−2
• compiler/GHC/Core/TyCo/Rep.hs +2/−2
• compiler/GHC/Core/TyCon.hs +14/−11
• compiler/GHC/Core/Type.hs +27/−12
• compiler/GHC/Core/Unfold.hs +7/−21
• compiler/GHC/Core/Unfold/Make.hs +95/−74
• compiler/GHC/Core/Utils.hs +2/−2
• compiler/GHC/CoreToIface.hs +7/−10
• compiler/GHC/Data/Bag.hs +2/−25
• compiler/GHC/Data/BooleanFormula.hs +3/−2
• compiler/GHC/Data/FastString.hs +0/−6
• compiler/GHC/Data/Graph/UnVar.hs +1/−1
• compiler/GHC/Data/Maybe.hs +2/−3
• compiler/GHC/Data/OrdList.hs +23/−13
• compiler/GHC/Data/Pair.hs +2/−8
• compiler/GHC/Data/Stream.hs +3/−4
• compiler/GHC/Data/Unboxed.hs +50/−0
• compiler/GHC/Driver/Backend.hs +1/−1
• compiler/GHC/Driver/CmdLine.hs +3/−4
• compiler/GHC/Driver/Config/Core/Lint.hs +1/−1
• compiler/GHC/Driver/Env/KnotVars.hs +3/−3
• compiler/GHC/Driver/Errors.hs +2/−1
• compiler/GHC/Driver/Errors/Ppr.hs +9/−1
• compiler/GHC/Driver/Errors/Types.hs +11/−3
• compiler/GHC/Driver/Flags.hs +1/−1
• compiler/GHC/Driver/Monad.hs +4/−27
• compiler/GHC/Driver/Session.hs +8/−7
• compiler/GHC/Hs.hs +1/−1
• compiler/GHC/Hs/Binds.hs +2/−2
• compiler/GHC/Hs/Decls.hs +50/−31
• compiler/GHC/Hs/Doc.hs +0/−1
• compiler/GHC/Hs/DocString.hs +2/−2
• compiler/GHC/Hs/Expr.hs +2/−2
• compiler/GHC/Hs/Pat.hs +2/−2
• compiler/GHC/Hs/Type.hs +3/−3
• compiler/GHC/Hs/Utils.hs +3/−2
• compiler/GHC/HsToCore/Errors/Ppr.hs +5/−4
• compiler/GHC/HsToCore/Errors/Types.hs +6/−6
• compiler/GHC/HsToCore/Pmc/Ppr.hs +1/−1
• compiler/GHC/Iface/Recomp/Binary.hs +1/−1
• compiler/GHC/Iface/Syntax.hs +41/−53
• compiler/GHC/Linker/Types.hs +1/−1
• compiler/GHC/Parser.y +21/−16
• compiler/GHC/Parser/Annotation.hs +2/−2
• compiler/GHC/Parser/Errors/Ppr.hs +13/−0
• compiler/GHC/Parser/Errors/Types.hs +12/−8
• compiler/GHC/Parser/Lexer.x +121/−96
• compiler/GHC/Parser/PostProcess.hs +50/−29
• compiler/GHC/Parser/PostProcess/Haddock.hs +6/−5
• compiler/GHC/Platform/Ways.hs +1/−1
• compiler/GHC/Prelude.hs +4/−2
• compiler/GHC/Runtime/Context.hs +2/−2
• compiler/GHC/Settings.hs +1/−1
• compiler/GHC/SysTools/BaseDir.hs +2/−2
• compiler/GHC/Tc/Errors/Ppr.hs +372/−301
• compiler/GHC/Tc/Errors/Types.hs +261/−153
• compiler/GHC/Tc/Solver/InertSet.hs +13/−8
• compiler/GHC/Tc/Types.hs +3/−3
• compiler/GHC/Tc/Types/Constraint.hs +3/−3
• compiler/GHC/Tc/Types/Evidence.hs +3/−3
• compiler/GHC/Tc/Types/Origin.hs +8/−8
• compiler/GHC/Tc/Utils/TcType.hs +8/−4
• compiler/GHC/Types/Avail.hs +4/−4
• compiler/GHC/Types/Basic.hs +62/−3
• compiler/GHC/Types/Demand.hs +276/−276
• compiler/GHC/Types/Error.hs +143/−66
• compiler/GHC/Types/Error/Codes.hs +821/−0
• compiler/GHC/Types/ForeignCall.hs +1/−1
• compiler/GHC/Types/Hint.hs +1/−1
• compiler/GHC/Types/Id/Info.hs +2/−2
• compiler/GHC/Types/Id/Make.hs +17/−17
• compiler/GHC/Types/Literal.hs +5/−5
• compiler/GHC/Types/Name.hs +2/−1
• compiler/GHC/Types/Name/Cache.hs +1/−1
• compiler/GHC/Types/Name/Occurrence.hs +5/−3
• compiler/GHC/Types/Name/Reader.hs +7/−7
• compiler/GHC/Types/RepType.hs +1/−1
• compiler/GHC/Types/SafeHaskell.hs +1/−1
• compiler/GHC/Types/SrcLoc.hs +5/−23
• compiler/GHC/Types/TyThing.hs +13/−3
• compiler/GHC/Types/Unique/Supply.hs +2/−2
• compiler/GHC/Unit.hs +1/−1
• compiler/GHC/Unit/Env.hs +3/−3
• compiler/GHC/Unit/External.hs +1/−1
• compiler/GHC/Unit/Module.hs +3/−4
• compiler/GHC/Unit/Module/Env.hs +3/−3
• compiler/GHC/Unit/Module/ModSummary.hs +1/−1
• compiler/GHC/Unit/Module/Warnings.hs +3/−0
• compiler/GHC/Unit/State.hs +14/−16
• compiler/GHC/Unit/Types.hs-boot +0/−2
• compiler/GHC/Utils/Binary.hs +1/−1
• compiler/GHC/Utils/Error.hs +9/−6
• compiler/GHC/Utils/Lexeme.hs +9/−11
• compiler/GHC/Utils/Logger.hs +14/−38
• compiler/GHC/Utils/Misc.hs +25/−72
• compiler/GHC/Utils/Monad.hs +6/−39
• compiler/GHC/Utils/Outputable.hs +8/−8
• compiler/GHC/Utils/Outputable.hs-boot +0/−9
• compiler/Language/Haskell/Syntax/Decls.hs +37/−8
• compiler/Language/Haskell/Syntax/Expr.hs +2/−2
• compiler/Language/Haskell/Syntax/Type.hs +5/−5
• ghc-lib-parser.cabal +4/−1
• ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl +3/−0
• ghc-lib/stage0/compiler/build/primop-docs.hs-incl +5/−1
• ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl +3/−0
• ghc-lib/stage0/compiler/build/primop-list.hs-incl +3/−0
• ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl +3/−0
• ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +3/−0
• ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +2/−0
• ghc-lib/stage0/compiler/build/primop-tag.hs-incl +1311/−1308
• ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +4/−4
• ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +13/−0
• libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +1/−0
• libraries/ghc-heap/GHC/Exts/Heap.hs +76/−93
• libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs +1/−0
• libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc +1/−5
• libraries/ghci/GHCi/Message.hs +1/−1
• libraries/template-haskell/Language/Haskell/TH/Lib.hs +2/−2
• libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +2/−2
• libraries/template-haskell/Language/Haskell/TH/Syntax.hs +8/−5

@@ -87,4 +87,5 @@ #define SMALL_MUT_ARR_PTRS_FROZEN_DIRTY 61 #define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62 #define COMPACT_NFDATA                63-#define N_CLOSURE_TYPES               64+#define CONTINUATION                  64+#define N_CLOSURE_TYPES               65

@@ -50,7 +50,7 @@ This is accomplished through a combination of mechanisms:    1. When parsing source code, the RdrName-decorated AST has some-     RdrNames which are Exact. These are wired-in RdrNames where the+     RdrNames which are Exact. These are wired-in RdrNames where      we could directly tell from the parsed syntax what Name to      use. For example, when we parse a [] in a type we can just insert      an Exact RdrName Name with the listTyConKey.@@ -427,7 +427,7 @@         rationalToDoubleName,          -- Other classes-        randomClassName, randomGenClassName, monadPlusClassName,+        monadPlusClassName,          -- Type-level naturals         knownNatClassName, knownSymbolClassName, knownCharClassName,@@ -538,7 +538,7 @@     gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING,     gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE,     gHC_NUM_INTEGER, gHC_NUM_NATURAL, gHC_NUM_BIGNAT,-    gHC_LIST, gHC_TUPLE, dATA_EITHER, dATA_VOID, dATA_LIST, dATA_STRING,+    gHC_LIST, gHC_TUPLE, gHC_TUPLE_PRIM, dATA_EITHER, dATA_VOID, dATA_LIST, dATA_STRING,     dATA_FOLDABLE, dATA_TRAVERSABLE,     gHC_CONC, gHC_IO, gHC_IO_Exception,     gHC_ST, gHC_IX, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,@@ -573,6 +573,7 @@ gHC_NUM_BIGNAT  = mkBignumModule (fsLit "GHC.Num.BigNat") gHC_LIST        = mkBaseModule (fsLit "GHC.List") gHC_TUPLE       = mkPrimModule (fsLit "GHC.Tuple")+gHC_TUPLE_PRIM  = mkPrimModule (fsLit "GHC.Tuple.Prim") dATA_EITHER     = mkBaseModule (fsLit "Data.Either") dATA_VOID       = mkBaseModule (fsLit "Data.Void") dATA_LIST       = mkBaseModule (fsLit "Data.List")@@ -1575,11 +1576,8 @@ toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey  -- Other classes, needed for type defaulting-monadPlusClassName, randomClassName, randomGenClassName,-    isStringClassName :: Name+monadPlusClassName, isStringClassName :: Name monadPlusClassName  = clsQual mONAD (fsLit "MonadPlus")      monadPlusClassKey-randomClassName     = clsQual rANDOM (fsLit "Random")        randomClassKey-randomGenClassName  = clsQual rANDOM (fsLit "RandomGen")     randomGenClassKey isStringClassName   = clsQual dATA_STRING (fsLit "IsString") isStringClassKey  -- Type-level naturals@@ -1849,7 +1847,8 @@     typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,     funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,     eqReprPrimTyConKey, eqPhantPrimTyConKey,-    compactPrimTyConKey, stackSnapshotPrimTyConKey :: Unique+    compactPrimTyConKey, stackSnapshotPrimTyConKey,+    promptTagPrimTyConKey :: Unique statePrimTyConKey                       = mkPreludeTyConUnique 50 stableNamePrimTyConKey                  = mkPreludeTyConUnique 51 stableNameTyConKey                      = mkPreludeTyConUnique 52@@ -1878,6 +1877,7 @@ tVarPrimTyConKey                        = mkPreludeTyConUnique 79 compactPrimTyConKey                     = mkPreludeTyConUnique 80 stackSnapshotPrimTyConKey               = mkPreludeTyConUnique 81+promptTagPrimTyConKey                   = mkPreludeTyConUnique 82  eitherTyConKey :: Unique eitherTyConKey                          = mkPreludeTyConUnique 84

@@ -658,7 +658,7 @@ GHC.ByteCode.Linker.primopToCLabel). TODO: Perhaps this should be changed?  Note that these wrappers aren't *quite* as expressive as their unwrapped-breathren, in that they may exhibit less representation polymorphism.+brethren, in that they may exhibit less representation polymorphism. For instance, consider the case of mkWeakNoFinalizer#, which has type:      mkWeakNoFinalizer# :: forall (r :: RuntimeRep) (k :: TYPE r) (v :: Type).

@@ -282,7 +282,7 @@                   unitTyCon                 , unboxedUnitTyCon -                -- Solo (i.e., the bosed 1-tuple) is also not treated+                -- Solo (i.e., the boxed 1-tuple) is also not treated                 -- like other tuples (i.e. we /do/ include it here),                 -- since it does not use special syntax like other tuples                 -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names@@ -809,7 +809,7 @@ Zero-tuples have used up the logical name. So we use 'Solo' and 'Solo#' for one-tuples.  So in ghc-prim:GHC.Tuple we see the declarations:   data ()     = ()-  data Solo a = Solo a+  data Solo a = MkSolo a   data (a,b)  = (a,b)  There is no way to write a boxed one-tuple in Haskell using tuple syntax.@@ -832,7 +832,7 @@ -- Wrinkle: Make boxed one-tuple names have known keys ----- -We make boxed one-tuple names have known keys so that `data Solo a = Solo a`,+We make boxed one-tuple names have known keys so that `data Solo a = MkSolo a`, defined in GHC.Tuple, will be used when one-tuples are spliced in through Template Haskell. This program (from #18097) crucially relies on this: @@ -943,20 +943,21 @@  mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName -- No need to cache these, the caching is done in mk_tuple-mkTupleOcc ns Boxed   ar = mkOccName ns (mkBoxedTupleStr   ar)+mkTupleOcc ns Boxed   ar = mkOccName ns (mkBoxedTupleStr ns ar) mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ar)  mkCTupleOcc :: NameSpace -> Arity -> OccName mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar) -mkTupleStr :: Boxity -> Arity -> String+mkTupleStr :: Boxity -> NameSpace -> Arity -> String mkTupleStr Boxed   = mkBoxedTupleStr-mkTupleStr Unboxed = mkUnboxedTupleStr+mkTupleStr Unboxed = const mkUnboxedTupleStr -mkBoxedTupleStr :: Arity -> String-mkBoxedTupleStr 0  = "()"-mkBoxedTupleStr 1  = "Solo"   -- See Note [One-tuples]-mkBoxedTupleStr ar = '(' : commas ar ++ ")"+mkBoxedTupleStr :: NameSpace -> Arity -> String+mkBoxedTupleStr _ 0  = "()"+mkBoxedTupleStr ns 1 | isDataConNameSpace ns = "MkSolo"  -- See Note [One-tuples]+mkBoxedTupleStr _ 1 = "Solo"                             -- See Note [One-tuples]+mkBoxedTupleStr _ ar = '(' : commas ar ++ ")"  mkUnboxedTupleStr :: Arity -> String mkUnboxedTupleStr 0  = "(##)"@@ -1117,7 +1118,7 @@     tuple_con  = pcDataCon dc_name dc_tvs dc_arg_tys tycon      boxity  = Boxed-    modu    = gHC_TUPLE+    modu    = gHC_TUPLE_PRIM     tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq                          (ATyCon tycon) BuiltInSyntax     dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq

@@ -80,6 +80,7 @@         weakPrimTyCon,                  mkWeakPrimTy,         threadIdPrimTyCon,              threadIdPrimTy,         stackSnapshotPrimTyCon,         stackSnapshotPrimTy,+        promptTagPrimTyCon,             mkPromptTagPrimTy,          int8PrimTyCon,          int8PrimTy, int8PrimTyConName,         word8PrimTyCon,         word8PrimTy, word8PrimTyConName,@@ -198,6 +199,7 @@     , word32PrimTyCon     , word64PrimTyCon     , stackSnapshotPrimTyCon+    , promptTagPrimTyCon      , tYPETyCon     , funTyCon@@ -231,7 +233,7 @@   stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName,   weakPrimTyConName, threadIdPrimTyConName,   eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName,-  stackSnapshotPrimTyConName :: Name+  stackSnapshotPrimTyConName, promptTagPrimTyConName :: Name charPrimTyConName             = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName              = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon int8PrimTyConName             = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon@@ -275,6 +277,7 @@  weakPrimTyConName             = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon threadIdPrimTyConName         = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon+promptTagPrimTyConName        = mkPrimTc (fsLit "PromptTag#") promptTagPrimTyConKey promptTagPrimTyCon  {- ************************************************************************@@ -1173,6 +1176,20 @@ threadIdPrimTy    = mkTyConTy threadIdPrimTyCon threadIdPrimTyCon :: TyCon threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName unliftedRepTy++{-+************************************************************************+*                                                                      *+   The ``prompt tag'' type+*                                                                      *+************************************************************************+-}++promptTagPrimTyCon :: TyCon+promptTagPrimTyCon = pcPrimTyCon promptTagPrimTyConName [Representational] unliftedRepTy++mkPromptTagPrimTy :: Type -> Type+mkPromptTagPrimTy v = TyConApp promptTagPrimTyCon [v]  {- ************************************************************************

@@ -37,7 +37,7 @@     , mkBuiltinUnique     , mkPseudoUniqueE -      -- ** Deriving uniquesc+      -- ** Deriving uniques       -- *** From TyCon name uniques     , tyConRepNameUnique       -- *** From DataCon name uniques

@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- ----- Object-file symbols (called CLabel for histerical raisins).+-- Object-file symbols (called CLabel for historical reasons). -- -- (c) The University of Glasgow 2004-2006 --@@ -153,10 +153,11 @@ import GHC.Data.FastString import GHC.Platform import GHC.Types.Unique.Set-import GHC.Utils.Misc import GHC.Core.Ppr ( {- instances -} ) import GHC.Types.SrcLoc +import qualified Data.Semigroup as S+ -- ----------------------------------------------------------------------------- -- The CLabel type @@ -343,26 +344,26 @@ -- code-generation. See Note [Unique Determinism and code generation] instance Ord CLabel where   compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) =-    compare a1 a2 `thenCmp`-    compare b1 b2 `thenCmp`+    compare a1 a2 S.<>+    compare b1 b2 S.<>     compare c1 c2   compare (CmmLabel a1 b1 c1 d1) (CmmLabel a2 b2 c2 d2) =-    compare a1 a2 `thenCmp`-    compare b1 b2 `thenCmp`+    compare a1 a2 S.<>+    compare b1 b2 S.<>     -- This non-determinism is "safe" in the sense that it only affects object code,     -- which is currently not covered by GHC's determinism guarantees. See #12935.-    uniqCompareFS c1 c2 `thenCmp`+    uniqCompareFS c1 c2 S.<>     compare d1 d2   compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2   compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2   compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) =-    uniqCompareFS a1 a2 `thenCmp`-    compare b1 b2 `thenCmp`-    compare c1 c2 `thenCmp`+    uniqCompareFS a1 a2 S.<>+    compare b1 b2 S.<>+    compare c1 c2 S.<>     compare d1 d2   compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2   compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) =-    compare a1 a2 `thenCmp`+    compare a1 a2 S.<>     lexicalCompareFS b1 b2   compare (StringLitLabel u1) (StringLitLabel u2) =     nonDetCmpUnique u1 u2@@ -373,10 +374,10 @@   compare (IPE_Label a1) (IPE_Label a2) =     compare a1 a2   compare (ModuleLabel m1 k1) (ModuleLabel m2 k2) =-    compare m1 m2 `thenCmp`+    compare m1 m2 S.<>     compare k1 k2   compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) =-    compare a1 a2 `thenCmp`+    compare a1 a2 S.<>     compare b1 b2   compare PicBaseLabel PicBaseLabel = EQ   compare (DeadStripPreventer a1) (DeadStripPreventer a2) =@@ -612,7 +613,7 @@ mkConInfoTableLabel         :: Name -> ConInfoTableLocation -> CLabel mkBytesLabel                :: Name -> CLabel mkClosureLabel name         c     = IdLabel name c Closure--- | Decicdes between external and local labels based on the names externality.+-- | Decides between external and local labels based on the names externality. mkInfoTableLabel name       c   | isExternalName name = IdLabel name c InfoTable   | otherwise           = IdLabel name c LocalInfoTable@@ -1480,28 +1481,28 @@       -> maybe_underscore $ ftext str <> text "_fast"     RtsLabel (RtsSelectorInfoTable upd_reqd offset)-      -> maybe_underscore $ hcat [ text "stg_sel_", text (show offset)+      -> maybe_underscore $ hcat [ text "stg_sel_", int offset                                  , if upd_reqd                                     then text "_upd_info"                                     else text "_noupd_info"                                  ]     RtsLabel (RtsSelectorEntry upd_reqd offset)-      -> maybe_underscore $ hcat [ text "stg_sel_", text (show offset)+      -> maybe_underscore $ hcat [ text "stg_sel_", int offset                                  , if upd_reqd                                     then text "_upd_entry"                                     else text "_noupd_entry"                                  ]     RtsLabel (RtsApInfoTable upd_reqd arity)-      -> maybe_underscore $ hcat [ text "stg_ap_", text (show arity)+      -> maybe_underscore $ hcat [ text "stg_ap_", int arity                                  , if upd_reqd                                     then text "_upd_info"                                     else text "_noupd_info"                                  ]     RtsLabel (RtsApEntry upd_reqd arity)-      -> maybe_underscore $ hcat [ text "stg_ap_", text (show arity)+      -> maybe_underscore $ hcat [ text "stg_ap_", int arity                                  , if upd_reqd                                     then text "_upd_entry"                                     else text "_noupd_entry"

@@ -45,11 +45,12 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label+import Data.Foldable (toList)+import Data.Functor.Classes (liftCompare) import Data.Maybe import Data.List (tails,sortBy) import GHC.Types.Unique (nonDetCmpUnique) import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Misc   ------------------------@@ -247,7 +248,7 @@             (cases, mbdef) = switchTargetsFallThrough ids             ppCase (is,l) = hsep                             [ text "case"-                            , commafy $ map integer is+                            , commafy $ toList $ fmap integer is                             , text ": goto"                             , ppr l <> semi                             ]@@ -912,7 +913,7 @@   compare GlobalScope    _               = LT   compare _              GlobalScope     = GT   compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u'-  compare scope scope'                   = cmpList nonDetCmpUnique+  compare scope scope'                   = liftCompare nonDetCmpUnique      (sortBy nonDetCmpUnique $ scopeUniques scope)      (sortBy nonDetCmpUnique $ scopeUniques scope') 

@@ -352,7 +352,7 @@    (LongReg _)              -> cmmBits W64    -- TODO: improve the internal model of SIMD/vectorized registers    -- the right design SHOULd improve handling of float and double code too.-   -- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim+   -- see remarks in Note [SIMD Design for the future] in GHC.StgToCmm.Prim    (XmmReg _) -> cmmVec 4 (cmmBits W32)    (YmmReg _) -> cmmVec 8 (cmmBits W32)    (ZmmReg _) -> cmmVec 16 (cmmBits W32)

@@ -12,7 +12,7 @@      createSwitchPlan,   ) where -import GHC.Prelude+import GHC.Prelude hiding (head)  import GHC.Utils.Outputable import GHC.Driver.Backend@@ -20,8 +20,7 @@ import GHC.Cmm.Dataflow.Label (Label)  import Data.Maybe-import Data.List (groupBy)-import Data.Function (on)+import Data.List.NonEmpty (NonEmpty (..), groupWith, head) import qualified Data.Map as M  -- Note [Cmm Switches, the general plan]@@ -201,11 +200,11 @@  -- | Groups cases with equal targets, suitable for pretty-printing to a -- c-like switch statement with fall-through semantics.-switchTargetsFallThrough :: SwitchTargets -> ([([Integer], Label)], Maybe Label)+switchTargetsFallThrough :: SwitchTargets -> ([(NonEmpty Integer, Label)], Maybe Label) switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef)   where-    groups = map (\xs -> (map fst xs, snd (head xs))) $-             groupBy ((==) `on` snd) $+    groups = fmap (\xs -> (fmap fst xs, snd (head xs))) $+             groupWith snd $              M.toList branches  -- | Custom equality helper, needed for "GHC.Cmm.CommonBlockElim"@@ -365,7 +364,7 @@ ---  Step 3: Fill in the blanks --- --- | A FlatSwitchPlan is a list of SwitchPlans, with an integer inbetween every+-- | A FlatSwitchPlan is a list of SwitchPlans, with an integer in between every -- two entries, dividing the range. -- So if we have (abusing list syntax) [plan1,n,plan2], then we use plan1 if -- the expression is < n, and plan2 otherwise.

@@ -65,7 +65,8 @@         maybeUnfoldingTemplate, otherCons,         isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,         isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,-        isStableUnfolding, isInlineUnfolding, isBootUnfolding,+        isStableUnfolding, isStableUserUnfolding, isStableSystemUnfolding,+        isInlineUnfolding, isBootUnfolding,         hasCoreUnfolding, hasSomeUnfolding,         canUnfold, neverUnfoldGuidance, isStableSource, @@ -1338,36 +1339,6 @@   -------------------------------------------------data UnfoldingSource-  = -- See also Note [Historical note: unfoldings for wrappers]--    InlineRhs          -- The current rhs of the function-                       -- Replace uf_tmpl each time around--  | InlineStable       -- From an INLINE or INLINABLE pragma-                       --   INLINE     if guidance is UnfWhen-                       --   INLINABLE  if guidance is UnfIfGoodArgs/UnfoldNever-                       -- (well, technically an INLINABLE might be made-                       -- UnfWhen if it was small enough, and then-                       -- it will behave like INLINE outside the current-                       -- module, but that is the way automatic unfoldings-                       -- work so it is consistent with the intended-                       -- meaning of INLINABLE).-                       ---                       -- uf_tmpl may change, but only as a result of-                       -- gentle simplification, it doesn't get updated-                       -- to the current RHS during compilation as with-                       -- InlineRhs.-                       ---                       -- See Note [InlineStable]--  | InlineCompulsory   -- Something that *has* no binding, so you *must* inline it-                       -- Only a few primop-like things have this property-                       -- (see "GHC.Types.Id.Make", calls to mkCompulsoryUnfolding).-                       -- Inline absolutely always, however boring the context.--- -- | 'UnfoldingGuidance' says when unfolding should take place data UnfoldingGuidance   = UnfWhen {   -- Inline without thinking about the *size* of the uf_tmpl@@ -1472,18 +1443,12 @@ mkOtherCon :: [AltCon] -> Unfolding mkOtherCon = OtherCon -isStableSource :: UnfoldingSource -> Bool--- Keep the unfolding template-isStableSource InlineCompulsory   = True-isStableSource InlineStable       = True-isStableSource InlineRhs          = False- -- | Retrieves the template of an unfolding: panics if none is known unfoldingTemplate :: Unfolding -> CoreExpr unfoldingTemplate = uf_tmpl  -- | Retrieves the template of an unfolding if possible--- maybeUnfoldingTemplate is used mainly wnen specialising, and we do+-- maybeUnfoldingTemplate is used mainly when specialising, and we do -- want to specialise DFuns, so it's important to return a template -- for DFunUnfoldings maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr@@ -1542,8 +1507,8 @@ expandUnfolding_maybe _                                                       = Nothing  isCompulsoryUnfolding :: Unfolding -> Bool-isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True-isCompulsoryUnfolding _                                             = False+isCompulsoryUnfolding (CoreUnfolding { uf_src = src }) = isCompulsorySource src+isCompulsoryUnfolding _                                = False  isStableUnfolding :: Unfolding -> Bool -- True of unfoldings that should not be overwritten@@ -1552,6 +1517,16 @@ isStableUnfolding (DFunUnfolding {})               = True isStableUnfolding _                                = False +isStableUserUnfolding :: Unfolding -> Bool+-- True of unfoldings that arise from an INLINE or INLINEABLE pragma+isStableUserUnfolding (CoreUnfolding { uf_src = src }) = isStableUserSource src+isStableUserUnfolding _                                = False++isStableSystemUnfolding :: Unfolding -> Bool+-- True of unfoldings that arise from an INLINE or INLINEABLE pragma+isStableSystemUnfolding (CoreUnfolding { uf_src = src }) = isStableSystemSource src+isStableSystemUnfolding _                                = False+ isInlineUnfolding :: Unfolding -> Bool -- ^ True of a /stable/ unfolding that is --   (a) always inlined; that is, with an `UnfWhen` guidance, or@@ -1608,8 +1583,8 @@  We consider even a StableUnfolding as fragile, because it needs substitution. -Note [InlineStable]-~~~~~~~~~~~~~~~~~+Note [Stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~ When you say       {-# INLINE f #-}       f x = <rhs>@@ -1619,10 +1594,11 @@ leaving the original unfolding intact in Unfolding of 'f'. For example         all xs = foldr (&&) True xs         any p = all . map p  {-# INLINE any #-}-We optimise any's RHS fully, but leave the InlineRule saying "all . map p",-which deforests well at the call site.+We optimise any's RHS fully, but leave the stable unfolding for `any`+saying "all . map p", which deforests well at the call site. -So INLINE pragma gives rise to an InlineRule, which captures the original RHS.+So INLINE pragma gives rise to a stable unfolding, which captures the+original RHS.  Moreover, it's only used when 'f' is applied to the specified number of arguments; that is, the number of argument on@@ -1635,9 +1611,6 @@    (.) f g x = f (g x) it'd only inline when applied to three arguments.  This slightly-experimental change was requested by Roman, but it seems to make sense.--See also Note [Inlining an InlineRule] in GHC.Core.Unfold.-  Note [OccInfo in unfoldings and rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveFunctor       #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -51,8 +52,7 @@         -- ** Decomposition         instNewTyCon_maybe, -        NormaliseStepper, NormaliseStepResult(..), composeSteppers,-        mapStepResult, unwrapNewTypeStepper,+        NormaliseStepper, NormaliseStepResult(..), composeSteppers, unwrapNewTypeStepper,         topNormaliseNewType_maybe, topNormaliseTypeX,          decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe,@@ -304,7 +304,7 @@ coToMCo :: Coercion -> MCoercion -- Convert a coercion to a MCoercion, -- It's not clear whether or not isReflexiveCo would be better here---    See #19815 for a bit of data and dicussion on this point+--    See #19815 for a bit of data and discussion on this point coToMCo co | isReflCo co = MRefl            | otherwise   = MCo co @@ -781,7 +781,7 @@     mkFunCo r w co1 co2                 -- Expand type synonyms-  | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos+  | ExpandsSyn tv_co_prs rhs_ty leftover_cos <- expandSynTyCon_maybe tc cos   = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos    | Just tys_roles <- traverse isReflCo_maybe cos@@ -874,7 +874,7 @@ Richard's thesis is unable to prove that it isn't. Specifically, the liftCoSubst function might create an invalid coercion. Because a violation of the restriction might lead to a program that "goes wrong", it is checked all the time,-even in a production compiler and without -dcore-list. We *have* proved that the+even in a production compiler and without -dcore-lint. We *have* proved that the problem does not occur with homogeneous equality, so this check can be dropped once ~# is made to be homogeneous. -}@@ -955,7 +955,7 @@  mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion]            -> Coercion--- mkAxInstCo can legitimately be called over-staturated;+-- mkAxInstCo can legitimately be called over-saturated; -- i.e. with more type arguments than the coercion requires mkAxInstCo role ax index tys cos   | arity == n_tys = downgradeRole role ax_role $@@ -1615,7 +1615,7 @@ mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co               | isCoVar v = assert (not (v `elemVarSet` tyCoVarsOfCo co)) $                   -- We didn't call mkForAllCo here because if v does not appear-                  -- in co, the argement coercion will be nominal. But here we+                  -- in co, the argument coercion will be nominal. But here we                   -- want it to be r. It is only called in 'mkPiCos', which is                   -- only used in GHC.Core.Opt.Simplify.Utils, where we are sure for                   -- now (Aug 2018) v won't occur in co.@@ -1712,17 +1712,12 @@   | NS_Step RecTcChecker Type ev    -- ^ We stepped, yielding new bits;                                     -- ^ ev is evidence;                                     -- Usually a co :: old type ~ new type+  deriving (Functor)  instance Outputable ev => Outputable (NormaliseStepResult ev) where   ppr NS_Done           = text "NS_Done"   ppr NS_Abort          = text "NS_Abort"   ppr (NS_Step _ ty ev) = sep [text "NS_Step", ppr ty, ppr ev]--mapStepResult :: (ev1 -> ev2)-              -> NormaliseStepResult ev1 -> NormaliseStepResult ev2-mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev)-mapStepResult _ NS_Done                 = NS_Done-mapStepResult _ NS_Abort                = NS_Abort  -- | Try one stepper and then try the next, if the first doesn't make -- progress.

@@ -485,7 +485,7 @@                   , cab_lhs = lhs                   , cab_rhs = rhs }) =     text "CoAxBranch" <+> parens (ppr loc) <> colon-      <+> brackets (fsep (punctuate comma (map pprType lhs)))+      <+> brackets (pprWithCommas pprType lhs)       <+> text "=>" <+> pprType rhs  {-

@@ -57,7 +57,8 @@         isNullarySrcDataCon, isNullaryRepDataCon,         isTupleDataCon, isBoxedTupleDataCon, isUnboxedTupleDataCon,         isUnboxedSumDataCon,-        isVanillaDataCon, isNewDataCon, classDataCon, dataConCannotMatch,+        isVanillaDataCon, isNewDataCon, isTypeDataCon,+        classDataCon, dataConCannotMatch,         dataConUserTyVarsArePermuted,         isBanged, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked,         specialPromotedDc,@@ -232,7 +233,7 @@         data T = MkT !(Int,Int)         \$wMkT :: (Int,Int) -> T         \$wMkT (x,y) = MkT x y-  Notice that the worker has two fields where the wapper has+  Notice that the worker has two fields where the wrapper has   just one.  That is, the worker has type                 MkT :: Int -> Int -> T @@ -1633,6 +1634,11 @@ -- | Is this the 'DataCon' of a newtype? isNewDataCon :: DataCon -> Bool isNewDataCon dc = isNewTyCon (dataConTyCon dc)++-- | Is this data constructor in a "type data" declaration?+-- See Note [Type data declarations] in GHC.Rename.Module.+isTypeDataCon :: DataCon -> Bool+isTypeDataCon dc = isTcClsNameSpace (nameNameSpace (getName dc))  -- | Should this DataCon be allowed in a type even without -XDataKinds? -- Currently, only Lifted & Unlifted

@@ -366,7 +366,7 @@  data FamInstEnv   = FamIE !Int -- The number of instances, used to choose the smaller environment-               -- when checking type family consistnecy of home modules.+               -- when checking type family consistency of home modules.           !(RoughMap FamInst)      -- See Note [FamInstEnv]      -- See Note [FamInstEnv determinism]@@ -549,7 +549,7 @@    | InjectivityUnified CoAxBranch CoAxBranch     -- ^ RHSs unify but LHSs don't unify under that substitution.  Relevant for     -- closed type families where equation after unification might be-    -- overlpapped (in which case it is OK if they don't unify).  Constructor+    -- overlapped (in which case it is OK if they don't unify).  Constructor     -- stores axioms after unification.  -- | Check whether two type family axioms don't violate injectivity annotation.@@ -920,7 +920,7 @@ lookupFamInstEnvInjectivityConflicts     :: [Bool]         -- injectivity annotation for this type family instance                       -- INVARIANT: list contains at least one True value-    ->  FamInstEnvs   -- all type instances seens so far+    ->  FamInstEnvs   -- all type instances seen so far     ->  FamInst       -- new type instance that we're checking     -> [CoAxBranch]   -- conflicting instance declarations lookupFamInstEnvInjectivityConflicts injList fam_inst_envs@@ -1315,7 +1315,7 @@      unwrapNewTypeStepper' :: NormaliseStepper (Coercion, MCoercionN)     unwrapNewTypeStepper' rec_nts tc tys-      = mapStepResult (, MRefl) $ unwrapNewTypeStepper rec_nts tc tys+      = (, MRefl) <$> unwrapNewTypeStepper rec_nts tc tys        -- second coercion below is the kind coercion relating the original type's kind       -- to the normalised type's kind@@ -1370,7 +1370,7 @@ -- See Note [Normalising types] about the LiftingContext normalise_tc_app :: TyCon -> [Type] -> NormM Reduction normalise_tc_app tc tys-  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys+  | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc tys   , not (isFamFreeTyCon tc)  -- Expand and try again   = -- A synonym with type families in the RHS     -- Expand and try again

@@ -1059,7 +1059,7 @@       A2. M is not overlapping,       A3. G is overlapping. -    This means that we eliminate G from the set of matches (it is overriden by M),+    This means that we eliminate G from the set of matches (it is overridden by M),     but we keep it around until we are done with instance resolution because     it might still be useful to eliminate other matches. @@ -1067,7 +1067,7 @@      There are two situations in which guards can eliminate a match: -      B1. We want to add a new instance, but it is overriden by a guard.+      B1. We want to add a new instance, but it is overridden by a guard.           We can immediately discard the instance.            Example for B1:@@ -1080,7 +1080,7 @@            Processing them in order: we add J1 as a match, then J2 as a guard.           Now, when we come across J3, we can immediately discard it because-          it is overriden by the guard J2.+          it is overridden by the guard J2.        B2. We have found a new guard. We must use it to discard matches           we have already found. This is necessary because we must obtain@@ -1096,7 +1096,7 @@              We start by considering K1 and K2. Neither has any overlapping flag set,             so we end up with two matches, {K1, K2}.-            Next we look at K3: it is overriden by K1, but as K1 is not+            Next we look at K3: it is overridden by K1, but as K1 is not             overlapping this means K3 should function as a guard.             We must then ensure we eliminate K2 from the list of matches,             as K3 guards against it.

@@ -1,6 +1,8 @@-{-# LANGUAGE DeriveFunctor       #-} {-# LANGUAGE MultiWayIf          #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnboxedSums #-}  {- (c) The University of Glasgow 2006@@ -95,6 +97,8 @@ import Data.List          ( partition ) import Data.Maybe import GHC.Data.Pair+import GHC.Base (oneShot)+import GHC.Data.Unboxed  {- Note [Core Lint guarantee]@@ -187,7 +191,7 @@    (SI2) The result of that substitution is used only to check for type         equality, to check well-typed-ness, /but is then discarded/.-        The result of substittion does not outlive the CoreLint pass.+        The result of substitution does not outlive the CoreLint pass.    (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders. @@ -263,6 +267,42 @@ error. Similarly, join points can occur free in RHSes of other join points but not the RHSes of value bindings (thunks and functions). +Note [Avoiding compiler perf traps when constructing error messages.]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's quite common to put error messages into a where clause when it might+be triggered by multiple branches. E.g.++  checkThing x y z =+    case x of+      X -> unless (correctX x) $ failWithL errMsg+      Y -> unless (correctY y) $ failWithL errMsg+    where+      errMsg = text "My error involving:" $$ ppr x <+> ppr y++However ghc will compile this to:++  checkThink x y z =+    let errMsg = text "My error involving:" $$ ppr x <+> ppr y+    in case x of+      X -> unless (correctX x) $ failWithL errMsg+      Y -> unless (correctY y) $ failWithL errMsg++Putting the allocation of errMsg into the common non-error path.+One way to work around this is to turn errMsg into a function:++  checkThink x y z =+    case x of+      X -> unless (correctX x) $ failWithL (errMsg x y)+      Y -> unless (correctY y) $ failWithL (errMsg x y)+    where+      errMsg x y = text "My error involving:" $$ ppr x <+> ppr y++This way `errMsg` is a static function and it being defined in the common+path does not result in allocation in the hot path. This can be surprisingly+impactful. Changing `lint_app` reduced allocations for one test program I was+looking at by ~4%.++ ************************************************************************ *                                                                      *                  Beginning and ending passes@@ -732,7 +772,7 @@ take effect -- the warning turned out to be temporary.  To stop excessive warnings, this warning for INLINE loop breakers is-switched off when linting the the result of the desugarer.  See+switched off when linting the result of the desugarer.  See lf_check_inline_loop_breakers in GHC.Core.Lint.  @@ -1825,7 +1865,7 @@   = failWithL (hang (text "Un-saturated type application") 2 (ppr ty))    -- Deal with type synonyms-  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys+  | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc tys   , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys'   = do { -- Kind-check the argument types, but without reporting          -- un-saturated type families/synonyms@@ -1874,13 +1914,15 @@  ----------------- lint_ty_app :: Type -> LintedKind -> [LintedType] -> LintM ()-lint_ty_app ty k tys-  = lint_app (text "type" <+> quotes (ppr ty)) k tys+lint_ty_app msg_ty k tys+    -- See Note [Avoiding compiler perf traps when constructing error messages.]+  = lint_app (\msg_ty -> text "type" <+> quotes (ppr msg_ty)) msg_ty k tys  ---------------- lint_co_app :: Coercion -> LintedKind -> [LintedType] -> LintM ()-lint_co_app ty k tys-  = lint_app (text "coercion" <+> quotes (ppr ty)) k tys+lint_co_app msg_ty k tys+    -- See Note [Avoiding compiler perf traps when constructing error messages.]+  = lint_app (\msg_ty -> text "coercion" <+> quotes (ppr msg_ty)) msg_ty k tys  ---------------- lintTyLit :: TyLit -> LintM ()@@ -1891,46 +1933,62 @@ lintTyLit (StrTyLit _) = return () lintTyLit (CharTyLit _) = return () -lint_app :: SDoc -> LintedKind -> [LintedType] -> LintM ()+lint_app :: Outputable msg_thing => (msg_thing -> SDoc) -> msg_thing -> LintedKind -> [LintedType] -> LintM () -- (lint_app d fun_kind arg_tys) --    We have an application (f arg_ty1 .. arg_tyn), --    where f :: fun_kind  -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism]-lint_app doc kfn arg_tys-    = do { in_scope <- getInScope+--+-- Being strict in the kind here avoids quite a few pointless thunks+-- reducing allocations by ~5%+lint_app mk_msg msg_type !kfn arg_tys+    = do { !in_scope <- getInScope          -- We need the in_scope set to satisfy the invariant in          -- Note [The substitution invariant] in GHC.Core.TyCo.Subst-         ; _ <- foldlM (go_app in_scope) kfn arg_tys-         ; return () }+         -- Forcing the in scope set eagerly here reduces allocations by up to 4%.+         ; go_app in_scope kfn arg_tys+         }   where-    fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc-                          , nest 2 (text "Function kind =" <+> ppr kfn)-                          , nest 2 (text "Arg types =" <+> ppr arg_tys)-                          , extra ] -    go_app in_scope kfn ta+    -- We use explicit recursion instead of a fold here to avoid go_app becoming+    -- an allocated function closure. This reduced allocations by up to 7% for some+    -- modules.+    go_app :: InScopeSet -> LintedKind -> [Type] -> LintM ()+    go_app !in_scope !kfn ta       | Just kfn' <- coreView kfn       = go_app in_scope kfn' ta -    go_app _ fun_kind@(FunTy _ _ kfa kfb) ta+    go_app _in_scope _kind [] = return ()++    go_app in_scope fun_kind@(FunTy _ _ kfa kfb) (ta:tas)       = do { let ka = typeKind ta            ; unless (ka `eqType` kfa) $-             addErrL (fail_msg (text "Fun:" <+> (ppr fun_kind $$ ppr ta <+> dcolon <+> ppr ka)))-           ; return kfb }+             addErrL (lint_app_fail_msg kfn arg_tys mk_msg msg_type (text "Fun:" <+> (ppr fun_kind $$ ppr ta <+> dcolon <+> ppr ka)))+           ; go_app in_scope kfb tas } -    go_app in_scope (ForAllTy (Bndr kv _vis) kfn) ta+    go_app in_scope (ForAllTy (Bndr kv _vis) kfn) (ta:tas)       = do { let kv_kind = varType kv                  ka      = typeKind ta            ; unless (ka `eqType` kv_kind) $-             addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$+             addErrL (lint_app_fail_msg kfn arg_tys mk_msg msg_type (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$                                                     ppr ta <+> dcolon <+> ppr ka)))-           ; return $ substTy (extendTCvSubst (mkEmptySubst in_scope) kv ta) kfn }+           ; let kind' = substTy (extendTCvSubst (mkEmptySubst in_scope) kv ta) kfn+           ; go_app in_scope kind' tas }      go_app _ kfn ta-       = failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ta)))+       = failWithL (lint_app_fail_msg kfn arg_tys mk_msg msg_type (text "Not a fun:" <+> (ppr kfn $$ ppr ta))) +-- This is a top level definition to ensure we pass all variables of the error message+-- explicitly and don't capture them as free variables. Otherwise this binder might+-- become a thunk that get's allocated in the hot code path.+-- See Note [Avoiding compiler perf traps when constructing error messages.]+lint_app_fail_msg :: (Outputable a1, Outputable a2) => a1 -> a2 -> (t -> SDoc) -> t -> SDoc -> SDoc+lint_app_fail_msg kfn arg_tys mk_msg msg_type extra = vcat [ hang (text "Kind application error in") 2 (mk_msg msg_type)+                      , nest 2 (text "Function kind =" <+> ppr kfn)+                      , nest 2 (text "Arg types =" <+> ppr arg_tys)+                      , extra ] {- ********************************************************************* *                                                                      *         Linting rules@@ -2079,7 +2137,7 @@                    -> return (CoVarCo cv)               | otherwise                    ->-                      -- lintCoBndr always extends the substitition+                      -- lintCoBndr always extends the substitution                       failWithL $                       hang (text "The coercion variable" <+> pprBndr LetBind cv)                          2 (text "is out of scope")@@ -2672,14 +2730,41 @@   deriving Eq  newtype LintM a =-   LintM { unLintM ::+   LintM' { unLintM ::             LintEnv ->             WarnsAndErrs ->           -- Warning and error messages so far-            (Maybe a, WarnsAndErrs) } -- Result and messages (if any)-   deriving (Functor)+            LResult a } -- Result and messages (if any) ++pattern LintM :: (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad+pattern LintM m <- LintM' m+  where+    LintM m = LintM' (oneShot $ \env -> oneShot $ \we -> m env we)+    -- LintM m = LintM' (oneShot $ oneShot m)+{-# COMPLETE LintM #-}++instance Functor (LintM) where+  fmap f (LintM m) = LintM $ \e w -> mapLResult f (m e w)+ type WarnsAndErrs = (Bag SDoc, Bag SDoc) +-- Using a unboxed tuple here reduced allocations for a lint heavy+-- file by ~6%. Using MaybeUB reduced them further by another ~12%.+type LResult a = (# MaybeUB a, WarnsAndErrs #)++pattern LResult :: MaybeUB a -> WarnsAndErrs -> LResult a+pattern LResult m w = (# m, w #)+{-# COMPLETE LResult #-}++mapLResult :: (a1 -> a2) -> LResult a1 -> LResult a2+mapLResult f (LResult r w) = LResult (fmapMaybeUB f r) w++-- Just for testing.+fromBoxedLResult :: (Maybe a, WarnsAndErrs) -> LResult a+fromBoxedLResult (Just x, errs) = LResult (JustUB x) errs+fromBoxedLResult (Nothing,errs) = LResult NothingUB errs+ {- Note [Checking for global Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Before CoreTidy, all locally-bound Ids must be LocalIds, even@@ -2804,21 +2889,27 @@ -}  instance Applicative LintM where-      pure x = LintM $ \ _ errs -> (Just x, errs)+      pure x = LintM $ \ _ errs -> LResult (JustUB x) errs+                                   --(Just x, errs)       (<*>) = ap  instance Monad LintM where   m >>= k  = LintM (\ env errs ->-                       let (res, errs') = unLintM m env errs in+                       let res = unLintM m env errs in                          case res of-                           Just r -> unLintM (k r) env errs'-                           Nothing -> (Nothing, errs'))+                           LResult (JustUB r) errs' -> unLintM (k r) env errs'+                           LResult NothingUB errs' -> LResult NothingUB errs'+                    )+                          --  LError errs'-> LError errs')+                      --  let (res, errs') = unLintM m env errs in+                          --  Just r -> unLintM (k r) env errs'+                          --  Nothing -> (Nothing, errs'))  instance MonadFail LintM where     fail err = failWithL (text err)  getPlatform :: LintM Platform-getPlatform = LintM (\ e errs -> (Just (le_platform e), errs))+getPlatform = LintM (\ e errs -> (LResult (JustUB $ le_platform e) errs))  data LintLocInfo   = RhsOf Id            -- The variable bound@@ -2851,9 +2942,9 @@       -> WarnsAndErrs initL cfg m   = case unLintM m env (emptyBag, emptyBag) of-      (Just _, errs) -> errs-      (Nothing, errs@(_, e)) | not (isEmptyBag e) -> errs-                             | otherwise -> pprPanic ("Bug in Lint: a failure occurred " +++      LResult (JustUB _) errs -> errs+      LResult NothingUB errs@(_, e) | not (isEmptyBag e) -> errs+                                    | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++                                                       "without reporting an error message") empty   where     (tcvs, ids) = partition isTyCoVar $ l_vars cfg@@ -2882,7 +2973,7 @@     in unLintM thing_inside env' errs  getLintFlags :: LintM LintFlags-getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs)+getLintFlags = LintM $ \ env errs -> fromBoxedLResult (Just (le_flags env), errs)  checkL :: Bool -> SDoc -> LintM () checkL True  _   = return ()@@ -2898,15 +2989,15 @@  failWithL :: SDoc -> LintM a failWithL msg = LintM $ \ env (warns,errs) ->-                (Nothing, (warns, addMsg True env errs msg))+                fromBoxedLResult (Nothing, (warns, addMsg True env errs msg))  addErrL :: SDoc -> LintM () addErrL msg = LintM $ \ env (warns,errs) ->-              (Just (), (warns, addMsg True env errs msg))+              fromBoxedLResult (Just (), (warns, addMsg True env errs msg))  addWarnL :: SDoc -> LintM () addWarnL msg = LintM $ \ env (warns,errs) ->-              (Just (), (addMsg False env warns msg, errs))+              fromBoxedLResult (Just (), (addMsg False env warns msg, errs))  addMsg :: Bool -> LintEnv ->  Bag SDoc -> SDoc -> Bag SDoc addMsg is_error env msgs msg@@ -2929,7 +3020,7 @@                []    -> noSrcSpan                (s:_) -> s    !diag_opts = le_diagOpts env-   mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag) msg_span+   mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) msg_span                              (msg $$ context)  addLoc :: LintLocInfo -> LintM a -> LintM a@@ -2938,7 +3029,7 @@     unLintM m (env { le_loc = extra_loc : le_loc env }) errs  inCasePat :: LintM Bool         -- A slight hack; see the unique call site-inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs)+inCasePat = LintM $ \ env errs -> fromBoxedLResult (Just (is_case_pat env), errs)   where     is_case_pat (LE { le_loc = CasePat {} : _ }) = True     is_case_pat _other                           = False@@ -2954,7 +3045,7 @@       | otherwise   = delVarSet    join_set id -- Remove any existing binding  getInScopeIds :: LintM (VarEnv (Id,LintedType))-getInScopeIds = LintM (\env errs -> (Just (le_ids env), errs))+getInScopeIds = LintM (\env errs -> fromBoxedLResult (Just (le_ids env), errs))  extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a extendTvSubstL tv ty m@@ -2974,16 +3065,16 @@ markAllJoinsBadIf False m = m  getValidJoins :: LintM IdSet-getValidJoins = LintM (\ env errs -> (Just (le_joins env), errs))+getValidJoins = LintM (\ env errs -> fromBoxedLResult (Just (le_joins env), errs))  getSubst :: LintM Subst-getSubst = LintM (\ env errs -> (Just (le_subst env), errs))+getSubst = LintM (\ env errs -> fromBoxedLResult (Just (le_subst env), errs))  getUEAliases :: LintM (NameEnv UsageEnv)-getUEAliases = LintM (\ env errs -> (Just (le_ue_aliases env), errs))+getUEAliases = LintM (\ env errs -> fromBoxedLResult (Just (le_ue_aliases env), errs))  getInScope :: LintM InScopeSet-getInScope = LintM (\ env errs -> (Just (getSubstInScope $ le_subst env), errs))+getInScope = LintM (\ env errs -> fromBoxedLResult (Just (getSubstInScope $ le_subst env), errs))  lookupIdInScope :: Id -> LintM (Id, LintedType) lookupIdInScope id_occ

@@ -105,7 +105,7 @@ -- | Sort the variables, putting type and covars first, in scoped order, -- and then other Ids ----- It is a deterministic sort, meaining it doesn't look at the values of+-- It is a deterministic sort, meaning it doesn't look at the values of -- Uniques. For explanation why it's important See Note [Unique Determinism] -- in GHC.Types.Unique. sortQuantVars :: [Var] -> [Var]@@ -263,7 +263,7 @@ mkIntExprInt :: Platform -> Int -> CoreExpr         -- Result = I# i :: Int mkIntExprInt platform i = mkCoreConApps intDataCon  [mkIntLit platform (fromIntegral i)] --- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value+-- | Create a 'CoreExpr' which will evaluate to a @Word@ with the given value mkWordExpr :: Platform -> Integer -> CoreExpr mkWordExpr platform w = mkCoreConApps wordDataCon [mkWordLit platform w] @@ -467,7 +467,7 @@ ************************************************************************ -} --- | Builds a selector which scrutises the given+-- | Builds a selector which scrutinises the given -- expression and extracts the one name from the list given. -- If you want the no-shadowing rule to apply, the caller -- is responsible for making sure that none of these names

@@ -132,7 +132,7 @@ Usages are usually group in a UsageEnv, as defined in the UsageEnv module.  So, in our function application example, the typechecking algorithm would-receive usage environements f_ue from the typechecking of f, and u_ue from the+receive usage environments f_ue from the typechecking of f, and u_ue from the typechecking of u. Then the output would be f_ue + (k * u_ue). Addition and scaling of usage environment is the pointwise extension of the semiring operations on multiplicities.

@@ -509,9 +509,6 @@  Of course both (1) and (2) are readily defeated by disguising the bottoms. -Another place where -fpedantic-bottoms comes up is during eta-reduction.-See Note [Eta reduction soundness], the bit about -fpedantic-bottoms.- 4. Note [Newtype arity] ~~~~~~~~~~~~~~~~~~~~~~~~ Non-recursive newtypes are transparent, and should not get in the way.@@ -571,7 +568,7 @@   f' = \p. \s. ((error "...") |> g1) s   f = f' |> (String -> g2) -Discard args for bottomming function+Discard args for bottoming function    f' = \p. \s. ((error "...") |> g1 |> g3   g3 :: (S -> (S,T)) ~ (S,T)@@ -823,7 +820,7 @@  safeArityType :: ArityType -> SafeArityType -- ^ Assuming this ArityType is all we know, find the arity of--- the function, and trim the argument info (and Divergenge)+-- the function, and trim the argument info (and Divergence) -- to match that arity. See Note [SafeArityType] safeArityType at@(AT lams _)   = case go 0 IsCheap lams of@@ -980,7 +977,7 @@     call_arity = idCallArity bndr      dmd_one_shots :: [OneShotInfo]-    -- If the demand info is Cx(C1(C1(.))) then we know that an+    -- If the demand info is C(x,C(1,C(1,.))) then we know that an     -- application to one arg is also an application to three     dmd_one_shots = argOneShots (idDemandInfo bndr) @@ -1089,10 +1086,10 @@ We may have /more/ call demands from the calls than we have lambdas in the binding.  E.g.     let f1 = \x. g x x in ...(f1 p q r)...-    -- Demand on f1 is Cx(C1(C1(L)))+    -- Demand on f1 is C(x,C(1,C(1,L)))      let f2 = \y. error y in ...(f2 p q r)...-    -- Demand on f2 is Cx(C1(C1(L)))+    -- Demand on f2 is C(x,C(1,C(1,L)))  In both these cases we can eta expand f1 and f2 to arity 3. But /only/ for called-once demands.  Suppose we had@@ -2034,7 +2031,7 @@     where etas :: EtaInfo          etaInfoAbs builds the lambdas-         etaInfoApp builds the applictions+         etaInfoApp builds the applications     Note that the /same/ EtaInfo drives both etaInfoAbs and etaInfoApp @@ -2382,20 +2379,13 @@     `e = \x y. bot`.      Could we relax to "*At least one call in the same trace* is with n args"?-    (NB: Strictness analysis can only answer this relaxed question, not the-     original formulation.)-    Consider what happens for+    No. Consider what happens for       ``g2 c = c True `seq` c False 42``     Here, `g2` will call `c` with 2 arguments (if there is a call at all).     But it is unsound to eta-reduce the arg in `g2 (\x y. e x y)` to `g2 e`     when `e = \x. if x then bot else id`, because the latter will diverge when-    the former would not.--    On the other hand, with `-fno-pendantic-bottoms` , we will have eta-expanded-    the definition of `e` and then eta-reduction is sound-    (see Note [Dealing with bottom]).-    Consequence: We have to check that `-fpedantic-bottoms` is off; otherwise-    eta-reduction based on demands is in fact unsound.+    the former would not. Fortunately, the strictness analyser will report+    "Not always called with two arguments" for `g2` and we won't eta-expand.      See Note [Eta reduction based on evaluation context] for the implementation     details. This criterion is tested extensively in T21261.@@ -2487,7 +2477,7 @@ that might mean that f isn't saturated any more, and does not inline. This led to some other regressions. -TL;DR currrently we do /not/ eta reduce if the result is a PAP.+TL;DR currently we do /not/ eta reduce if the result is a PAP.  Note [Eta reduction with casted arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2532,20 +2522,20 @@   g c = c 1 2 + c 3 4 Then this is how the pieces are put together: -  * Demand analysis infers `<SCS(C1(L))>` for `g`'s demand signature+  * Demand analysis infers `<SC(S,C(1,L))>` for `g`'s demand signature    * When the Simplifier next simplifies the argument in `g (\x y. e x y)`, it     looks up the *evaluation context* of the argument in the form of the-    sub-demand `CS(C1(L))` and stores it in the 'SimplCont'.+    sub-demand `C(S,C(1,L))` and stores it in the 'SimplCont'.     (Why does it drop the outer evaluation cardinality of the demand, `S`?     Because it's irrelevant! When we simplify an expression, we do so under the     assumption that it is currently under evaluation.)     This sub-demand literally says "Whenever this expression is evaluated, it-    is also called with two arguments, potentially multiple times".+    is called with at least two arguments, potentially multiple times".    * Then the simplifier takes apart the lambda and simplifies the lambda group     and then calls 'tryEtaReduce' when rebuilding the lambda, passing the-    evaluation context `CS(C1(L))` along. Then we simply peel off 2 call+    evaluation context `C(S,C(1,L))` along. Then we simply peel off 2 call     sub-demands `Cn` and see whether all of the n's (here: `S=C_1N` and     `1=C_11`) were strict. And strict they are! Thus, it will eta-reduce     `\x y. e x y` to `e`.

@@ -1288,7 +1288,7 @@ word64Result' result = Lit (mkLitWord64Wrap result)  --- | 'ambiant (primop x) = x', but not nececesarily 'primop (ambient x) = x'.+-- | 'ambient (primop x) = x', but not necessarily 'primop (ambient x) = x'. semiInversePrimOp :: PrimOp -> RuleM CoreExpr semiInversePrimOp primop = do   [Var primop_id `App` e] <- getArgs@@ -2909,7 +2909,7 @@  andFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr andFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of-    -- R2) * `or` `and` simplications+    -- R2) * `or` `and` simplifications     -- l1 and (l2 and x) ==> (l1 and l2) and x     (L l1, is_lit_and num_ops -> Just (l2, x))        -> Just (mkL (l1 .&. l2) `and` x)@@ -2932,7 +2932,7 @@  orFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr orFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of-    -- R2) *  `or` `and` simplications+    -- R2) *  `or` `and` simplifications     -- l1 or (l2 or x) ==> (l1 or l2) or x     (L l1, is_lit_or num_ops -> Just (l2, x))        -> Just (mkL (l1 .|. l2) `or` x)

@@ -35,7 +35,7 @@     getAnnotations, getFirstAnnotations,      -- ** Screen output-    putMsg, putMsgS, errorMsg, errorMsgS, msg,+    putMsg, putMsgS, errorMsg, msg,     fatalErrorMsg, fatalErrorMsgS,     debugTraceMsg, debugTraceMsgS,   ) where@@ -267,7 +267,7 @@  -- Convenience accessors for useful fields of HscEnv --- | Adjust the dyn flags passed to the arugment action+-- | Adjust the dyn flags passed to the argument action mapDynFlagsCoreM :: (DynFlags -> DynFlags) -> CoreM a -> CoreM a mapDynFlagsCoreM f m = CoreM $ do   !e <- getEnv@@ -363,9 +363,9 @@     loc    <- getSrcSpanM     unqual <- getPrintUnqualified     let sty = case msg_class of-                MCDiagnostic _ _ -> err_sty-                MCDump           -> dump_sty-                _                -> user_sty+                MCDiagnostic _ _ _ -> err_sty+                MCDump             -> dump_sty+                _                  -> user_sty         err_sty  = mkErrStyle unqual         user_sty = mkUserStyle unqual AllTheWay         dump_sty = mkDumpStyle unqual@@ -378,10 +378,6 @@ -- | Output a message to the screen putMsg :: SDoc -> CoreM () putMsg = msg MCInfo---- | Output an error to the screen. Does not cause the compiler to die.-errorMsgS :: String -> CoreM ()-errorMsgS = errorMsg . text  -- | Output an error to the screen. Does not cause the compiler to die. errorMsg :: SDoc -> CoreM ()

@@ -788,7 +788,7 @@          --     h = ...          --     g = ...          --     RULE map g = h-         -- Then we want to ensure that h is in scope everwhere+         -- Then we want to ensure that h is in scope everywhere          -- that g is (since the RULE might turn g into h), so          -- we make g mention h. @@ -958,7 +958,7 @@ (which occurs just once), but because it is last we won't actually substitute in lvl2.  Sigh. -To avoid this possiblity, we include edges from lvl2 to /both/ its+To avoid this possibility, we include edges from lvl2 to /both/ its stable unfolding /and/ its RHS.  Hence the defn of inl_fvs in makeNode.  Maybe we could be more clever, but it's very much a corner case.@@ -1222,7 +1222,7 @@         $s$dm2 = \x. op dBool } The RULES stuff means that we can't choose $dm as a loop breaker (Note [Choosing loop breakers]), so we must choose at least (say)-opInt *and* opBool, and so on.  The number of loop breakders is+opInt *and* opBool, and so on.  The number of loop breakers is linear in the number of instance declarations.  Note [Loop breakers and INLINE/INLINABLE pragmas]@@ -1867,7 +1867,7 @@ {- Note [Occ-anal and cast worker/wrapper] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider   y = e; x = y |> co-If we mark y as used-once, we'll inline y into x, and the the Cast+If we mark y as used-once, we'll inline y into x, and the Cast worker/wrapper transform will float it straight back out again.  See Note [Cast worker/wrapper] in GHC.Core.Opt.Simplify. @@ -2368,7 +2368,7 @@     f's strictness signature into e1 .. en, but /only/ if n is enough to     saturate the strictness signature. A strictness signature like -          f :: C1(C1(L))LS+          f :: C(1,C(1,L))LS      means that *if f is applied to three arguments* then it will guarantee to     call its first argument at most once, and to call the result of that at@@ -2404,10 +2404,10 @@ B:  Let-bindings:  eg   let f = \c. let ... in \n -> blah                         in (build f, build f) -    Propagate one-shot info from the demanand-info on 'f' to the+    Propagate one-shot info from the demand-info on 'f' to the     lambdas in its RHS (which may not be syntactically at the top) -    This information must have come from a previous run of the demanand+    This information must have come from a previous run of the demand     analyser.  Previously, the demand analyser would *also* set the one-shot information, but@@ -2550,7 +2550,7 @@  addInScope :: OccEnv -> [Var] -> OccEnv -- See Note [The binder-swap substitution]--- It's only neccessary to call this on in-scope Ids,+-- It's only necessary to call this on in-scope Ids, -- but harmless to include TyVars too addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndrs   | any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }

@@ -45,7 +45,8 @@   | CoreDoStaticArgs   | CoreDoCallArity   | CoreDoExitify-  | CoreDoDemand+  | CoreDoDemand Bool  -- Bool: Do worker/wrapper afterwards?+                       -- See Note [Don't change boxity without worker/wrapper]   | CoreDoCpr   | CoreDoWorkerWrapper   | CoreDoSpecialising@@ -74,7 +75,8 @@   ppr CoreDoStaticArgs         = text "Static argument"   ppr CoreDoCallArity          = text "Called arity analysis"   ppr CoreDoExitify            = text "Exitification transformation"-  ppr CoreDoDemand             = text "Demand analysis"+  ppr (CoreDoDemand True)      = text "Demand analysis (including Boxity)"+  ppr (CoreDoDemand False)     = text "Demand analysis"   ppr CoreDoCpr                = text "Constructed Product Result analysis"   ppr CoreDoWorkerWrapper      = text "Worker Wrapper binds"   ppr CoreDoSpecialising       = text "Specialise"

@@ -468,7 +468,7 @@   binding site.  * The in-scope "set" usually maps x->x; we use it simply for its domain.-  But sometimes we have two in-scope Ids that are synomyms, and should+  But sometimes we have two in-scope Ids that are synonyms, and should   map to the same target:  x->x, y->x.  Notably:         case y of x { ... }   That's why the "set" is actually a VarEnv Var@@ -1160,7 +1160,7 @@ adjustJoinPointType :: Mult                     -> Type     -- New result type                     -> Id       -- Old join-point Id-                    -> Id       -- Adjusted jont-point Id+                    -> Id       -- Adjusted join-point Id -- (adjustJoinPointType mult new_res_ty join_id) does two things: -- --   1. Set the return type of the join_id to new_res_ty

@@ -628,7 +628,7 @@                            , extendIdSubst (setInScopeFromF env floats) old_bndr $                              DoneEx triv_rhs Nothing ) } -          else do { wrap_unf <- mkLetUnfolding uf_opts top_lvl InlineRhs bndr triv_rhs+          else do { wrap_unf <- mkLetUnfolding uf_opts top_lvl VanillaSrc bndr triv_rhs                   ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)                                 `setIdUnfolding`  wrap_unf                         floats' = floats `extendFloats` NonRec bndr' triv_rhs@@ -659,7 +659,7 @@       = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers            unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })              | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) })-           _ -> mkLetUnfolding uf_opts top_lvl InlineRhs work_id work_rhs+           _ -> mkLetUnfolding uf_opts top_lvl VanillaSrc work_id work_rhs  tryCastWorkerWrapper env _ _ _ bndr rhs  -- All other bindings   = do { traceSmpl "tcww:no" (vcat [ text "bndr:" <+> ppr bndr@@ -668,9 +668,9 @@  mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma -- See Note [Cast worker/wrapper]-mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info })+mkCastWrapperInlinePrag (InlinePragma { inl_inline = fn_inl, inl_act = fn_act, inl_rule = rule_info })   = InlinePragma { inl_src    = SourceText "{-# INLINE"-                 , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInlinePrag]+                 , inl_inline = fn_inl       -- See Note [Worker/wrapper for INLINABLE functions]                  , inl_sat    = Nothing      --     in GHC.Core.Opt.WorkWrap                  , inl_act    = wrap_act     -- See Note [Wrapper activation]                  , inl_rule   = rule_info }  --     in GHC.Core.Opt.WorkWrap@@ -678,8 +678,8 @@   where     -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap     -- But simpler, because we don't need to disable during InitialPhase-    wrap_act | isNeverActive act = activateDuringFinal-             | otherwise         = act+    wrap_act | isNeverActive fn_act = activateDuringFinal+             | otherwise            = fn_act   {- *********************************************************************@@ -841,7 +841,7 @@           -- the 'floats' from prepareRHS; but they are all fresh, so there is           -- no danger of introducing name shadowig in eta expansion -        ; unf <- mkLetUnfolding uf_opts top_lvl InlineRhs var expr2+        ; unf <- mkLetUnfolding uf_opts top_lvl VanillaSrc var expr2          ; let final_id = addLetBndrInfo var arity_type unf               bind     = NonRec final_id expr2@@ -2939,7 +2939,7 @@     -- We can call isUnliftedType here: scrutinees always have a fixed RuntimeRep (see FRRCase).     -- Note however that we must check 'scrut' (which is an 'OutExpr') and not 'case_bndr'     -- (which is an 'InId'): see Note [Dark corner with representation polymorphism].-    -- Using `exprType` is typically cheap becuase `scrut` is typically a variable.+    -- Using `exprType` is typically cheap because `scrut` is typically a variable.     -- We could instead use mightBeUnliftedType (idType case_bndr), but that hurts     -- the brain more.  Consider that if this test ever turns out to be a perf     -- problem (which seems unlikely).@@ -4110,7 +4110,7 @@   | otherwise   = -- Otherwise, we end up retaining all the SimpleEnv     let !opts = seUnfoldingOpts env-    in mkLetUnfolding opts (bindContextLevel bind_cxt) InlineRhs id new_rhs+    in mkLetUnfolding opts (bindContextLevel bind_cxt) VanillaSrc id new_rhs  ------------------- mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource@@ -4161,23 +4161,14 @@                                         ; expr' <- simplExprC unf_env expr cont                                         ; return (eta_expand expr') }               ; case guide of-                  UnfWhen { ug_arity = arity-                          , ug_unsat_ok = sat_ok-                          , ug_boring_ok = boring_ok-                          }-                          -- Happens for INLINE things-                        -- Really important to force new_boring_ok as otherwise-                        -- `ug_boring_ok` is a thunk chain of-                        -- inlineBoringExprOk expr0-                        --  || inlineBoringExprOk expr1 || ...-                        --  See #20134+                  UnfWhen { ug_boring_ok = boring_ok }+                     -- Happens for INLINE things+                     -- Really important to force new_boring_ok since otherwise+                     --   `ug_boring_ok` is a thunk chain of+                     --   inlineBoringExprOk expr0 || inlineBoringExprOk expr1 || ...+                     -- See #20134                      -> let !new_boring_ok = boring_ok || inlineBoringOk expr'-                            guide' =-                              UnfWhen { ug_arity = arity-                                      , ug_unsat_ok = sat_ok-                                      , ug_boring_ok = new_boring_ok--                                      }+                            guide' = guide { ug_boring_ok = new_boring_ok }                         -- Refresh the boring-ok flag, in case expr'                         -- has got small. This happens, notably in the inlinings                         -- for dfuns for single-method classes; see

@@ -320,7 +320,7 @@                                 --   that the function diverges after being given                                 --   that number of args -        ai_discs :: [Int]       -- Discounts for remaining value arguments (beyong ai_args)+        ai_discs :: [Int]       -- Discounts for remaining value arguments (beyond ai_args)                                 --   non-zero => be keener to inline                                 --   Always infinite     }@@ -566,10 +566,10 @@   ApplyToTy{sc_cont=k}       -> contEvalContext k     --  ApplyToVal{sc_cont=k}      -> mkCalledOnceDmd $ contEvalContext k     -- Not 100% sure that's correct, . Here's an example:-    --   f (e x) and f :: <SCS(C1(L))>+    --   f (e x) and f :: <SC(S,C(1,L))>     -- then what is the evaluation context of 'e' when we simplify it? E.g.,-    --   simpl e (ApplyToVal x $ Stop "CS(C1(L))")-    -- then it *should* be "C1(CS(C1(L))", so perhaps correct after all.+    --   simpl e (ApplyToVal x $ Stop "C(S,C(1,L))")+    -- then it *should* be "C(1,C(S,C(1,L))", so perhaps correct after all.     -- But for now we just panic:   ApplyToVal{}               -> pprPanic "contEvalContext" (ppr k)   StrictArg{sc_fun=fun_info} -> subDemandIfEvaluated (head (ai_dmds fun_info))@@ -1643,11 +1643,7 @@     mb_rhs   = contIsRhs cont      -- See Note [Eta reduction based on evaluation context]-    eval_sd-      | sePedanticBottoms env = topSubDmd-          -- See Note [Eta reduction soundness], criterion (S)-          -- the bit about -fpedantic-bottoms-      | otherwise = contEvalContext cont+    eval_sd = contEvalContext cont         -- NB: cont is never ApplyToVal, because beta-reduction would         -- have happened.  So contEvalContext can panic on ApplyToVal. @@ -2001,7 +1997,7 @@     mentioned in the abstracted body. This means:     - they are automatically in dependency order, because main_tvs is     - there is no issue about non-determinism-    - we don't gratuitiously change order, which may help (in a tiny+    - we don't gratuitously change order, which may help (in a tiny       way) with CSE and/or the compiler-debugging experience -} @@ -2081,7 +2077,7 @@       = (poly_id `setIdUnfolding` unf, poly_rhs)       where         poly_rhs = mkLams tvs_here rhs-        unf = mkUnfolding uf_opts InlineRhs is_top_lvl False poly_rhs+        unf = mkUnfolding uf_opts VanillaSrc is_top_lvl False poly_rhs          -- We want the unfolding.  Consider         --      let@@ -2229,7 +2225,7 @@        }  which merges two cases in one case when -- the default alternative of-the outer case scrutises the same variable as the outer case. This+the outer case scrutinises the same variable as the outer case. This transformation is called Case Merging.  It avoids that the same variable is scrutinised multiple times. @@ -2500,7 +2496,7 @@      DEFAULT -> e1      1#      -> e2 -This may generate sligthtly better code (although it should not, since+This may generate slightly better code (although it should not, since all cases are exhaustive) and/or optimise better.  I'm not certain that it's necessary, but currently we do make this change.  We do it here, NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum]

@@ -22,12 +22,14 @@  import GHC.Data.FastString -import Data.List (groupBy, sortBy)+import Data.List (sortOn)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE import Data.Ord import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Map.Strict as MapStrict-import GHC.Utils.Panic (throwGhcException, GhcException(..), panic)+import GHC.Utils.Panic (throwGhcException, GhcException(..))  getVerboseSimplStats :: (Bool -> SDoc) -> SDoc getVerboseSimplStats = getPprDebug          -- For now, anyway@@ -205,18 +207,16 @@ pprTickCounts counts   = vcat (map pprTickGroup groups)   where-    groups :: [[(Tick,Int)]]    -- Each group shares a common tag-                                -- toList returns common tags adjacent-    groups = groupBy same_tag (Map.toList counts)-    same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2+    groups :: [NonEmpty (Tick, Int)] -- Each group shares a common tag+                                     -- toList returns common tags adjacent+    groups = NE.groupWith (tickToTag . fst) (Map.toList counts) -pprTickGroup :: [(Tick, Int)] -> SDoc-pprTickGroup group@((tick1,_):_)-  = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))+pprTickGroup :: NonEmpty (Tick, Int) -> SDoc+pprTickGroup group@((tick1,_) :| _)+  = hang (int (sum (fmap snd group)) <+> text (tickString tick1))        2 (vcat [ int n <+> pprTickCts tick                                     -- flip as we want largest first-               | (tick,n) <- sortBy (flip (comparing snd)) group])-pprTickGroup [] = panic "pprTickGroup"+               | (tick,n) <- sortOn (Down . snd) (NE.toList group)])  data Tick  -- See Note [Which transformations are innocuous]   = PreInlineUnconditionally    Id

@@ -378,7 +378,7 @@ -- | Build a new pattern synonym mkPatSyn :: Name          -> Bool                 -- ^ Is the pattern synonym declared infix?-         -> ([InvisTVBinder], ThetaType) -- ^ Universially-quantified type+         -> ([InvisTVBinder], ThetaType) -- ^ Universally-quantified type                                          -- variables and required dicts          -> ([InvisTVBinder], ThetaType) -- ^ Existentially-quantified type                                          -- variables and provided dicts

@@ -618,11 +618,6 @@                int size,                int discount ] -instance Outputable UnfoldingSource where-  ppr InlineCompulsory  = text "Compulsory"-  ppr InlineStable      = text "InlineStable"-  ppr InlineRhs         = text "<vanilla>"- instance Outputable Unfolding where   ppr NoUnfolding                = text "No unfolding"   ppr BootUnfolding              = text "No unfolding (from boot)"

@@ -106,7 +106,7 @@ KnownTc Int, KnownTc Char]`.  This explains the third clause of the mightMatch specification in Note [Simple Matching Semantics].-As soon as the the lookup key runs out, the remaining instances might match.+As soon as the lookup key runs out, the remaining instances might match.  Note [Matching a RoughMap] ~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -149,7 +149,7 @@ The potential matches is likely to be much smaller than the bag of potential unifiers due to the reasoning about rigid type variables described in Note [Matching a RoughMap]. On the other hand, the instances captured by the RML_NoKnownTC case can still potentially unify-with any instance (depending on the substituion of said rigid variable) so they can't be discounted+with any instance (depending on the substitution of said rigid variable) so they can't be discounted from the list of potential unifiers. This is achieved by the RML_NoKnownTC case continuing the lookup for unifiers by replacing RML_NoKnownTC with RML_LookupOtherTC. @@ -315,7 +315,7 @@  -- | N.B. Returns a 'Bag' for matches, which allows us to avoid rebuilding all of the lists -- we find in 'rm_empty', which would otherwise be necessary due to '++' if we--- returned a list. We use a list for unifiers becuase the tail is computed lazily and+-- returned a list. We use a list for unifiers because the tail is computed lazily and -- we often only care about the first couple of potential unifiers. Constructing a -- bag forces the tail which performs much too much work. --

@@ -153,7 +153,7 @@    In a single simplifier run new rules can be added into the EPS so it matters   to keep an up-to-date view of which rules have been loaded. For examples of-  where this went wrong and caused cryptic performance regressions seee+  where this went wrong and caused cryptic performance regressions   see T19790 and !6735.  @@ -971,7 +971,7 @@ -- Note the match on MRefl!  We fail if there is a cast in the target --     (e1 e2) ~ (d1 d2) |> co -- See Note [Cancel reflexive casts]: in the Cast equations for 'match'--- we agressively ensure that if MCo is reflective, it really is MRefl.+-- we aggressively ensure that if MCo is reflective, it really is MRefl. match renv subst (App f1 a1) (App f2 a2) MRefl   = do  { subst' <- match renv subst f1 f2 MRefl         ; match renv subst' a1 a2 MRefl }@@ -1150,7 +1150,7 @@ and we really want to spot that the co/sym-co cancels out. Hence   * We keep an invariant that the MCoercion is always MRefl-    if the MCoercion is reflextve+    if the MCoercion is reflexive   * We maintain this invariant via the call to checkReflexiveMCo     in the Cast case of 'match'. -}

@@ -275,7 +275,7 @@               (env', mb_prs) = mapAccumL (simple_out_bind NotTopLevel) env $                                zipEqual "simpleOptExpr" bs es -         -- Note [Getting the map/coerce RULE to work]+         -- See Note [Getting the map/coerce RULE to work]       | isDeadBinder b       , [Alt DEFAULT _ rhs] <- as       , isCoVarType (varType b)@@ -756,7 +756,7 @@                  | otherwise                  = unfolding_from_rhs -   unfolding_from_rhs = mkUnfolding uf_opts InlineRhs+   unfolding_from_rhs = mkUnfolding uf_opts VanillaSrc                                     (isTopLevel top_level)                                     False -- may be bottom or not                                     new_rhs

@@ -192,7 +192,7 @@   | Just v' <- lookupInScope in_scope v = Var v'         -- Vital! See Note [Extending the IdSubstEnv]         -- If v isn't in the InScopeSet, we panic, because-        -- it's a bad bug and we reallly want to know+        -- it's a bad bug and we really want to know   | otherwise = pprPanic "lookupIdSubst" (ppr v $$ ppr in_scope)  delBndr :: Subst -> Var -> Subst

@@ -400,7 +400,7 @@    (a) To make printing tidy core nicer -  (b) Because we tidy RULES and InlineRules, which may then propagate+  (b) Because we tidy RULES and unfoldings, which may then propagate       via --make into the compilation of the next module, and we want       the benefit of that occurrence analysis when we use the rule or       or inline the function.  In particular, it's vital not to lose

@@ -219,7 +219,7 @@ *                                                                      * ********************************************************************* -} -{- Note [Acumulating parameter free variables]+{- Note [Accumulating parameter free variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We can use foldType to build an accumulating-parameter version of a free-var finder, thus:@@ -254,7 +254,7 @@ AppTy equation we don't build a thunk for (fvs env t2 acc).  The optimiser does do all this, but not very robustly. It depends-critially on the basic arity-2 function not being exported, so that+critically on the basic arity-2 function not being exported, so that all its calls are visibly to three arguments. This analysis is done by the Call Arity pass. 

@@ -569,7 +569,7 @@ about outermost casts to uphold (EQ). Eliminating reflexive casts is done in mkCastTy. This is (EQ1) below. -Unforunately, that's not the end of the story. Consider comparing+Unfortunately, that's not the end of the story. Consider comparing   (T a b c)      =?       (T a b |> (co -> <Type>)) (c |> co) These two types have the same kind (Type), but the left type is a TyConApp while the right type is not. To handle this case, we say that the right-hand@@ -1720,7 +1720,7 @@     holes are easier.    - Moreover, nothing is lost from the lack of let-bindings. For-    dictionaries want to achieve sharing to avoid recomoputing the+    dictionaries want to achieve sharing to avoid recomputing the     dictionary.  But coercions are entirely erased, so there's little     benefit to sharing. Indeed, even if we had a let-binding, we     always inline types and coercions at every use site and drop the

@@ -108,6 +108,7 @@         mkTyConTagMap,          -- ** Manipulating TyCons+        ExpandSynResult(..),         expandSynTyCon_maybe,         newTyConCo, newTyConCo_maybe,         pprPromotionQuote, mkTyConKind,@@ -695,7 +696,7 @@  * Similarly, when typechecking default definitions for class methods, in   GHC.Tc.TyCl.Class.tcClassDecl2, we only have the (final) Class available;-  but the variables bound in that class must be in scope.  Eample (#19738):+  but the variables bound in that class must be in scope.  Example (#19738):      type P :: k -> Type     data P a = MkP@@ -989,7 +990,7 @@         tyConArity   :: Arity,         -- ^ Arity         tyConNullaryTy :: Type,           -- ^ A pre-allocated @TyConApp tycon []@ -          -- NB: the TyConArity of a TcTyCon must match+          -- NB: the tyConArity of a TcTyCon must match           -- the number of Required (positional, user-specified)           -- arguments to the type constructor; see the use           -- of tyConArity in generaliseTcTyCon@@ -1012,7 +1013,7 @@ between the original, user-specified Name (i.e. thing in scope) and the TcTyVar that the Name is bound to. -Order *does* matter; the tcTyConScopedTyvars list consists of+Order *does* matter; the tcTyConScopedTyVars list consists of      specified_tvs ++ required_tvs  where@@ -2521,12 +2522,14 @@ ----------------------------------------------- -} +data ExpandSynResult tyco+  = NoExpansion+  | ExpandsSyn [(TyVar,tyco)] Type [tyco]+ expandSynTyCon_maybe         :: TyCon         -> [tyco]                 -- ^ Arguments to 'TyCon'-        -> Maybe ([(TyVar,tyco)],-                  Type,-                  [tyco])         -- ^ Returns a 'TyVar' substitution, the body+        -> ExpandSynResult tyco       -- ^ Returns a 'TyVar' substitution, the body                                   -- type of the synonym (not yet substituted)                                   -- and any arguments remaining from the                                   -- application@@ -2536,13 +2539,13 @@ expandSynTyCon_maybe tc tys   | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc   = if arity == 0-    then Just ([], rhs, tys)  -- Avoid a bit of work in the case of nullary synonyms+    then ExpandsSyn [] rhs tys  -- Avoid a bit of work in the case of nullary synonyms     else case tys `listLengthCmp` arity of-              GT -> Just (tvs `zip` tys, rhs, drop arity tys)-              EQ -> Just (tvs `zip` tys, rhs, [])-              LT -> Nothing+              GT -> ExpandsSyn (tvs `zip` tys) rhs (drop arity tys)+              EQ -> ExpandsSyn (tvs `zip` tys) rhs []+              LT -> NoExpansion    | otherwise-   = Nothing+   = NoExpansion  ---------------- 

@@ -4,6 +4,7 @@ -- Type - public interface  {-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE MagicHash #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -294,9 +295,10 @@ import GHC.Data.List.SetOps import GHC.Types.Unique ( nonDetCmpUnique ) +import GHC.Base (reallyUnsafePtrEquality#) import GHC.Data.Maybe   ( orElse, expectJust, isJust ) import Control.Monad    ( guard )--- import GHC.Utils.Trace+import qualified Data.Semigroup as S  -- $type_classification -- #type_classification#@@ -555,7 +557,7 @@     in_scope = mkInScopeSet (tyCoVarsOfType ty)      go subst (TyConApp tc tys)-      | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc expanded_tys+      | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc expanded_tys       = let subst' = mkTvSubst in_scope (mkVarEnv tenv)             -- Make a fresh substitution; rhs has nothing to             -- do with anything that has happened so far@@ -1431,7 +1433,7 @@         pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args)  applyTysX :: [TyVar] -> Type -> [Type] -> Type--- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys+-- applyTysX beta-reduces (/\tvs. body_ty) arg_tys -- Assumes that (/\tvs. body_ty) is closed applyTysX tvs body_ty arg_tys   = assertPpr (tvs `leLength` arg_tys) pp_stuff $@@ -2786,6 +2788,16 @@ nonDetCmpTypeX. See Note [Unique Determinism] for more details. +Note [Type comparisons using object pointer comparisons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Quite often we substitute the type from a definition site into+occurances without a change. This means for code like:+    \x -> (x,x,x)+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%.+ Note [Computing equality on types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are several places within GHC that depend on the precise choice of@@ -2799,11 +2811,15 @@ -}  nonDetCmpType :: Type -> Type -> Ordering+nonDetCmpType !t1 !t2+  -- See Note [Type comparisons using object pointer comparisons]+  | 1# <- reallyUnsafePtrEquality# t1 t2+  = EQ nonDetCmpType (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2   = EQ-nonDetCmpType t1 t2+nonDetCmpType t1 t2 =   -- we know k1 and k2 have the same kind, because they both have kind *.-  = nonDetCmpTypeX rn_env t1 t2+  nonDetCmpTypeX rn_env t1 t2   where     rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2])) {-# INLINE nonDetCmpType #-}@@ -2882,7 +2898,7 @@     go env (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2)         -- NB: nonDepCmpTypeX does the kind check requested by         -- Note [Equality on FunTys] in GHC.Core.TyCo.Rep-      = liftOrdering (nonDetCmpTypeX env s1 s2 `thenCmp` nonDetCmpTypeX env t1 t2)+      = liftOrdering (nonDetCmpTypeX env s1 s2 S.<> nonDetCmpTypeX env t1 t2)           `thenCmpTy` go env w1 w2         -- Comparing multiplicities last because the test is usually true     go env (TyConApp tc1 tys1) (TyConApp tc2 tys2)@@ -2916,8 +2932,7 @@ ------------- nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering nonDetCmpTypesX _   []        []        = EQ-nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2-                                          `thenCmp`+nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2 S.<>                                           nonDetCmpTypesX env tys1 tys2 nonDetCmpTypesX _   []        _         = LT nonDetCmpTypesX _   _         []        = GT@@ -3012,7 +3027,7 @@ normally it would make no sense to have    forall r. (ty :: K r) because the kind of the forall would escape the binding-of 'r'.  But in this case it's fine because (K r) exapands+of 'r'.  But in this case it's fine because (K r) expands to Type, so we explicitly /permit/ the type    forall r. T r @@ -3079,7 +3094,7 @@   , tcIsConstraintKind (tcTypeKind res)   = constraintKind     -- Eq a => Ord a         :: Constraint   | otherwise          -- Eq a => a -> a        :: TYPE LiftedRep-  = liftedTypeKind     -- Eq a => Array# Int    :: Type LiftedRep (not TYPE PtrRep)+  = liftedTypeKind     -- Eq a => Array# Int    :: TYPE LiftedRep (not TYPE PtrRep)  tcTypeKind (AppTy fun arg)   = go fun [arg]@@ -3714,7 +3729,7 @@ * Given the first n arguments of T, do the kinds of the non-omitted arguments   fill in the omitted arguments? -(This is still a bit hand-wavey, but we'll refine this question incrementally+(This is still a bit hand-wavy, but we'll refine this question incrementally as we explain more of the machinery underlying this process.)  Answering this question is precisely the role that the `injectiveVarsOfType`@@ -3787,7 +3802,7 @@      There are some situations where using visible kind application is appropriate     and others where it is not (e.g., TH-    reification), so the `injective_vars_of_binder` function is parametrized by+    reification), so the `injective_vars_of_binder` function is parameterized by     a Bool which decides if specified binders should be counted towards     injective positions or not. 

@@ -735,7 +735,7 @@ charge 10 for each case alternative (see size_up_alt).  If we give a bigger discount (say 20) in conSize, we'll make the case expression cost *nothing*, and that can make a huge case tree cost nothing. This-leads to massive, sometimes exponenial inlinings (#18282).  In short,+leads to massive, sometimes exponential inlinings (#18282).  In short, don't give a discount that give a negative size to a sub-expression!  Historical note 2: Much longer ago, Simon M tried a MUCH bigger@@ -1213,7 +1213,7 @@              , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]      ctx = log_default_dump_context (logFlags logger)-    str = "Considering inlining: " ++ renderWithContext ctx (ppr id)+    str = "Considering inlining: " ++ showSDocOneLine ctx (ppr id)     n_val_args = length arg_infos             -- some_benefit is used when the RHS is small enough@@ -1307,20 +1307,6 @@     Make sure that x does not inline unconditionally!     Lest we get extra allocation. -Note [Inlining an InlineRule]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-An InlineRules is used for-  (a) programmer INLINE pragmas-  (b) inlinings from worker/wrapper--For (a) the RHS may be large, and our contract is that we *only* inline-when the function is applied to all the arguments on the LHS of the-source-code defn.  (The uf_arity in the rule.)--However for worker/wrapper it may be worth inlining even if the-arity is not satisfied (as we do in the CoreUnfolding case) so we don't-require saturation.- Note [Nested functions] ~~~~~~~~~~~~~~~~~~~~~~~ At one time we treated a call of a non-top-level function as@@ -1399,8 +1385,8 @@ However, watch out:   * Consider this:-        foo = _inline_ (\n. [n])-        bar = _inline_ (foo 20)+        foo = \n. [n])  {-# INLINE foo #-}+        bar = foo 20    {-# INLINE bar #-}         baz = \n. case bar of { (m:_) -> m + n }    Here we really want to inline 'bar' so that we can inline 'foo'    and the whole thing unravels as it should obviously do.  This is@@ -1408,9 +1394,9 @@    structure rather than a list.     So the non-inlining of lone_variables should only apply if the-   unfolding is regarded as cheap; because that is when exprIsConApp_maybe-   looks through the unfolding.  Hence the "&& is_wf" in the-   InlineRule branch.+   unfolding is regarded as expandable; because that is when+   exprIsConApp_maybe looks through the unfolding.  Hence the "&&+   is_exp" in the CaseCtxt branch of interesting_call   * Even a type application or coercion isn't a lone variable.    Consider

@@ -8,13 +8,12 @@    , mkFinalUnfolding    , mkSimpleUnfolding    , mkWorkerUnfolding-   , mkInlineUnfolding-   , mkInlineUnfoldingWithArity+   , mkInlineUnfoldingWithArity, mkInlineUnfoldingNoArity    , mkInlinableUnfolding    , mkWrapperUnfolding-   , mkCompulsoryUnfolding-   , mkCompulsoryUnfolding'+   , mkCompulsoryUnfolding, mkCompulsoryUnfolding'    , mkDFunUnfolding+   , mkDataConUnfolding    , specUnfolding    , certainlyWillInline    )@@ -50,15 +49,14 @@                 (isDeadEndSig strict_sig)                 expr --- | Used for things that absolutely must be unfolded-mkCompulsoryUnfolding :: SimpleOpts -> CoreExpr -> Unfolding-mkCompulsoryUnfolding opts expr = mkCompulsoryUnfolding' (simpleOptExpr opts expr)+-- | Same as 'mkCompulsoryUnfolding' but simplifies the unfolding first+mkCompulsoryUnfolding' :: SimpleOpts -> CoreExpr -> Unfolding+mkCompulsoryUnfolding' opts expr = mkCompulsoryUnfolding (simpleOptExpr opts expr) --- | Same as 'mkCompulsoryUnfolding' but no simple optimiser pass is performed--- on the unfolding.-mkCompulsoryUnfolding' :: CoreExpr -> Unfolding-mkCompulsoryUnfolding' expr-  = mkCoreUnfolding InlineCompulsory True+-- | Used for things that absolutely must be unfolded+mkCompulsoryUnfolding :: CoreExpr -> Unfolding+mkCompulsoryUnfolding expr+  = mkCoreUnfolding CompulsorySrc True                     expr                     (UnfWhen { ug_arity = 0    -- Arity of unfolding doesn't matter                              , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk })@@ -71,7 +69,7 @@  mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding mkSimpleUnfolding !opts rhs-  = mkUnfolding opts InlineRhs False False rhs+  = mkUnfolding opts VanillaSrc False False rhs  mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding mkDFunUnfolding bndrs con ops@@ -80,11 +78,21 @@                   , df_args = map occurAnalyseExpr ops }                   -- See Note [Occurrence analysis of unfoldings] +mkDataConUnfolding :: CoreExpr -> Unfolding+-- Used for non-newtype data constructors with non-trivial wrappers+mkDataConUnfolding expr+  = mkCoreUnfolding StableSystemSrc True expr guide+    -- No need to simplify the expression+  where+    guide = UnfWhen { ug_arity     = manifestArity expr+                    , ug_unsat_ok  = unSaturatedOk+                    , ug_boring_ok = False }+ mkWrapperUnfolding :: SimpleOpts -> CoreExpr -> Arity -> Unfolding -- Make the unfolding for the wrapper in a worker/wrapper split -- after demand/CPR analysis mkWrapperUnfolding opts expr arity-  = mkCoreUnfolding InlineStable True+  = mkCoreUnfolding StableSystemSrc True                     (simpleOptExpr opts expr)                     (UnfWhen { ug_arity     = arity                              , ug_unsat_ok  = unSaturatedOk@@ -103,13 +111,13 @@  mkWorkerUnfolding _ _ _ = noUnfolding --- | Make an unfolding that may be used unsaturated+-- | Make an INLINE unfolding that may be used unsaturated -- (ug_unsat_ok = unSaturatedOk) and that is reported as having its -- manifest arity (the number of outer lambdas applications will -- resolve before doing any work).-mkInlineUnfolding :: SimpleOpts -> CoreExpr -> Unfolding-mkInlineUnfolding opts expr-  = mkCoreUnfolding InlineStable+mkInlineUnfoldingNoArity :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding+mkInlineUnfoldingNoArity opts src expr+  = mkCoreUnfolding src                     True         -- Note [Top-level flag on inline rules]                     expr' guide   where@@ -119,11 +127,11 @@                     , ug_boring_ok = boring_ok }     boring_ok = inlineBoringOk expr' --- | Make an unfolding that will be used once the RHS has been saturated+-- | Make an INLINE unfolding that will be used once the RHS has been saturated -- to the given arity.-mkInlineUnfoldingWithArity :: Arity -> SimpleOpts -> CoreExpr -> Unfolding-mkInlineUnfoldingWithArity arity opts expr-  = mkCoreUnfolding InlineStable+mkInlineUnfoldingWithArity :: SimpleOpts -> UnfoldingSource -> Arity -> CoreExpr -> Unfolding+mkInlineUnfoldingWithArity opts src arity expr+  = mkCoreUnfolding src                     True         -- Note [Top-level flag on inline rules]                     expr' guide   where@@ -136,9 +144,9 @@     boring_ok | arity == 0 = True               | otherwise  = inlineBoringOk expr' -mkInlinableUnfolding :: SimpleOpts -> CoreExpr -> Unfolding-mkInlinableUnfolding opts expr-  = mkUnfolding (so_uf_opts opts) InlineStable False False expr'+mkInlinableUnfolding :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding+mkInlinableUnfolding opts src expr+  = mkUnfolding (so_uf_opts opts) src False False expr'   where     expr' = simpleOptExpr opts expr @@ -193,25 +201,40 @@   must do so too!  Otherwise we lose the magic rules that make it   interact with ClassOps -* There is a bit of hack for INLINABLE functions:-     f :: Ord a => ....-     f = <big-rhs>-     {- INLINABLE f #-}-  Now if we specialise f, should the specialised version still have-  an INLINABLE pragma?  If it does, we'll capture a specialised copy-  of <big-rhs> as its unfolding, and that probably won't inline.  But-  if we don't, the specialised version of <big-rhs> might be small-  enough to inline at a call site. This happens with Control.Monad.liftM3,-  and can cause a lot more allocation as a result (nofib n-body shows this).+* For a /stable/ CoreUnfolding, we specialise the unfolding, no matter+  how big, iff it has UnfWhen guidance.  This happens for INLINE+  functions, and for wrappers.  For these, it would be very odd if a+  function marked INLINE was specialised (because of some local use),+  and then forever after (including importing modules) the specialised+  version wasn't INLINEd!  After all, the programmer said INLINE. -  Moreover, keeping the INLINABLE thing isn't much help, because+* However, for a stable CoreUnfolding with guidance UnfoldIfGoodArgs,+  which arises from INLINABLE functions, we drop the unfolding.+  See #4874 for persuasive examples.  Suppose we have+    {-# INLINABLE f #-}+    f :: Ord a => [a] -> Int f xs = letrec f' = ...f'... in f'++  Then, when f is specialised and optimised we might get+    wgo :: [Int] -> Int#+    wgo = ...wgo...+    f_spec :: [Int] -> Int+    f_spec xs = case wgo xs of { r -> I# r }++  and we clearly want to inline f_spec at call sites.  But if we still+  have the big, un-optimised of f (albeit specialised) captured in the+  stable unfolding for f_spec, we won't get that optimisation.++  This happens with Control.Monad.liftM3, and can cause a lot more+  allocation as a result (nofib n-body shows this).++  Moreover, keeping the stable unfoldign isn't much help, because   the specialised function (probably) isn't overloaded any more. -  Conclusion: drop the INLINEALE pragma.  In practice what this means is:-     if a stable unfolding has UnfoldingGuidance of UnfWhen,-        we keep it (so the specialised thing too will always inline)-     if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs-        (which arises from INLINABLE), we discard it+  TL;DR: we simply drop the stable unfolding when specialising. It's+  not really a complete solution; ignoring specialisation for now,+  INLINABLE functions don't get properly strictness analysed, for+  example. But it works well for examples involving specialisation,+  which is the dominant use of INLINABLE.  Note [Honour INLINE on 0-ary bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -301,29 +324,29 @@                 -> UnfoldingGuidance -> Unfolding -- Occurrence-analyses the expression before capturing it mkCoreUnfolding src top_lvl expr guidance-  =+  = CoreUnfolding { uf_tmpl = is_value `seq`+                              is_conlike `seq`+                              is_work_free `seq`+                              is_expandable `seq`+                              occurAnalyseExpr expr+      -- occAnalyseExpr: see Note [Occurrence analysis of unfoldings]+      -- See #20905 for what a discussion of these 'seq's+      -- We are careful to make sure we only+      -- have one copy of an unfolding around at once.+      -- Note [Thoughtful forcing in mkCoreUnfolding] -  let is_value = exprIsHNF expr-      is_conlike = exprIsConLike expr-      is_work_free = exprIsWorkFree expr-      is_expandable = exprIsExpandable expr-  in-  -- See #20905 for what is going on here. We are careful to make sure we only-  -- have one copy of an unfolding around at once.-  -- Note [Thoughtful forcing in mkCoreUnfolding]-  CoreUnfolding { uf_tmpl         = is_value `seq`-                                    is_conlike `seq`-                                    is_work_free `seq`-                                    is_expandable `seq`-                                      occurAnalyseExpr expr,-                      -- See Note [Occurrence analysis of unfoldings]-                    uf_src          = src,-                    uf_is_top       = top_lvl,-                    uf_is_value     = is_value,-                    uf_is_conlike   = is_conlike,-                    uf_is_work_free = is_work_free,-                    uf_expandable   = is_expandable,-                    uf_guidance     = guidance }+                  , uf_src          = src+                  , uf_is_top       = top_lvl+                  , uf_is_value     = is_value+                  , uf_is_conlike   = is_conlike+                  , uf_is_work_free = is_work_free+                  , uf_expandable   = is_expandable+                  , uf_guidance     = guidance }+  where+    is_value      = exprIsHNF expr+    is_conlike    = exprIsConLike expr+    is_work_free  = exprIsWorkFree expr+    is_expandable = exprIsExpandable expr  ---------------- certainlyWillInline :: UnfoldingOpts -> IdInfo -> CoreExpr -> Maybe Unfolding@@ -343,15 +366,13 @@              UnfIfGoodArgs { ug_size = size, ug_args = args }                         -> do_cunf size args src' tmpl'         where-          src' = -- Do not change InlineCompulsory!-                 case src of-                   InlineCompulsory -> InlineCompulsory-                   _                -> InlineStable-          tmpl' = -- Do not overwrite stable unfoldings!-                  case src of-                    InlineRhs -> occurAnalyseExpr rhs'-                    _         -> uf_tmpl fn_unf+          src' | isCompulsorySource src = src  -- Do not change InlineCompulsory!+               | otherwise              = StableSystemSrc +          tmpl' | isStableSource src = uf_tmpl fn_unf+                | otherwise          = occurAnalyseExpr rhs'+                -- Do not overwrite stable unfoldings!+       DFunUnfolding {} -> Just fn_unf  -- Don't w/w DFuns; it never makes sense                                        -- to do so, and even if it is currently a                                        -- loop breaker, it may not be later@@ -419,12 +440,12 @@  Core expressions retained in unfoldings is one of biggest uses of memory when compiling a program. Therefore we have to be careful about retaining copies of old or redundant-templates (see !6202 for a particularlly bad case).+templates (see !6202 for a particularly bad case).  With that in mind we want to maintain the invariant that each unfolding only references a single CoreExpr. One place where we have to be careful is in mkCoreUnfolding. -* The template of the unfolding is the result of performing occurence analysis+* The template of the unfolding is the result of performing occurrence analysis   (Note [Occurrence analysis of unfoldings]) * Predicates are applied to the unanalysed expression @@ -445,7 +466,7 @@ 1. Perform the predicates on the analysed expression. 2. Force the predicates to remove retainer to the old expression if we force the template. -Option 1 is bad because occurence analysis is expensive and destroys any sharing of the unfolding+Option 1 is bad because occurrence analysis is expensive and destroys any sharing of the unfolding with the actual program. (Testing this approach showed peak 25G memory usage)  Therefore we got for Option 2 which performs a little more work but compensates by

@@ -803,7 +803,7 @@    which causes the KnownBranch optimisation to kick in. If we don't    refine DEFAULT to `Foo ip1`, we are left with both case expressions. -2. combineIdenticalAlts does a better job. For exapple (Simon Jacobi)+2. combineIdenticalAlts does a better job. For example (Simon Jacobi)        data D = C0 | C1 | C2         case e of@@ -2007,7 +2007,7 @@ -- --   ex_tvs are intended to be used as binders for existential type args -----   arg_ids are indended to be used as binders for value arguments,+--   arg_ids are intended to be used as binders for value arguments, --     and their types have been instantiated with inst_tys and ex_tys --     The arg_ids include both evidence and --     programmer-specified arguments (both after rep-ing)

@@ -501,20 +501,11 @@                                 , uf_src = src                                 , uf_guidance = guidance })   = Just $ HsUnfold lb $-    case src of-        InlineStable-          -> case guidance of-               UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok =  boring_ok }-                      -> IfInlineRule arity unsat_ok boring_ok if_rhs-               _other -> IfCoreUnfold True if_rhs-        InlineCompulsory -> IfCompulsory if_rhs-        InlineRhs        -> IfCoreUnfold False if_rhs+    IfCoreUnfold src (toIfGuidance src guidance) (toIfaceExpr rhs)         -- Yes, even if guidance is UnfNever, expose the unfolding         -- If we didn't want to expose the unfolding, GHC.Iface.Tidy would         -- have stuck in NoUnfolding.  For supercompilation we want         -- to see that unfolding!-  where-    if_rhs = toIfaceExpr rhs  toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args })   = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args)))@@ -530,6 +521,12 @@   -- Can't happen; we only have BootUnfolding for imported binders  toIfUnfolding _ NoUnfolding = Nothing++toIfGuidance :: UnfoldingSource -> UnfoldingGuidance -> IfGuidance+toIfGuidance src guidance+  | UnfWhen arity unsat_ok boring_ok <- guidance+  , isStableSource src = IfWhen arity unsat_ok boring_ok+  | otherwise          = IfNoGuidance  {- ************************************************************************

@@ -6,7 +6,7 @@ Bag: an unordered collection with duplicates -} -{-# LANGUAGE ScopedTypeVariables, DeriveFunctor, TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables, DeriveTraversable, TypeFamilies #-}  module GHC.Data.Bag (         Bag, -- abstract type@@ -36,7 +36,6 @@ import Data.Maybe( mapMaybe, listToMaybe ) import Data.List ( partition, mapAccumL ) import Data.List.NonEmpty ( NonEmpty(..) )-import qualified Data.Foldable as Foldable import qualified Data.Semigroup ( (<>) )  infixr 3 `consBag`@@ -47,7 +46,7 @@   | UnitBag a   | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty   | ListBag [a]             -- INVARIANT: the list is non-empty-  deriving (Functor)+  deriving (Foldable, Functor, Traversable)  emptyBag :: Bag a emptyBag = EmptyBag@@ -323,28 +322,6 @@   gunfold _ _  = error "gunfold"   dataTypeOf _ = mkNoRepType "Bag"   dataCast1 x  = gcast1 x--instance Foldable.Foldable Bag where-  foldr _ z EmptyBag        = z-  foldr k z (UnitBag x)     = k x z-  foldr k z (TwoBags b1 b2) = foldr k (foldr k z b2) b1-  foldr k z (ListBag xs)    = foldr k z xs--  foldl _ z EmptyBag        = z-  foldl k z (UnitBag x)     = k z x-  foldl k z (TwoBags b1 b2) = foldl k (foldl k z b1) b2-  foldl k z (ListBag xs)    = foldl k z xs--  foldl' _ z EmptyBag        = z-  foldl' k z (UnitBag x)     = k z x-  foldl' k z (TwoBags b1 b2) = let r1 = foldl' k z b1 in seq r1 $ foldl' k r1 b2-  foldl' k z (ListBag xs)    = foldl' k z xs--instance Traversable Bag where-  traverse _ EmptyBag        = pure EmptyBag-  traverse f (UnitBag x)     = UnitBag <$> f x-  traverse f (TwoBags b1 b2) = TwoBags <$> traverse f b1 <*> traverse f b2-  traverse f (ListBag xs)    = ListBag <$> traverse f xs  instance IsList (Bag a) where   type Item (Bag a) = a

@@ -16,9 +16,10 @@         pprBooleanFormula, pprBooleanFormulaNice   ) where -import GHC.Prelude+import GHC.Prelude hiding ( init, last )  import Data.List ( nub, intersperse )+import Data.List.NonEmpty ( NonEmpty (..), init, last ) import Data.Data  import GHC.Utils.Monad@@ -227,7 +228,7 @@   pprAnd p = cparen (p > 1) . pprAnd'   pprAnd' [] = empty   pprAnd' [x,y] = x <+> text "and" <+> y-  pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs+  pprAnd' (x:xs) = fsep (punctuate comma (init (x:|xs))) <> text ", and" <+> last (x:|xs)   pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs)  instance (OutputableBndr a) => Outputable (BooleanFormula a) where

@@ -82,7 +82,6 @@         lengthFS,         nullFS,         appendFS,-        headFS,         concatFS,         consFS,         nilFS,@@ -608,11 +607,6 @@  concatFS :: [FastString] -> FastString concatFS = mkFastStringShortByteString . mconcat . map fs_sbs--headFS :: FastString -> Char-headFS fs-  | SBS.null $ fs_sbs fs = panic "headFS: Empty FastString"-headFS fs = head $ unpackFS fs  consFS :: Char -> FastString -> FastString consFS c fs = mkFastString (c : unpackFS fs)

@@ -43,7 +43,7 @@ -- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet. -- Therefore, use a IntSet directly (which is likely also a bit more efficient). --- Set of uniques, i.e. for adjancet nodes+-- Set of uniques, i.e. for adjacent nodes newtype UnVarSet = UnVarSet (S.IntSet)     deriving Eq 

@@ -32,7 +32,7 @@ import Control.Monad.Trans.Maybe import Control.Exception (SomeException(..)) import Data.Maybe-import Data.Foldable ( foldlM )+import Data.Foldable ( foldlM, for_ ) import GHC.Utils.Misc (HasCallStack) import Data.List.NonEmpty ( NonEmpty ) @@ -71,8 +71,7 @@ expectJust err Nothing  = error ("expectJust " ++ err)  whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()-whenIsJust (Just x) f = f x-whenIsJust Nothing  _ = return ()+whenIsJust = for_  -- | Flipped version of @fromMaybe@, useful for chaining. orElse :: Maybe a -> a -> a

@@ -28,6 +28,8 @@ import GHC.Utils.Outputable import GHC.Utils.Panic +import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as Semigroup  infixl 5  `appOL`@@ -37,7 +39,7 @@ data OrdList a   = None   | One a-  | Many [a]          -- Invariant: non-empty+  | Many (NonEmpty a)   | Cons a (OrdList a)   | Snoc (OrdList a) a   | Two (OrdList a) -- Invariant: non-empty@@ -100,8 +102,12 @@ pattern ConsOL x xs <- (viewCons -> VJust x xs) where   ConsOL x xs = consOL x xs {-# COMPLETE NilOL, ConsOL #-}+ viewCons :: OrdList a -> VMaybe a (OrdList a)-viewCons (One a)       = VJust a NilOL+viewCons None        = VNothing+viewCons (One a)     = VJust a NilOL+viewCons (Many (a :| [])) = VJust a NilOL+viewCons (Many (a :| b : bs)) = VJust a (Many (b :| bs)) viewCons (Cons a as) = VJust a as viewCons (Snoc as a) = case viewCons as of   VJust a' as' -> VJust a' (Snoc as' a)@@ -109,15 +115,18 @@ viewCons (Two as1 as2) = case viewCons as1 of   VJust a' as1' -> VJust a' (Two as1' as2)   VNothing      -> viewCons as2-viewCons _ = VNothing  pattern SnocOL :: OrdList a -> a -> OrdList a pattern SnocOL xs x <- (viewSnoc -> VJust xs x) where   SnocOL xs x = snocOL xs x {-# COMPLETE NilOL, SnocOL #-}+ viewSnoc :: OrdList a -> VMaybe (OrdList a) a-viewSnoc (One a)       = VJust NilOL a-viewSnoc (Many (reverse -> a:as)) = VJust (Many (reverse as)) a+viewSnoc None        = VNothing+viewSnoc (One a)     = VJust NilOL a+viewSnoc (Many as)   = (`VJust` NE.last as) $ case NE.init as of+  [] -> NilOL+  b : bs -> Many (b :| bs) viewSnoc (Snoc as a) = VJust as a viewSnoc (Cons a as) = case viewSnoc as of   VJust as' a' -> VJust (Cons a as') a'@@ -125,18 +134,17 @@ viewSnoc (Two as1 as2) = case viewSnoc as2 of   VJust as2' a' -> VJust (Two as1 as2') a'   VNothing      -> viewSnoc as1-viewSnoc _ = VNothing  headOL None        = panic "headOL" headOL (One a)     = a-headOL (Many as)   = head as+headOL (Many as)   = NE.head as headOL (Cons a _)  = a headOL (Snoc as _) = headOL as headOL (Two as _)  = headOL as  lastOL None        = panic "lastOL" lastOL (One a)     = a-lastOL (Many as)   = last as+lastOL (Many as)   = NE.last as lastOL (Cons _ as) = lastOL as lastOL (Snoc _ a)  = a lastOL (Two _ as)  = lastOL as@@ -164,7 +172,7 @@         go (Cons a b) acc = a : go b acc         go (Snoc a b) acc = go a (b:acc)         go (Two a b)  acc = go a (go b acc)-        go (Many xs)  acc = xs ++ acc+        go (Many xs)  acc = NE.toList xs ++ acc  fromOLReverse :: OrdList a -> [a] fromOLReverse a = go a []@@ -175,7 +183,7 @@         go (Cons a b) acc = go b (a : acc)         go (Snoc a b) acc = b : go a acc         go (Two a b)  acc = go b (go a acc)-        go (Many xs)  acc = reverse xs ++ acc+        go (Many xs)  acc = reverse (NE.toList xs) ++ acc  mapOL :: (a -> b) -> OrdList a -> OrdList b mapOL = fmap@@ -192,7 +200,9 @@ mapOL' f (Two b1 b2) = let !b1' = mapOL' f b1                            !b2' = mapOL' f b2                        in Two b1' b2'-mapOL' f (Many xs)   = Many $! strictMap f xs+mapOL' f (Many (x :| xs)) = let !x1 = f x+                                !xs1 = strictMap f xs+                            in Many (x1 :| xs1)  foldrOL :: (a->b->b) -> b -> OrdList a -> b foldrOL _ z None        = z@@ -214,7 +224,7 @@ toOL :: [a] -> OrdList a toOL [] = None toOL [x] = One x-toOL xs = Many xs+toOL (x : xs) = Many (x :| xs)  reverseOL :: OrdList a -> OrdList a reverseOL None = None@@ -222,7 +232,7 @@ reverseOL (Cons a b) = Snoc (reverseOL b) a reverseOL (Snoc a b) = Cons b (reverseOL a) reverseOL (Two a b)  = Two (reverseOL b) (reverseOL a)-reverseOL (Many xs)  = Many (reverse xs)+reverseOL (Many xs)  = Many (NE.reverse xs)  -- | Compare not only the values but also the structure of two lists strictlyEqOL :: Eq a => OrdList a   -> OrdList a -> Bool

@@ -4,7 +4,7 @@ -}  -{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}  module GHC.Data.Pair    ( Pair(..)@@ -22,7 +22,7 @@ import qualified Data.Semigroup as Semi  data Pair a = Pair { pFst :: a, pSnd :: a }-  deriving (Functor)+  deriving (Foldable, Functor, Traversable) -- Note that Pair is a *unary* type constructor -- whereas (,) is binary @@ -33,12 +33,6 @@ instance Applicative Pair where   pure x = Pair x x   (Pair f g) <*> (Pair x y) = Pair (f x) (g y)--instance Foldable Pair where-  foldMap f (Pair x y) = f x `mappend` f y--instance Traversable Pair where-  traverse f (Pair x y) = Pair <$> f x <*> f y  instance Semi.Semigroup a => Semi.Semigroup (Pair a) where   Pair a1 b1 <> Pair a2 b2 =  Pair (a1 Semi.<> a2) (b1 Semi.<> b2)

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} -- -----------------------------------------------------------------------------@@ -66,9 +67,7 @@ data StreamS m a b = Yield a (StreamS m a b)                    | Done b                    | Effect (m (StreamS m a b))--instance Monad m => Functor (StreamS m a) where-  fmap = liftM+  deriving (Functor)  instance Monad m => Applicative (StreamS m a) where   pure = Done@@ -126,7 +125,7 @@ -- | Note this is not very efficient because it traverses the whole stream -- before rebuilding it, avoid using it if you can. mapAccumL used to -- implemented but it wasn't used anywhere in the compiler and has similar--- effiency problems.+-- efficiency problems. mapAccumL_ :: forall m a b c r . Monad m => (c -> a -> m (c,b)) -> c -> Stream m a r            -> Stream m b (c, r) mapAccumL_ f c str = Stream $ \f h -> go c f h (runStream str)

@@ -0,0 +1,50 @@+-- Unboxed counterparts to data structures++{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UnliftedNewtypes #-}++module GHC.Data.Unboxed (+  MaybeUB(JustUB, NothingUB),+  fmapMaybeUB, fromMaybeUB, apMaybeUB, maybeUB+  ) where++import GHC.Prelude hiding (Maybe(..), Either(..))++-- | Like Maybe, but using unboxed sums.+--+-- Use with care. Using a unboxed maybe is not always a win+-- in execution *time* even when allocations go down. So make+-- sure to benchmark for execution time as well. If the difference+-- in *runtime* for the compiler is too small to measure it's likely+-- better to use a regular Maybe instead.+--+-- This is since it causes more function arguments to be passed, and+-- potentially more variables to be captured by closures increasing+-- closure size.+newtype MaybeUB a = MaybeUB (# (# #) | a #)++pattern JustUB :: a -> MaybeUB a+pattern JustUB x = MaybeUB (# | x #)++pattern NothingUB :: MaybeUB a+pattern NothingUB = MaybeUB (# (# #) | #)++{-# COMPLETE NothingUB, JustUB #-}++fromMaybeUB :: a -> MaybeUB a -> a+fromMaybeUB d NothingUB = d+fromMaybeUB _ (JustUB x) = x++apMaybeUB :: MaybeUB (a -> b) -> MaybeUB a -> MaybeUB b+apMaybeUB (JustUB f) (JustUB x) = JustUB (f x)+apMaybeUB _ _ = NothingUB++fmapMaybeUB :: (a -> b) -> MaybeUB a -> MaybeUB b+fmapMaybeUB _f NothingUB = NothingUB+fmapMaybeUB f (JustUB x) = JustUB $ f x++maybeUB :: b -> (a -> b) -> MaybeUB a -> b+maybeUB _def f (JustUB x) = f x+maybeUB def _f NothingUB = def

@@ -27,7 +27,7 @@    this back end, then these are the command-line flags you should add    to any invocation of the C compiler." -These properties are use elsewhere in GHC, primarily in the driver, to+These properties are used elsewhere in GHC, primarily in the driver, to fine-tune operations according to the capabilities of the chosen back end.  You might use a property to make GHC aware of a potential limitation of certain back ends, or a special feature available only

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RankNTypes #-}  -------------------------------------------------------------------------------@@ -38,7 +39,7 @@  import GHC.ResponseFile import Control.Exception (IOException, catch)-import Control.Monad (liftM, ap)+import Control.Monad (ap) import Control.Monad.IO.Class  --------------------------------------------------------@@ -138,9 +139,7 @@ newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg                               -> Errs -> Warns                               -> m (Errs, Warns, a) }--instance Monad m => Functor (EwM m) where-    fmap = liftM+  deriving (Functor)  instance Monad m => Applicative (EwM m) where     pure v = EwM (\_ e w -> return (e, w, v))

@@ -83,7 +83,7 @@ coreDumpFlag CoreDoStaticArgs         = Just Opt_D_verbose_core2core coreDumpFlag CoreDoCallArity          = Just Opt_D_dump_call_arity coreDumpFlag CoreDoExitify            = Just Opt_D_dump_exitify-coreDumpFlag CoreDoDemand             = Just Opt_D_dump_stranal+coreDumpFlag (CoreDoDemand {})        = Just Opt_D_dump_stranal coreDumpFlag CoreDoCpr                = Just Opt_D_dump_cpranal coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec

@@ -57,7 +57,7 @@ the data structure in 'mkDsEnvs' which required this generalised structure.  In interactive mode the TypeEnvs from all the previous statements are merged-togethed into one big TypeEnv. 'dsLookupVar' relies on `tcIfaceVar'. The normal+together into one big TypeEnv. 'dsLookupVar' relies on `tcIfaceVar'. The normal lookup functions either look in the HPT or EPS but there is no entry for the `Ghci<N>` modules in either, so the whole merged TypeEnv for all previous Ghci* is stored in the `if_rec_types` variable and then lookup checks there in the case of any interactive module.@@ -71,7 +71,7 @@  Normally there's a 'Module' at hand to tell us which 'TypeEnv' we want to interrogate at a particular time, apart from one case, when constructing the in-scope set-when linting an unfolding. In this case the whole environemnt is needed to tell us+when linting an unfolding. In this case the whole environment is needed to tell us everything that's in-scope at top-level in the loop because whilst we are linting unfoldings the top-level identifiers from modules in the cycle might not be globalised properly yet. @@ -89,7 +89,7 @@ This invariant is difficult to test but easy to check using ghc-debug. The usage of NoKnotVars is intended to make this invariant easier to check. -The most common situation where a KnotVars is retained accidently is if a HscEnv+The most common situation where a KnotVars is retained accidentally is if a HscEnv which contains reference to a KnotVars is used during interface file loading. The thunks created during this process will retain a reference to the KnotVars. In theory, all these references should be removed by 'maybeRehydrateAfter' as that rehydrates all

@@ -20,7 +20,7 @@ printMessages logger opts msgs   = sequence_ [ let style = mkErrStyle unqual                     ctx   = (diag_ppr_ctx opts) { sdocStyle = style }-                in logMsg logger (MCDiagnostic sev . diagnosticReason $ dia) s $+                in logMsg logger (MCDiagnostic sev (diagnosticReason dia) (diagnosticCode dia)) s $                    withPprStyle style (messageWithHints ctx dia)               | MsgEnvelope { errMsgSpan      = s,                               errMsgDiagnostic = dia,@@ -44,6 +44,7 @@       bag = listToBag [ mkPlainMsgEnvelope opts loc $                         GhcDriverMessage $                         DriverUnknownMessage $+                        UnknownDiagnostic $                         mkPlainDiagnostic reason noHints $ text warn                       | CmdLine.Warn reason (L loc warn) <- warns ] 

@@ -1,8 +1,11 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic {DriverMessage, GhcMessage} -module GHC.Driver.Errors.Ppr where+module GHC.Driver.Errors.Ppr (+  -- This module only exports Diagnostic instances.+  ) where  import GHC.Prelude @@ -13,6 +16,7 @@ import GHC.Parser.Errors.Ppr () import GHC.Tc.Errors.Ppr () import GHC.Types.Error+import GHC.Types.Error.Codes ( constructorCode ) import GHC.Unit.Types import GHC.Utils.Outputable import GHC.Unit.Module@@ -70,6 +74,8 @@     GhcUnknownMessage m       -> diagnosticHints m +  diagnosticCode = constructorCode+ instance Diagnostic DriverMessage where   diagnosticMessage = \case     DriverUnknownMessage m@@ -311,3 +317,5 @@       -> noHints     DriverHomePackagesNotClosed {}       -> noHints++  diagnosticCode = constructorCode

@@ -1,4 +1,6 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}  module GHC.Driver.Errors.Types (     GhcMessage(..)@@ -32,6 +34,8 @@  import Language.Haskell.Syntax.Decls (RuleDecl) +import GHC.Generics ( Generic )+ -- | A collection of warning messages. -- /INVARIANT/: Each 'GhcMessage' in the collection should have 'SevWarning' severity. type WarningMessages = Messages GhcMessage@@ -83,8 +87,10 @@   -- 'Diagnostic' constraint ensures that worst case scenario we can still   -- render this into something which can be eventually converted into a   -- 'DecoratedSDoc'.-  GhcUnknownMessage :: forall a. (Diagnostic a, Typeable a) => a -> GhcMessage+  GhcUnknownMessage :: UnknownDiagnostic -> GhcMessage +  deriving Generic+ -- | Creates a new 'GhcMessage' out of any diagnostic. This function is also -- provided to ease the integration of #18516 by allowing diagnostics to be -- wrapped into the general (but structured) 'GhcMessage' type, so that the@@ -92,7 +98,7 @@ -- GHC, as it would typically be used by plugin or library authors (see -- comment for the 'GhcUnknownMessage' type constructor) ghcUnknownMessage :: (Diagnostic a, Typeable a) => a -> GhcMessage-ghcUnknownMessage = GhcUnknownMessage+ghcUnknownMessage = GhcUnknownMessage . UnknownDiagnostic  -- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on -- the result of 'IO (Messages TcRnMessage, a)'.@@ -110,7 +116,7 @@ -- | A message from the driver. data DriverMessage where   -- | Simply wraps a generic 'Diagnostic' message @a@.-  DriverUnknownMessage :: (Diagnostic a, Typeable a) => a -> DriverMessage+  DriverUnknownMessage :: UnknownDiagnostic -> DriverMessage   -- | A parse error in parsing a Haskell file header during dependency   -- analysis   DriverPsHeaderMessage :: !PsMessage -> DriverMessage@@ -350,6 +356,8 @@   DriverRedirectedNoMain :: !ModuleName -> DriverMessage    DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage++deriving instance Generic DriverMessage  -- | Pass to a 'DriverMessage' the information whether or not the -- '-fbuilding-cabal-package' flag is set.

@@ -362,7 +362,7 @@    | Opt_VersionMacros    | Opt_WholeArchiveHsLibs    -- copy all libs into a single folder prior to linking binaries-   -- this should elivate the excessive command line limit restrictions+   -- this should alleviate the excessive command line limit restrictions    -- on windows, by only requiring a single -L argument instead of    -- one for each dependency.  At the time of this writing, gcc    -- forwards all -L flags to the collect2 command without using a

@@ -154,8 +154,8 @@ -- e.g., to maintain additional state consider wrapping this monad or using -- 'GhcT'. newtype Ghc a = Ghc { unGhc :: Session -> IO a }-  deriving (Functor)-  deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT Session IO)+  deriving stock (Functor)+  deriving (Applicative, Monad, MonadFail, MonadFix, MonadThrow, MonadCatch, MonadMask, MonadIO) via (ReaderT Session IO)  -- | The Session is a handle to the complete state of a compilation -- session.  A compilation session consists of a set of modules@@ -163,19 +163,6 @@ -- interactive evaluation, and various caches. data Session = Session !(IORef HscEnv) -instance Applicative Ghc where-  pure a = Ghc $ \_ -> return a-  g <*> m = do f <- g; a <- m; return (f a)--instance Monad Ghc where-  m >>= g  = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s--instance MonadIO Ghc where-  liftIO ioA = Ghc $ \_ -> ioA--instance MonadFix Ghc where-  mfix f = Ghc $ \s -> mfix (\x -> unGhc (f x) s)- instance HasDynFlags Ghc where   getDynFlags = getSessionDynFlags @@ -213,21 +200,11 @@ -- -- Note that the wrapped monad must support IO and handling of exceptions. newtype GhcT m a = GhcT { unGhcT :: Session -> m a }-  deriving (Functor)-  deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT Session m)+  deriving stock (Functor)+  deriving (Applicative, Monad, MonadFail, MonadFix, MonadThrow, MonadCatch, MonadMask, MonadIO) via (ReaderT Session m)  liftGhcT :: m a -> GhcT m a liftGhcT m = GhcT $ \_ -> m--instance Applicative m => Applicative (GhcT m) where-  pure x  = GhcT $ \_ -> pure x-  g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s--instance Monad m => Monad (GhcT m) where-  m >>= k  = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s--instance MonadIO m => MonadIO (GhcT m) where-  liftIO ioA = GhcT $ \_ -> liftIO ioA  instance MonadIO m => HasDynFlags (GhcT m) where   getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r)

@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -O0 #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-}@@ -41,6 +42,7 @@         DynamicTooState(..), dynamicTooState, setDynamicNow,         sccProfilingEnabled,         needSourceNotes,+        OnOff(..),         DynFlags(..),         outputFile, objectSuf, ways,         FlagSpec(..),@@ -416,7 +418,7 @@   Build systems with a remote cache like Bazel or Buck (or Shake, see #16956)   store the build artifacts produced by a build BA for reuse in subsequent builds. -  Embedding source paths in interface fingerprints will thwart these attemps and+  Embedding source paths in interface fingerprints will thwart these attempts and   lead to unnecessary recompilations when the source paths in BA differ from the   source paths in subsequent builds.  -}@@ -743,7 +745,7 @@   'doFloatFromRhs'; with this we can control floating out with GHC flags.    This addresses https://gitlab.haskell.org/ghc/ghc/-/issues/13663 and-  allows for experminentation.+  allows for experimentation. -}  class HasDynFlags m where@@ -774,7 +776,7 @@     extractDynFlags :: t -> DynFlags  -------------------------------------------------------------------------------- Accessessors from 'DynFlags'+-- Accessors from 'DynFlags'  -- | "unbuild" a 'Settings' from a 'DynFlags'. This shouldn't be needed in the -- vast majority of code. But GHCi questionably uses this to produce a default@@ -1843,6 +1845,7 @@ parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False  newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a)+  deriving (Functor)  instance Monad (CmdLineP s) where     CmdLineP k >>= f = CmdLineP (k >>= \x -> case f x of CmdLineP g -> g)@@ -1852,9 +1855,6 @@     pure x = CmdLineP (pure x)     (<*>) = ap -instance Functor (CmdLineP s) where-    fmap f (CmdLineP k) = CmdLineP (fmap f k)- getCmdLineState :: CmdLineP s s getCmdLineState = CmdLineP State.get @@ -2383,7 +2383,7 @@   , make_ord_flag defFlag "fdiagnostics-color=never"       (NoArg (upd (\d -> d { useColor = Never }))) -  -- Suppress all that is suppressable in core dumps.+  -- Suppress all that is suppressible in core dumps.   -- Except for uniques, as some simplifier phases introduce new variables that   -- have otherwise identical names.   , make_ord_flag defGhcFlag "dsuppress-all"@@ -3761,6 +3761,7 @@   flagSpec "TransformListComp"                LangExt.TransformListComp,   flagSpec "TupleSections"                    LangExt.TupleSections,   flagSpec "TypeApplications"                 LangExt.TypeApplications,+  flagSpec "TypeData"                         LangExt.TypeData,   depFlagSpec' "TypeInType"                   LangExt.TypeInType     (deprecatedForExtensions ["DataKinds", "PolyKinds"]),   flagSpec "TypeFamilies"                     LangExt.TypeFamilies,

@@ -125,7 +125,7 @@               Nothing -> pp_header (text "where")               Just es -> vcat [                            pp_header lparen,-                           nest 8 (fsep (punctuate comma (map ppr (unLoc es)))),+                           nest 8 (pprWithCommas ppr (unLoc es)),                            nest 4 (text ") where")                           ],             pp_nonnull imports,

@@ -67,7 +67,7 @@ Global bindings (where clauses) -} --- the ...LR datatypes are parametrized by two id types,+-- the ...LR datatypes are parameterized by two id types, -- one for the left and one for the right.  type instance XHsValBinds      (GhcPass pL) (GhcPass pR) = EpAnn AnnList@@ -848,7 +848,7 @@  instance Outputable TcSpecPrag where   ppr (SpecPrag var _ inl)-    = ppr (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "<type>") inl+    = text (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "<type>") inl  pprMinimalSig :: (OutputableBndr name)               => LBooleanFormula (GenLocated l name) -> SDoc

@@ -27,7 +27,7 @@   -- * Toplevel declarations   HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep,   HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys,-  NewOrData(..), newOrDataToFlavour,+  NewOrData, newOrDataToFlavour, anyLConIsGadt,   StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName,    -- ** Class or type declarations@@ -43,7 +43,8 @@   tyClDeclLName, tyClDeclTyVars,   hsDeclHasCusk, famResultKindSignature,   FamilyDecl(..), LFamilyDecl,-  FunDep(..),+  FunDep(..), ppDataDefnHeader,+  pp_vanilla_decl_head,    -- ** Instance declarations   InstDecl(..), LInstDecl, FamilyInfo(..),@@ -132,6 +133,7 @@ import GHC.Data.Bag import GHC.Data.Maybe import Data.Data (Data)+import Data.Foldable (toList)  {- ************************************************************************@@ -399,10 +401,10 @@     count isNewTy        decls,  -- ...instances     count isFamilyDecl   decls)  where-   isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True+   isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_cons = DataTypeCons _ _ } } = True    isDataTy _                                                       = False -   isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True+   isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_cons = NewTypeCon _ } } = True    isNewTy _                                                      = False  -- FIXME: tcdName is commonly used by both GHC and third-party tools, so it@@ -501,8 +503,8 @@ pprTyClDeclFlavour (SynDecl {})     = text "type" pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})   = pprFlavour info <+> text "family"-pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })-  = ppr nd+pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = nd } })+  = ppr (dataDefnConsNewOrData nd)  instance OutputableBndrId p => Outputable (FunDep (GhcPass p)) where   ppr = pprFunDep@@ -665,9 +667,10 @@  type instance XXConDecl (GhcPass _) = DataConCantHappen +-- Codomain could be 'NonEmpty', but at the moment all users need a list. getConNames :: ConDecl GhcRn -> [LocatedN Name] getConNames ConDeclH98  {con_name  = name}  = [name]-getConNames ConDeclGADT {con_names = names} = names+getConNames ConDeclGADT {con_names = names} = toList names  -- | Return @'Just' fields@ if a data constructor declaration uses record -- syntax (i.e., 'RecCon'), where @fields@ are the field selectors.@@ -685,28 +688,41 @@ hsConDeclTheta Nothing            = [] hsConDeclTheta (Just (L _ theta)) = theta +ppDataDefnHeader+ :: (OutputableBndrId p)+ => (Maybe (LHsContext (GhcPass p)) -> SDoc)   -- Printing the header+ -> HsDataDefn (GhcPass p)+ -> SDoc+ppDataDefnHeader pp_hdr HsDataDefn+  { dd_ctxt = context+  , dd_cType = mb_ct+  , dd_kindSig = mb_sig+  , dd_cons = condecls }+  = pp_type <+> ppr (dataDefnConsNewOrData condecls) <+> pp_ct <+> pp_hdr context <+> pp_sig+  where+    pp_type+      | isTypeDataDefnCons condecls = text "type"+      | otherwise = empty+    pp_ct = case mb_ct of+               Nothing   -> empty+               Just ct -> ppr ct+    pp_sig = case mb_sig of+               Nothing   -> empty+               Just kind -> dcolon <+> ppr kind+ pp_data_defn :: (OutputableBndrId p)                   => (Maybe (LHsContext (GhcPass p)) -> SDoc)   -- Printing the header                   -> HsDataDefn (GhcPass p)                   -> SDoc-pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context-                                , dd_cType = mb_ct-                                , dd_kindSig = mb_sig-                                , dd_cons = condecls, dd_derivs = derivings })+pp_data_defn pp_hdr defn@HsDataDefn+  { dd_cons = condecls+  , dd_derivs = derivings }   | null condecls-  = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig-    <+> pp_derivings derivings+  = ppDataDefnHeader pp_hdr defn <+> pp_derivings derivings    | otherwise-  = hang (ppr new_or_data <+> pp_ct  <+> pp_hdr context <+> pp_sig)-       2 (pp_condecls condecls $$ pp_derivings derivings)+  = hang (ppDataDefnHeader pp_hdr defn) 2 (pp_condecls (toList condecls) $$ pp_derivings derivings)   where-    pp_ct = case mb_ct of-               Nothing   -> empty-               Just ct -> ppr ct-    pp_sig = case mb_sig of-               Nothing   -> empty-               Just kind -> dcolon <+> ppr kind     pp_derivings ds = vcat (map ppr ds)  instance OutputableBndrId p@@ -720,15 +736,10 @@  pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc pp_condecls cs-  | gadt_syntax                  -- In GADT syntax+  | anyLConIsGadt cs             -- In GADT syntax   = hang (text "where") 2 (vcat (map ppr cs))   | otherwise                    -- In H98 syntax   = equals <+> sep (punctuate (text " |") (map ppr cs))-  where-    gadt_syntax = case cs of-      []                      -> False-      (L _ ConDeclH98{}  : _) -> False-      (L _ ConDeclGADT{} : _) -> True  instance (OutputableBndrId p) => Outputable (ConDecl (GhcPass p)) where     ppr = pprConDecl@@ -756,7 +767,7 @@ pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs                         , con_mb_cxt = mcxt, con_g_args = args                         , con_res_ty = res_ty, con_doc = doc })-  = pprMaybeWithDoc doc $ ppr_con_names cons <+> dcolon+  = pprMaybeWithDoc doc $ ppr_con_names (toList cons) <+> dcolon     <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt,               sep (ppr_args args ++ [ppr res_ty]) ])   where@@ -850,9 +861,9 @@                   -- pp_data_defn pretty-prints the kind sig. See #14817.  pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc-pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn =-                       (FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }})})-  = ppr nd+pprDataFamInstFlavour DataFamInstDecl+  { dfid_eqn = FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons }}}+  = ppr (dataDefnConsNewOrData cons)  pprHsFamInstLHS :: (OutputableBndrId p)    => IdP (GhcPass p)@@ -931,6 +942,14 @@ instance Outputable NewOrData where   ppr NewType  = text "newtype"   ppr DataType = text "data"++-- At the moment we only call this with @f = '[]'@ and @f = 'DataDefnCons'@.+anyLConIsGadt :: Foldable f => f (GenLocated l (ConDecl pass)) -> Bool+anyLConIsGadt xs = case toList xs of+    L _ ConDeclGADT {} : _ -> True+    _ -> False+{-# SPECIALIZE anyLConIsGadt :: [GenLocated l (ConDecl pass)] -> Bool #-}+{-# SPECIALIZE anyLConIsGadt :: DataDefnCons (GenLocated l (ConDecl pass)) -> Bool #-}  {- ************************************************************************

@@ -38,7 +38,6 @@ import GHC.Types.Name.Set import GHC.Driver.Flags -import Control.Applicative (liftA2) import Data.Data import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap

@@ -124,7 +124,7 @@  type LHsDocStringChunk = Located HsDocStringChunk --- | A continguous chunk of documentation+-- | A contiguous chunk of documentation newtype HsDocStringChunk = HsDocStringChunk ByteString   deriving (Eq,Ord,Data, Show) @@ -192,6 +192,6 @@ unlines' = intercalate "\n"  -- | Just get the docstring, without any decorators--- Seperates docstrings using "\n\n", which is how haddock likes to render them+-- Separates docstrings using "\n\n", which is how haddock likes to render them renderHsDocStrings :: [HsDocString] -> String renderHsDocStrings = intercalate "\n\n" . map renderHsDocString

@@ -549,7 +549,7 @@     -- `Solo x`, not `(x)`   | [Present _ expr] <- exprs   , Boxed <- boxity-  = hsep [text (mkTupleStr Boxed 1), ppr expr]+  = hsep [text (mkTupleStr Boxed dataName 1), ppr expr]   | otherwise   = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args exprs))   where@@ -1765,7 +1765,7 @@ pprTypedSplice n e = ppr_splice (text "$$") n e  pprUntypedSplice :: forall p. (OutputableBndrId p)-                 => Bool -- Whether to preceed the splice with "$"+                 => Bool -- Whether to precede the splice with "$"                  -> Maybe SplicePointName -- Used for pretty printing when exists                  -> HsUntypedSplice (GhcPass p)                  -> SDoc

@@ -81,7 +81,7 @@ import GHC.Types.SrcLoc import GHC.Data.Bag -- collect ev vars from pats import GHC.Data.Maybe-import GHC.Types.Name (Name)+import GHC.Types.Name (Name, dataName) import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt import Data.Data@@ -353,7 +353,7 @@     -- `Solo x`, not `(x)`   | [pat] <- pats   , Boxed <- bx-  = hcat [text (mkTupleStr Boxed 1), pprParendLPat appPrec pat]+  = hcat [text (mkTupleStr Boxed dataName 1), pprParendLPat appPrec pat]   | otherwise   = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats) pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity)

@@ -102,7 +102,7 @@ import GHC.Types.Fixity ( LexicalFixity(..) ) import GHC.Types.Id ( Id ) import GHC.Types.SourceText-import GHC.Types.Name( Name, NamedThing(getName) )+import GHC.Types.Name( Name, NamedThing(getName), tcName ) import GHC.Types.Name.Reader ( RdrName ) import GHC.Types.Var ( VarBndr ) import GHC.Core.TyCo.Rep ( Type(..) )@@ -1145,7 +1145,7 @@     -- `Solo x`, not `(x)`   | [ty] <- tys   , BoxedTuple <- std_con-  = sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty]+  = sep [text (mkTupleStr Boxed tcName 1), ppr_mono_lty ty]   | otherwise   = tupleParens std_con (pprWithCommas ppr tys)   where std_con = case con of@@ -1170,7 +1170,7 @@     -- Special-case unary boxed tuples so that they are pretty-printed as     -- `'Solo x`, not `'(x)`   | [ty] <- tys-  = quote $ sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty]+  = quote $ sep [text (mkTupleStr Boxed tcName 1), ppr_mono_lty ty]   | otherwise   = quote $ parens (maybeAddSpace tys $ interpp'SP tys) ppr_mono_ty (HsTyLit _ t)       = ppr t

@@ -147,6 +147,7 @@ import GHC.Utils.Panic  import Data.Either+import Data.Foldable ( toList ) import Data.Function import Data.List ( partition, deleteBy ) @@ -1439,7 +1440,7 @@                   => HsDataDefn (GhcPass p)                   -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsDataDefnBinders (HsDataDefn { dd_cons = cons })-  = hsConDeclsBinders cons+  = hsConDeclsBinders (toList cons)   -- See Note [Binders in family instances]  -------------------@@ -1466,7 +1467,7 @@            -- remove only the first occurrence of any seen field in order to            -- avoid circumventing detection of duplicate fields (#9156)            ConDeclGADT { con_names = names, con_g_args = args }-             -> (map (L loc . unLoc) names ++ ns, flds ++ fs)+             -> (toList (L loc . unLoc <$> names) ++ ns, flds ++ fs)              where                 (remSeen', flds) = get_flds_gadt remSeen args                 (ns, fs) = go remSeen' rs

@@ -1,4 +1,6 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-}+ {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic DsMessage  module GHC.HsToCore.Errors.Ppr where@@ -11,6 +13,7 @@ import GHC.Prelude import GHC.Types.Basic (pprRuleName) import GHC.Types.Error+import GHC.Types.Error.Codes ( constructorCode ) import GHC.Types.Id (idType) import GHC.Types.SrcLoc import GHC.Utils.Misc@@ -111,8 +114,6 @@             | isTyVar b = text "type variable" <+> quotes (ppr b)             | isEvVar b = text "constraint"    <+> quotes (ppr (varType b))             | otherwise = text "variable"      <+> quotes (ppr b)-    DsMultipleConForNewtype names-      -> mkSimpleDecorated $ text "Multiple constructors for newtype:" <+> pprQuotedList names     DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs       -> mkSimpleDecorated $           hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$@@ -223,7 +224,6 @@     DsRuleLhsTooComplicated{}                   -> WarningWithoutFlag     DsRuleIgnoredDueToConstructor{}             -> WarningWithoutFlag     DsRuleBindersNotBound{}                     -> WarningWithoutFlag-    DsMultipleConForNewtype{}                   -> ErrorWithoutFlag     DsLazyPatCantBindVarsOfUnliftedType{}       -> ErrorWithoutFlag     DsNotYetHandledByTH{}                       -> ErrorWithoutFlag     DsAggregatedViewExpressions{}               -> WarningWithoutFlag@@ -260,7 +260,6 @@     DsRuleLhsTooComplicated{}                   -> noHints     DsRuleIgnoredDueToConstructor{}             -> noHints     DsRuleBindersNotBound{}                     -> noHints-    DsMultipleConForNewtype{}                   -> noHints     DsLazyPatCantBindVarsOfUnliftedType{}       -> noHints     DsNotYetHandledByTH{}                       -> noHints     DsAggregatedViewExpressions{}               -> noHints@@ -271,6 +270,8 @@     DsRecBindsNotAllowedForUnliftedTys{}        -> noHints     DsRuleMightInlineFirst _ lhs_id rule_act    -> [SuggestAddInlineOrNoInlinePragma lhs_id rule_act]     DsAnotherRuleMightFireFirst _ bad_rule _    -> [SuggestAddPhaseToCompetingRule bad_rule]++  diagnosticCode = constructorCode  {- Note [Suggest NegativeLiterals]

@@ -1,9 +1,7 @@-{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DeriveGeneric #-}  module GHC.HsToCore.Errors.Types where -import Data.Typeable- import GHC.Prelude  import GHC.Core (CoreRule, CoreExpr, RuleName)@@ -19,6 +17,8 @@ import GHC.Types.Name (Name) import qualified GHC.LanguageExtensions as LangExt +import GHC.Generics (Generic)+ newtype MinBound = MinBound Integer newtype MaxBound = MaxBound Integer type MaxUncoveredPatterns = Int@@ -27,7 +27,7 @@ -- | Diagnostics messages emitted during desugaring. data DsMessage   -- | Simply wraps a generic 'Diagnostic' message.-  = forall a. (Diagnostic a, Typeable a) => DsUnknownMessage a+  = DsUnknownMessage UnknownDiagnostic      {-| DsEmptyEnumeration is a warning (controlled by the -Wempty-enumerations flag) that is         emitted if an enumeration is empty.@@ -122,8 +122,6 @@                           !CoreExpr                           -- ^ The optimised LHS -  | DsMultipleConForNewtype [LocatedN Name]-   | DsLazyPatCantBindVarsOfUnliftedType [Var]    | DsNotYetHandledByTH !ThRejectionReason@@ -145,6 +143,8 @@   | DsAnotherRuleMightFireFirst !RuleName                                 !RuleName -- the \"bad\" rule                                 !Var++  deriving Generic  -- The positional number of the argument for an expression (first, second, third, etc) newtype DsArgNum = DsArgNum Int

@@ -2,7 +2,7 @@  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} --- | Provides factilities for pretty-printing 'Nabla's in a way appropriate for+-- | Provides facilities for pretty-printing 'Nabla's in a way appropriate for -- user facing pattern match warnings. module GHC.HsToCore.Pmc.Ppr (       pprUncovered

@@ -1,6 +1,6 @@  --- | Computing fingerprints of values serializeable with GHC's \"Binary\" module.+-- | Computing fingerprints of values serializable with GHC's \"Binary\" module. module GHC.Iface.Recomp.Binary   ( -- * Computing fingerprints     fingerprintBinMem

@@ -13,7 +13,7 @@         IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec,         IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceJoinInfo(..),         IfaceBinding(..), IfaceConAlt(..),-        IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..),+        IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..),         IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,         IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),         IfaceClassBody(..),@@ -360,21 +360,12 @@ -- only later attached to the Id.  Partial reason: some are orphans.  data IfaceUnfolding-  = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding-                                -- Possibly could eliminate the Bool here, the information-                                -- is also in the InlinePragma.--  | IfCompulsory IfaceExpr      -- default methods and unsafeCoerce#-                                -- for more about unsafeCoerce#, see-                                -- Note [Wiring in unsafeCoerce#] in "GHC.HsToCore"--  | IfInlineRule Arity          -- INLINE pragmas-                 Bool           -- OK to inline even if *un*-saturated-                 Bool           -- OK to inline even if context is boring-                 IfaceExpr-+  = IfCoreUnfold UnfoldingSource IfGuidance IfaceExpr   | IfDFunUnfold [IfaceBndr] [IfaceExpr] +data IfGuidance+  = IfNoGuidance            -- Compute it from the IfaceExpr+  | IfWhen Arity Bool Bool  -- Just like UnfWhen in Core.UnfoldingGuidance  -- We only serialise the IdDetails of top-level Ids, and even then -- we only need a very limited selection.  Notably, none of the@@ -1488,17 +1479,15 @@   ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar)  instance Outputable IfaceUnfolding where-  ppr (IfCompulsory e)     = text "<compulsory>" <+> parens (ppr e)-  ppr (IfCoreUnfold s e)   = (if s-                                then text "<stable>"-                                else Outputable.empty)-                              <+> parens (ppr e)-  ppr (IfInlineRule a uok bok e) = sep [text "InlineRule"-                                            <+> ppr (a,uok,bok),-                                        pprParendIfaceExpr e]+  ppr (IfCoreUnfold src guide e)+    = sep [ text "Core:" <+> ppr src <+> ppr guide, ppr e ]   ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot)                                 2 (sep (map pprParendIfaceExpr es)) +instance Outputable IfGuidance where+  ppr IfNoGuidance   = empty+  ppr (IfWhen a u b) = angleBrackets (ppr a <> comma <> ppr u <> ppr b)+ {- ************************************************************************ *                                                                      *@@ -1742,9 +1731,7 @@ freeNamesItem _                      = emptyNameSet  freeNamesIfUnfold :: IfaceUnfolding -> NameSet-freeNamesIfUnfold (IfCoreUnfold _ e)     = freeNamesIfExpr e-freeNamesIfUnfold (IfCompulsory e)       = freeNamesIfExpr e-freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e+freeNamesIfUnfold (IfCoreUnfold _ _ e)   = freeNamesIfExpr e freeNamesIfUnfold (IfDFunUnfold bs es)   = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es  freeNamesIfExpr :: IfaceExpr -> NameSet@@ -2264,40 +2251,42 @@             _ -> HsTagSig <$> get bh  instance Binary IfaceUnfolding where-    put_ bh (IfCoreUnfold s e) = do+    put_ bh (IfCoreUnfold s g e) = do         putByte bh 0         put_ bh s+        put_ bh g         put_ bh e-    put_ bh (IfInlineRule a b c d) = do-        putByte bh 1-        put_ bh a-        put_ bh b-        put_ bh c-        put_ bh d     put_ bh (IfDFunUnfold as bs) = do-        putByte bh 2+        putByte bh 1         put_ bh as         put_ bh bs-    put_ bh (IfCompulsory e) = do-        putByte bh 3-        put_ bh e     get bh = do         h <- getByte bh         case h of             0 -> do s <- get bh+                    g <- get bh                     e <- get bh-                    return (IfCoreUnfold s e)-            1 -> do a <- get bh-                    b <- get bh-                    c <- get bh-                    d <- get bh-                    return (IfInlineRule a b c d)-            2 -> do as <- get bh+                    return (IfCoreUnfold s g e)+            _ -> do as <- get bh                     bs <- get bh                     return (IfDFunUnfold as bs)-            _ -> do e <- get bh-                    return (IfCompulsory e) +instance Binary IfGuidance where+    put_ bh IfNoGuidance = putByte bh 0+    put_ bh (IfWhen a b c ) = do+        putByte bh 1+        put_ bh a+        put_ bh b+        put_ bh c+    get bh = do+        h <- getByte bh+        case h of+            0 -> return IfNoGuidance+            _ -> do a <- get bh+                    b <- get bh+                    c <- get bh+                    return (IfWhen a b c)+ instance Binary IfaceAlt where     put_ bh (IfaceAlt a b c) = do         put_ bh a@@ -2610,16 +2599,15 @@     HsLFInfo lf_info -> lf_info `seq` () -- TODO: seq further?     HsTagSig sig -> sig `seq` () +instance NFData IfGuidance where+  rnf = \case+    IfNoGuidance -> ()+    IfWhen a b c -> a `seq` b `seq` c `seq` ()+ instance NFData IfaceUnfolding where   rnf = \case-    IfCoreUnfold inlinable expr ->-      rnf inlinable `seq` rnf expr-    IfCompulsory expr ->-      rnf expr-    IfInlineRule arity b1 b2 e ->-      rnf arity `seq` rnf b1 `seq` rnf b2 `seq` rnf e-    IfDFunUnfold bndrs exprs ->-      rnf bndrs `seq` rnf exprs+    IfCoreUnfold src guidance expr -> src `seq` rnf guidance `seq` rnf expr+    IfDFunUnfold bndrs exprs       -> rnf bndrs `seq` rnf exprs  instance NFData IfaceExpr where   rnf = \case

@@ -244,7 +244,7 @@    | Framework String   -- Only used for darwin, but does no harm  instance Outputable LibrarySpec where-  ppr (Objects objs) = text "Objects" <+> ppr objs+  ppr (Objects objs) = text "Objects" <+> ppr (map text objs)   ppr (Archive a) = text "Archive" <+> text a   ppr (DLL s) = text "DLL" <+> text s   ppr (DLLPath f) = text "DLLPath" <+> text f

@@ -12,6 +12,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}  -- | This module provides the generated Happy parser for Haskell. It exports -- a number of parsers which may be used in any library that uses the GHC API.@@ -462,7 +463,7 @@     foo :: (:%)  Ambiguity:-    If we reduced, (:%) would be parsed as a parenthehsized infix type+    If we reduced, (:%) would be parsed as a parenthesized infix type     expression without arguments, resulting in the 'failOpFewArgs' error.      We shift, so it is parsed as a type constructor.@@ -1270,22 +1271,22 @@                            ++ (fst $ unLoc $5) ++ (fst $ unLoc $6))  }            -- ordinary data type or newtype declaration-        | data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings-                {% mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3+        | type_data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings+                {% mkTyData (comb4 $1 $3 $4 $5) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3                            Nothing (reverse (snd $ unLoc $4))                                    (fmap reverse $5)-                           ((fst $ unLoc $1):(fst $ unLoc $4)) }+                           ((fstOf3 $ unLoc $1):(fst $ unLoc $4)) }                                    -- We need the location on tycl_hdr in case                                    -- constrs and deriving are both empty            -- ordinary GADT declaration-        | data_or_newtype capi_ctype tycl_hdr opt_kind_sig+        | type_data_or_newtype capi_ctype tycl_hdr opt_kind_sig                  gadt_constrlist                  maybe_derivings-            {% mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3+            {% mkTyData (comb4 $1 $3 $5 $6) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3                             (snd $ unLoc $4) (snd $ unLoc $5)                             (fmap reverse $6)-                            ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }+                            ((fstOf3 $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }                                    -- We need the location on tycl_hdr in case                                    -- constrs and deriving are both empty @@ -1509,6 +1510,11 @@                                 (fmap reverse $7)                         ((fst $ unLoc $1):$2++(fst $ unLoc $5)++(fst $ unLoc $6)) } +type_data_or_newtype :: { Located (AddEpAnn, Bool, NewOrData) }+        : 'data'        { sL1 $1 (mj AnnData    $1,False,DataType) }+        | 'newtype'     { sL1 $1 (mj AnnNewtype $1,False,NewType) }+        | 'type' 'data' { sL1 $1 (mj AnnData    $1,True ,DataType) }+ data_or_newtype :: { Located (AddEpAnn, NewOrData) }         : 'data'        { sL1 $1 (mj AnnData    $1,DataType) }         | 'newtype'     { sL1 $1 (mj AnnNewtype $1,NewType) }@@ -1660,7 +1666,7 @@         : 'pattern' con_list '::' sigtype                    {% acsA (\cs -> sLL $1 (reLoc $>)                                 $ PatSynSig (EpAnn (glR $1) (AnnSig (mu AnnDcolon $3) [mj AnnPattern $1]) cs)-                                  (unLoc $2) $4) }+                                  (toList $ unLoc $2) $4) }  qvarcon :: { LocatedN RdrName }         : qvar                          { $1 }@@ -2427,7 +2433,7 @@         | {- empty -}                 { noLoc ([], Nothing) }  constr_stuff :: { Located (LocatedN RdrName, HsConDeclH98Details GhcPs) }-        : infixtype       {% fmap (reLoc. (mapLoc (\b -> (dataConBuilderCon b,+        : infixtype       {% fmap (reLoc. (fmap (\b -> (dataConBuilderCon b,                                                           dataConBuilderDetails b))))                                      (runPV $1) } @@ -2935,7 +2941,7 @@          -- Template Haskell Extension         | splice_untyped { ECP $ pvA $ mkHsSplicePV $1 }-        | splice_typed   { ecpFromExp $ mapLoc (uncurry HsTypedSplice) (reLocA $1) }+        | splice_typed   { ecpFromExp $ fmap (uncurry HsTypedSplice) (reLocA $1) }          | SIMPLEQUOTE  qvar     {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True  $2)) }         | SIMPLEQUOTE  qcon     {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True  $2)) }@@ -2973,8 +2979,8 @@         | PREFIX_PROJ field  {% acs (\cs -> sLL $1 (reLoc $>) ((sLLa $1 (reLoc $>) $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $2) :| [])) }  splice_exp :: { LHsExpr GhcPs }-        : splice_untyped { mapLoc (HsUntypedSplice noAnn) (reLocA $1) }-        | splice_typed   { mapLoc (uncurry HsTypedSplice) (reLocA $1) }+        : splice_untyped { fmap (HsUntypedSplice noAnn) (reLocA $1) }+        | splice_typed   { fmap (uncurry HsTypedSplice) (reLocA $1) }  splice_untyped :: { Located (HsUntypedSplice GhcPs) }         -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer@@ -3544,10 +3550,9 @@                                          (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }         | sysdcon               { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) } -con_list :: { Located [LocatedN RdrName] }-con_list : con                  { sL1N $1 [$1] }-         | con ',' con_list     {% do { h <- addTrailingCommaN $1 (gl $2)-                                      ; return (sLL (reLocN $1) $> (h : unLoc $3)) }}+con_list :: { Located (NonEmpty (LocatedN RdrName)) }+con_list : con                  { sL1N $1 (pure $1) }+         | con ',' con_list     {% sLL (reLocN $1) $> . (:| toList (unLoc $3)) <\$> addTrailingCommaN $1 (gl $2) }  qcon_list :: { Located [LocatedN RdrName] } qcon_list : qcon                  { sL1N $1 [$1] }

@@ -547,7 +547,7 @@ -- element, and print them together with the element, interleaving -- them into the output stream.  But when editing the AST to move -- fragments around it is useful to be able to first separate the--- comments into those occuring before the AST element and those+-- comments into those occurring before the AST element and those -- following it.  The 'EpaCommentsBalanced' constructor is used to do -- this. The GHC parser will only insert the 'EpaComments' form. data EpAnnComments = EpaComments@@ -633,7 +633,7 @@ -- Annotations for items in a list -- --------------------------------------------------------------------- --- | Captures the location of punctuation occuring between items,+-- | Captures the location of punctuation occurring between items, -- normally in a list.  It is captured as a trailing annotation. data TrailingAnn   = AddSemiAnn EpaLocation    -- ^ Trailing ';'

@@ -3,6 +3,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}  {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic PsMessage @@ -18,6 +20,7 @@ import GHC.Types.Error import GHC.Types.Hint.Ppr (perhapsAsPat) import GHC.Types.SrcLoc+import GHC.Types.Error.Codes ( constructorCode ) import GHC.Types.Name.Reader ( opIsAt, rdrNameOcc, mkUnqual ) import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName) import GHC.Utils.Outputable@@ -500,6 +503,12 @@             ]     PsErrInvalidCApiImport {} -> mkSimpleDecorated $ vcat [ text "Wrapper stubs can't be used with CApiFFI."] +    PsErrMultipleConForNewtype tycon n -> mkSimpleDecorated $ vcat+      [ sep+          [ text "A newtype must have exactly one constructor,"+          , nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ]+      , text "In the newtype declaration for" <+> quotes (ppr tycon) ]+   diagnosticReason  = \case     PsUnknownMessage m                            -> diagnosticReason m     PsHeaderMessage  m                            -> psHeaderMessageReason m@@ -616,6 +625,7 @@     PsErrParseRightOpSectionInPat{}               -> ErrorWithoutFlag     PsErrIllegalGadtRecordMultiplicity{}          -> ErrorWithoutFlag     PsErrInvalidCApiImport {}                     -> ErrorWithoutFlag+    PsErrMultipleConForNewtype {}                 -> ErrorWithoutFlag    diagnosticHints  = \case     PsUnknownMessage m                            -> diagnosticHints m@@ -785,6 +795,9 @@     PsErrInvalidPackageName{}                     -> noHints     PsErrIllegalGadtRecordMultiplicity{}          -> noHints     PsErrInvalidCApiImport {}                     -> noHints+    PsErrMultipleConForNewtype {}                 -> noHints++  diagnosticCode = constructorCode  psHeaderMessageDiagnostic :: PsHeaderMessage -> DecoratedSDoc psHeaderMessageDiagnostic = \case

@@ -1,11 +1,9 @@-{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DeriveGeneric #-}  module GHC.Parser.Errors.Types where  import GHC.Prelude -import Data.Typeable- import GHC.Core.TyCon (Role) import GHC.Data.FastString import GHC.Hs@@ -15,10 +13,11 @@ import GHC.Types.Hint import GHC.Types.Name.Occurrence (OccName) import GHC.Types.Name.Reader-import GHC.Utils.Outputable import Data.List.NonEmpty (NonEmpty) import GHC.Types.SrcLoc (PsLoc) +import GHC.Generics ( Generic )+ -- The type aliases below are useful to make some type signatures a bit more -- descriptive, like 'handleWarningsThrowErrors' in 'GHC.Driver.Main'. @@ -59,6 +58,7 @@         tests/driver/T2499   -}   | PsErrUnknownOptionsPragma !String+  deriving Generic   data PsMessage@@ -67,7 +67,7 @@         arbitrary messages to be embedded. The typical use case would be GHC plugins         willing to emit custom diagnostics.     -}-   forall a. (Diagnostic a, Typeable a) => PsUnknownMessage a+    PsUnknownMessage UnknownDiagnostic      {-| A group of parser messages emitted in 'GHC.Parser.Header'.         See Note [Messages from GHC.Parser.Header].@@ -77,7 +77,7 @@    {-| PsWarnBidirectionalFormatChars is a warning (controlled by the -Wwarn-bidirectional-format-characters flag)    that occurs when unicode bi-directional format characters are found within in a file -   The 'PsLoc' contains the exact position in the buffer the character occured, and the+   The 'PsLoc' contains the exact position in the buffer the character occurred, and the    string contains a description of the character.    -}    | PsWarnBidirectionalFormatChars (NonEmpty (PsLoc, Char, String))@@ -456,13 +456,17 @@     -- | Parse error in right operator section pattern    -- TODO: embed the proper operator, if possible-   | forall infixOcc. (OutputableBndr infixOcc) => PsErrParseRightOpSectionInPat !infixOcc !(PatBuilder GhcPs)+   | PsErrParseRightOpSectionInPat !RdrName !(PatBuilder GhcPs)     -- | Illegal linear arrow or multiplicity annotation in GADT record syntax    | PsErrIllegalGadtRecordMultiplicity !(HsArrow GhcPs)     | PsErrInvalidCApiImport +   | PsErrMultipleConForNewtype !RdrName !Int++   deriving Generic+ -- | Extra details about a parse error, which helps -- us in determining which should be the hints to -- suggest.@@ -496,7 +500,7 @@   = ParseContext   { is_infix :: !(Maybe RdrName)     -- ^ If 'Just', this is an infix-    -- pattern with the binded operator name+    -- pattern with the bound operator name   , incomplete_do_block :: !PatIncompleteDoBlock     -- ^ Did the parser likely fail due to an incomplete do block?   } deriving Eq

@@ -490,21 +490,13 @@   @conid "#"+       / { ifExtension MagicHashBit } { idtoken conid } } --- Operators classified into prefix, suffix, tight infix, and loose infix.--- See Note [Whitespace-sensitive operator parsing]-<0> {-  @varsym / { precededByClosingToken `alexAndPred` followedByOpeningToken } { varsym_tight_infix }-  @varsym / { followedByOpeningToken }  { varsym_prefix }-  @varsym / { precededByClosingToken }  { varsym_suffix }-  @varsym                               { varsym_loose_infix }-}- -- ToDo: - move `var` and (sym) into lexical syntax? --       - remove backquote from $special? <0> {   @qvarsym                                         { idtoken qvarsym }   @qconsym                                         { idtoken qconsym }-  @consym                                          { consym }+  @varsym                                          { with_op_ws varsym }+  @consym                                          { with_op_ws consym } }  -- For the normal boxed literals we need to be careful@@ -707,6 +699,14 @@  { +-- Operator whitespace occurrence. See Note [Whitespace-sensitive operator parsing].+data OpWs+  = OpWsPrefix         -- a !b+  | OpWsSuffix         -- a! b+  | OpWsTightInfix     -- a!b+  | OpWsLooseInfix     -- a ! b+  deriving Show+ -- ----------------------------------------------------------------------------- -- The token type @@ -1093,60 +1093,61 @@ -- ----------------------------------------------------------------------------- -- Lexer actions -type Action = PsSpan -> StringBuffer -> Int -> P (PsLocated Token)+type Action = PsSpan -> StringBuffer -> Int -> StringBuffer -> P (PsLocated Token)  special :: Token -> Action-special tok span _buf _len = return (L span tok)+special tok span _buf _len _buf2 = return (L span tok)  token, layout_token :: Token -> Action-token t span _buf _len = return (L span t)-layout_token t span _buf _len = pushLexState layout >> return (L span t)+token t span _buf _len _buf2 = return (L span t)+layout_token t span _buf _len _buf2 = pushLexState layout >> return (L span t)  idtoken :: (StringBuffer -> Int -> Token) -> Action-idtoken f span buf len = return (L span $! (f buf len))+idtoken f span buf len _buf2 = return (L span $! (f buf len))  qdo_token :: (Maybe FastString -> Token) -> Action-qdo_token con span buf len = do+qdo_token con span buf len _buf2 = do     maybe_layout token     return (L span $! token)   where     !token = con $! Just $! fst $! splitQualName buf len False  skip_one_varid :: (FastString -> Token) -> Action-skip_one_varid f span buf len+skip_one_varid f span buf len _buf2   = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))  skip_two_varid :: (FastString -> Token) -> Action-skip_two_varid f span buf len+skip_two_varid f span buf len _buf2   = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2)))  strtoken :: (String -> Token) -> Action-strtoken f span buf len =+strtoken f span buf len _buf2 =   return (L span $! (f $! lexemeToString buf len))  begin :: Int -> Action-begin code _span _str _len = do pushLexState code; lexToken+begin code _span _str _len _buf2 = do pushLexState code; lexToken  pop :: Action-pop _span _buf _len = do _ <- popLexState-                         lexToken+pop _span _buf _len _buf2 =+  do _ <- popLexState+     lexToken -- See Note [Nested comment line pragmas] failLinePrag1 :: Action-failLinePrag1 span _buf _len = do+failLinePrag1 span _buf _len _buf2 = do   b <- getBit InNestedCommentBit   if b then return (L span ITcomment_line_prag)        else lexError LexErrorInPragma  -- See Note [Nested comment line pragmas] popLinePrag1 :: Action-popLinePrag1 span _buf _len = do+popLinePrag1 span _buf _len _buf2 = do   b <- getBit InNestedCommentBit   if b then return (L span ITcomment_line_prag) else do     _ <- popLexState     lexToken  hopefully_open_brace :: Action-hopefully_open_brace span buf len+hopefully_open_brace span buf len buf2  = do relaxed <- getBit RelaxedLayoutBit       ctx <- getContext       (AI l _) <- getInput@@ -1155,17 +1156,23 @@                  case ctx of                  Layout prev_off _ : _ -> prev_off < offset                  _                     -> True-      if isOK then pop_and open_brace span buf len+      if isOK then pop_and open_brace span buf len buf2               else addFatalError $                      mkPlainErrorMsgEnvelope (mkSrcSpanPs span) PsErrMissingBlock  pop_and :: Action -> Action-pop_and act span buf len = do _ <- popLexState-                              act span buf len+pop_and act span buf len buf2 =+  do _ <- popLexState+     act span buf len buf2  -- See Note [Whitespace-sensitive operator parsing]-followedByOpeningToken :: AlexAccPred ExtsBitmap-followedByOpeningToken _ _ _ (AI _ buf)+followedByOpeningToken, precededByClosingToken :: AlexAccPred ExtsBitmap+followedByOpeningToken _ _ _ (AI _ buf) = followedByOpeningToken' buf+precededByClosingToken _ (AI _ buf) _ _ = precededByClosingToken' buf++-- The input is the buffer *after* the token.+followedByOpeningToken' :: StringBuffer -> Bool+followedByOpeningToken' buf   | atEnd buf = False   | otherwise =       case nextChar buf of@@ -1179,9 +1186,9 @@         ('⦇', _) -> True         (c, _) -> isAlphaNum c --- See Note [Whitespace-sensitive operator parsing]-precededByClosingToken :: AlexAccPred ExtsBitmap-precededByClosingToken _ (AI _ buf) _ _ =+-- The input is the buffer *before* the token.+precededByClosingToken' :: StringBuffer -> Bool+precededByClosingToken' buf =   case prevChar buf '\n' of     '}' -> decodePrevNChars 1 buf /= "-"     ')' -> True@@ -1193,6 +1200,19 @@     '⦈' -> True     c -> isAlphaNum c +get_op_ws :: StringBuffer -> StringBuffer -> OpWs+get_op_ws buf1 buf2 =+    mk_op_ws (precededByClosingToken' buf1) (followedByOpeningToken' buf2)+  where+    mk_op_ws False True  = OpWsPrefix+    mk_op_ws True  False = OpWsSuffix+    mk_op_ws True  True  = OpWsTightInfix+    mk_op_ws False False = OpWsLooseInfix++{-# INLINE with_op_ws #-}+with_op_ws :: (OpWs -> Action) -> Action+with_op_ws act span buf len buf2 = act (get_op_ws buf buf2) span buf len buf2+ {-# INLINE nextCharIs #-} nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool nextCharIs buf p = not (atEnd buf) && p (currentChar buf)@@ -1289,7 +1309,7 @@   = p1 userState in1 len in2 || p2 userState in1 len in2  multiline_doc_comment :: Action-multiline_doc_comment span buf _len = {-# SCC "multiline_doc_comment" #-} withLexedDocType worker+multiline_doc_comment span buf _len _buf2 = {-# SCC "multiline_doc_comment" #-} withLexedDocType worker   where     worker input@(AI start_loc _) docType checkNextLine = go start_loc "" [] input       where@@ -1335,11 +1355,11 @@           Nothing -> input  lineCommentToken :: Action-lineCommentToken span buf len = do+lineCommentToken span buf len buf2 = do   b <- getBit RawTokenStreamBit   if b then do          lt <- getLastLocComment-         strtoken (\s -> ITlineComment s lt) span buf len+         strtoken (\s -> ITlineComment s lt) span buf len buf2        else lexToken  @@ -1348,7 +1368,7 @@   using regular expressions. -} nested_comment :: Action-nested_comment span buf len = {-# SCC "nested_comment" #-} do+nested_comment span buf len _buf2 = {-# SCC "nested_comment" #-} do   l <- getLastLocComment   let endComment input (L _ comment) = commentEnd lexToken input (Nothing, ITblockComment comment l) buf span   input <- getInput@@ -1357,7 +1377,7 @@   nested_comment_logic endComment start_decorator input span  nested_doc_comment :: Action-nested_doc_comment span buf _len = {-# SCC "nested_doc_comment" #-} withLexedDocType worker+nested_doc_comment span buf _len _buf2 = {-# SCC "nested_doc_comment" #-} withLexedDocType worker   where     worker input docType _checkNextLine = nested_comment_logic endComment "" input span       where@@ -1496,7 +1516,7 @@ -- RULES pragmas turn on the forall and '.' keywords, and we turn them -- off again at the end of the pragma. rulePrag :: Action-rulePrag span buf len = do+rulePrag span buf len _buf2 = do   setExts (.|. xbit InRulePragBit)   let !src = lexemeToString buf len   return (L span (ITrules_prag (SourceText src)))@@ -1504,26 +1524,26 @@ -- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead -- of updating the position in 'PState' linePrag :: Action-linePrag span buf len = do+linePrag span buf len buf2 = do   usePosPrags <- getBit UsePosPragsBit   if usePosPrags-    then begin line_prag2 span buf len+    then begin line_prag2 span buf len buf2     else let !src = lexemeToString buf len          in return (L span (ITline_prag (SourceText src)))  -- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead -- of updating the position in 'PState' columnPrag :: Action-columnPrag span buf len = do+columnPrag span buf len buf2 = do   usePosPrags <- getBit UsePosPragsBit   let !src = lexemeToString buf len   if usePosPrags-    then begin column_prag span buf len+    then begin column_prag span buf len buf2     else let !src = lexemeToString buf len          in return (L span (ITcolumn_prag (SourceText src)))  endPrag :: Action-endPrag span _buf _len = do+endPrag span _buf _len _buf2 = do   setExts (.&. complement (xbit InRulePragBit))   return (L span ITclose_prag) @@ -1567,11 +1587,11 @@               (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedComment LexErrKind_EOF))  open_brace, close_brace :: Action-open_brace span _str _len = do+open_brace span _str _len _buf2 = do   ctx <- getContext   setContext (NoLayout:ctx)   return (L span ITocurly)-close_brace span _str _len = do+close_brace span _str _len _buf2 = do   popContext   return (L span ITccurly) @@ -1614,7 +1634,7 @@         qual_size = orig_buf `byteDiff` dot_buf  varid :: Action-varid span buf len =+varid span buf len _buf2 =   case lookupUFM reservedWordsFM fs of     Just (ITcase, _) -> do       lastTk <- getLastTk@@ -1660,8 +1680,8 @@ qconsym buf len = ITqconsym $! splitQualName buf len False  -- See Note [Whitespace-sensitive operator parsing]-varsym_prefix :: Action-varsym_prefix = sym $ \span exts s ->+varsym :: OpWs -> Action+varsym opws@OpWsPrefix = sym $ \span exts s ->   let warnExtConflict errtok =         do { addPsMessage (mkSrcSpanPs span) (PsWarnOperatorWhitespaceExtConflict errtok)            ; return (ITvarsym s) }@@ -1689,47 +1709,51 @@      | s == fsLit "!" -> return ITbang      | s == fsLit "~" -> return ITtilde      | otherwise ->-         do { addPsMessage-                (mkSrcSpanPs span)-                (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Prefix)+         do { warnOperatorWhitespace opws span s             ; return (ITvarsym s) }---- See Note [Whitespace-sensitive operator parsing]-varsym_suffix :: Action-varsym_suffix = sym $ \span _ s ->+varsym opws@OpWsSuffix = sym $ \span _ s ->   if | s == fsLit "@" -> failMsgP (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrSuffixAT)      | s == fsLit "." -> return ITdot      | otherwise ->-         do { addPsMessage-                (mkSrcSpanPs span)-                (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Suffix)+         do { warnOperatorWhitespace opws span s             ; return (ITvarsym s) }---- See Note [Whitespace-sensitive operator parsing]-varsym_tight_infix :: Action-varsym_tight_infix = sym $ \span exts s ->+varsym opws@OpWsTightInfix = sym $ \span exts s ->   if | s == fsLit "@" -> return ITat      | s == fsLit ".", OverloadedRecordDotBit `xtest` exts  -> return (ITproj False)      | s == fsLit "." -> return ITdot      | otherwise ->-         do { addPsMessage-                (mkSrcSpanPs span)-                (PsWarnOperatorWhitespace s (OperatorWhitespaceOccurrence_TightInfix))-            ;  return (ITvarsym s) }---- See Note [Whitespace-sensitive operator parsing]-varsym_loose_infix :: Action-varsym_loose_infix = sym $ \_ _ s ->+         do { warnOperatorWhitespace opws span s+            ; return (ITvarsym s) }+varsym OpWsLooseInfix = sym $ \_ _ s ->   if | s == fsLit "."      -> return ITdot      | otherwise      -> return $ ITvarsym s -consym :: Action-consym = sym (\_span _exts s -> return $ ITconsym s)+consym :: OpWs -> Action+consym opws = sym $ \span _exts s ->+  do { warnOperatorWhitespace opws span s+     ; return (ITconsym s) } +warnOperatorWhitespace :: OpWs -> PsSpan -> FastString -> P ()+warnOperatorWhitespace opws span s =+  whenIsJust (check_unusual_opws opws) $ \opws' ->+    addPsMessage+      (mkSrcSpanPs span)+      (PsWarnOperatorWhitespace s opws')++-- Check an operator occurrence for unusual whitespace (prefix, suffix, tight infix).+-- This determines if -Woperator-whitespace is triggered.+check_unusual_opws :: OpWs -> Maybe OperatorWhitespaceOccurrence+check_unusual_opws opws =+  case opws of+    OpWsPrefix     -> Just OperatorWhitespaceOccurrence_Prefix+    OpWsSuffix     -> Just OperatorWhitespaceOccurrence_Suffix+    OpWsTightInfix -> Just OperatorWhitespaceOccurrence_TightInfix+    OpWsLooseInfix -> Nothing+ sym :: (PsSpan -> ExtsBitmap -> FastString -> P Token) -> Action-sym con span buf len =+sym con span buf len _buf2 =   case lookupUFM reservedSymsFM fs of     Just (keyword, NormalSyntax, 0) ->       return $ L span keyword@@ -1760,7 +1784,7 @@              -> Int -> Int              -> (Integer, (Char -> Int))              -> Action-tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = do+tok_integral itint transint transbuf translen (radix,char_to_int) span buf len _buf2 = do   numericUnderscores <- getBit NumericUnderscoresBit  -- #14473   let src = lexemeToString buf len   when ((not numericUnderscores) && ('_' `elem` src)) $ do@@ -1802,7 +1826,7 @@  -- readSignificandExponentPair can understand negative rationals, exponents, everything. tok_frac :: Int -> (String -> Token) -> Action-tok_frac drop f span buf len = do+tok_frac drop f span buf len _buf2 = do   numericUnderscores <- getBit NumericUnderscoresBit  -- #14473   let src = lexemeToString buf (len-drop)   when ((not numericUnderscores) && ('_' `elem` src)) $ do@@ -1837,7 +1861,7 @@  -- we're at the first token on a line, insert layout tokens if necessary do_bol :: Action-do_bol span _str _len = do+do_bol span _str _len _buf2 = do         -- See Note [Nested comment line pragmas]         b <- getBit InNestedCommentBit         if b then return (L span ITcomment_line_prag) else do@@ -1888,7 +1912,7 @@ -- by a 'do', then we allow the new context to be at the same indentation as -- the previous context.  This is what the 'strict' argument is for. new_layout_context :: Bool -> Bool -> Token -> Action-new_layout_context strict gen_semic tok span _buf len = do+new_layout_context strict gen_semic tok span _buf len _buf2 = do     _ <- popLexState     (AI l _) <- getInput     let offset = srcLocCol (psRealLoc l) - len@@ -1907,7 +1931,7 @@                 return (L span tok)  do_layout_left :: Action-do_layout_left span _buf _len = do+do_layout_left span _buf _len _buf2 = do     _ <- popLexState     pushLexState bol  -- we must be at the start of a line     return (L span ITvccurly)@@ -1916,7 +1940,7 @@ -- LINE pragmas  setLineAndFile :: Int -> Action-setLineAndFile code (PsSpan span _) buf len = do+setLineAndFile code (PsSpan span _) buf len _buf2 = do   let src = lexemeToString buf (len - 1)  -- drop trailing quotation mark       linenumLen = length $ head $ words src       linenum = parseUnsignedInteger buf linenumLen 10 octDecDigit@@ -1943,7 +1967,7 @@   lexToken  setColumn :: Action-setColumn (PsSpan span _) buf len = do+setColumn (PsSpan span _) buf len _buf2 = do   let column =         case reads (lexemeToString buf len) of           [(column, _)] -> column@@ -1969,7 +1993,7 @@     mkTok' s _ = mkTok s  lex_string_prag_comment :: (String -> PsSpan -> Token) -> Action-lex_string_prag_comment mkTok span _buf _len+lex_string_prag_comment mkTok span _buf _len _buf2     = do input <- getInput          start <- getParsedLoc          l <- getLastLocComment@@ -1998,7 +2022,7 @@ -- This stuff is horrible.  I hates it.  lex_string_tok :: Action-lex_string_tok span buf _len = do+lex_string_tok span buf _len _buf2 = do   tok <- lex_string ""   (AI end bufEnd) <- getInput   let@@ -2068,7 +2092,7 @@ -- (the parser does that). -- So we have to do two characters of lookahead: when we see 'x we need to -- see if there's a trailing quote-lex_char_tok span buf _len = do        -- We've seen '+lex_char_tok span buf _len _buf2 = do        -- We've seen '    i1 <- getInput       -- Look ahead to first character    let loc = psSpanStart span    case alexGetChar' i1 of@@ -2246,7 +2270,7 @@ -- QuasiQuote  lex_qquasiquote_tok :: Action-lex_qquasiquote_tok span buf len = do+lex_qquasiquote_tok span buf len _buf2 = do   let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False   quoteStart <- getParsedLoc   quote <- lex_quasiquote (psRealLoc quoteStart) ""@@ -2258,7 +2282,7 @@                            mkPsSpan quoteStart end)))  lex_quasiquote_tok :: Action-lex_quasiquote_tok span buf len = do+lex_quasiquote_tok span buf len _buf2 = do   let quoter = tail (lexemeToString buf (len - 1))                 -- 'tail' drops the initial '[',                 -- while the -1 drops the trailing '|'@@ -2297,14 +2321,14 @@ -- Warnings  warnTab :: Action-warnTab srcspan _buf _len = do+warnTab srcspan _buf _len _buf2 = do     addTabWarning (psRealSpan srcspan)     lexToken  warnThen :: PsMessage -> Action -> Action-warnThen warning action srcspan buf len = do+warnThen warning action srcspan buf len buf2 = do     addPsMessage (RealSrcSpan (psRealSpan srcspan) Strict.Nothing) warning-    action srcspan buf len+    action srcspan buf len buf2  -- ----------------------------------------------------------------------------- -- The Parse Monad@@ -2431,7 +2455,7 @@         -- implement pushCurrentContext (which is only called from one place).          -- AZ question: setLastToken which sets last_loc and last_len-        -- is called whan processing AlexToken, immediately prior to+        -- is called when processing AlexToken, immediately prior to         -- calling the action in the token.  So from the perspective         -- of the action, it is the *current* token.  Do I understand         -- correctly?@@ -3401,7 +3425,7 @@         let span = mkPsSpan loc1 end         let bytes = byteDiff buf buf2         span `seq` setLastToken span bytes-        lt <- t span buf bytes+        lt <- t span buf bytes buf2         let lt' = unLoc lt         if (isComment lt') then setLastComment lt else setLastTk lt         return lt@@ -3490,9 +3514,10 @@      ]  dispatch_pragmas :: Map String Action -> Action-dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of-                                       Just found -> found span buf len-                                       Nothing -> lexError LexUnknownPragma+dispatch_pragmas prags span buf len buf2 =+  case Map.lookup (clean_pragma (lexemeToString buf len)) prags of+    Just found -> found span buf len buf2+    Nothing -> lexError LexUnknownPragma  known_pragma :: Map String Action -> AlexAccPred ExtsBitmap known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf)@@ -3514,13 +3539,13 @@                           canon_ws s = unwords (map canonical (words s))  warn_unknown_prag :: Map String Action -> Action-warn_unknown_prag prags span buf len = do+warn_unknown_prag prags span buf len buf2 = do   let uppercase    = map toUpper       unknown_prag = uppercase (clean_pragma (lexemeToString buf len))       suggestions  = map uppercase (Map.keys prags)   addPsMessage (RealSrcSpan (psRealSpan span) Strict.Nothing) $     PsWarnUnrecognisedPragma unknown_prag suggestions-  nested_comment span buf len+  nested_comment span buf len buf2  {- %************************************************************************

@@ -1,5 +1,6 @@  {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -214,6 +215,7 @@                                   , tcdDocs  = docs })) }  mkTyData :: SrcSpan+         -> Bool          -> NewOrData          -> Maybe (LocatedP CType)          -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)@@ -222,36 +224,35 @@          -> Located (HsDeriving GhcPs)          -> [AddEpAnn]          -> P (LTyClDecl GhcPs)-mkTyData loc' new_or_data cType (L _ (mcxt, tycl_hdr))+mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))          ksig data_cons (L _ maybe_deriv) annsIn   = do { let loc = noAnnSrcSpan loc'        ; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr        ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams        ; cs <- getCommentsFor (locA loc) -- Get any remaining comments        ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs-       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv+       ; data_cons <- checkNewOrData (locA loc) (unLoc tc) is_type_data new_or_data data_cons+       ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv        ; return (L loc (DataDecl { tcdDExt = anns',                                    tcdLName = tc, tcdTyVars = tyvars,                                    tcdFixity = fixity,                                    tcdDataDefn = defn })) } -mkDataDefn :: NewOrData-           -> Maybe (LocatedP CType)+mkDataDefn :: Maybe (LocatedP CType)            -> Maybe (LHsContext GhcPs)            -> Maybe (LHsKind GhcPs)-           -> [LConDecl GhcPs]+           -> DataDefnCons (LConDecl GhcPs)            -> HsDeriving GhcPs            -> P (HsDataDefn GhcPs)-mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv+mkDataDefn cType mcxt ksig data_cons maybe_deriv   = do { checkDatatypeContext mcxt        ; return (HsDataDefn { dd_ext = noExtField-                            , dd_ND = new_or_data, dd_cType = cType+                            , dd_cType = cType                             , dd_ctxt = mcxt                             , dd_cons = data_cons                             , dd_kindSig = ksig                             , dd_derivs = maybe_deriv }) } - mkTySynonym :: SrcSpan             -> LHsType GhcPs  -- LHS             -> LHsType GhcPs  -- RHS@@ -326,7 +327,8 @@   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr        ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan        ; let fam_eqn_ans = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments-       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv+       ; data_cons <- checkNewOrData loc (unLoc tc) False new_or_data data_cons+       ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv        ; return (L (noAnnSrcSpan loc) (DataFamInstD noExtField (DataFamInstDecl                   (FamEqn { feqn_ext    = fam_eqn_ans                           , feqn_tycon  = tc@@ -751,7 +753,7 @@ --   records whether this is a prefix or record GADT constructor. See --   Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details. mkGadtDecl :: SrcSpan-           -> [LocatedN RdrName]+           -> NonEmpty (LocatedN RdrName)            -> LHsUniToken "::" "∷" GhcPs            -> LHsSigType GhcPs            -> P (LConDecl GhcPs)@@ -1689,7 +1691,7 @@   mkHsWildCardPV l = cmdFail l (text "_")   mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> text "::" <+> ppr sig)   mkHsExplicitListPV l xs _ = cmdFail l $-    brackets (fsep (punctuate comma (map ppr xs)))+    brackets (pprWithCommas ppr xs)   mkHsSplicePV (L l sp) = cmdFail l (pprUntypedSplice True Nothing sp)   mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do     let (fs, ps) = partitionEithers fbinds@@ -1786,7 +1788,7 @@     return $ L (noAnnSrcSpan l) (ExplicitList (EpAnn (spanAsAnchor l) anns cs) xs)   mkHsSplicePV sp@(L l _) = do     cs <- getCommentsFor l-    return $ mapLoc (HsUntypedSplice (EpAnn (spanAsAnchor l) NoEpAnns cs)) sp+    return $ fmap (HsUntypedSplice (EpAnn (spanAsAnchor l) NoEpAnns cs)) sp   mkHsRecordPV opts l lrec a (fbinds, ddLoc) anns = do     cs <- getCommentsFor l     r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) (EpAnn (spanAsAnchor l) anns cs)@@ -2511,10 +2513,10 @@   | isRdrDataCon c   = do       let (fs, ps) = partitionEithers fbinds-      if not (null ps)-        then addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head ps)) $-                               PsErrOverloadedRecordDotInvalid-        else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns)+      case ps of+          p:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $+              PsErrOverloadedRecordDotInvalid+          _ -> return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns) mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns   | Just dd_loc <- dd = addFatalError $ mkPlainErrorMsgEnvelope dd_loc $                                           PsErrDotsInRecordUpdate@@ -2544,15 +2546,13 @@             [ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs'                       , isQual . rdrNameAmbiguousFieldOcc $ lbl             ]-      if not $ null qualifiedFields-        then-          addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head qualifiedFields)) $+      case qualifiedFields of+          qf:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA qf) $             PsErrOverloadedRecordUpdateNoQualifiedFields-        else -- This is a RecordDotSyntax update.-          return RecordUpd {-            rupd_ext = anns-           , rupd_expr = exp-           , rupd_flds = Right (toProjUpdates fbinds) }+          _ -> return RecordUpd -- This is a RecordDotSyntax update.+             { rupd_ext = anns+             , rupd_expr = exp+             , rupd_flds = Right (toProjUpdates fbinds) }   where     toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecUpdProj GhcPs]     toProjUpdates = map (\case { Right p -> p; Left f -> recFieldToProjUpdate f })@@ -2620,6 +2620,28 @@                  , inl_rule   = FunLike                  } +checkNewOrData :: SrcSpan -> RdrName -> Bool -> NewOrData -> [LConDecl GhcPs]+               -> P (DataDefnCons (LConDecl GhcPs))+checkNewOrData span name is_type_data = curry $ \ case+    (NewType, [a]) -> pure $ NewTypeCon a+    (DataType, as) -> pure $ DataTypeCons is_type_data (handle_type_data as)+    (NewType, as) -> addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrMultipleConForNewtype name (length as)+  where+    -- In a "type data" declaration, the constructors are in the type/class+    -- namespace rather than the data constructor namespace.+    -- See Note [Type data declarations] in GHC.Rename.Module.+    handle_type_data+      | is_type_data = map (fmap promote_constructor)+      | otherwise = id++    promote_constructor (dc@ConDeclGADT { con_names = cons })+      = dc { con_names = fmap (fmap promote_name) cons }+    promote_constructor (dc@ConDeclH98 { con_name = con })+      = dc { con_name = fmap promote_name con }+    promote_constructor dc = dc++    promote_name name = fromMaybe name (promoteRdrName name)+ ----------------------------------------------------------------------------- -- utilities for foreign declarations @@ -2811,7 +2833,7 @@     ieNameFromSpec (ImpExpQcType r (L l n)) = IEType r (L l n)     ieNameFromSpec (ImpExpQcWildcard)  = panic "ieName got wildcard" -    wrapped = map (mapLoc ieNameFromSpec)+    wrapped = map (fmap ieNameFromSpec)  mkTypeImpExp :: LocatedN RdrName   -- TcCls or Var name space              -> P (LocatedN RdrName)@@ -2887,6 +2909,7 @@     }  data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum+  deriving (Foldable, Functor, Traversable)  -- During parsing, we make use of several monadic effects: reporting parse errors, -- accumulating warnings, adding API annotations, and checking for extensions. These@@ -2908,9 +2931,7 @@ --   abParser :: forall x. DisambAB x => P (PV x) -- newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a }--instance Functor PV where-  fmap = liftM+  deriving (Functor)  instance Applicative PV where   pure a = a `seq` PV (\_ acc -> PV_Ok acc a)@@ -2985,7 +3006,7 @@  {- Note [Parser-Validator Details] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A PV computation is parametrized by some 'ParseContext' for diagnostic messages, which can be set+A PV computation is parameterized by some 'ParseContext' for diagnostic messages, which can be set depending on validation context. We use this in checkPattern to fix #984.  Consider this example, where the user has forgotten a 'do':

@@ -48,7 +48,7 @@ -} module GHC.Parser.PostProcess.Haddock (addHaddockToModule) where -import GHC.Prelude hiding (mod)+import GHC.Prelude hiding (head, mod)  import GHC.Hs @@ -60,6 +60,7 @@ import Data.Foldable import Data.Traversable import Data.Maybe+import Data.List.NonEmpty (head) import Control.Monad import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader@@ -584,7 +585,7 @@     --      = MkT1 Int Bool  -- ^ Comment on MkT1     --      | MkT2 Char Int  -- ^ Comment on MkT2     ---    dd_cons' <- addHaddock (dd_cons defn)+    dd_cons' <- traverse addHaddock (dd_cons defn)      -- Process the deriving clauses:     --@@ -1308,7 +1309,7 @@ ********************************************************************* -}  mkDocHsDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs)-mkDocHsDecl layout_info a = mapLoc (DocD noExtField) <$> mkDocDecl layout_info a+mkDocHsDecl layout_info a = fmap (DocD noExtField) <$> mkDocDecl layout_info a  mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs) mkDocDecl layout_info (L l_comment hdk_comment)@@ -1530,7 +1531,7 @@  -- Map a function over a list of located items. mapLL :: (a -> b) -> [GenLocated l a] -> [GenLocated l b]-mapLL f = map (mapLoc f)+mapLL f = map (fmap f)  {- Note [Old solution: Haddock in the grammar] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1576,7 +1577,7 @@  We could use EPA (exactprint annotations) to fix this, but not without modification. For example, EpaLocation contains RealSrcSpan but not BufSpan.-Also, the fix would be more straghtforward after #19623.+Also, the fix would be more straightforward after #19623.  For examples, see tests/haddock/should_compile_flag_haddock/T17544_kw.hs -}

@@ -61,7 +61,7 @@  -- | A way ----- Don't change the constructor order as it us used by `waysTag` to create a+-- Don't change the constructor order as it is used by `waysTag` to create a -- unique tag (e.g. thr_debug_p) which is expected by other tools (e.g. Cabal). data Way   = WayCustom String -- ^ for GHC API clients building custom variants

@@ -14,6 +14,7 @@  module GHC.Prelude   (module X+  ,Applicative (..)   ,module Bits   ,shiftL, shiftR   ) where@@ -47,7 +48,8 @@     extensions. -} -import Prelude as X hiding ((<>))+import Prelude as X hiding ((<>), Applicative(..))+import Control.Applicative (Applicative(..)) import Data.Foldable as X (foldl')  #if MIN_VERSION_base(4,16,0)@@ -74,7 +76,7 @@ Why do we then continue on to re-export the rest of Data.Bits? If we would not what is likely to happen is: * Someone imports Data.Bits, uses xor. Things are fine.-* They add a shift and get an ambigious definition error.+* They add a shift and get an ambiguous definition error. * The are puzzled for a bit. * They either:   + Remove the import of Data.Bits and get an error because xor is not in scope.

@@ -198,7 +198,7 @@   It would be correct ot re-construct the env from scratch based on-`ic_tythings`, but that'd be quite expensive if there are many entires in+`ic_tythings`, but that'd be quite expensive if there are many entries in `ic_tythings` that shadow each other.  Therefore we keep around a that `GlobalRdrEnv` in `igre_prompt_env` that@@ -285,7 +285,7 @@           ic_plugins :: !Plugins              -- ^ Cache of loaded plugins. We store them here to avoid having to-             -- load them everytime we switch to the interctive context.+             -- load them every time we switch to the interactive context.     }  data InteractiveImport

@@ -167,7 +167,7 @@ dynLibSuffix (GhcNameVersion name ver) = '-':name ++ ver  -------------------------------------------------------------------------------- Accessessors from 'Settings'+-- Accessors from 'Settings'  sProgramName         :: Settings -> String sProgramName = ghcNameVersion_programName . sGhcNameVersion

@@ -122,7 +122,7 @@ -- | Expand occurrences of the @$tooldir@ interpolation in a string -- on Windows, leave the string untouched otherwise. expandToolDir-  :: Bool -- ^ whether we are use the ambiant mingw toolchain+  :: Bool -- ^ whether we use the ambient mingw toolchain   -> Maybe FilePath -- ^ tooldir   -> String -> String #if defined(mingw32_HOST_OS)@@ -166,7 +166,7 @@ -- tooldir can't be located, or returns @Just tooldirpath@. -- If the distro toolchain is being used we treat Windows the same as Linux findToolDir-  :: Bool -- ^ whether we are use the ambiant mingw toolchain+  :: Bool -- ^ whether we use the ambient mingw toolchain   -> FilePath -- ^ topdir   -> IO (Maybe FilePath) #if defined(mingw32_HOST_OS)

@@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DataKinds #-}  {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage @@ -56,6 +57,7 @@ import GHC.Types.Hint (UntickedPromotedThing(..), pprUntickedConstructor, isBareSymbol) import GHC.Types.Hint.Ppr () -- Outputable GhcHint import GHC.Types.Basic+import GHC.Types.Error.Codes ( constructorCode ) import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Reader ( GreName(..), pprNameProvenance@@ -102,19 +104,18 @@       -> case msg_with_info of            TcRnMessageDetailed err_info msg              -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage msg)-    TcRnSolverReport msgs _ _-      -> mkDecorated $-           map pprSolverReportWithCtxt msgs+    TcRnSolverReport msg _ _+      -> mkSimpleDecorated $ pprSolverReportWithCtxt msg     TcRnRedundantConstraints redundants (info, show_info)       -> mkSimpleDecorated $          text "Redundant constraint" <> plural redundants <> colon            <+> pprEvVarTheta redundants          $$ if show_info then text "In" <+> ppr info else empty-    TcRnInaccessibleCode implic contras+    TcRnInaccessibleCode implic contra       -> mkSimpleDecorated $          hang (text "Inaccessible code in")            2 (ppr (ic_info implic))-         $$ vcat (map pprSolverReportWithCtxt (NE.toList contras))+         $$ pprSolverReportWithCtxt contra     TcRnTypeDoesNotHaveFixedRuntimeRep ty prov (ErrInfo extra supplementary)       -> mkDecorated [pprTypeDoesNotHaveFixedRuntimeRep ty prov, extra, supplementary]     TcRnImplicitLift id_or_name ErrInfo{..}@@ -906,7 +907,7 @@                      TyConPE        -> same_rec_group_msg                      TermVariablePE -> text "term variables cannot be promoted"           same_rec_group_msg = text "it is defined and used in the same recursive group"-    TcRnMatchesHaveDiffNumArgs argsContext match1 bad_matches+    TcRnMatchesHaveDiffNumArgs argsContext (MatchArgMatches match1 bad_matches)       -> mkSimpleDecorated $            (vcat [ pprArgsContext argsContext <+>                    text "have different numbers of arguments"@@ -993,6 +994,13 @@         text "No explicit" <+> text "associated type"           <+> text "or default declaration for"           <+> quotes (ppr name)+    TcRnIllegalTypeData+      -> mkSimpleDecorated $+        text "Illegal type-level data declaration"+    TcRnTypeDataForbids feature+      -> mkSimpleDecorated $+        ppr feature <+> text "are not allowed in type data declarations."+   diagnosticReason = \case     TcRnUnknownMessage m       -> diagnosticReason m@@ -1322,6 +1330,10 @@       -> ErrorWithoutFlag     TcRnNoExplicitAssocTypeOrDefaultDeclaration{}       -> WarningWithFlag (Opt_WarnMissingMethods)+    TcRnIllegalTypeData+      -> ErrorWithoutFlag+    TcRnTypeDataForbids{}+      -> ErrorWithoutFlag    diagnosticHints = \case     TcRnUnknownMessage m@@ -1634,17 +1646,34 @@       -> noHints     TcRnSpecialiseNotVisible name       -> [SuggestSpecialiseVisibilityHints name]-    TcRnNameByTemplateHaskellQuote{} -> noHints-    TcRnIllegalBindingOfBuiltIn{} -> noHints-    TcRnPragmaWarning{} -> noHints-    TcRnIllegalHsigDefaultMethods{} -> noHints-    TcRnBadGenericMethod{} -> noHints-    TcRnWarningMinimalDefIncomplete{} -> noHints-    TcRnDefaultMethodForPragmaLacksBinding{} -> noHints-    TcRnIgnoreSpecialisePragmaOnDefMethod{} -> noHints-    TcRnBadMethodErr{} -> noHints-    TcRnNoExplicitAssocTypeOrDefaultDeclaration{} -> noHints+    TcRnNameByTemplateHaskellQuote{}+      -> noHints+    TcRnIllegalBindingOfBuiltIn{}+      -> noHints+    TcRnPragmaWarning{}+      -> noHints+    TcRnIllegalHsigDefaultMethods{}+      -> noHints+    TcRnBadGenericMethod{}+      -> noHints+    TcRnWarningMinimalDefIncomplete{}+      -> noHints+    TcRnDefaultMethodForPragmaLacksBinding{}+      -> noHints+    TcRnIgnoreSpecialisePragmaOnDefMethod{}+      -> noHints+    TcRnBadMethodErr{}+      -> noHints+    TcRnNoExplicitAssocTypeOrDefaultDeclaration{}+      -> noHints+    TcRnIllegalTypeData+      -> [suggestExtension LangExt.TypeData]+    TcRnTypeDataForbids{}+      -> noHints +  diagnosticCode = constructorCode++ -- | Change [x] to "x", [x, y] to "x and y", [x, y, z] to "x, y, and z", -- and so on.  The `and` stands for any `conjunction`, which is passed in. commafyWith :: SDoc -> [SDoc] -> [SDoc]@@ -2059,11 +2088,6 @@  -- | Pretty-print a 'TcSolverReportMsg', with its enclosing 'SolverReportErrCtxt'. pprTcSolverReportMsg :: SolverReportErrCtxt -> TcSolverReportMsg -> SDoc-pprTcSolverReportMsg ctxt (TcReportWithInfo msg (info :| infos)) =-  vcat-    ( pprTcSolverReportMsg ctxt msg-    : pprTcSolverReportInfo ctxt info-    : map (pprTcSolverReportInfo ctxt) infos ) pprTcSolverReportMsg _ (BadTelescope telescope skols) =   hang (text "These kind and type variables:" <+> ppr telescope $$        text "are out of dependency order. Perhaps try this ordering:")@@ -2074,143 +2098,22 @@   pprUserTypeErrorTy ty pprTcSolverReportMsg ctxt (ReportHoleError hole err) =   pprHoleError ctxt hole err-pprTcSolverReportMsg _ (CannotUnifyWithPolytype item tv1 ty2) =-  vcat [ (if isSkolemTyVar tv1-          then text "Cannot equate type variable"-          else text "Cannot instantiate unification variable")-         <+> quotes (ppr tv1)-       , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ]-  where-    what = text $ levelString $-           ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel-pprTcSolverReportMsg _-  (Mismatch { mismatch_ea   = add_ea-            , mismatch_item = item-            , mismatch_ty1  = ty1-            , mismatch_ty2  = ty2 })-  = addArising (errorItemCtLoc item) msg-  where-    msg-      | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) ||-        (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) ||-        (isLiftedLevity ty1 && isUnliftedLevity ty2) ||-        (isLiftedLevity ty2 && isUnliftedLevity ty1)-      = text "Couldn't match a lifted type with an unlifted type"--      | isAtomicTy ty1 || isAtomicTy ty2-      = -- Print with quotes-        sep [ text herald1 <+> quotes (ppr ty1)-            , nest padding $-              text herald2 <+> quotes (ppr ty2) ]--      | otherwise-      = -- Print with vertical layout-        vcat [ text herald1 <> colon <+> ppr ty1-             , nest padding $-               text herald2 <> colon <+> ppr ty2 ]--    herald1 = conc [ "Couldn't match"-                   , if is_repr then "representation of" else ""-                   , if add_ea then "expected"          else ""-                   , what ]-    herald2 = conc [ "with"-                   , if is_repr then "that of"          else ""-                   , if add_ea then ("actual " ++ what) else "" ]--    padding = length herald1 - length herald2--    is_repr = case errorItemEqRel item of { ReprEq -> True; NomEq -> False }--    what = levelString (ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel)--    conc :: [String] -> String-    conc = foldr1 add_space--    add_space :: String -> String -> String-    add_space s1 s2 | null s1   = s2-                    | null s2   = s1-                    | otherwise = s1 ++ (' ' : s2)-pprTcSolverReportMsg _-  (KindMismatch { kmismatch_what     = thing-                , kmismatch_expected = exp-                , kmismatch_actual   = act })-  = hang (text "Expected" <+> kind_desc <> comma)-      2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+>-        quotes (ppr act))-  where-    kind_desc | tcIsConstraintKind exp = text "a constraint"-              | Just arg <- kindRep_maybe exp  -- TYPE t0-              , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case-                                   True  -> text "kind" <+> quotes (ppr exp)-                                   False -> text "a type"-              | otherwise       = text "kind" <+> quotes (ppr exp)-- pprTcSolverReportMsg ctxt-  (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds-                  , teq_mismatch_item     = item-                  , teq_mismatch_ty1      = ty1-                  , teq_mismatch_ty2      = ty2-                  , teq_mismatch_expected = exp-                  , teq_mismatch_actual   = act-                  , teq_mismatch_what     = mb_thing })-  = addArising ct_loc $ pprWithExplicitKindsWhen ppr_explicit_kinds msg-  where-    msg-      | isUnliftedTypeKind act, isLiftedTypeKind exp-      = sep [ text "Expecting a lifted type, but"-            , thing_msg mb_thing (text "an") (text "unlifted") ]-      | isLiftedTypeKind act, isUnliftedTypeKind exp-      = sep [ text "Expecting an unlifted type, but"-            , thing_msg mb_thing (text "a") (text "lifted") ]-      | tcIsLiftedTypeKind exp-      = maybe_num_args_msg $$-        sep [ text "Expected a type, but"-            , case mb_thing of-                Nothing    -> text "found something with kind"-                Just thing -> quotes (ppr thing) <+> text "has kind"-            , quotes (pprWithTYPE act) ]-      | Just nargs_msg <- num_args_msg-      , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig-      = nargs_msg $$ pprTcSolverReportMsg ctxt ea_msg-      | -- pprTrace "check" (ppr ea_looks_same $$ ppr exp $$ ppr act $$ ppr ty1 $$ ppr ty2) $-        ea_looks_same ty1 ty2 exp act-      , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig-      = pprTcSolverReportMsg ctxt ea_msg-      -- The mismatched types are /inside/ exp and act-      | let mismatch_err = Mismatch False item ty1 ty2-            errs = case mk_ea_msg ctxt Nothing level orig of-              Left ea_info -> [ mkTcReportWithInfo mismatch_err ea_info ]-              Right ea_err -> [ mismatch_err, ea_err ]-      = vcat $ map (pprTcSolverReportMsg ctxt) errs--    ct_loc = errorItemCtLoc item-    orig   = errorItemOrigin item-    level  = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel--    thing_msg (Just thing) _  levity = quotes (ppr thing) <+> text "is" <+> levity-    thing_msg Nothing      an levity = text "got" <+> an <+> levity <+> text "type"--    num_args_msg = case level of-      KindLevel-        | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act)-           -- if one is a meta-tyvar, then it's possible that the user-           -- has asked for something impredicative, and we couldn't unify.-           -- Don't bother with counting arguments.-        -> let n_act = count_args act-               n_exp = count_args exp in-           case n_act - n_exp of-             n | n > 0   -- we don't know how many args there are, so don't-                         -- recommend removing args that aren't-               , Just thing <- mb_thing-               -> Just $ pprTcSolverReportMsg ctxt (ExpectingMoreArguments n thing)-             _ -> Nothing--      _ -> Nothing--    maybe_num_args_msg = num_args_msg `orElse` empty--    count_args ty = count isVisibleBinder $ fst $ splitPiTys ty+  (CannotUnifyVariable+    { mismatchMsg             = msg+    , cannotUnifyReason       = reason })+  =  pprMismatchMsg ctxt msg+  $$ pprCannotUnifyVariableReason ctxt reason+pprTcSolverReportMsg ctxt+  (Mismatch+     { mismatchMsg           = mismatch_msg+     , mismatchTyVarInfo     = tv_info+     , mismatchAmbiguityInfo = ambig_infos+     , mismatchCoercibleInfo = coercible_info })+  = hang (pprMismatchMsg ctxt mismatch_msg)+     2 (vcat ( maybe empty (pprTyVarInfo ctxt) tv_info+             : maybe empty pprCoercibleMsg coercible_info+             : map pprAmbiguityInfo ambig_infos )) pprTcSolverReportMsg _ (FixedRuntimeRepError frr_origs) =   vcat (map make_msg frr_origs)   where@@ -2287,28 +2190,6 @@           = quotes (text "Levity")           | otherwise           = text "type"--pprTcSolverReportMsg _ (SkolemEscape item implic esc_skols) =-  let-    esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols-                <+> pprQuotedList esc_skols-              , text "would escape" <+>-                if isSingleton esc_skols then text "its scope"-                                         else text "their scope" ]-  in-  vcat [ nest 2 $ esc_doc-       , sep [ (if isSingleton esc_skols-                then text "This (rigid, skolem)" <+>-                     what <+> text "variable is"-                else text "These (rigid, skolem)" <+>-                     what <+> text "variables are")-         <+> text "bound by"-       , nest 2 $ ppr (ic_info implic)-       , nest 2 $ text "at" <+>-         ppr (getLclEnvLoc (ic_env implic)) ] ]-  where-    what = text $ levelString $-           ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel pprTcSolverReportMsg _ (UntouchableVariable tv implic)   | Implic { ic_given = given, ic_info = skol_info } <- implic   = sep [ quotes (ppr tv) <+> text "is untouchable"@@ -2333,52 +2214,11 @@      then addArising (errorItemCtLoc item) $             sep [ text "Unbound implicit parameter" <> plural preds                 , nest 2 (pprParendTheta preds) ]-     else pprTcSolverReportMsg ctxt (CouldNotDeduce givens (item :| items) Nothing)+     else pprMismatchMsg ctxt (CouldNotDeduce givens (item :| items) Nothing)   where     preds = map errorItemPred (item : items)-pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra)-  = main_msg $$-     case supplementary of-      Left infos-        -> vcat (map (pprTcSolverReportInfo ctxt) infos)-      Right other_msg-        -> pprTcSolverReportMsg ctxt other_msg-  where-    main_msg-      | null useful_givens-      = addArising ct_loc (no_instance_msg <+> missing)-      | otherwise-      = vcat (addArising ct_loc (no_deduce_msg <+> missing)-              : pp_givens useful_givens)--    supplementary = case mb_extra of-      Nothing-        -> Left []-      Just (CND_Extra level ty1 ty2)-        -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig-    ct_loc = errorItemCtLoc item-    orig   = ctLocOrigin ct_loc-    wanteds = map errorItemPred (item:others)--    no_instance_msg =-      case wanteds of-        [wanted] | Just (tc, _) <- splitTyConApp_maybe wanted-                 -- Don't say "no instance" for a constraint such as "c" for a type variable c.-                 , isClassTyCon tc -> text "No instance for"-        _ -> text "Could not solve:"--    no_deduce_msg =-      case wanteds of-        [_wanted] -> text "Could not deduce"-        _         -> text "Could not deduce:"--    missing =-      case wanteds of-        [wanted] -> quotes (ppr wanted)-        _        -> pprTheta wanteds--pprTcSolverReportMsg ctxt (AmbiguityPreventsSolvingCt item ambigs) =-  pprTcSolverReportInfo ctxt (Ambiguity True ambigs) <+>+pprTcSolverReportMsg _ (AmbiguityPreventsSolvingCt item ambigs) =+  pprAmbiguityInfo (Ambiguity True ambigs) <+>   pprArising (errorItemCtLoc item) $$   text "prevents the constraint" <+> quotes (pprParendType $ errorItemPred item)   <+> text "from being solved."@@ -2386,12 +2226,12 @@   (CannotResolveInstance item unifiers candidates imp_errs suggs binds)   =     vcat-      [ pprTcSolverReportMsg ctxt no_inst_msg+      [ no_inst_msg       , nest 2 extra_note       , mb_patsyn_prov `orElse` empty       , ppWhen (has_ambigs && not (null unifiers && null useful_givens))         (vcat [ ppUnless lead_with_ambig $-                  pprTcSolverReportInfo ctxt (Ambiguity False (ambig_kvs, ambig_tvs))+                  pprAmbiguityInfo (Ambiguity False (ambig_kvs, ambig_tvs))               , pprRelevantBindings binds               , potential_msg ])       , ppWhen (isNothing mb_patsyn_prov) $@@ -2421,12 +2261,12 @@                    && not (null unifiers)                    && null useful_givens -    no_inst_msg :: TcSolverReportMsg+    no_inst_msg :: SDoc     no_inst_msg       | lead_with_ambig-      = AmbiguityPreventsSolvingCt item (ambig_kvs, ambig_tvs)+      = pprTcSolverReportMsg ctxt $ AmbiguityPreventsSolvingCt item (ambig_kvs, ambig_tvs)       | otherwise-      = CouldNotDeduce useful_givens (item :| []) Nothing+      = pprMismatchMsg ctxt $ CouldNotDeduce useful_givens (item :| []) Nothing      -- Report "potential instances" only when the constraint arises     -- directly from the user's use of an overloaded function@@ -2556,6 +2396,242 @@     pred        = errorItemPred item     (clas, tys) = getClassPredTys pred +pprCannotUnifyVariableReason :: SolverReportErrCtxt -> CannotUnifyVariableReason -> SDoc+pprCannotUnifyVariableReason ctxt (CannotUnifyWithPolytype item tv1 ty2 mb_tv_info) =+  vcat [ (if isSkolemTyVar tv1+          then text "Cannot equate type variable"+          else text "Cannot instantiate unification variable")+         <+> quotes (ppr tv1)+       , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2)+       , maybe empty (pprTyVarInfo ctxt) mb_tv_info ]+  where+    what = text $ levelString $+           ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel++pprCannotUnifyVariableReason _ (SkolemEscape item implic esc_skols) =+  let+    esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols+                <+> pprQuotedList esc_skols+              , text "would escape" <+>+                if isSingleton esc_skols then text "its scope"+                                         else text "their scope" ]+  in+  vcat [ nest 2 $ esc_doc+       , sep [ (if isSingleton esc_skols+                then text "This (rigid, skolem)" <+>+                     what <+> text "variable is"+                else text "These (rigid, skolem)" <+>+                     what <+> text "variables are")+         <+> text "bound by"+       , nest 2 $ ppr (ic_info implic)+       , nest 2 $ text "at" <+>+         ppr (getLclEnvLoc (ic_env implic)) ] ]+  where+    what = text $ levelString $+           ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel++pprCannotUnifyVariableReason ctxt+  (OccursCheck+    { occursCheckInterestingTyVars = interesting_tvs+    , occursCheckAmbiguityInfos    = ambig_infos })+  = ppr_interesting_tyVars interesting_tvs+  $$ vcat (map pprAmbiguityInfo ambig_infos)+  where+    ppr_interesting_tyVars [] = empty+    ppr_interesting_tyVars (tv:tvs) =+      hang (text "Type variable kinds:") 2 $+      vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))+                (tv:tvs))+    tyvar_binding tyvar = ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)+pprCannotUnifyVariableReason ctxt (DifferentTyVars tv_info)+  = pprTyVarInfo ctxt tv_info+pprCannotUnifyVariableReason ctxt (RepresentationalEq tv_info mb_coercible_msg)+  = pprTyVarInfo ctxt tv_info+  $$ maybe empty pprCoercibleMsg mb_coercible_msg++pprMismatchMsg :: SolverReportErrCtxt -> MismatchMsg -> SDoc+pprMismatchMsg ctxt+  (BasicMismatch { mismatch_ea   = ea+                 , mismatch_item = item+                 , mismatch_ty1  = ty1+                 , mismatch_ty2  = ty2+                 , mismatch_whenMatching = mb_match_txt+                 , mismatch_mb_same_occ  = same_occ_info })+  = addArising (errorItemCtLoc item) msg+  $$ maybe empty (pprWhenMatching ctxt) mb_match_txt+  $$ maybe empty pprSameOccInfo same_occ_info+  where+    msg+      | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) ||+        (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) ||+        (isLiftedLevity ty1 && isUnliftedLevity ty2) ||+        (isLiftedLevity ty2 && isUnliftedLevity ty1)+      = text "Couldn't match a lifted type with an unlifted type"++      | isAtomicTy ty1 || isAtomicTy ty2+      = -- Print with quotes+        sep [ text herald1 <+> quotes (ppr ty1)+            , nest padding $+              text herald2 <+> quotes (ppr ty2) ]++      | otherwise+      = -- Print with vertical layout+        vcat [ text herald1 <> colon <+> ppr ty1+             , nest padding $+               text herald2 <> colon <+> ppr ty2 ]++    want_ea = case ea of { NoEA -> False; EA {} -> True }++    herald1 = conc [ "Couldn't match"+                   , if is_repr then "representation of" else ""+                   , if want_ea then "expected"          else ""+                   , what ]+    herald2 = conc [ "with"+                   , if is_repr then "that of"          else ""+                   , if want_ea then ("actual " ++ what) else "" ]++    padding = length herald1 - length herald2++    is_repr = case errorItemEqRel item of { ReprEq -> True; NomEq -> False }++    what = levelString (ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel)++    conc :: [String] -> String+    conc = foldr1 add_space++    add_space :: String -> String -> String+    add_space s1 s2 | null s1   = s2+                    | null s2   = s1+                    | otherwise = s1 ++ (' ' : s2)+pprMismatchMsg _+  (KindMismatch { kmismatch_what     = thing+                , kmismatch_expected = exp+                , kmismatch_actual   = act })+  = hang (text "Expected" <+> kind_desc <> comma)+      2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+>+        quotes (ppr act))+  where+    kind_desc | tcIsConstraintKind exp = text "a constraint"+              | Just arg <- kindRep_maybe exp  -- TYPE t0+              , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case+                                   True  -> text "kind" <+> quotes (ppr exp)+                                   False -> text "a type"+              | otherwise       = text "kind" <+> quotes (ppr exp)++pprMismatchMsg ctxt+  (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds+                  , teq_mismatch_item     = item+                  , teq_mismatch_ty1      = ty1+                  , teq_mismatch_ty2      = ty2+                  , teq_mismatch_expected = exp+                  , teq_mismatch_actual   = act+                  , teq_mismatch_what     = mb_thing+                  , teq_mb_same_occ       = mb_same_occ })+  = (addArising ct_loc $ pprWithExplicitKindsWhen ppr_explicit_kinds msg)+  $$ maybe empty pprSameOccInfo mb_same_occ+  where+    msg+      | isUnliftedTypeKind act, isLiftedTypeKind exp+      = sep [ text "Expecting a lifted type, but"+            , thing_msg mb_thing (text "an") (text "unlifted") ]+      | isLiftedTypeKind act, isUnliftedTypeKind exp+      = sep [ text "Expecting an unlifted type, but"+            , thing_msg mb_thing (text "a") (text "lifted") ]+      | tcIsLiftedTypeKind exp+      = maybe_num_args_msg $$+        sep [ text "Expected a type, but"+            , case mb_thing of+                Nothing    -> text "found something with kind"+                Just thing -> quotes (ppr thing) <+> text "has kind"+            , quotes (pprWithTYPE act) ]+      | Just nargs_msg <- num_args_msg+      , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig+      = nargs_msg $$ pprMismatchMsg ctxt ea_msg+      | -- pprTrace "check" (ppr ea_looks_same $$ ppr exp $$ ppr act $$ ppr ty1 $$ ppr ty2) $+        ea_looks_same ty1 ty2 exp act+      , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig+      = pprMismatchMsg ctxt ea_msg++      | otherwise+      =+      -- The mismatched types are /inside/ exp and act+        let mismatch_err = mkBasicMismatchMsg NoEA item ty1 ty2+            errs = case mk_ea_msg ctxt Nothing level orig of+              Left ea_info -> pprMismatchMsg ctxt mismatch_err : map (pprExpectedActualInfo ctxt) ea_info+              Right ea_err -> [ pprMismatchMsg ctxt mismatch_err, pprMismatchMsg ctxt ea_err ]+        in vcat errs++    ct_loc = errorItemCtLoc item+    orig   = errorItemOrigin item+    level  = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel++    thing_msg (Just thing) _  levity = quotes (ppr thing) <+> text "is" <+> levity+    thing_msg Nothing      an levity = text "got" <+> an <+> levity <+> text "type"++    num_args_msg = case level of+      KindLevel+        | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act)+           -- if one is a meta-tyvar, then it's possible that the user+           -- has asked for something impredicative, and we couldn't unify.+           -- Don't bother with counting arguments.+        -> let n_act = count_args act+               n_exp = count_args exp in+           case n_act - n_exp of+             n | n > 0   -- we don't know how many args there are, so don't+                         -- recommend removing args that aren't+               , Just thing <- mb_thing+               -> Just $ pprTcSolverReportMsg ctxt (ExpectingMoreArguments n thing)+             _ -> Nothing++      _ -> Nothing++    maybe_num_args_msg = num_args_msg `orElse` empty++    count_args ty = count isVisibleBinder $ fst $ splitPiTys ty++pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra)+  = main_msg $$+     case supplementary of+      Left infos+        -> vcat (map (pprExpectedActualInfo ctxt) infos)+      Right other_msg+        -> pprMismatchMsg ctxt other_msg+  where+    main_msg+      | null useful_givens+      = addArising ct_loc (no_instance_msg <+> missing)+      | otherwise+      = vcat (addArising ct_loc (no_deduce_msg <+> missing)+              : pp_givens useful_givens)++    supplementary = case mb_extra of+      Nothing+        -> Left []+      Just (CND_Extra level ty1 ty2)+        -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig+    ct_loc = errorItemCtLoc item+    orig   = ctLocOrigin ct_loc+    wanteds = map errorItemPred (item:others)++    no_instance_msg =+      case wanteds of+        [wanted] | Just (tc, _) <- splitTyConApp_maybe wanted+                 -- Don't say "no instance" for a constraint such as "c" for a type variable c.+                 , isClassTyCon tc -> text "No instance for"+        _ -> text "Could not solve:"++    no_deduce_msg =+      case wanteds of+        [_wanted] -> text "Could not deduce"+        _         -> text "Could not deduce:"++    missing =+      case wanteds of+        [wanted] -> quotes (ppr wanted)+        _        -> pprTheta wanteds+++ {- ********************************************************************* *                                                                      *                  Displaying potential instances@@ -2746,50 +2822,17 @@  {- ********************************************************************* *                                                                      *-                    Outputting TcSolverReportInfo+             Outputting additional solver report information *                                                                      * **********************************************************************-}  -- | Pretty-print an informational message, to accompany a 'TcSolverReportMsg'.-pprTcSolverReportInfo :: SolverReportErrCtxt -> TcSolverReportInfo -> SDoc-pprTcSolverReportInfo _ (Ambiguity prepend_msg (ambig_kvs, ambig_tvs)) = msg-  where--    msg |  any isRuntimeUnkSkol ambig_kvs  -- See Note [Runtime skolems]-        || any isRuntimeUnkSkol ambig_tvs-        = vcat [ text "Cannot resolve unknown runtime type"-                 <> plural ambig_tvs <+> pprQuotedList ambig_tvs-               , text "Use :print or :force to determine these types"]--        | not (null ambig_tvs)-        = pp_ambig (text "type") ambig_tvs--        | otherwise-        = pp_ambig (text "kind") ambig_kvs--    pp_ambig what tkvs-      | prepend_msg -- "Ambiguous type variable 't0'"-      = text "Ambiguous" <+> what <+> text "variable"-        <> plural tkvs <+> pprQuotedList tkvs--      | otherwise -- "The type variable 't0' is ambiguous"-      = text "The" <+> what <+> text "variable" <> plural tkvs-        <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous"-pprTcSolverReportInfo ctxt (TyVarInfo tv ) =-  case tcTyVarDetails tv of-    SkolemTv sk_info _ _   -> pprSkols ctxt [(getSkolemInfo sk_info, [tv])]-    RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem"-    MetaTv {}     -> empty-pprTcSolverReportInfo _ (NonInjectiveTyFam tc) =-  text "NB:" <+> quotes (ppr tc)-  <+> text "is a non-injective type family"-pprTcSolverReportInfo _ (ReportCoercibleMsg msg) =-  pprCoercibleMsg msg-pprTcSolverReportInfo _ (ExpectedActual { ea_expected = exp, ea_actual = act }) =+pprExpectedActualInfo :: SolverReportErrCtxt -> ExpectedActualInfo -> SDoc+pprExpectedActualInfo _ (ExpectedActual { ea_expected = exp, ea_actual = act }) =   vcat     [ text "Expected:" <+> ppr exp     , text "  Actual:" <+> ppr act ]-pprTcSolverReportInfo _+pprExpectedActualInfo _   (ExpectedActualAfterTySynExpansion     { ea_expanded_expected = exp     , ea_expanded_actual   = act } )@@ -2797,7 +2840,23 @@       [ text "Type synonyms expanded:"       , text "Expected type:" <+> ppr exp       , text "  Actual type:" <+> ppr act ]-pprTcSolverReportInfo ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) =++pprCoercibleMsg :: CoercibleMsg -> SDoc+pprCoercibleMsg (UnknownRoles ty) =+  hang (text "NB: We cannot know what roles the parameters to" <+>+          quotes (ppr ty) <+> text "have;")+       2 (text "we must assume that the role is nominal")+pprCoercibleMsg (TyConIsAbstract tc) =+  hsep [ text "NB: The type constructor"+       , quotes (pprSourceTyCon tc)+       , text "is abstract" ]+pprCoercibleMsg (OutOfScopeNewtypeConstructor tc dc) =+  hang (text "The data constructor" <+> quotes (ppr $ dataConName dc))+    2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)+           , text "is not in scope" ])++pprWhenMatching :: SolverReportErrCtxt -> WhenMatching -> SDoc+pprWhenMatching ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) =   sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions ->     if printExplicitCoercions        || not (cty1 `pickyEqType` cty2)@@ -2813,9 +2872,48 @@     sub_whats  = text (levelString sub_t_or_k) <> char 's'     supplementary =       case mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o of-        Left infos -> vcat $ map (pprTcSolverReportInfo ctxt) infos-        Right msg  -> pprTcSolverReportMsg ctxt msg-pprTcSolverReportInfo _ (SameOcc same_pkg n1 n2) =+        Left infos -> vcat $ map (pprExpectedActualInfo ctxt) infos+        Right msg  -> pprMismatchMsg ctxt msg++pprTyVarInfo :: SolverReportErrCtxt -> TyVarInfo -> SDoc+pprTyVarInfo ctxt (TyVarInfo { thisTyVar = tv1, otherTy = mb_tv2 }) =+  mk_msg tv1 $$ case mb_tv2 of { Nothing -> empty; Just tv2 -> mk_msg tv2 }+  where+    mk_msg tv = case tcTyVarDetails tv of+      SkolemTv sk_info _ _ -> pprSkols ctxt [(getSkolemInfo sk_info, [tv])]+      RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem"+      MetaTv {}     -> empty++pprAmbiguityInfo :: AmbiguityInfo -> SDoc+pprAmbiguityInfo (Ambiguity prepend_msg (ambig_kvs, ambig_tvs)) = msg+  where++    msg |  any isRuntimeUnkSkol ambig_kvs  -- See Note [Runtime skolems]+        || any isRuntimeUnkSkol ambig_tvs+        = vcat [ text "Cannot resolve unknown runtime type"+                 <> plural ambig_tvs <+> pprQuotedList ambig_tvs+               , text "Use :print or :force to determine these types"]++        | not (null ambig_tvs)+        = pp_ambig (text "type") ambig_tvs++        | otherwise+        = pp_ambig (text "kind") ambig_kvs++    pp_ambig what tkvs+      | prepend_msg -- "Ambiguous type variable 't0'"+      = text "Ambiguous" <+> what <+> text "variable"+        <> plural tkvs <+> pprQuotedList tkvs++      | otherwise -- "The type variable 't0' is ambiguous"+      = text "The" <+> what <+> text "variable" <> plural tkvs+        <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous"+pprAmbiguityInfo (NonInjectiveTyFam tc) =+  text "NB:" <+> quotes (ppr tc)+  <+> text "is a non-injective type family"++pprSameOccInfo :: SameOccInfo -> SDoc+pprSameOccInfo (SameOcc same_pkg n1 n2) =   text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2)   where     ppr_from same_pkg nm@@ -2831,27 +2929,7 @@         pkg = moduleUnit mod         mod = nameModule nm         loc = nameSrcSpan nm-pprTcSolverReportInfo ctxt (OccursCheckInterestingTyVars (tv :| tvs)) =-  hang (text "Type variable kinds:") 2 $-    vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))-              (tv:tvs))-  where-    tyvar_binding tyvar = ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) -pprCoercibleMsg :: CoercibleMsg -> SDoc-pprCoercibleMsg (UnknownRoles ty) =-  hang (text "NB: We cannot know what roles the parameters to" <+>-          quotes (ppr ty) <+> text "have;")-       2 (text "we must assume that the role is nominal")-pprCoercibleMsg (TyConIsAbstract tc) =-  hsep [ text "NB: The type constructor"-       , quotes (pprSourceTyCon tc)-       , text "is abstract" ]-pprCoercibleMsg (OutOfScopeNewtypeConstructor tc dc) =-  hang (text "The data constructor" <+> quotes (ppr $ dataConName dc))-    2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)-           , text "is not in scope" ])- {- ********************************************************************* *                                                                      *                   Outputting HoleError messages@@ -3229,7 +3307,7 @@ **********************************************************************-}  mk_supplementary_ea_msg :: SolverReportErrCtxt -> TypeOrKind-                        -> Type -> Type -> CtOrigin -> Either [TcSolverReportInfo] TcSolverReportMsg+                        -> Type -> Type -> CtOrigin -> Either [ExpectedActualInfo] MismatchMsg mk_supplementary_ea_msg ctxt level ty1 ty2 orig   | TypeEqOrigin { uo_expected = exp, uo_actual = act } <- orig   , not (ea_looks_same ty1 ty2 exp act)@@ -3252,7 +3330,7 @@       -- (TYPE 'LiftedRep) and Type both print the same way.  mk_ea_msg :: SolverReportErrCtxt -> Maybe ErrorItem -> TypeOrKind-          -> CtOrigin -> Either [TcSolverReportInfo] TcSolverReportMsg+          -> CtOrigin -> Either [ExpectedActualInfo] MismatchMsg -- Constructs a "Couldn't match" message -- The (Maybe ErrorItem) says whether this is the main top-level message (Just) --     or a supplementary message (Nothing)@@ -3264,16 +3342,9 @@                          , kmismatch_expected = exp                          , kmismatch_actual   = act }   | Just item <- at_top-  , let mismatch =-          Mismatch-            { mismatch_ea   = True-            , mismatch_item = item-            , mismatch_ty1  = exp-            , mismatch_ty2  = act }-  = Right $-    if expanded_syns-    then mkTcReportWithInfo mismatch [ea_expanded]-    else mismatch+  , let  ea = EA $ if expanded_syns then Just ea_expanded else Nothing+         mismatch = mkBasicMismatchMsg ea item exp act+  = Right mismatch   | otherwise   = Left $     if expanded_syns

@@ -1,9 +1,13 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}  module GHC.Tc.Errors.Types (   -- * Main types     TcRnMessage(..)+  , mkTcRnUnknownMessage   , TcRnMessageDetailed(..)+  , TypeDataForbids(..)   , ErrInfo(..)   , FixedRuntimeRepProvenance(..)   , pprFixedRuntimeRepProvenance@@ -48,9 +52,16 @@   , SolverReportWithCtxt(..)   , SolverReportErrCtxt(..)   , getUserGivens, discardProvCtxtGivens-  , TcSolverReportMsg(..), TcSolverReportInfo(..)+  , TcSolverReportMsg(..)+  , CannotUnifyVariableReason(..)+  , MismatchMsg(..)+  , MismatchEA(..)+  , mkPlainMismatchMsg, mkBasicMismatchMsg+  , WhenMatching(..)+  , ExpectedActualInfo(..)+  , TyVarInfo(..), SameOccInfo(..)+  , AmbiguityInfo(..)   , CND_Extra(..)-  , mkTcReportWithInfo   , FitsMbSuppressed(..)   , ValidHoleFits(..), noValidHoleFits   , HoleFitDispConfig(..)@@ -64,7 +75,7 @@   , UnsupportedCallConvention(..)   , ExpectedBackends   , ArgOrResult(..)-  , MatchArgsContext(..)+  , MatchArgsContext(..), MatchArgBadMatches(..)   ) where  import GHC.Prelude@@ -111,10 +122,11 @@ import Language.Haskell.Syntax.Basic (FieldLabelString(..))  import qualified Data.List.NonEmpty as NE-import           Data.Typeable hiding (TyCon)-import qualified Data.Semigroup as Semigroup+import           Data.Typeable (Typeable) import GHC.Unit.Module.Warnings (WarningTxt) +import GHC.Generics ( Generic )+ {- Note [Migrating TcM Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -133,7 +145,7 @@ Under the hood, the reporting functions in Tc.Utils.Monad were emitting "Couldn't match" as the important part, "In the expression" as the context and "In a stmt..In the expression" as the supplementary, with the context and supplementary usually smashed together so that-the final message would be composed only by two SDoc (which would then be bulletted like in+the final message would be composed only by two SDoc (which would then be bulleted like in the example).  In order for us to smooth out the migration to the new diagnostic infrastructure, we@@ -167,13 +179,17 @@   = TcRnMessageDetailed !ErrInfo                         -- ^ Extra info associated with the message                         !TcRnMessage+  deriving Generic +mkTcRnUnknownMessage :: (Diagnostic a, Typeable a) => a -> TcRnMessage+mkTcRnUnknownMessage diag = TcRnUnknownMessage (UnknownDiagnostic diag)+ -- | An error which might arise during typechecking/renaming. data TcRnMessage where   {-| Simply wraps a generic 'Diagnostic' message @a@. It can be used by plugins       to provide custom diagnostic messages originated during typechecking/renaming.   -}-  TcRnUnknownMessage :: (Diagnostic a, Typeable a) => a -> TcRnMessage+  TcRnUnknownMessage :: UnknownDiagnostic -> TcRnMessage    {-| TcRnMessageWithInfo is a constructor which is used when extra information is needed       to be provided in order to qualify a diagnostic and where it was originated (and why).@@ -193,7 +209,7 @@       See the documentation of the 'TcSolverReportMsg' datatype for an overview       of the different errors.   -}-  TcRnSolverReport :: [SolverReportWithCtxt]+  TcRnSolverReport :: SolverReportWithCtxt                    -> DiagnosticReason                    -> [GhcHint]                    -> TcRnMessage@@ -234,8 +250,8 @@      Test cases: T7293, T7294, T15558, T17646, T18572, T18610, tcfail167.   -}-  TcRnInaccessibleCode :: Implication -- ^ The implication containing a contradiction.-                       -> NE.NonEmpty SolverReportWithCtxt -- ^ The contradiction(s).+  TcRnInaccessibleCode :: Implication          -- ^ The implication containing a contradiction.+                       -> SolverReportWithCtxt -- ^ The contradiction.                        -> TcRnMessage    {-| A type which was expected to have a fixed runtime representation@@ -263,7 +279,7 @@       Test cases: th/T17804   -}-  TcRnImplicitLift :: Outputable var => var -> !ErrInfo -> TcRnMessage+  TcRnImplicitLift :: Name -> !ErrInfo -> TcRnMessage   {-| TcRnUnusedPatternBinds is a warning (controlled with -Wunused-pattern-binds)       that occurs if a pattern binding binds no variables at all, unless it is a       lone wild-card pattern, or a banged pattern.@@ -316,7 +332,7 @@      Test cases: plugins/T19926   -}   TcRnUnsafeDueToPlugin :: TcRnMessage-  {-| TcRnModMissingRealSrcSpan is an error that occurrs when compiling a module that lacks+  {-| TcRnModMissingRealSrcSpan is an error that occurs when compiling a module that lacks       an associated 'RealSrcSpan'.       Test cases: None@@ -1744,7 +1760,7 @@      Test cases: ffi/should_fail/T20116   -}-  TcRnForeignImportPrimExtNotSet :: ForeignImport p -> TcRnMessage+  TcRnForeignImportPrimExtNotSet :: ForeignImport GhcRn -> TcRnMessage    {- TcRnForeignImportPrimSafeAnn is an error declaring that the safe/unsafe      annotation should not be used with @prim@ foreign imports.@@ -1754,7 +1770,7 @@      Test cases: None   -}-  TcRnForeignImportPrimSafeAnn :: ForeignImport p -> TcRnMessage+  TcRnForeignImportPrimSafeAnn :: ForeignImport GhcRn -> TcRnMessage    {- TcRnForeignFunctionImportAsValue is an error explaining that foreign @value@      imports cannot have function types.@@ -1764,7 +1780,7 @@      Test cases: ffi/should_fail/capi_value_function   -}-  TcRnForeignFunctionImportAsValue :: ForeignImport p -> TcRnMessage+  TcRnForeignFunctionImportAsValue :: ForeignImport GhcRn -> TcRnMessage    {- TcRnFunPtrImportWithoutAmpersand is a warning controlled by @-Wdodgy-foreign-imports@      that informs the user of a possible missing @&@ in the declaration of a@@ -1775,7 +1791,7 @@      Test cases: ffi/should_compile/T1357   -}-  TcRnFunPtrImportWithoutAmpersand :: ForeignImport p -> TcRnMessage+  TcRnFunPtrImportWithoutAmpersand :: ForeignImport GhcRn -> TcRnMessage    {- TcRnIllegalForeignDeclBackend is an error occurring when a foreign import declaration      is not compatible with the code generation backend being used.@@ -1785,7 +1801,7 @@     Test cases: None   -}   TcRnIllegalForeignDeclBackend-    :: Either (ForeignExport p) (ForeignImport p)+    :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)     -> Backend     -> ExpectedBackends     -> TcRnMessage@@ -1799,7 +1815,9 @@      Test cases: None   -}-  TcRnUnsupportedCallConv :: Either (ForeignExport p) (ForeignImport p) -> UnsupportedCallConvention -> TcRnMessage+  TcRnUnsupportedCallConv :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)+                          -> UnsupportedCallConvention+                          -> TcRnMessage    {- TcRnIllegalForeignType is an error for when a type appears in a foreign      function signature that is not compatible with the FFI.@@ -2055,8 +2073,7 @@   -}   TcRnMatchesHaveDiffNumArgs     :: !MatchArgsContext-    -> !(LocatedA (Match GhcRn body))-    -> !(NE.NonEmpty (LocatedA (Match GhcRn body))) -- ^ bad matches+    -> !MatchArgBadMatches     -> TcRnMessage    {- TcRnCannotBindScopedTyVarInPatSig is an error stating that scoped type@@ -2112,7 +2129,7 @@     -> !(NE.NonEmpty (LocatedA InlinePragma)) -- ^ Other pragmas     -> TcRnMessage -  {- TcRnUnexpectedPragmas is a warning that occurrs when unexpected pragmas appear+  {- TcRnUnexpectedPragmas is a warning that occurs when unexpected pragmas appear      in the source.       Example(s):@@ -2134,7 +2151,7 @@   -}   TcRnNonOverloadedSpecialisePragma :: !(LIdP GhcRn) -> TcRnMessage -  {- TcRnSpecialiseNotVisible is a warning that occurrs when the subject of a+  {- TcRnSpecialiseNotVisible is a warning that occurs when the subject of a      SPECIALISE pragma has a definition that is not visible from the current module.       Example(s): none@@ -2272,6 +2289,48 @@             :: Name             -> TcRnMessage +  {-| TcRnIllegalTypeData is an error that occurs when a @type data@+      declaration occurs without the TypeOperators extension.++      See Note [Type data declarations]++     Test case:+       testsuite/tests/type-data/should_fail/TDNoPragma+  -}+  TcRnIllegalTypeData :: TcRnMessage++  {-| TcRnTypeDataForbids is an error that occurs when a @type data@+      declaration contains @data@ declaration features that are+      forbidden in a @type data@ declaration.++      See Note [Type data declarations]++     Test cases:+       testsuite/tests/type-data/should_fail/TDDeriving+       testsuite/tests/type-data/should_fail/TDRecordsGADT+       testsuite/tests/type-data/should_fail/TDRecordsH98+       testsuite/tests/type-data/should_fail/TDStrictnessGADT+       testsuite/tests/type-data/should_fail/TDStrictnessH98+  -}+  TcRnTypeDataForbids :: !TypeDataForbids -> TcRnMessage++  deriving Generic++-- | Things forbidden in @type data@ declarations.+-- See Note [Type data declarations]+data TypeDataForbids+  = TypeDataForbidsDatatypeContexts+  | TypeDataForbidsLabelledFields+  | TypeDataForbidsStrictnessAnnotations+  | TypeDataForbidsDerivingClauses+  deriving Generic++instance Outputable TypeDataForbids where+  ppr TypeDataForbidsDatatypeContexts      = text "Data type contexts"+  ppr TypeDataForbidsLabelledFields        = text "Labelled fields"+  ppr TypeDataForbidsStrictnessAnnotations = text "Strictness flags"+  ppr TypeDataForbidsDerivingClauses       = text "Deriving clauses"+ -- | Specifies which back ends can handle a requested foreign import or export type ExpectedBackends = [Backend] -- | Specifies which calling convention is unsupported on the current platform@@ -2463,7 +2522,7 @@                                    !DeriveAnyClassEnabled                                    -- ^ Whether or not -XDeriveAnyClass is enabled                                    -- already.-  -- | Stock deriving won't work, but perhas DeriveAnyClass will.+  -- | Stock deriving won't work, but perhaps DeriveAnyClass will.   | DerivErrNotDeriveable !DeriveAnyClassEnabled   -- | The given 'PredType' is not a class.   | DerivErrNotAClass !PredType@@ -2492,6 +2551,7 @@   -- | We couldn't derive an instance either because the type was not an   -- enum type or because it did have more than one constructor.   | DerivErrEnumOrProduct !DeriveInstanceErrReason !DeriveInstanceErrReason+  deriving Generic  data DeriveInstanceBadConstructor   =@@ -2643,9 +2703,9 @@ -- See Note [Error report] for details. data SolverReport   = SolverReport-  { sr_important_msgs :: [SolverReportWithCtxt]-  , sr_supplementary  :: [SolverReportSupplementary]-  , sr_hints          :: [GhcHint]+  { sr_important_msg :: SolverReportWithCtxt+  , sr_supplementary :: [SolverReportSupplementary]+  , sr_hints         :: [GhcHint]   }  -- | Additional information to print in a 'SolverReport', after the@@ -2668,14 +2728,7 @@     , reportContent :: TcSolverReportMsg       -- ^ The content of the message to report.     }--instance Semigroup SolverReport where-    SolverReport main1 supp1 hints1 <> SolverReport main2 supp2 hints2-      = SolverReport (main1 ++ main2) (supp1 ++ supp2) (hints1 ++ hints2)--instance Monoid SolverReport where-    mempty = SolverReport [] [] []-    mappend = (Semigroup.<>)+  deriving Generic  -- | Context needed when reporting a 'TcSolverReportMsg', such as -- the enclosing implication constraints or whether we are deferring type errors.@@ -2820,15 +2873,6 @@ -- This is usually, some sort of unsolved constraint error, -- but we try to be specific about the precise problem we encountered. data TcSolverReportMsg-  -- NB: this datatype is only a first step in refactoring GHC.Tc.Errors-  -- to use the diagnostic infrastructure (TcRnMessage etc).-  -- If you see possible improvements, please go right ahead!--  -- | Wrap a message with additional information.-  ---  -- Prefer using the 'mkTcReportWithInfo' smart constructor-  = TcReportWithInfo TcSolverReportMsg (NE.NonEmpty TcSolverReportInfo)-   -- | Quantified variables appear out of dependency order.   --   -- Example:@@ -2836,7 +2880,7 @@   --   forall (a :: k) k. ...   --   -- Test cases: BadTelescope2, T16418, T16247, T16726, T18451.-  | BadTelescope TyVarBndrs [TyCoVar]+  = BadTelescope TyVarBndrs [TyCoVar]    -- | We came across a custom type error and we have decided to report it.   --@@ -2855,71 +2899,33 @@   -- See 'HoleError'.   | ReportHoleError Hole HoleError -  -- | A type equality between a type variable and a polytype.-  ---  -- Test cases: T12427a, T2846b, T10194, ...-  | CannotUnifyWithPolytype ErrorItem TyVar Type--  -- | Couldn't unify two types or kinds.-  ---  --  Example:-  ---  --    3 + 3# -- can't match a lifted type with an unlifted type+  -- | Trying to unify an untouchable variable, e.g. a variable from an outer scope.   ---  --  Test cases: T1396, T8263, ...-  | Mismatch-      { mismatch_ea   :: Bool        -- ^ Should this be phrased in terms of expected vs actual?-      , mismatch_item :: ErrorItem   -- ^ The constraint in which the mismatch originated.-      , mismatch_ty1  :: Type        -- ^ First type (the expected type if if mismatch_ea is True)-      , mismatch_ty2  :: Type        -- ^ Second type (the actual type if mismatch_ea is True)-      }+  -- Test case: Simple14+  | UntouchableVariable+    { untouchableTyVar :: TyVar+    , untouchableTyVarImplication :: Implication+    } -  -- | A type has an unexpected kind.-  ---  -- Test cases: T2994, T7609, ...-  | KindMismatch-      { kmismatch_what     :: TypedThing -- ^ What thing is 'kmismatch_actual' the kind of?-      , kmismatch_expected :: Type-      , kmismatch_actual   :: Type-      }-    -- TODO: combine 'Mismatch' and 'KindMismatch' messages.+  -- | Cannot unify a variable, because of a type mismatch.+  | CannotUnifyVariable+    { mismatchMsg             :: MismatchMsg+    , cannotUnifyReason       :: CannotUnifyVariableReason } -  -- | A mismatch between two types, which arose from a type equality.-  ---  -- Test cases: T1470, tcfail212.-  | TypeEqMismatch-      { teq_mismatch_ppr_explicit_kinds :: Bool-      , teq_mismatch_item     :: ErrorItem-      , teq_mismatch_ty1      :: Type-      , teq_mismatch_ty2      :: Type-      , teq_mismatch_expected :: Type -- ^ The overall expected type-      , teq_mismatch_actual   :: Type -- ^ The overall actual type-      , teq_mismatch_what     :: Maybe TypedThing -- ^ What thing is 'teq_mismatch_actual' the kind of?-      }-    -- TODO: combine 'Mismatch' and 'TypeEqMismatch' messages.+  -- | A mismatch between two types.+  | Mismatch+     { mismatchMsg           :: MismatchMsg+     , mismatchTyVarInfo     :: Maybe TyVarInfo+     , mismatchAmbiguityInfo :: [AmbiguityInfo]+     , mismatchCoercibleInfo :: Maybe CoercibleMsg }     -- | A violation of the representation-polymorphism invariants.    --    -- See 'FixedRuntimeRepErrorInfo' and 'FixedRuntimeRepContext' for more information.   | FixedRuntimeRepError [FixedRuntimeRepErrorInfo] -  -- | A skolem type variable escapes its scope.-  ---  -- Example:-  ---  --   data Ex where { MkEx :: a -> MkEx }-  --   foo (MkEx x) = x-  ---  -- Test cases: TypeSkolEscape, T11142.-  | SkolemEscape ErrorItem Implication [TyVar]--  -- | Trying to unify an untouchable variable, e.g. a variable from an outer scope.-  ---  -- Test case: Simple14-  | UntouchableVariable TyVar Implication-   -- | An equality between two types is blocked on a kind equality-  -- beteen their kinds.+  -- between their kinds.   --   -- Test cases: none.   | BlockedEquality ErrorItem@@ -2944,21 +2950,6 @@   | UnboundImplicitParams       (NE.NonEmpty ErrorItem) -  -- | Couldn't solve some Wanted constraints using the Givens.-  -- This is the most commonly used constructor, used for generic-  -- @"No instance for ..."@ and @"Could not deduce ... from"@ messages.-  | CouldNotDeduce-     { cnd_user_givens :: [Implication]-        -- | The Wanted constraints we couldn't solve.-        ---        -- N.B.: the 'ErrorItem' at the head of the list has been tidied,-        -- perhaps not the others.-     , cnd_wanted      :: NE.NonEmpty ErrorItem--       -- | Some additional info consumed by 'mk_supplementary_ea_msg'.-     , cnd_extra       :: Maybe CND_Extra-     }-   -- | A constraint couldn't be solved because it contains   -- ambiguous type variables.   --@@ -3008,18 +2999,149 @@     , unsafeOverlap_matches :: [ClsInst]     , unsafeOverlapped      :: [ClsInst] } +  deriving Generic++data MismatchMsg+  =  -- | Couldn't unify two types or kinds.+  --+  --  Example:+  --+  --    3 + 3# -- can't match a lifted type with an unlifted type+  --+  --  Test cases: T1396, T8263, ...+    BasicMismatch -- SLD TODO rename this+      { mismatch_ea           :: MismatchEA  -- ^ Should this be phrased in terms of expected vs actual?+      , mismatch_item         :: ErrorItem   -- ^ The constraint in which the mismatch originated.+      , mismatch_ty1          :: Type        -- ^ First type (the expected type if if mismatch_ea is True)+      , mismatch_ty2          :: Type        -- ^ Second type (the actual type if mismatch_ea is True)+      , mismatch_whenMatching :: Maybe WhenMatching+      , mismatch_mb_same_occ  :: Maybe SameOccInfo+      }++  -- | A type has an unexpected kind.+  --+  -- Test cases: T2994, T7609, ...+  | KindMismatch+      { kmismatch_what     :: TypedThing -- ^ What thing is 'kmismatch_actual' the kind of?+      , kmismatch_expected :: Type+      , kmismatch_actual   :: Type+      }+    -- TODO: combine with 'BasicMismatch'.++  -- | A mismatch between two types, which arose from a type equality.+  --+  -- Test cases: T1470, tcfail212.+  | TypeEqMismatch+      { teq_mismatch_ppr_explicit_kinds :: Bool+      , teq_mismatch_item     :: ErrorItem+      , teq_mismatch_ty1      :: Type+      , teq_mismatch_ty2      :: Type+      , teq_mismatch_expected :: Type -- ^ The overall expected type+      , teq_mismatch_actual   :: Type -- ^ The overall actual type+      , teq_mismatch_what     :: Maybe TypedThing -- ^ What thing is 'teq_mismatch_actual' the kind of?+      , teq_mb_same_occ       :: Maybe SameOccInfo+      }+    -- TODO: combine with 'BasicMismatch'.++  -- | Couldn't solve some Wanted constraints using the Givens.+  -- Used for messages such as @"No instance for ..."@ and+  -- @"Could not deduce ... from"@.+  | CouldNotDeduce+     { cnd_user_givens :: [Implication]+        -- | The Wanted constraints we couldn't solve.+        --+        -- N.B.: the 'ErrorItem' at the head of the list has been tidied,+        -- perhaps not the others.+     , cnd_wanted      :: NE.NonEmpty ErrorItem++       -- | Some additional info consumed by 'mk_supplementary_ea_msg'.+     , cnd_extra       :: Maybe CND_Extra+     }+  deriving Generic++mkBasicMismatchMsg :: MismatchEA -> ErrorItem -> Type -> Type -> MismatchMsg+mkBasicMismatchMsg ea item ty1 ty2+  = BasicMismatch+      { mismatch_ea           = ea+      , mismatch_item         = item+      , mismatch_ty1          = ty1+      , mismatch_ty2          = ty2+      , mismatch_whenMatching = Nothing+      , mismatch_mb_same_occ  = Nothing+      }++-- | Whether to use expected/actual in a type mismatch message.+data MismatchEA+  -- | Don't use expected/actual.+  = NoEA+  -- | Use expected/actual.+  | EA+  { mismatch_mbEA :: Maybe ExpectedActualInfo+    -- ^ Whether to also mention type synonym expansion.+  }++data CannotUnifyVariableReason+  =  -- | A type equality between a type variable and a polytype.+    --+    -- Test cases: T12427a, T2846b, T10194, ...+    CannotUnifyWithPolytype ErrorItem TyVar Type (Maybe TyVarInfo)++  -- | An occurs check.+  | OccursCheck+    { occursCheckInterestingTyVars :: [TyVar]+    , occursCheckAmbiguityInfos    :: [AmbiguityInfo] }++  -- | A skolem type variable escapes its scope.+  --+  -- Example:+  --+  --   data Ex where { MkEx :: a -> MkEx }+  --   foo (MkEx x) = x+  --+  -- Test cases: TypeSkolEscape, T11142.+  | SkolemEscape ErrorItem Implication [TyVar]++  -- | Can't unify the type variable with the other type+  -- due to the kind of type variable it is.+  --+  -- For example, trying to unify a 'SkolemTv' with the+  -- type Int, or with a 'TyVarTv'.+  | DifferentTyVars TyVarInfo+  | RepresentationalEq TyVarInfo (Maybe CoercibleMsg)+  deriving Generic++mkPlainMismatchMsg :: MismatchMsg -> TcSolverReportMsg+mkPlainMismatchMsg msg+  = Mismatch+     { mismatchMsg           = msg+     , mismatchTyVarInfo     = Nothing+     , mismatchAmbiguityInfo = []+     , mismatchCoercibleInfo = Nothing }+ -- | Additional information to be given in a 'CouldNotDeduce' message, -- which is then passed on to 'mk_supplementary_ea_msg'. data CND_Extra = CND_Extra TypeOrKind Type Type --- | Additional information that can be appended to an existing 'TcSolverReportMsg'.-data TcSolverReportInfo-  -- NB: this datatype is only a first step in refactoring GHC.Tc.Errors-  -- to use the diagnostic infrastructure (TcRnMessage etc).-  -- It would be better for these constructors to not be so closely tied-  -- to the constructors of 'TcSolverReportMsg'.-  -- If you see possible improvements, please go right ahead!+-- | A cue to print out information about type variables,+-- e.g. where they were bound, when there is a mismatch @tv1 ~ ty2@.+data TyVarInfo =+  TyVarInfo { thisTyVar :: TyVar+            , thisTyVarIsUntouchable :: Maybe Implication+            , otherTy   :: Maybe TyVar } +-- | Add some information to disambiguate errors in which+-- two 'Names' would otherwise appear to be identical.+--+-- See Note [Disambiguating (X ~ X) errors].+data SameOccInfo+  = SameOcc+    { sameOcc_same_pkg :: Bool -- ^ Whether the two 'Name's also came from the same package.+    , sameOcc_lhs :: Name+    , sameOcc_rhs :: Name }++-- | Add some information about ambiguity+data AmbiguityInfo+   -- | Some type variables remained ambiguous: print them to the user.   = Ambiguity     { lead_with_ambig_msg :: Bool -- ^ True <=> start the message with "Ambiguous type variable ..."@@ -3028,38 +3150,24 @@                                                 -- Guaranteed to not both be empty.     } -  -- | Specify some information about a type variable,-  -- e.g. its 'SkolemInfo'.-  | TyVarInfo TyVar-   -- | Remind the user that a particular type family is not injective.   | NonInjectiveTyFam TyCon -  -- | Explain why we couldn't coerce between two types. See 'CoercibleMsg'.-  | ReportCoercibleMsg CoercibleMsg-+-- | Expected/actual information.+data ExpectedActualInfo   -- | Display the expected and actual types.-  | ExpectedActual+  = ExpectedActual      { ea_expected, ea_actual :: Type }    -- | Display the expected and actual types, after expanding type synonyms.   | ExpectedActualAfterTySynExpansion      { ea_expanded_expected, ea_expanded_actual :: Type } -  -- | Explain how a kind equality originated.-  | WhenMatching TcType TcType CtOrigin (Maybe TypeOrKind)--  -- | Add some information to disambiguate errors in which-  -- two 'Names' would otherwise appear to be identical.-  ---  -- See Note [Disambiguating (X ~ X) errors].-  | SameOcc-    { sameOcc_same_pkg :: Bool -- ^ Whether the two 'Name's also came from the same package.-    , sameOcc_lhs :: Name-    , sameOcc_rhs :: Name }+-- | Explain how a kind equality originated.+data WhenMatching -  -- | Report some type variables that might be participating in an occurs-check failure.-  | OccursCheckInterestingTyVars (NE.NonEmpty TyVar)+  = WhenMatching TcType TcType CtOrigin (Maybe TypeOrKind)+  deriving Generic  -- | Some form of @"not in scope"@ error. See also the 'OutOfScopeHole' -- constructor of 'HoleError'.@@ -3095,10 +3203,11 @@   -- Test cases: annfail01, annfail02, annfail11.   | NoTopLevelBinding -  -- | A class doesnt have a method with this name,+  -- | A class doesn't have a method with this name,   -- or, a class doesn't have an associated type with this name,   -- or, a record doesn't have a record field with this name.   | UnknownSubordinate SDoc+  deriving Generic  -- | Create a @"not in scope"@ error message for the given 'RdrName'. mkTcRnNotInScope :: RdrName -> NotInScopeError -> TcRnMessage@@ -3175,15 +3284,6 @@   , unifiers :: [ClsInst]   } --- | Append additional information to a `TcSolverReportMsg`.-mkTcReportWithInfo :: TcSolverReportMsg -> [TcSolverReportInfo] -> TcSolverReportMsg-mkTcReportWithInfo msg []-  = msg-mkTcReportWithInfo (TcReportWithInfo msg (prev NE.:| prevs)) infos-  = TcReportWithInfo msg (prev NE.:| prevs ++ infos)-mkTcReportWithInfo msg (info : infos)-  = TcReportWithInfo msg (info NE.:| infos)- -- | A collection of valid hole fits or refinement fits, -- in which some fits might have been suppressed. data FitsMbSuppressed@@ -3211,7 +3311,7 @@ -- | Display some relevant bindings. pprRelevantBindings :: RelevantBindings -> SDoc -- This function should be in "GHC.Tc.Errors.Ppr",--- but's it's here for the moment as it's needed in "GHC.Tc.Errors".+-- but it's here for the moment as it's needed in "GHC.Tc.Errors". pprRelevantBindings (RelevantBindings bds ran_out_of_fuel) =   ppUnless (null rel_bds) $     hang (text "Relevant bindings include")@@ -3323,3 +3423,11 @@       !Name -- ^ Name of the function   | PatternArgs       !(HsMatchContext GhcTc) -- ^ Pattern match specifics++-- | The information necessary to report mismatched+-- numbers of arguments in a match group.+data MatchArgBadMatches where+  MatchArgMatches+    ::  { matchArgFirstMatch :: LocatedA (Match GhcRn body)+        , matchArgBadMatches :: NE.NonEmpty (LocatedA (Match GhcRn body)) }+    -> MatchArgBadMatches

@@ -338,7 +338,7 @@      in the above sense     - Exception 1: local quantified constraints have no such guarantee;-     indeed, adding a "solved dictionary" when appling a quantified+     indeed, adding a "solved dictionary" when applying a quantified      constraint led to the ability to define unsafeCoerce      in #17267. @@ -883,7 +883,7 @@     (this is Lemma (L0)), and hence this triple never plays a role in application S(f,t).     It is always safe to extend S with such a triple. -    (NB: we could strengten K1) in this way too, but see K3.+    (NB: we could strengthen K1) in this way too, but see K3.    - (K2b): if lhs not in s, we have no further opportunity to apply the     work item@@ -1558,23 +1558,28 @@     matchable_given :: Ct -> Bool     matchable_given ct       | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct-      = mightEqualLater inerts pred_g loc_g pred_w loc_w+      = isJust $ mightEqualLater inerts pred_g loc_g pred_w loc_w        | otherwise       = False -mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool+mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Maybe Subst -- See Note [What might equal later?] -- Used to implement logic in Note [Instance and Given overlap] in GHC.Tc.Solver.Interact mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc   | prohibitedSuperClassSolve given_loc wanted_loc-  = False+  = Nothing    | otherwise   = case tcUnifyTysFG bind_fun [flattened_given] [flattened_wanted] of-      SurelyApart              -> False  -- types that are surely apart do not equal later-      MaybeApart MARInfinite _ -> False  -- see Example 7 in the Note.-      _                        -> True+      Unifiable subst+        -> Just subst+      MaybeApart reason subst+        | MARInfinite <- reason -- see Example 7 in the Note.+        -> Nothing+        | otherwise+        -> Just subst+      SurelyApart -> Nothing    where     in_scope  = mkInScopeSet $ tyCoVarsOfTypes [given_pred, wanted_pred]

@@ -184,7 +184,7 @@ -- 'ns_module_name' @A@, defines a mapping from @{A.T}@ -- (for some 'OccName' @T@) to some arbitrary other 'Name'. ----- The most intruiging thing about a 'NameShape', however, is+-- The most intriguing thing about a 'NameShape', however, is -- how it's constructed.  A 'NameShape' is *implied* by the -- exported 'AvailInfo's of the implementor of an interface: -- if an implementor of signature @\<H>@ exports @M.T@, you implicitly@@ -401,7 +401,7 @@ --        signatures (we just generate blank object files for --        hsig files.) -----        A corrolary of this is that the following invariant holds at any point+--        A corollary of this is that the following invariant holds at any point --        past desugaring, -- --            if I have a Module, this_mod, in hand representing the module@@ -1138,7 +1138,7 @@   | ATyVar  Name TcTyVar   -- See Note [Type variables in the type environment]    | ATcTyCon TyCon   -- Used temporarily, during kind checking, for the-                     -- tycons and clases in this recursive group+                     -- tycons and classes in this recursive group                      -- The TyCon is always a TcTyCon.  Its kind                      -- can be a mono-kind or a poly-kind; in TcTyClsDcls see                      -- Note [Type checking recursive type and class declarations]

@@ -1404,7 +1404,7 @@  * LocalGivenEqs: definitely no Given equalities that would affect principal   types.  But may have equalities that affect only skolems of this implication-  (and hence do not affect princial types)+  (and hence do not affect principal types)   Examples: forall a. F a ~ Int => ...             forall a b. F a ~ G b => ... @@ -1557,7 +1557,7 @@ We assume NO SHADOWING in a constraint.  Specifically  * The unification variables are all implicitly quantified at top    level, and are all unique- * The skolem variables bound in ic_skols are all freah when the+ * The skolem variables bound in ic_skols are all fresh when the    implication is created. So we can safely substitute. For example, if we have    forall a.  a~Int => ...(forall b. ...a...)...@@ -2248,7 +2248,7 @@ it's actually quite easy to mistake one for another, in sufficiently involved scenarios, like ConstraintKinds.) -The flag -freduction-depth=n fixes the maximium level.+The flag -freduction-depth=n fixes the maximum level.  * The counter includes the depth of type class instance declarations.  Example:      [W] d{7} : Eq [Int]

@@ -448,7 +448,7 @@ Class constraints etc give rise to /term/ bindings for evidence, and we have nowhere to put term bindings in /types/.  So in some places we use CoEvBindsVar (see newCoTcEvBinds) to signal that no term-level-evidence bindings are allowed.  Notebly ():+evidence bindings are allowed.  Notably ():    - Places in types where we are solving kind constraints (all of which     are equalities); see solveEqualities@@ -565,7 +565,7 @@ type EvExpr = CoreExpr  -- An EvTerm is (usually) constructed by any of the constructors here--- and those more complicates ones who were moved to module GHC.Tc.Types.EvTerm+-- and those more complicated ones who were moved to module GHC.Tc.Types.EvTerm  -- | Any sort of evidence Id, including coercions evId ::  EvId -> EvExpr@@ -671,7 +671,7 @@     dl :: Typeable [a] = EvTypeable [a]                             (EvTypeableTyApp (EvTypeableTyCon []) (EvId d)) where-    d :: Typable a+    d :: Typeable a is the lambda-bound dictionary passed into f.  Note [Coercion evidence terms]

@@ -267,7 +267,7 @@   | RuleSkol RuleName   -- The LHS of a RULE    | InferSkol [(Name,TcType)]-                        -- We have inferred a type for these (mutually-recursivive)+                        -- We have inferred a type for these (mutually recursive)                         -- polymorphic Ids, and are now checking that their RHS                         -- constraints are satisfied. @@ -464,8 +464,7 @@   -- have 'InstSCOrigin' origin.   | InstSCOrigin ScDepth      -- ^ The number of superclass selections necessary to                               -- get this constraint; see Note [Replacement vs keeping]-                              -- and Note [Use only the best local instance], both in-                              -- GHC.Tc.Solver.Interact+                              -- in GHC.Tc.Solver.Interact                  TypeSize     -- ^ If @(C ty1 .. tyn)@ is the largest class from                               --    which we made a superclass selection in the chain,                               --    then @TypeSize = sizeTypes [ty1, .., tyn]@@@ -478,12 +477,13 @@   --      f = e   -- When typechecking body of 'f', the superclasses of the Given (Foo a)   -- will have 'OtherSCOrigin'.-  -- Needed for Note [Replacement vs keeping] and-  -- Note [Use only the best local instance], both in GHC.Tc.Solver.Interact.+  --+  -- Needed for Note [Replacement vs keeping] in GHC.Tc.Solver.Interact.   | OtherSCOrigin ScDepth -- ^ The number of superclass selections necessary to                           -- get this constraint-                  SkolemInfoAnon   -- ^ Where the sub-class constraint arose from-                               -- (used only for printing)+                  SkolemInfoAnon+                    -- ^ Where the sub-class constraint arose from+                    -- (used only for printing)    -- All the others are for *wanted* constraints @@ -1056,7 +1056,7 @@   -- Test cases: RepPolyDoBody{1,2}, RepPolyMcBody.   | FRRBodyStmt !StmtOrigin !Int -  -- | Arguments to a guard in a monad comprehesion must have+  -- | Arguments to a guard in a monad comprehension must have   -- a fixed runtime representation.   --   -- Test case: RepPolyMcGuard.

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric       #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections       #-}@@ -246,6 +247,7 @@ import Data.List.NonEmpty( NonEmpty(..) ) import Data.List ( partition ) +import GHC.Generics ( Generic )  {- ************************************************************************@@ -327,7 +329,7 @@   of Var.Var.  The "tc" prefix means "a type variable that can be   encountered by the typechecker". -This is a bit of a change from an earlier era when we remoselessly+This is a bit of a change from an earlier era when we remorselessly insisted on real TcTyVars in the type checker.  But that seems unnecessary (for skolems, TyVars are fine) and it's now very hard to guarantee, with the advent of kind equalities.@@ -582,7 +584,7 @@ (historically but still there) Var.tcTyVarDetails returns vanillaSkolemTv for a TyVar. -But ultimately I want to seeparate Type from TcType, and in that case+But ultimately I want to separate Type from TcType, and in that case we would need to enforce the separation. -} @@ -763,7 +765,7 @@                         (forall[3] b. alpha[3] ~ b)  We can unify alpha:=b in the inner implication, because 'alpha' is-touchable; but then 'b' has excaped its scope into the outer implication.+touchable; but then 'b' has escaped its scope into the outer implication. -}  maxTcLevel :: TcLevel -> TcLevel -> TcLevel@@ -1899,7 +1901,7 @@       NomEq  | homo_kind -> Just (eqClass,        [k1,     ty1, ty2])              | otherwise -> Just (heqClass,       [k1, k2, ty1, ty2])       ReprEq | homo_kind -> Just (coercibleClass, [k1,     ty1, ty2])-             | otherwise -> Nothing -- Sigh: we do not have hererogeneous Coercible+             | otherwise -> Nothing -- Sigh: we do not have heterogeneous Coercible                                     --       so we can't abstract over it                                     -- Nothing fundamental: we could add it  where@@ -2244,6 +2246,7 @@   | LinearTypesNotAllowed   | OneArgExpected   | AtLeastOneArgExpected+  deriving Generic  -- | Reason why a type cannot be marshalled through the FFI. data TypeCannotBeMarshaledReason@@ -2254,6 +2257,7 @@   | ForeignLabelNotAPtr   | NotSimpleUnliftedType   | NotBoxedKindAny+  deriving Generic  isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason -- Checks for valid argument type for a 'foreign import'

@@ -48,13 +48,14 @@ import GHC.Data.List.SetOps import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Misc import GHC.Utils.Constants (debugIsOn)  import Data.Data ( Data ) import Data.Either ( partitionEithers )+import Data.Functor.Classes ( liftCompare ) import Data.List ( find ) import Data.Maybe+import qualified Data.Semigroup as S  -- ----------------------------------------------------------------------------- -- The AvailInfo type@@ -166,8 +167,7 @@ stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering stableAvailCmp (Avail c1)     (Avail c2)     = c1 `stableGreNameCmp` c2 stableAvailCmp (Avail {})     (AvailTC {})   = LT-stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp`-                                               (cmpList stableGreNameCmp ns ms)+stableAvailCmp (AvailTC n ns) (AvailTC m ms) = stableNameCmp n m S.<> liftCompare stableGreNameCmp ns ms stableAvailCmp (AvailTC {})   (Avail {})     = GT  stableGreNameCmp :: GreName -> GreName -> Ordering@@ -366,7 +366,7 @@ pprAvail (Avail n)   = ppr n pprAvail (AvailTC n ns)-  = ppr n <> braces (fsep (punctuate comma (map ppr ns)))+  = ppr n <> braces (pprWithCommas ppr ns)  instance Binary AvailInfo where     put_ bh (Avail aa) = do

@@ -98,6 +98,9 @@         setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,         pprInline, pprInlineDebug, +        UnfoldingSource(..), isStableSource, isStableUserSource,+        isStableSystemSource, isCompulsorySource,+         SuccessFlag(..), succeeded, failed, successIf,          IntWithInf, infinity, treatZeroAsInf, subWithInf, mkIntWithInf, intGtLimit,@@ -282,14 +285,14 @@      f g x = Just (case g x of { ... })    Here 'f' is lazy in 'g', but it guarantees to call it no-  more than once.  So g will get a C1(U) usage demand.+  more than once.  So g will get a C(1,U) usage demand.  * Occurrence analysis propagates this usage information   (in the demand signature of a function) to its calls.   Example, given 'f' above      f (\x.e) blah -  Since f's demand signature says it has a C1(U) usage demand on its+  Since f's demand signature says it has a C(1,U) usage demand on its   first argument, the occurrence analyser sets the \x to be one-shot.   This is done via the occ_one_shots field of OccEnv. @@ -1433,7 +1436,7 @@ It's not possible to get that combination by *writing* something, so if an Id has defaultInlinePragma it means the user didn't specify anything. -If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding.+If inl_inline = Inline or Inlineable, then the Id should have a stable unfolding.  If you want to know where InlinePragmas take effect: Look in GHC.HsToCore.Binds.makeCorePair @@ -1778,6 +1781,62 @@               | otherwise      = ppr info  +{- *********************************************************************+*                                                                      *+                 UnfoldingSource+*                                                                      *+********************************************************************* -}++data UnfoldingSource+  = -- See also Note [Historical note: unfoldings for wrappers]+    VanillaSrc         -- The current rhs of the function+                       -- Replace uf_tmpl each time around++  -- See Note [Stable unfoldings] in GHC.Core+  | StableUserSrc   -- From a user-specified INLINE or INLINABLE pragma+  | StableSystemSrc -- From a wrapper, or system-generated unfolding++  | CompulsorySrc   -- Something that *has* no binding, so you *must* inline it+                    -- Only a few primop-like things have this property+                    -- (see "GHC.Types.Id.Make", calls to mkCompulsoryUnfolding).+                    -- Inline absolutely always, however boring the context.++isStableUserSource :: UnfoldingSource -> Bool+isStableUserSource StableUserSrc = True+isStableUserSource _             = False++isStableSystemSource :: UnfoldingSource -> Bool+isStableSystemSource StableSystemSrc = True+isStableSystemSource _               = False++isCompulsorySource :: UnfoldingSource -> Bool+isCompulsorySource CompulsorySrc = True+isCompulsorySource _             = False++isStableSource :: UnfoldingSource -> Bool+isStableSource CompulsorySrc   = True+isStableSource StableSystemSrc = True+isStableSource StableUserSrc   = True+isStableSource VanillaSrc      = False++instance Binary UnfoldingSource where+    put_ bh CompulsorySrc   = putByte bh 0+    put_ bh StableUserSrc   = putByte bh 1+    put_ bh StableSystemSrc = putByte bh 2+    put_ bh VanillaSrc      = putByte bh 3+    get bh = do+        h <- getByte bh+        case h of+            0 -> return CompulsorySrc+            1 -> return StableUserSrc+            2 -> return StableSystemSrc+            _ -> return VanillaSrc++instance Outputable UnfoldingSource where+  ppr CompulsorySrc     = text "Compulsory"+  ppr StableUserSrc     = text "StableUser"+  ppr StableSystemSrc   = text "StableSystem"+  ppr VanillaSrc        = text "<vanilla>"  {- ************************************************************************

@@ -64,7 +64,8 @@     -- * Demand signatures     DmdSig(..), mkDmdSigForArity, mkClosedDmdSig, mkVanillaDmdSig,     splitDmdSig, dmdSigDmdEnv, hasDemandEnvSig,-    nopSig, botSig, isNopSig, isDeadEndSig, isDeadEndAppSig, trimBoxityDmdSig,+    nopSig, botSig, isNopSig, isBottomingSig, isDeadEndSig, isDeadEndAppSig,+    trimBoxityDmdSig, transferArgBoxityDmdSig,      -- ** Handling arity adjustments     prependArgsDmdSig, etaConvertDmdSig,@@ -270,7 +271,7 @@              frequently than small records (e.g., Int). Result:      Big records tend to be passed around boxed (unmodified) much more              frequently than small records.-Consequnce:  The larger the record, the more likely conditions (1) and (2) from+Consequence:  The larger the record, the more likely conditions (1) and (2) from              Note [Function body boxity and call sites] are met, in which case              unboxing returned parameters leads to reboxing. @@ -598,26 +599,6 @@     bit1 = (a .&. b)                   .&. 0b010     bitN = (a .|. b) .&. shiftL bit1 1 .&. 0b100 --- | Denotes '∪' on lower and '+' on upper bounds of 'Card'.-lubPlusCard :: Card -> Card -> Card--- See Note [Algebraic specification for plusCard and multCard]-lubPlusCard (Card a) (Card b)-  = Card (bit0 .|. bit1 .|. bitN)-  where-    bit0 =  (a .|. b)                         .&. 0b001-    bit1 =  (a .|. b)                         .&. 0b010-    bitN = ((a .|. b) .|. shiftL (a .&. b) 1) .&. 0b100---- | Denotes '+' on lower and '∪' on upper bounds of 'Card'.-plusLubCard :: Card -> Card -> Card--- See Note [Algebraic specification for plusCard and multCard]-plusLubCard (Card a) (Card b)-  = Card (bit0 .|. bit1 .|. bitN)-  where-    bit0 = (a .&. b) .&. 0b001-    bit1 = (a .|. b) .&. 0b010-    bitN = (a .|. b) .&. 0b100- {- ************************************************************************ *                                                                      *@@ -626,11 +607,11 @@ ************************************************************************ -} --- | A demand describes a /scaled evaluation context/, e.g. how many times--- and how deep the denoted thing is evaluated.+-- | A demand describes ----- The "how many" component is represented by a 'Card'inality.--- The "how deep" component is represented by a 'SubDemand'.+--   * How many times a variable is evaluated, via a 'Card'inality, and+--   * How deep its value was evaluated in turn, via a 'SubDemand'.+-- -- Examples (using Note [Demand notation]): -- --   * 'seq' puts demand @1A@ on its first argument: It evaluates the argument@@ -638,10 +619,10 @@ --   * 'fst' puts demand @1P(1L,A)@ on its argument: It evaluates the argument --     pair strictly and the first component strictly, but no nested info --     beyond that (@L@). Its second argument is not used at all.---   * '$' puts demand @1C1(L)@ on its first argument: It calls (@C@) the+--   * '$' puts demand @1C(1,L)@ on its first argument: It calls (@C@) the --     argument function with one argument, exactly once (@1@). No info --     on how the result of that call is evaluated (@L@).---   * 'maybe' puts demand @MCM(L)@ on its second argument: It evaluates+--   * 'maybe' puts demand @MC(M,L)@ on its second argument: It evaluates --     the argument function at most once ((M)aybe) and calls it once when --     it is evaluated. --   * @fst p + fst p@ puts demand @SP(SL,A)@ on @p@: It's @1P(1L,A)@@@ -674,8 +655,8 @@ viewDmdPair AbsDmd   = (C_00, botSubDmd) viewDmdPair (D n sd) = (n, sd) --- | @c :* sd@ is a demand that says \"evaluated @c@ times, and each time it--- was evaluated, it was at least as deep as @sd@\".+-- | @c :* sd@ is a demand that says \"evaluated @c@ times, and any trace in+-- which it is evaluated will evaluate at least as deep as @sd@\". -- -- Matching on this pattern synonym is a complete match. -- If the matched demand was 'AbsDmd', it will match as @C_00 :* seqSubDmd@.@@ -695,8 +676,9 @@   n    :* sd = D n sd & assertPpr (isCardNonAbs n)  (ppr n $$ ppr sd) {-# COMPLETE (:*) #-} --- | A sub-demand describes an /evaluation context/, e.g. how deep the--- denoted thing is evaluated. See 'Demand' for examples.+-- | A sub-demand describes an /evaluation context/ (in the sense of an+-- operational semantics), e.g. how deep the denoted thing is going to be+-- evaluated. See 'Demand' for examples. -- -- See Note [SubDemand denotes at least one evaluation] for a more detailed -- description of what a sub-demand means.@@ -714,14 +696,17 @@   -- @Poly b n@ is semantically equivalent to @Prod b [n :* Poly b n, ...]   -- or @Call n (Poly Boxed n)@. 'viewCall' and 'viewProd' do these rewrites.   ---  -- In Note [Demand notation]: @L  === P(L,L,...)@  and @L  === CL(L)@,-  --                            @B  === P(B,B,...)@  and @B  === CB(B)@,-  --                            @!A === !P(A,A,...)@ and @!A === !CA(B)@,+  -- In Note [Demand notation]: @L  === P(L,L,...)@  and @L  === C(L)@,+  --                            @B  === P(B,B,...)@  and @B  === C(B)@,+  --                            @!A === !P(A,A,...)@ and @!A === C(A)@,   --                            and so on.   --   -- We'll only see 'Poly' with 'C_10' (B), 'C_00' (A), 'C_0N' (L) and sometimes   -- 'C_1N' (S) through 'plusSubDmd', never 'C_01' (M) or 'C_11' (1) (grep the   -- source code). Hence 'CardNonOnce', which is closed under 'lub' and 'plus'.+  --+  -- Why doesn't this constructor simply carry a 'Demand' instead of its fields?+  -- See Note [Call SubDemand vs. evaluation Demand].   | Call !CardNonAbs !SubDemand   -- ^ @Call n sd@ describes the evaluation context of @n@ function   -- applications (with one argument), where the result of each call is@@ -803,7 +788,7 @@ -- equality @Call C_0N (Poly C_0N) === Poly C_0N@, simplifying to 'Poly' 'SubDemand's -- when possible. mkCall :: CardNonAbs -> SubDemand -> SubDemand-mkCall C_1N sd@(Poly Boxed C_1N) = sd+--mkCall C_1N sd@(Poly Boxed C_1N) = sd -- NO! #21085 strikes. See Note [mkCall and plusSubDmd] mkCall C_0N sd@(Poly Boxed C_0N) = sd mkCall n    sd                   = assertPpr (isCardNonAbs n) (ppr n $$ ppr sd) $                                    Call n sd@@ -838,17 +823,6 @@ unboxDeeplyDmd dmd@(D n sd) | isStrict n = D n (unboxDeeplySubDmd sd)                             | otherwise  = dmd -multSubDmd :: Card -> SubDemand -> SubDemand-multSubDmd C_11 sd           = sd -- An optimisation, for when sd is a deep Prod--- The following three equations don't have an impact on Demands, only on--- Boxity. They are needed so that we don't trigger the assertions in `:*`--- when called from `multDmd`.-multSubDmd C_00 _            = seqSubDmd -- Otherwise `multSubDmd A L == A /= !A`-multSubDmd C_10 (Poly _ n)   = if isStrict n then botSubDmd else seqSubDmd -- Otherwise `multSubDmd B L == B /= !B`-multSubDmd C_10 (Call n _)   = if isStrict n then botSubDmd else seqSubDmd -- Otherwise we'd call `mkCall` with absent cardinality-multSubDmd n    (Poly b m)   = Poly b (multCard n m)-multSubDmd n    (Call n' sd) = mkCall (multCard n n') sd-multSubDmd n    (Prod b ds)  = mkProd b (strictMap (multDmd n) ds)  multDmd :: Card -> Demand -> Demand multDmd C_11 dmd       = dmd -- An optimisation@@ -866,170 +840,85 @@ -- See Note [SubDemand denotes at least one evaluation] for the strictifyCard multDmd n    (D m sd) = multCard n m :* multSubDmd (strictifyCard n) sd -{- Note [Manual specialisation of lub*Dmd/plus*Dmd]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As Note [SubDemand denotes at least one evaluation] points out, we need all 4-different combinations of lub/plus demand operations on upper and lower bounds-  lubDmd, plusDmd, lubPlusDmd, plusLubDmd-and the same for lubSubDmd, etc. In order to share as much code as possible-and for the programmer to see immediately how the operations differ, we have-one implementation of opDmd (and opSubDmd) that dispatches on a 'OpMode'.--For good perf, we specialise this one implementation to the four different-modes. So ideally we'd write-```-lubSubDmd = opSubDmd (Lub, Lub)-opSubDmd (l, u) = ... opSubDmd ...-{-# RULES "lubSubDmd" opSubDmd (Lub, Lub) = lubSubDmd #-}-```-But unfortunately, 'opSubDmd' will be picked as a loop-breaker and thus never-inline into 'lubSubDmd', so its body will never actually be specialised for-the op mode `(Lub, Lub)`. So instead we write-```-lubSubDmd = opSubDmdInl (Lub, Lub)-opSubDmdInl (l, u) = ... opSubDmd ...-{-# INLINE opSubDmdInl #-}-opSubDmd = opSubDmdInl-{-# RULES "lubSubDmd" forall l r. opSubDmd (Lub, Lub) = lubSubDmd #-}-```-Here, 'opSubDmdInl' will not be picked as the loop-breaker and thus inline into-'lubSubDmd' and 'opSubDmd'. Since the latter will never inline, we'll specialise-all call sites of 'opSubDmd' for the proper op mode. A nice trick!--}--data LubOrPlus = Lub | Plus deriving Show-instance Outputable LubOrPlus where ppr = text . show---- | Determines whether to use 'LubOrPlus' for lower bounds and upper bounds,--- respectively. See Note [Manual specialisation of lub*Dmd/plus*Dmd].-type OpMode = (LubOrPlus, LubOrPlus)+multSubDmd :: Card -> SubDemand -> SubDemand+multSubDmd C_11 sd           = sd -- An optimisation, for when sd is a deep Prod+-- The following three equations don't have an impact on Demands, only on+-- Boxity. They are needed so that we don't trigger the assertions in `:*`+-- when called from `multDmd`.+multSubDmd C_00 _            = seqSubDmd -- Otherwise `multSubDmd A L == A /= !A`+multSubDmd C_10 (Poly _ n)   = if isStrict n then botSubDmd else seqSubDmd -- Otherwise `multSubDmd B L == B /= !B`+multSubDmd C_10 (Call n _)   = if isStrict n then botSubDmd else seqSubDmd -- Otherwise we'd call `mkCall` with absent cardinality+multSubDmd n    (Poly b m)   = Poly b (multCard n m)+multSubDmd n    (Call n' sd) = mkCall (multCard n n') sd+multSubDmd n    (Prod b ds)  = mkProd b (strictMap (multDmd n) ds) --- | Denotes '∪' on 'SubDemand'.-lubSubDmd :: SubDemand -> SubDemand -> SubDemand--- See Note [Manual specialisation of lub*Dmd/plus*Dmd]-lubSubDmd l r = opSubDmdInl (Lub, Lub) l r+lazifyIfStrict :: Card -> SubDemand -> SubDemand+lazifyIfStrict n sd = multSubDmd (glbCard C_01 n) sd  -- | Denotes '∪' on 'Demand'. lubDmd :: Demand -> Demand -> Demand--- See Note [Manual specialisation of lub*Dmd/plus*Dmd]-lubDmd l r = opDmdInl (Lub, Lub) l r+lubDmd BotDmd      dmd2        = dmd2+lubDmd dmd1        BotDmd      = dmd1+lubDmd (n1 :* sd1) (n2 :* sd2) = -- pprTraceWith "lubDmd" (\it -> ppr (n1:*sd1) $$ ppr (n2:*sd2) $$ ppr it) $+  lubCard n1 n2 :* lubSubDmd sd1 sd2 --- | Denotes '+' on 'SubDemand'.-plusSubDmd :: SubDemand -> SubDemand -> SubDemand--- See Note [Manual specialisation of lub*Dmd/plus*Dmd]-plusSubDmd l r = opSubDmdInl (Plus, Plus) l r+lubSubDmd :: SubDemand -> SubDemand -> SubDemand+-- Shortcuts for neutral and absorbing elements.+-- Below we assume that Boxed always wins.+lubSubDmd (Poly Unboxed C_10)  sd                   = sd+lubSubDmd sd                   (Poly Unboxed C_10)  = sd+lubSubDmd sd@(Poly Boxed C_0N) _                    = sd+lubSubDmd _                    sd@(Poly Boxed C_0N) = sd+-- Handle Prod+lubSubDmd (Prod b1 ds1) (Poly b2 n2)+  | let !d = polyFieldDmd b2 n2+  = mkProd (lubBoxity b1 b2) (strictMap (lubDmd d) ds1)+lubSubDmd (Prod b1 ds1) (Prod b2 ds2)+  | equalLength ds1 ds2+  = mkProd (lubBoxity b1 b2) (strictZipWith lubDmd ds1 ds2)+-- Handle Call+lubSubDmd (Call n1 sd1) (viewCall -> Just (n2, sd2)) =+  mkCall (lubCard n1 n2) (lubSubDmd sd1 sd2)+-- Handle Poly+lubSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (lubBoxity b1 b2) (lubCard n1 n2)+-- Other Poly case by commutativity+lubSubDmd sd1@Poly{}   sd2          = lubSubDmd sd2 sd1+-- Otherwise (Call `lub` Prod) return Top+lubSubDmd _            _            = topSubDmd  -- | Denotes '+' on 'Demand'. plusDmd :: Demand -> Demand -> Demand--- See Note [Manual specialisation of lub*Dmd/plus*Dmd]-plusDmd l r = opDmdInl (Plus, Plus) l r---- | Denotes '∪' on lower bounds and '+' on upper bounds on 'SubDemand'.-lubPlusSubDmd :: SubDemand -> SubDemand -> SubDemand--- See Note [Manual specialisation of lub*Dmd/plus*Dmd]-lubPlusSubDmd l r = opSubDmdInl (Lub, Plus) l r---- | Denotes '∪' on lower bounds and '+' on upper bounds on 'Demand'.-lubPlusDmd :: Demand -> Demand -> Demand--- See Note [Manual specialisation of lub*Dmd/plus*Dmd]-lubPlusDmd l r = opDmdInl (Lub, Plus) l r---- | Denotes '+' on lower bounds and '∪' on upper bounds on 'SubDemand'.-plusLubSubDmd :: SubDemand -> SubDemand -> SubDemand--- See Note [Manual specialisation of lub*Dmd/plus*Dmd]-plusLubSubDmd l r = opSubDmdInl (Plus, Lub) l r---- | Denotes '∪' on lower bounds and '+' on upper bounds on 'SubDemand'.-plusLubDmd :: Demand -> Demand -> Demand--- See Note [Manual specialisation of lub*Dmd/plus*Dmd]-plusLubDmd l r = opDmdInl (Plus, Lub) l r---- See Note [Manual specialisation of lub*Dmd/plus*Dmd]-{-# RULES "lubSubDmd"     opSubDmd (Lub, Lub)   = lubSubDmd #-}-{-# RULES "lubDmd"        opDmd (Lub, Lub)      = lubDmd #-}-{-# RULES "plusSubDmd"    opSubDmd (Plus, Plus) = plusSubDmd #-}-{-# RULES "plusDmd"       opDmd (Plus, Plus)    = plusDmd #-}-{-# RULES "lubPlusSubDmd" opSubDmd (Lub, Plus)  = lubPlusSubDmd #-}-{-# RULES "lubPlusDmd"    opDmd (Lub, Plus)     = lubPlusDmd #-}-{-# RULES "plusLubSubDmd" opSubDmd (Plus, Lub)  = plusLubSubDmd #-}-{-# RULES "plusLubDmd"    opDmd (Plus, Lub)     = plusLubDmd #-}------- And now the actual implementation that is to be specialised:-----neutralCard :: OpMode -> Card-neutralCard (Lub, _)  = C_10-neutralCard (Plus, _) = C_00-{-# INLINE neutralCard #-}--absorbingCard :: OpMode -> Card-absorbingCard (Lub, _)  = C_0N-absorbingCard (Plus, _) = C_1N-{-# INLINE absorbingCard #-}--opCard :: OpMode -> Card -> Card -> Card-opCard (Lub,  Lub)  = lubCard-opCard (Lub,  Plus) = lubPlusCard-opCard (Plus, Lub)  = plusLubCard-opCard (Plus, Plus) = plusCard-{-# INLINE opCard #-}--opDmdInl, opDmd :: OpMode -> Demand -> Demand -> Demand-opDmdInl m       (n1 :* _)   dmd2        | n1 == neutralCard m = dmd2-opDmdInl m       dmd1        (n2 :* _)   | n2 == neutralCard m = dmd1-opDmdInl m@(l,u) (n1 :* sd1) (n2 :* sd2) = -- pprTraceWith "opDmd" (\it -> ppr l <+> ppr u $$ ppr (n1:*sd1) $$ ppr (n2:*sd2) $$ ppr it) $-  opCard m n1 n2 :* case l of-    Lub  -> opSubDmd m sd1 sd2-    -- For Plus, there are four special cases due to strictness demands and-    -- Note [SubDemand denotes at least one evaluation]:-    Plus -> case (isStrict n1, isStrict n2) of-      (True,  True)  -> opSubDmd (Plus, u) sd1 sd2                  -- (D1)-      (True,  False) -> opSubDmd (Plus, u) sd1 (lazifySubDmd sd2)   -- (D2)-      (False, True)  -> opSubDmd (Plus, u) (lazifySubDmd sd1) sd2   -- (D2)-      (False, False) -> opSubDmd (Lub, u)  sd1 sd2                  -- (D3)---- See Note [Manual specialisation of lub*Dmd/plus*Dmd]-opDmd = opDmdInl-{-# INLINE opDmdInl #-}-{-# NOINLINE opDmd #-}+plusDmd AbsDmd      dmd2        = dmd2+plusDmd dmd1        AbsDmd      = dmd1+plusDmd (n1 :* sd1) (n2 :* sd2) = -- pprTraceWith "plusDmd" (\it -> ppr (n1:*sd1) $$ ppr (n2:*sd2) $$ ppr it) $+  -- Why lazify? See Note [SubDemand denotes at least one evaluation]+  -- and also Note [Unrealised opportunity in plusDmd] which applies when both+  -- n1 and n2 are lazy already+  plusCard n1 n2 :* plusSubDmd (lazifyIfStrict n1 sd1) (lazifyIfStrict n2 sd2) -opSubDmdInl, opSubDmd :: OpMode -> SubDemand -> SubDemand -> SubDemand+plusSubDmd :: SubDemand -> SubDemand -> SubDemand -- Shortcuts for neutral and absorbing elements. -- Below we assume that Boxed always wins.-opSubDmdInl m (Poly Unboxed n)  sd                | n == neutralCard m   = sd-opSubDmdInl m sd                (Poly Unboxed n)  | n == neutralCard m   = sd-opSubDmdInl m sd@(Poly Boxed n) _                 | n == absorbingCard m = sd-opSubDmdInl m _                 sd@(Poly Boxed n) | n == absorbingCard m = sd+plusSubDmd (Poly Unboxed C_00)  sd                   = sd+plusSubDmd sd                   (Poly Unboxed C_00)  = sd+plusSubDmd sd@(Poly Boxed C_1N) _                    = sd+plusSubDmd _                    sd@(Poly Boxed C_1N) = sd -- Handle Prod-opSubDmdInl m (Prod b1 ds1) (Poly b2 n2)+plusSubDmd (Prod b1 ds1) (Poly b2 n2)   | let !d = polyFieldDmd b2 n2-  = mkProd (lubBoxity b1 b2) (strictMap (opDmd m d) ds1)-opSubDmdInl m (Prod b1 ds1) (Prod b2 ds2)+  = mkProd (lubBoxity b1 b2) (strictMap (plusDmd d) ds1)+plusSubDmd (Prod b1 ds1) (Prod b2 ds2)   | equalLength ds1 ds2-  = mkProd (lubBoxity b1 b2) (strictZipWith (opDmd m) ds1 ds2)+  = mkProd (lubBoxity b1 b2) (strictZipWith plusDmd ds1 ds2) -- Handle Call-opSubDmdInl m@(l, _) (Call n1 sd1) (viewCall -> Just (n2, sd2)) =-  mkCall (opCard m n1 n2) $! case l of-    Lub  -> opSubDmd (Lub, Lub) sd1 sd2-    -- For Plus, there are four special cases due to strictness demands and-    -- Note [SubDemand denotes at least one evaluation]. Usage is always lubbed:-    Plus -> case (isStrict n1, isStrict n2) of-      (True,  True)  -> opSubDmd (Plus, Lub) sd1 sd2                  -- (C3)-      (False, True)  -> opSubDmd (Plus, Lub) (lazifySubDmd sd1) sd2   -- (C2)-      (True,  False) -> opSubDmd (Plus, Lub) sd1 (lazifySubDmd sd2)   -- (C2)-      (False, False) -> opSubDmd (Lub,  Lub) sd1 sd2                  -- (C1)+plusSubDmd (Call n1 sd1) (viewCall -> Just (n2, sd2)) =+  mkCall (plusCard n1 n2) (lubSubDmd sd1 sd2) -- Handle Poly-opSubDmdInl m (Poly b1 n1) (Poly b2 n2) = Poly (lubBoxity b1 b2) (opCard m n1 n2)+plusSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (lubBoxity b1 b2) (plusCard n1 n2) -- Other Poly case by commutativity-opSubDmdInl m sd1@Poly{}   sd2          = opSubDmd m sd2 sd1--- Otherwise (Call `op` Prod) return Top-opSubDmdInl _ _            _            = topSubDmd---- See Note [Manual specialisation of lub*Dmd/plus*Dmd]-opSubDmd = opSubDmdInl-{-# INLINE opSubDmdInl #-}-{-# NOINLINE opSubDmd #-}+plusSubDmd sd1@Poly{}   sd2          = plusSubDmd sd2 sd1+-- Otherwise (Call `plus` Prod) return Top+plusSubDmd _            _            = topSubDmd  -- | Used to suppress pretty-printing of an uninformative demand isTopDmd :: Demand -> Bool@@ -1072,22 +961,22 @@ evalDmd :: Demand evalDmd = C_1N :* topSubDmd --- | First argument of 'GHC.Exts.maskAsyncExceptions#': @1C1(L)@.+-- | First argument of 'GHC.Exts.maskAsyncExceptions#': @1C(1,L)@. -- Called exactly once. strictOnceApply1Dmd :: Demand strictOnceApply1Dmd = C_11 :* mkCall C_11 topSubDmd --- | First argument of 'GHC.Exts.atomically#': @SCS(L)@.+-- | First argument of 'GHC.Exts.atomically#': @SC(S,L)@. -- Called at least once, possibly many times. strictManyApply1Dmd :: Demand strictManyApply1Dmd = C_1N :* mkCall C_1N topSubDmd --- | First argument of catch#: @MCM(L)@.+-- | First argument of catch#: @MC(M,L)@. -- Evaluates its arg lazily, but then applies it exactly once to one argument. lazyApply1Dmd :: Demand lazyApply1Dmd = C_01 :* mkCall C_01 topSubDmd --- | Second argument of catch#: @MCM(C1(L))@.+-- | Second argument of catch#: @MC(M,C(1,L))@. -- Calls its arg lazily, but then applies it exactly once to an additional argument. lazyApply2Dmd :: Demand lazyApply2Dmd = C_01 :* mkCall C_01 (mkCall C_11 topSubDmd)@@ -1129,16 +1018,11 @@ lazifyDmd :: Demand -> Demand lazifyDmd = multDmd C_01 ---- | Make a 'SubDemand' lazy.-lazifySubDmd :: SubDemand -> SubDemand-lazifySubDmd = multSubDmd C_01---- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @C1(d)@.+-- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @C(1,d)@. mkCalledOnceDmd :: SubDemand -> SubDemand mkCalledOnceDmd sd = mkCall C_11 sd --- | @mkCalledOnceDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s.+-- | @mkCalledOnceDmds n d@ returns @C(1,C1...C(1,d))@ where there are @n@ @C1@'s. mkCalledOnceDmds :: Arity -> SubDemand -> SubDemand mkCalledOnceDmds arity sd = iterate mkCalledOnceDmd sd !! arity @@ -1166,7 +1050,7 @@ mkWorkerDemand :: Int -> Demand mkWorkerDemand n = C_01 :* go n   where go 0 = topSubDmd-        go n = Call C_01 $ go (n-1)+        go n = mkCall C_01 $ go (n-1)  argsOneShots :: DmdSig -> Arity -> [[OneShotInfo]] -- ^ See Note [Computing one-shot info]@@ -1197,9 +1081,9 @@     go _    = []  -- |--- @saturatedByOneShots n CM(CM(...)) = True@+-- @saturatedByOneShots n C(M,C(M,...)) = True@ --   <=>--- There are at least n nested CM(..) calls.+-- There are at least n nested C(M,..) calls. -- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap saturatedByOneShots :: Int -> Demand -> Bool saturatedByOneShots _ AbsDmd    = True@@ -1242,22 +1126,24 @@ Upper bounds/usage are unaffected by adding or leaving out evaluations that never happen. -So if `x` was demanded with `LP(1L)`, so perhaps `<body>` was-  f1 x = (x `seq` case x of (a,b) -> a, True)-then `x` will be evaluated lazily, but any time `x` is evaluated, `e` is-evaluated with sub-demand `P(1L)`, e.g., the first field of `e` is evaluated-strictly, too.+The Premise comes into play when we have lazy Demands. For example, if `x` was+demanded with `LP(SL,A)`, so perhaps the full expression was+  let x = (e1, e2) in (x `seq` fun y `seq` case x of (a,b) -> a, True)+then `x` will be evaluated lazily, but in any trace in which `x` is evaluated,+the pair in its RHS will ultimately be evaluated deeply with sub-demand+`P(SL,A)`. That means that `e1` is ultimately evaluated strictly, even though+evaluation of the field does not directly follow the eval of `x` due to the+intermittent call `fun y`. -How does the additional strictness help? The long version is in #21081.+How does the additional strictness help? The long version is the list of+examples at the end of this Note (as procured in #21081 and #18903). The short version is -  * We get to take advantage of call-by-value/let-to-case in more situations.-    See example "More let-to-case" below.+  * We get to take advantage of call-by-value/let-to-case in more situations,+    as for e1 above. See example "More let-to-case" below.   * Note [Eta reduction based on evaluation context] applies in more situations.     See example "More eta reduction" below.   * We get to unbox more results, see example "More CPR" below.-  * We prevent annoying issues with `Poly` equalities, #21085. In short, we'd get-    `L + S = S = CS(S) < CS(L) = C(L+S)(LuS) = L + CS(S)` although `S = CS(S)`.  It seems like we don't give up anything in return. Indeed that is the case: @@ -1271,47 +1157,26 @@     well as when expanding absent 'Poly's to 'Call' sub-demands in 'viewCall'.  Of course, we now have to maintain the Premise when we unpack and rebuild-SubDemands. For strict demands, we know that the Premise indeed always holds for+Demands. For strict demands, we know that the Premise indeed always holds for any program trace abstracted over, whereas we have to be careful for lazy demands.-That makes for a strange definition of `plusDmd`, where we use `plusSubDmd`-throughout for upper bounds (every eval returns the same, memoised heap object),-but what we do on lower bounds depends on the strictness of both arguments: - D1 `plusSubDmd` on the nested SubDemands if both args are strict.- D2 `plusSubDmd` on the nested SubDemands if one of them is lazy, which we-    *lazify* before (that's new), so that e.g.-      `LP(SL) + SP(L) = (L+S)P((M*SL)+L) = SP(L+L) = SP(L)`-    Multiplying with `M`/`C_01` is the "lazify" part here.-    Example proving that point:-        d2 :: <LP(SL)><SP(A)>-        d2 x y = y `seq` (case x of (a,b) -> a, True)-        -- What is demand on x in (d2 x x)? NOT SP(SL)!!- D3 `lubPlusSubDmd` on the nested SubDemands if both args are lazy.-    This new operation combines `lubSubDmd` on lower bounds with `plusSubDmd`-    on upper bounds.-    Examples proving that point:-        d3 :: <LP(SL)><LP(A)>-        d3 x y = (case x of (a,b) -> a, y `seq` ())-        -- What is demand on x in `snd (d3 x x)`?-        -- Not LP(SL)!!  d3 might evaluate second argument but not first.-        -- Lub lower bounds because we might evaluate one OR the other.--Similarly, in the handling of Call SubDemands `Cn(sd)` in `plusSubDmd`, we use-`lub` for upper bounds (because every call returns a fresh heap object), but-what we do for lower bounds depends on whether the outer `n`s are strict:+In particular, when doing `plusDmd` we have to *lazify* the nested SubDemand+if the outer cardinality is lazy. E.g.,+  LP(SL) + SP(L) = (L+S)P((M*SL)+L) = SP(L+L) = SP(L)+Multiplying with `M`/`C_01` is the "lazify" part here and is implemented in+`lazifyIfStrict`. Example proving that point:+  d2 :: <LP(SL)><SP(A)>+  d2 x y = y `seq` (case x of (a,b) -> a, True)+  -- What is the demand on x in (d2 x x)? NOT SP(SL)!! - C1 `lubSubDmd` on the nested SubDemands if both args are lazy.- C2 `plusLubSubDmd` on the nested `sd`s if one of the `n`s is lazy. That one's-    nested `sd` we *lazify*, so that e.g.-      `CL(SL) + CS(L) = C(L+S)((M*SL)+L) = CS(L+L) = CS(L)`-    `plusLubSubDmd` combines `plusSubDmd` on lower bounds with `lubSubDmd` on-    upper bounds.- C3 `plusLubSubDmd` on the nested SubDemands if both args are strict.+We used to apply the same reasoning to Call SubDemands `Cn(sd)` in `plusSubDmd`,+but that led to #21717, because different calls return different heap objects.+See Note [Call SubDemand vs. evaluation Demand]. -There are a couple of other examples in T21081.-Here is a selection of examples demonstrating the-usefulness of The Premise:+There are a couple more examples that improve in T21081.+Here is a selection of those examples demonstrating the usefulness of The+Premise:    * "More let-to-case" (from testcase T21081):     ```hs@@ -1331,8 +1196,8 @@     myfoldl f z [] = z     myfoldl f !z (x:xs) = myfoldl (\a b -> f a b) (f z x) xs     ```-    Here, we can give `f` a demand of `LCS(C1(L))` (instead of the lazier-    `LCL(C1(L))`) which says "Whenever `f` is evaluated (lazily), it is also+    Here, we can give `f` a demand of `LC(S,C(1,L))` (instead of the lazier+    `LC(L,C(1,L))`) which says "Whenever `f` is evaluated (lazily), it is also     called with two arguments".     And Note [Eta reduction based on evaluation context] means we can rewrite     `\a b -> f a b` to `f` in the call site of `myfoldl`. Nice!@@ -1350,17 +1215,113 @@         2 -> snd (g m)         _ -> uncurry (+) (g m)     ```-    We want to give `g` the demand `MC1(P(MP(L),1P(L)))`, so we see that in each+    We want to give `g` the demand `MC(1,P(MP(L),1P(L)))`, so we see that in each     call site of `g`, we are strict in the second component of the returned     pair. That in turn means that Nested CPR can unbox the result of the     division even though it might throw. +Note [Unrealised opportunity in plusDmd]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Recall the lazification of SubDemands happening in `plusDmd` as described in+Note [SubDemand denotes at least one evaluation].++We *could* do better when both Demands are lazy already. Example+  (fun 1, fun 2)+Both args put Demand SC(S,L) on `fun`. The lazy pair arg context lazifies+this to LC(S,L), and it would be reasonable to report this Demand on `fun` for+the entire pair expression; after all, `fun` is called whenever it is evaluated.+But our definition of `plusDmd` will compute+  LC(S,L) + LC(S,L) = (L+L)(M*C(S,L) + M*C(S,L)) = L(C(L,L)) = L+Which is clearly less precise.+Doing better here could mean to `lub` when both demands are lazy, e.g.,+  LC(S,L) + LC(S,L) = (L+L)(C(S,L) ⊔ C(S,L)) = L(C(S,L))+Indeed that's what we did at one point between 9.4 and 9.6 after !7599, but it+means that we need a function `lubPlusSubDmd` that lubs on lower bounds but+plus'es upper bounds, implying maintenance challenges and complicated+explanations.++Plus, NoFib says that this special case doesn't bring all that much+(geom. mean +0.0% counted instructions), so we don't bother anymore.++Note [Call SubDemand vs. evaluation Demand]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Although both evaluation Demands and Call SubDemands carry a (Card,SubDemand)+pair, their interpretation is quite different. Example:++  f x = fst x * snd x+    -- f :: <SP(1L,1L)>, because 1P(1L,A)+1P(A,1L) = SP(1L,1L)+  g x = fst (x 1) * snd (x 2)+    -- g :: <SC(S,P(ML,ML))>, because 1C(1,P(1L,A))+1C(1,P(A,1L)) = SC(S,P(ML,ML))++The point about this example is that both demands have P(A,1L)/P(1L,A) as+sub-expressions, but when these sub-demands occur++  1. under an evaluation demand, we combine with `plusSubDmd`+  2. whereas under a Call sub-demand, we combine with `lubSubDmd`++And thus (1) yields a stricter demand on the pair components than (2).++In #21717 we saw that we really need lub in (2), because otherwise we make an+unsound prediction in `g (\n -> if n == 1 then (1,1) else (bot,2))`; we'd say+that the `bot` expression is always evaluated, when it clearly is not.+Operationally, every call to `g` gives back a potentially distinct,+heap-allocated pair with potentially different contents, and we must `lubSubDmd`+over all such calls to approximate how any of those pairs might be used.++That is in stark contrast to f's argument `x`: Operationally, every eval of+`x` must yield the same pair and `f` evaluates both components of that pair.+The theorem "every eval of `x` returns the same heap object" is a very strong+MUST-alias property and we capitalise on that by using `plusSubDmd` in (1).++And indeed we *must* use `plusSubDmd` in (1) for sound upper bounds in an+analysis that assumes call-by-need (as opposed to the weaker call-by-name) for+let bindings. Consider++  h x = fst x * fst x+    -- h :: <SP(SL,A)>++And the expression `let a=1; p=(a,a)} in h p`. Here, *although* the RHS of `p`+is only evaluated once under call-by-need, `a` is still evaluated twice.+If we had used `lubSubDmd`, we'd see SP(1L,A) and the 1L unsoundly says "exactly+once".++If the analysis had assumed call-by-name, it would be sound to say "a is used+once in p": p is used multiple times and hence so would a, as if p was a+function. So using `plusSubDmd` does not only yield better strictness, it is+also "holding up the other end of the bargain" of the call-by-need assumption+for upper bounds.++(To SG's knowledge, the distinction between call-by-name and call-by-need does+not matter for strictness analysis/lower bounds, thus it would be sound to use+`lubSubDmd` all the time there.)++Note [mkCall and plusSubDmd]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We never rewrite a strict, non-absent Call sub-demand like C(S,S) to a+polymorphic sub-demand like S, otherwise #21085 strikes. Consider the+following inequality (would also for M and 1 instead of L and S, but we forbid+such Polys):++  L+S = S = C(S,S) < C(S,L) = C(L,L)+C(S,S)++Note that L=C(L,L). If we also had S=C(S,S), we'd be in trouble: Now+`plusSubDmd` would no longer maintain the equality relation on sub-demands,+much less monotonicity. Bad!++Clearly, `n <= Cn(n)` is unproblematic, as is `n >= Cn(n)` for any `n`+except 1 and S. But `C(S,S) >= S` would mean trouble, because then we'd get+the problematic `C(S,S) = S`. We have just established that `S < C(S,S)`!+As such, the rewrite C(S,S) to S is anti-monotone and we forbid it, first+and foremost in `mkCall` (which is the only place that rewrites Cn(n) to n).++Crisis and #21085 averted!+ Note [Computing one-shot info] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a call     f (\pqr. e1) (\xyz. e2) e3 where f has usage signature-    <CM(CL(CM(L)))><CM(L)><L>+    <C(M,C(L,C(M,L)))><C(M,L)><L> Then argsOneShots returns a [[OneShotInfo]] of     [[OneShot,NoOneShotInfo,OneShot],  [OneShot]] The occurrence analyser propagates this one-shot infor to the@@ -1411,7 +1372,7 @@  But then we regressed in T7837 (grep #19871 for boring specifics), which needed to transfer an ambient unboxed *demand* on a dictionary selector to its argument-dictionary, via a 'Call' sub-demand `C1(sd)`, as+dictionary, via a 'Call' sub-demand `C(1,sd)`, as Note [Demand transformer for a dictionary selector] explains. Annoyingly, the boxity info has to be stored in the *sub-demand* `sd`! There's no demand to store the boxity in. So we bit the bullet and now we store Boxity in@@ -1676,7 +1637,7 @@   catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this")  Any analysis that assumes otherwise will be broken in some way or another-(beyond `-fno-pendantic-bottoms`).+(beyond `-fno-pedantic-bottoms`).  But then #13380 and #17676 suggest (in Mar 20) that we need to re-introduce a subtly different variant of `ThrowsExn` (which we call `ExnOrDiv` now) that is@@ -1959,16 +1920,16 @@ this has a strictness signature of   <1L><1L>b meaning that we don't know what happens when we call err in weaker contexts than-C1(C1(L)), like @err `seq` ()@ (1A) and @err 1 `seq` ()@ (CS(A)). We+C(1,C(1,L)), like @err `seq` ()@ (1A) and @err 1 `seq` ()@ (C(S,A)). We may not unleash the botDiv, hence assume topDiv. Of course, in-@err 1 2 `seq` ()@ the incoming demand CS(CS(A)) is strong enough and we see+@err 1 2 `seq` ()@ the incoming demand C(S,C(S,A)) is strong enough and we see that the expression diverges.  Now consider a function   f g = g 1 2-with signature <C1(C1(L))>, and the expression+with signature <C(1,C(1,L))>, and the expression   f err `seq` ()-now f puts a strictness demand of C1(C1(L)) onto its argument, which is unleashed+now f puts a strictness demand of C(1,C(1,L)) onto its argument, which is unleashed on err via the App rule. In contrast to weaker head strictness, this demand is strong enough to unleash err's signature and hence we see that the whole expression diverges!@@ -2028,7 +1989,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a demand transformer d1 -> d2 -> r for f. If a sufficiently detailed demand is fed into this transformer,-e.g <C1(C1(L))> arising from "f x1 x2" in a strict, use-once context,+e.g <C(1,C(1,L))> arising from "f x1 x2" in a strict, use-once context, then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for the free variable environment) and furthermore the result information r is the one we want to use.@@ -2036,9 +1997,9 @@ An anonymous lambda is also an unsaturated function all (needs one argument, none given), so this applies to that case as well. -But the demand fed into f might be less than C1(C1(L)). Then we have to+But the demand fed into f might be less than C(1,C(1,L)). Then we have to 'multDmdType' the announced demand type. Examples:- * Not strict enough, e.g. C1(C1(L)):+ * Not strict enough, e.g. C(1,C(1,L)):    - We have to multiply all argument and free variable demands with C_01,      zapping strictness.    - We have to multiply divergence with C_01. If r says that f Diverges for sure,@@ -2046,7 +2007,7 @@      be passed. If the demand is lower, we may just as well converge.      If we were tracking definite convergence, than that would still hold under      a weaker demand than expected by the demand transformer.- * Used more than once, e.g. CS(C1(L)):+ * Used more than once, e.g. C(S,C(1,L)):    - Multiply with C_1N. Even if f puts a used-once demand on any of its argument      or free variables, if we call f multiple times, we may evaluate this      argument or free variable multiple times.@@ -2075,8 +2036,8 @@         c) an indication of the result of applying            the Id to its arguments -However, in fact we store in the Id an extremely emascuated demand-transfomer, namely+However, in fact we store in the Id an extremely emasculated demand+transformer, namely                  a single DmdType (Nevertheless we dignify DmdSig as a distinct type.)@@ -2102,7 +2063,7 @@ uses x with 1L, and its arg with demand 1P(L,L).  Note [Understanding DmdType and DmdSig]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Demand types are sound approximations of an expression's semantics relative to the incoming demand we put the expression under. Consider the following expression:@@ -2116,8 +2077,8 @@     incoming demand   |  demand type     --------------------------------     1A                  |  <L><L>{}-    C1(C1(L))           |  <1P(L)><L>{}-    C1(C1(1P(1P(L),A))) |  <1P(A)><A>{}+    C(1,C(1,L))           |  <1P(L)><L>{}+    C(1,C(1,1P(1P(L),A))) |  <1P(A)><A>{}  Note that in the first example, the depth of the demand type was *higher* than the arity of the incoming call demand due to the anonymous lambda.@@ -2187,6 +2148,13 @@ isDeadEndSig :: DmdSig -> Bool isDeadEndSig (DmdSig (DmdType _ _ res)) = isDeadEndDiv res +-- | True if the signature diverges or throws an imprecise exception in a saturated call.+-- NB: In constrast to 'isDeadEndSig' this returns False for 'exnDiv'.+-- See Note [Dead ends]+-- and Note [Precise vs imprecise exceptions].+isBottomingSig :: DmdSig -> Bool+isBottomingSig (DmdSig (DmdType _ _ res)) = res == botDiv+ -- | True when the signature indicates all arguments are boxed onlyBoxedArguments :: DmdSig -> Bool onlyBoxedArguments (DmdSig (DmdType _ dmds _)) = all demandIsBoxed dmds@@ -2219,6 +2187,38 @@ trimBoxityDmdSig :: DmdSig -> DmdSig trimBoxityDmdSig = coerce trimBoxityDmdType +-- | Transfers the boxity of the left arg to the demand structure of the right+-- arg. This only makes sense if applied to new and old demands of the same+-- value.+transferBoxity :: Demand -> Demand -> Demand+transferBoxity from to = go_dmd from to+  where+    go_dmd (from_n :* from_sd) to_dmd@(to_n :* to_sd)+      | isAbs from_n || isAbs to_n = to_dmd+      | otherwise = case (from_sd, to_sd) of+          (Poly from_b _, Poly _ to_c) ->+            to_n :* Poly from_b to_c+          (_, Prod _ to_ds)+            | Just (from_b, from_ds) <- viewProd (length to_ds) from_sd+            -> to_n :* mkProd from_b (strictZipWith go_dmd from_ds to_ds)+          (Prod from_b from_ds, _)+            | Just (_, to_ds) <- viewProd (length from_ds) to_sd+            -> to_n :* mkProd from_b (strictZipWith go_dmd from_ds to_ds)+          _ -> trimBoxity to_dmd++transferArgBoxityDmdType :: DmdType -> DmdType -> DmdType+transferArgBoxityDmdType _from@(DmdType _ from_ds _) to@(DmdType to_fvs to_ds to_res)+  | equalLength from_ds to_ds+  = -- pprTraceWith "transfer" (\r -> ppr _from $$ ppr to $$ ppr r) $+    DmdType to_fvs -- Only arg boxity! See Note [Don't change boxity without worker/wrapper]+            (zipWith transferBoxity from_ds to_ds)+            to_res+  | otherwise+  = trimBoxityDmdType to++transferArgBoxityDmdSig :: DmdSig -> DmdSig -> DmdSig+transferArgBoxityDmdSig = coerce transferArgBoxityDmdType+ prependArgsDmdSig :: Int -> DmdSig -> DmdSig -- ^ Add extra ('topDmd') arguments to a strictness signature. -- In contrast to 'etaConvertDmdSig', this /prepends/ additional argument@@ -2345,7 +2345,7 @@   SubDemand --F_f----> DmdType  With-  α(C1(C1(_))) = >=2+  α(C(1,C(1,_))) = >=2   α(_)         =  <2   γ(ty)        =  ty and F_f being the abstract transformer of f's RHS and f_f being the abstracted@@ -2375,7 +2375,7 @@  What do we learn about the demand on 'd'?  Alas, we see only the demand from 'sc_sel', namely '1P(1,A)'.  We /don't/ see that 'd' really has a nested-demand '1P(1P(A,1C1(1)),A)'.  On the other hand, if we inlined the two selectors+demand '1P(1P(A,1C(1,1)),A)'.  On the other hand, if we inlined the two selectors we'd have  f d x = case d of (x,_) ->@@ -2622,7 +2622,7 @@ -- | See Note [Demand notation] instance Outputable SubDemand where   ppr (Poly b n)  = pp_boxity b <> ppr n-  ppr (Call n sd) = char 'C' <> ppr n <> parens (ppr sd)+  ppr (Call n sd) = char 'C' <> parens (ppr n <> comma <> ppr sd)   ppr (Prod b ds) = pp_boxity b <> char 'P' <> parens (fields ds)     where       fields []     = empty