packages feed

ghc-lib-parser 9.12.3.20251228 → 9.14.1.20251220

raw patch · 328 files changed

+48842/−25311 lines, 328 filesdep ~basedep ~containersdep ~time

Dependency ranges changed: base, containers, time

Files

compiler/Bytecodes.h view
@@ -112,6 +112,109 @@  #define bci_PRIMCALL                    87 +#define bci_BCO_NAME                    88++#define bci_OP_ADD_64                   90+#define bci_OP_SUB_64                   91+#define bci_OP_AND_64                   92+#define bci_OP_XOR_64                   93+#define bci_OP_NOT_64                   94+#define bci_OP_NEG_64                   95+#define bci_OP_MUL_64                   96+#define bci_OP_SHL_64                   97+#define bci_OP_ASR_64                   98+#define bci_OP_LSR_64                   99+#define bci_OP_OR_64                   100++#define bci_OP_NEQ_64                  110+#define bci_OP_EQ_64                   111+#define bci_OP_U_GE_64                 112+#define bci_OP_U_GT_64                 113+#define bci_OP_U_LT_64                 114+#define bci_OP_U_LE_64                 115+#define bci_OP_S_GE_64                 116+#define bci_OP_S_GT_64                 117+#define bci_OP_S_LT_64                 118+#define bci_OP_S_LE_64                 119+++#define bci_OP_ADD_32                  130+#define bci_OP_SUB_32                  131+#define bci_OP_AND_32                  132+#define bci_OP_XOR_32                  133+#define bci_OP_NOT_32                  134+#define bci_OP_NEG_32                  135+#define bci_OP_MUL_32                  136+#define bci_OP_SHL_32                  137+#define bci_OP_ASR_32                  138+#define bci_OP_LSR_32                  139+#define bci_OP_OR_32                   140++#define bci_OP_NEQ_32                  150+#define bci_OP_EQ_32                   151+#define bci_OP_U_GE_32                 152+#define bci_OP_U_GT_32                 153+#define bci_OP_U_LT_32                 154+#define bci_OP_U_LE_32                 155+#define bci_OP_S_GE_32                 156+#define bci_OP_S_GT_32                 157+#define bci_OP_S_LT_32                 158+#define bci_OP_S_LE_32                 159+++#define bci_OP_ADD_16                  170+#define bci_OP_SUB_16                  171+#define bci_OP_AND_16                  172+#define bci_OP_XOR_16                  173+#define bci_OP_NOT_16                  174+#define bci_OP_NEG_16                  175+#define bci_OP_MUL_16                  176+#define bci_OP_SHL_16                  177+#define bci_OP_ASR_16                  178+#define bci_OP_LSR_16                  179+#define bci_OP_OR_16                   180++#define bci_OP_NEQ_16                  190+#define bci_OP_EQ_16                   191+#define bci_OP_U_GE_16                 192+#define bci_OP_U_GT_16                 193+#define bci_OP_U_LT_16                 194+#define bci_OP_U_LE_16                 195+#define bci_OP_S_GE_16                 196+#define bci_OP_S_GT_16                 197+#define bci_OP_S_LT_16                 198+#define bci_OP_S_LE_16                 199+++#define bci_OP_ADD_08                  200+#define bci_OP_SUB_08                  201+#define bci_OP_AND_08                  202+#define bci_OP_XOR_08                  203+#define bci_OP_NOT_08                  204+#define bci_OP_NEG_08                  205+#define bci_OP_MUL_08                  206+#define bci_OP_SHL_08                  207+#define bci_OP_ASR_08                  208+#define bci_OP_LSR_08                  209+#define bci_OP_OR_08                   210++#define bci_OP_NEQ_08                  220+#define bci_OP_EQ_08                   221+#define bci_OP_U_GE_08                 222+#define bci_OP_U_GT_08                 223+#define bci_OP_U_LT_08                 224+#define bci_OP_U_LE_08                 225+#define bci_OP_S_GE_08                 226+#define bci_OP_S_GT_08                 227+#define bci_OP_S_LT_08                 228+#define bci_OP_S_LE_08                 229++#define bci_OP_INDEX_ADDR_08           240+#define bci_OP_INDEX_ADDR_16           241+#define bci_OP_INDEX_ADDR_32           242+#define bci_OP_INDEX_ADDR_64           243++ /* If you need to go past 255 then you will run into the flags */  /* If you need to go below 0x0100 then you will run into the instructions */
compiler/ClosureTypes.h view
@@ -89,4 +89,5 @@ #define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62 #define COMPACT_NFDATA                63 #define CONTINUATION                  64-#define N_CLOSURE_TYPES               65+#define ANN_FRAME                     65+#define N_CLOSURE_TYPES               66
compiler/CodeGen.Platform.h view
@@ -2,7 +2,7 @@ import GHC.Cmm.Expr #if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \     || defined(MACHREGS_powerpc) || defined(MACHREGS_aarch64) \-    || defined(MACHREGS_riscv64))+    || defined(MACHREGS_riscv64) || defined(MACHREGS_loongarch64)) import GHC.Utils.Panic.Plain #endif import GHC.Platform.Reg@@ -1032,11 +1032,15 @@ -- ip0 -- used for spill offset computations freeReg 16 = False -#if defined(darwin_HOST_OS) || defined(ios_HOST_OS)+-- Note [Aarch64 Register x18 at Darwin and Windows]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- x18 is reserved by the platform on Darwin/iOS, and can not be used -- More about ARM64 ABI that Apple platforms support: -- https://developer.apple.com/documentation/xcode/writing-arm64-code-for-apple-platforms -- https://github.com/Siguza/ios-resources/blob/master/bits/arm64.md+-- It is a reserved at Windows as well. Acts like TEB register in user mode at Windows.+-- https://learn.microsoft.com/en-us/cpp/build/arm64-windows-abi-conventions+#if defined(darwin_HOST_OS) || defined(ios_HOST_OS) || defined(mingw32_HOST_OS) freeReg 18 = False #endif @@ -1138,6 +1142,104 @@ -- made-up inter-procedural (ip) register -- See Note [The made-up RISCV64 TMP (IP) register] freeReg 31 = False++# if defined(REG_Base)+freeReg REG_Base  = False+# endif+# if defined(REG_Sp)+freeReg REG_Sp    = False+# endif+# if defined(REG_SpLim)+freeReg REG_SpLim = False+# endif+# if defined(REG_Hp)+freeReg REG_Hp    = False+# endif+# if defined(REG_HpLim)+freeReg REG_HpLim = False+# endif++# if defined(REG_R1)+freeReg REG_R1    = False+# endif+# if defined(REG_R2)+freeReg REG_R2    = False+# endif+# if defined(REG_R3)+freeReg REG_R3    = False+# endif+# if defined(REG_R4)+freeReg REG_R4    = False+# endif+# if defined(REG_R5)+freeReg REG_R5    = False+# endif+# if defined(REG_R6)+freeReg REG_R6    = False+# endif+# if defined(REG_R7)+freeReg REG_R7    = False+# endif+# if defined(REG_R8)+freeReg REG_R8    = False+# endif++# if defined(REG_F1)+freeReg REG_F1    = False+# endif+# if defined(REG_F2)+freeReg REG_F2    = False+# endif+# if defined(REG_F3)+freeReg REG_F3    = False+# endif+# if defined(REG_F4)+freeReg REG_F4    = False+# endif+# if defined(REG_F5)+freeReg REG_F5    = False+# endif+# if defined(REG_F6)+freeReg REG_F6    = False+# endif++# if defined(REG_D1)+freeReg REG_D1    = False+# endif+# if defined(REG_D2)+freeReg REG_D2    = False+# endif+# if defined(REG_D3)+freeReg REG_D3    = False+# endif+# if defined(REG_D4)+freeReg REG_D4    = False+# endif+# if defined(REG_D5)+freeReg REG_D5    = False+# endif+# if defined(REG_D6)+freeReg REG_D6    = False+# endif++freeReg _ = True++#elif defined(MACHREGS_loongarch64)++-- zero register+freeReg 0 = False+-- linker regster+freeReg 1 = False+-- thread register+freeReg 2 = False+-- stack pointer+freeReg 3 = False+-- made-up inter-procedural (ip) register for spilling offset computations+freeReg 20 = False+-- reserved+freeReg 21 = False+-- frame pointer+freeReg 22 = False  # if defined(REG_Base) freeReg REG_Base  = False
compiler/GHC/Builtin/Names.hs view
@@ -54,14 +54,13 @@   1. When parsing source code, the RdrName-decorated AST has some      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.+     use. For example, when we parse a [] in a type and ListTuplePuns+     are enabled, we can just insert (Exact listTyConName :: RdrName). -     Currently, I believe this is just an optimisation: it would be-     equally valid to just output Orig RdrNames that correctly record-     the module etc we expect the final Name to come from. However,-     were we to eliminate isBuiltInOcc_maybe it would become essential-     (see point 3).+     This is just an optimisation: it would be equally valid to output+     Orig RdrNames that correctly record the module (and package) that+     we expect the final Name to come from. The name would be looked up+     in the OrigNameCache (see point 3).    2. The knownKeyNames (which consist of the basicKnownKeyNames from      the module, and those names reachable via the wired-in stuff from@@ -78,9 +77,10 @@   3. For "infinite families" of known-key names (i.e. tuples and sums), we      have to be extra careful. Because there are an infinite number of      these things, we cannot add them to the list of known-key names-     used to initialise the OrigNameCache. Instead, we have to-     rely on never having to look them up in that cache. See-     Note [Infinite families of known-key names] for details.+     used to initialise the OrigNameCache. Instead, lookupOrigNameCache pretends+     that these names are in the cache by using isInfiniteFamilyOrigName_maybe+     before the actual lookup.+     See Note [Infinite families of known-key names] for details.   Note [Infinite families of known-key names]@@ -98,26 +98,15 @@    b) The known infinite families of names are specially serialised by      GHC.Iface.Binary.putName, with that special treatment detected when we read-     back to ensure that we get back to the correct uniques. See Note [Symbol-     table representation of names] in GHC.Iface.Binary and Note [How tuples-     work] in GHC.Builtin.Types.--Most of the infinite families cannot occur in source code, so mechanisms (a) and (b)-suffice to ensure that they always have the right Unique. In particular,-implicit param TyCon names, constraint tuples and Any TyCons cannot be mentioned-by the user. For those things that *can* appear in source programs,--  c) GHC.Iface.Env.lookupOrigNameCache uses isBuiltInOcc_maybe to map built-in syntax-     directly onto the corresponding name, rather than trying to find it in the-     original-name cache.+     back to ensure that we get back to the correct uniques.+     See Note [Symbol table representation of names] in GHC.Iface.Binary and+     Note [How tuples work] in GHC.Builtin.Types. +  c) GHC.Iface.Env.lookupOrigNameCache uses isInfiniteFamilyOrigName_maybe to+     map tuples and sums onto their exact names, rather than trying to find them+     in the original-name cache.      See also Note [Built-in syntax and the OrigNameCache] -Note that one-tuples are an exception to the rule, as they do get assigned-known keys. See-Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys)-in GHC.Builtin.Types.- -}  {-# LANGUAGE CPP #-}@@ -522,6 +511,8 @@         , unsafeEqualityTyConName         , unsafeReflDataConName         , unsafeCoercePrimName++        , unsafeUnpackJSStringUtf8ShShName     ]  genericTyConNames :: [Name]@@ -557,24 +548,23 @@ gHC_PRIM, gHC_PRIM_PANIC,     gHC_TYPES, gHC_INTERNAL_DATA_DATA, gHC_MAGIC, gHC_MAGIC_DICT,     gHC_CLASSES, gHC_PRIMOPWRAPPERS :: Module-gHC_PRIM           = mkPrimModule (fsLit "GHC.Prim")   -- Primitive types and values-gHC_PRIM_PANIC     = mkPrimModule (fsLit "GHC.Prim.Panic")-gHC_TYPES          = mkPrimModule (fsLit "GHC.Types")-gHC_MAGIC          = mkPrimModule (fsLit "GHC.Magic")-gHC_MAGIC_DICT     = mkPrimModule (fsLit "GHC.Magic.Dict")-gHC_CSTRING        = mkPrimModule (fsLit "GHC.CString")-gHC_CLASSES        = mkPrimModule (fsLit "GHC.Classes")-gHC_PRIMOPWRAPPERS = mkPrimModule (fsLit "GHC.PrimopWrappers")--gHC_INTERNAL_TUPLE                  = mkPrimModule (fsLit "GHC.Tuple")+gHC_PRIM           = mkGhcInternalModule (fsLit "GHC.Internal.Prim")   -- Primitive types and values+gHC_PRIM_PANIC     = mkGhcInternalModule (fsLit "GHC.Internal.Prim.Panic")+gHC_TYPES          = mkGhcInternalModule (fsLit "GHC.Internal.Types")+gHC_MAGIC          = mkGhcInternalModule (fsLit "GHC.Internal.Magic")+gHC_MAGIC_DICT     = mkGhcInternalModule (fsLit "GHC.Internal.Magic.Dict")+gHC_CSTRING        = mkGhcInternalModule (fsLit "GHC.Internal.CString")+gHC_CLASSES        = mkGhcInternalModule (fsLit "GHC.Internal.Classes")+gHC_PRIMOPWRAPPERS = mkGhcInternalModule (fsLit "GHC.Internal.PrimopWrappers")+gHC_INTERNAL_TUPLE = mkGhcInternalModule (fsLit "GHC.Internal.Tuple")  gHC_INTERNAL_CONTROL_MONAD_ZIP :: Module gHC_INTERNAL_CONTROL_MONAD_ZIP  = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad.Zip")  gHC_INTERNAL_NUM_INTEGER, gHC_INTERNAL_NUM_NATURAL, gHC_INTERNAL_NUM_BIGNAT :: Module-gHC_INTERNAL_NUM_INTEGER            = mkBignumModule (fsLit "GHC.Num.Integer")-gHC_INTERNAL_NUM_NATURAL            = mkBignumModule (fsLit "GHC.Num.Natural")-gHC_INTERNAL_NUM_BIGNAT             = mkBignumModule (fsLit "GHC.Num.BigNat")+gHC_INTERNAL_NUM_INTEGER            = mkGhcInternalModule (fsLit "GHC.Internal.Bignum.Integer")+gHC_INTERNAL_NUM_NATURAL            = mkGhcInternalModule (fsLit "GHC.Internal.Bignum.Natural")+gHC_INTERNAL_NUM_BIGNAT             = mkGhcInternalModule (fsLit "GHC.Internal.Bignum.BigNat")  gHC_INTERNAL_BASE, gHC_INTERNAL_ENUM,     gHC_INTERNAL_GHCI, gHC_INTERNAL_GHCI_HELPERS, gHC_CSTRING, gHC_INTERNAL_DATA_STRING,@@ -590,7 +580,8 @@     gHC_INTERNAL_ARROW, gHC_INTERNAL_DESUGAR, gHC_INTERNAL_RANDOM, gHC_INTERNAL_EXTS, gHC_INTERNAL_IS_LIST,     gHC_INTERNAL_CONTROL_EXCEPTION_BASE, gHC_INTERNAL_TYPEERROR, gHC_INTERNAL_TYPELITS, gHC_INTERNAL_TYPELITS_INTERNAL,     gHC_INTERNAL_TYPENATS, gHC_INTERNAL_TYPENATS_INTERNAL,-    gHC_INTERNAL_DATA_COERCE, gHC_INTERNAL_DEBUG_TRACE, gHC_INTERNAL_UNSAFE_COERCE, gHC_INTERNAL_FOREIGN_C_CONSTPTR :: Module+    gHC_INTERNAL_DATA_COERCE, gHC_INTERNAL_DEBUG_TRACE, gHC_INTERNAL_UNSAFE_COERCE, gHC_INTERNAL_FOREIGN_C_CONSTPTR,+    gHC_INTERNAL_JS_PRIM, gHC_INTERNAL_WASM_PRIM_TYPES :: Module gHC_INTERNAL_BASE                   = mkGhcInternalModule (fsLit "GHC.Internal.Base") gHC_INTERNAL_ENUM                   = mkGhcInternalModule (fsLit "GHC.Internal.Enum") gHC_INTERNAL_GHCI                   = mkGhcInternalModule (fsLit "GHC.Internal.GHCi")@@ -633,7 +624,7 @@ gHC_INTERNAL_EXTS                   = mkGhcInternalModule (fsLit "GHC.Internal.Exts") gHC_INTERNAL_IS_LIST                = mkGhcInternalModule (fsLit "GHC.Internal.IsList") gHC_INTERNAL_CONTROL_EXCEPTION_BASE = mkGhcInternalModule (fsLit "GHC.Internal.Control.Exception.Base")-gHC_INTERNAL_EXCEPTION_CONTEXT = mkGhcInternalModule (fsLit "GHC.Internal.Exception.Context")+gHC_INTERNAL_EXCEPTION_CONTEXT      = mkGhcInternalModule (fsLit "GHC.Internal.Exception.Context") gHC_INTERNAL_GENERICS               = mkGhcInternalModule (fsLit "GHC.Internal.Generics") gHC_INTERNAL_TYPEERROR              = mkGhcInternalModule (fsLit "GHC.Internal.TypeError") gHC_INTERNAL_TYPELITS               = mkGhcInternalModule (fsLit "GHC.Internal.TypeLits")@@ -644,6 +635,8 @@ gHC_INTERNAL_DEBUG_TRACE            = mkGhcInternalModule (fsLit "GHC.Internal.Debug.Trace") gHC_INTERNAL_UNSAFE_COERCE          = mkGhcInternalModule (fsLit "GHC.Internal.Unsafe.Coerce") gHC_INTERNAL_FOREIGN_C_CONSTPTR     = mkGhcInternalModule (fsLit "GHC.Internal.Foreign.C.ConstPtr")+gHC_INTERNAL_JS_PRIM                = mkGhcInternalModule (fsLit "GHC.Internal.JS.Prim")+gHC_INTERNAL_WASM_PRIM_TYPES        = mkGhcInternalModule (fsLit "GHC.Internal.Wasm.Prim.Types")  gHC_INTERNAL_SRCLOC :: Module gHC_INTERNAL_SRCLOC = mkGhcInternalModule (fsLit "GHC.Internal.SrcLoc")@@ -678,12 +671,6 @@ pRELUDE_NAME   = mkModuleNameFS (fsLit "Prelude") mAIN_NAME      = mkModuleNameFS (fsLit "Main") -mkPrimModule :: FastString -> Module-mkPrimModule m = mkModule primUnit (mkModuleNameFS m)--mkBignumModule :: FastString -> Module-mkBignumModule m = mkModule bignumUnit (mkModuleNameFS m)- mkGhcInternalModule :: FastString -> Module mkGhcInternalModule m = mkGhcInternalModule_ (mkModuleNameFS m) @@ -1676,8 +1663,11 @@     tcQual gHC_INTERNAL_FOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey  jsvalTyConName :: Name-jsvalTyConName = tcQual (mkGhcInternalModule (fsLit "GHC.Internal.Wasm.Prim.Types")) (fsLit "JSVal") jsvalTyConKey+jsvalTyConName = tcQual gHC_INTERNAL_WASM_PRIM_TYPES (fsLit "JSVal") jsvalTyConKey +unsafeUnpackJSStringUtf8ShShName :: Name+unsafeUnpackJSStringUtf8ShShName = varQual gHC_INTERNAL_JS_PRIM (fsLit "unsafeUnpackJSStringUtf8##") unsafeUnpackJSStringUtf8ShShKey+ {- ************************************************************************ *                                                                      *@@ -1822,7 +1812,7 @@     weakPrimTyConKey, mutableArrayPrimTyConKey,     mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey,     ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey,-    stablePtrTyConKey, eqTyConKey, heqTyConKey, ioPortPrimTyConKey,+    stablePtrTyConKey, eqTyConKey, heqTyConKey,     smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey,     stringTyConKey,     ccArrowTyConKey, ctArrowTyConKey, tcArrowTyConKey :: Unique@@ -1859,7 +1849,7 @@ mutableByteArrayPrimTyConKey            = mkPreludeTyConUnique 31 orderingTyConKey                        = mkPreludeTyConUnique 32 mVarPrimTyConKey                        = mkPreludeTyConUnique 33-ioPortPrimTyConKey                      = mkPreludeTyConUnique 34+-- ioPortPrimTyConKey (34) was killed ratioTyConKey                           = mkPreludeTyConUnique 35 rationalTyConKey                        = mkPreludeTyConUnique 36 realWorldTyConKey                       = mkPreludeTyConUnique 37@@ -2082,6 +2072,7 @@   , typeNatLogTyFamNameKey   , typeConsSymbolTyFamNameKey, typeUnconsSymbolTyFamNameKey   , typeCharToNatTyFamNameKey, typeNatToCharTyFamNameKey+  , exceptionContextTyConKey, unsafeUnpackJSStringUtf8ShShKey   :: Unique typeSymbolKindConNameKey  = mkPreludeTyConUnique 400 typeCharKindConNameKey    = mkPreludeTyConUnique 401@@ -2104,8 +2095,9 @@  jsvalTyConKey = mkPreludeTyConUnique 418 -exceptionContextTyConKey :: Unique exceptionContextTyConKey = mkPreludeTyConUnique 420++unsafeUnpackJSStringUtf8ShShKey  = mkPreludeMiscIdUnique 805  {- ************************************************************************
+ compiler/GHC/Builtin/Names/TH.hs view
@@ -0,0 +1,1212 @@+-- %************************************************************************+-- %*                                                                   *+--              The known-key names for Template Haskell+-- %*                                                                   *+-- %************************************************************************++module GHC.Builtin.Names.TH where++import GHC.Prelude ()++import GHC.Builtin.Names( mk_known_key_name )+import GHC.Unit.Types+import GHC.Types.Name( Name )+import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName, fieldName )+import GHC.Types.Name.Reader( RdrName, nameRdrName )+import GHC.Types.Unique ( Unique )+import GHC.Builtin.Uniques+import GHC.Data.FastString++import Language.Haskell.Syntax.Module.Name++-- To add a name, do three things+--+--  1) Allocate a key+--  2) Make a "Name"+--  3) Add the name to templateHaskellNames++templateHaskellNames :: [Name]+-- The names that are implicitly mentioned by ``bracket''+-- Should stay in sync with the import list of GHC.HsToCore.Quote++templateHaskellNames = [+    returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,+    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameG_fldName,+    mkNameLName,+    mkNameSName, mkNameQName,+    mkModNameName,+    liftStringName,+    unTypeName, unTypeCodeName,+    unsafeCodeCoerceName,++    -- Lit+    charLName, stringLName, integerLName, intPrimLName, wordPrimLName,+    floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,+    charPrimLName,+    -- Pat+    litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName,+    conPName, tildePName, bangPName, infixPName,+    asPName, wildPName, recPName, listPName, sigPName, viewPName,+    typePName, invisPName, orPName,+    -- FieldPat+    fieldPatName,+    -- Match+    matchName,+    -- Clause+    clauseName,+    -- Exp+    varEName, conEName, litEName, appEName, appTypeEName, infixEName,+    infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,+    lamCasesEName, tupEName, unboxedTupEName, unboxedSumEName,+    condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName,+    fromEName, fromThenEName, fromToEName, fromThenToEName,+    listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,+    labelEName, implicitParamVarEName, getFieldEName, projectionEName,+    typeEName, forallEName, forallVisEName, constrainedEName,+    -- FieldExp+    fieldExpName,+    -- Body+    guardedBName, normalBName,+    -- Guard+    normalGEName, patGEName,+    -- Stmt+    bindSName, letSName, noBindSName, parSName, recSName,+    -- Dec+    funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName,+    classDName, instanceWithOverlapDName,+    standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,+    pragInlDName, pragOpaqueDName,+    pragSpecDName, pragSpecInlDName, pragSpecEDName, pragSpecInlEDName,+    pragSpecInstDName,+    pragRuleDName, pragCompleteDName, pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,+    defaultSigDName, defaultDName,+    dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,+    dataInstDName, newtypeInstDName, tySynInstDName,+    infixLWithSpecDName, infixRWithSpecDName, infixNWithSpecDName,+    roleAnnotDName, patSynDName, patSynSigDName,+    implicitParamBindDName,+    -- Cxt+    cxtName,++    -- SourceUnpackedness+    noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName,+    -- SourceStrictness+    noSourceStrictnessName, sourceLazyName, sourceStrictName,+    -- Con+    normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName,+    -- Bang+    bangName,+    -- BangType+    bangTypeName,+    -- VarBangType+    varBangTypeName,+    -- PatSynDir (for pattern synonyms)+    unidirPatSynName, implBidirPatSynName, explBidirPatSynName,+    -- PatSynArgs (for pattern synonyms)+    prefixPatSynName, infixPatSynName, recordPatSynName,+    -- Type+    forallTName, forallVisTName, varTName, conTName, infixTName, appTName,+    appKindTName, equalityTName, tupleTName, unboxedTupleTName,+    unboxedSumTName, arrowTName, mulArrowTName, listTName, sigTName, litTName,+    promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,+    wildCardTName, implicitParamTName,+    -- TyLit+    numTyLitName, strTyLitName, charTyLitName,+    -- TyVarBndr+    plainTVName, kindedTVName,+    plainInvisTVName, kindedInvisTVName,+    plainBndrTVName, kindedBndrTVName,+    -- Specificity+    specifiedSpecName, inferredSpecName,+    -- Visibility+    bndrReqName, bndrInvisName,+    -- Role+    nominalRName, representationalRName, phantomRName, inferRName,+    -- Kind+    starKName, constraintKName,+    -- FamilyResultSig+    noSigName, kindSigName, tyVarSigName,+    -- InjectivityAnn+    injectivityAnnName,+    -- Callconv+    cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName,+    -- Safety+    unsafeName,+    safeName,+    interruptibleName,+    -- Inline+    noInlineDataConName, inlineDataConName, inlinableDataConName,+    -- RuleMatch+    conLikeDataConName, funLikeDataConName,+    -- Phases+    allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName,+    -- Overlap+    overlappableDataConName, overlappingDataConName, overlapsDataConName,+    incoherentDataConName,+    -- NamespaceSpecifier+    noNamespaceSpecifierDataConName, typeNamespaceSpecifierDataConName,+    dataNamespaceSpecifierDataConName,+    -- DerivStrategy+    stockStrategyName, anyclassStrategyName,+    newtypeStrategyName, viaStrategyName,+    -- RuleBndr+    ruleVarName, typedRuleVarName,+    -- FunDep+    funDepName,+    -- TySynEqn+    tySynEqnName,+    -- AnnTarget+    valueAnnotationName, typeAnnotationName, moduleAnnotationName,+    -- DerivClause+    derivClauseName,++    -- The type classes+    liftClassName, quoteClassName,++    -- And the tycons+    qTyConName, nameTyConName, patTyConName,+    fieldPatTyConName, matchTyConName,+    expQTyConName, fieldExpTyConName, predTyConName,+    stmtTyConName,  decsTyConName, conTyConName, bangTypeTyConName,+    varBangTypeTyConName, typeQTyConName, expTyConName, decTyConName,+    typeTyConName,+    tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, tyVarBndrVisTyConName,+    clauseTyConName,+    patQTyConName, funDepTyConName, decsQTyConName,+    ruleBndrTyConName, tySynEqnTyConName,+    roleTyConName, codeTyConName, injAnnTyConName, kindTyConName,+    overlapTyConName, derivClauseTyConName, derivStrategyTyConName,+    modNameTyConName,++    -- Quasiquoting+    quasiQuoterTyConName, quoteDecName, quoteTypeName, quoteExpName, quotePatName]++thSyn, thLib, qqLib, liftLib :: Module+thSyn = mkTHModule (fsLit "GHC.Internal.TH.Syntax")+thLib = mkTHModule (fsLit "GHC.Internal.TH.Lib")+qqLib = mkTHModule (fsLit "GHC.Internal.TH.Quote")+liftLib = mkTHModule (fsLit "GHC.Internal.TH.Lift")++mkTHModule :: FastString -> Module+mkTHModule m = mkModule ghcInternalUnit (mkModuleNameFS m)++libFun, libTc, thFun, thTc, thCls, thCon, liftFun :: FastString -> Unique -> Name+libFun = mk_known_key_name varName  thLib+libTc  = mk_known_key_name tcName   thLib+thFun  = mk_known_key_name varName  thSyn+thTc   = mk_known_key_name tcName   thSyn+thCls  = mk_known_key_name clsName  thSyn+thCon  = mk_known_key_name dataName thSyn+liftFun = mk_known_key_name varName liftLib++thFld :: FastString -> FastString -> Unique -> Name+thFld con = mk_known_key_name (fieldName con) thSyn++qqFld :: FastString -> Unique -> Name+qqFld = mk_known_key_name (fieldName (fsLit "QuasiQuoter")) qqLib++-------------------- TH.Syntax -----------------------+liftClassName :: Name+liftClassName = mk_known_key_name clsName liftLib (fsLit "Lift") liftClassKey++quoteClassName :: Name+quoteClassName = thCls (fsLit "Quote") quoteClassKey++qTyConName, nameTyConName, fieldExpTyConName, patTyConName,+    fieldPatTyConName, expTyConName, decTyConName, typeTyConName,+    matchTyConName, clauseTyConName, funDepTyConName, predTyConName,+    codeTyConName, injAnnTyConName, overlapTyConName, decsTyConName,+    modNameTyConName, quasiQuoterTyConName :: Name+qTyConName             = thTc (fsLit "Q")              qTyConKey+nameTyConName          = thTc (fsLit "Name")           nameTyConKey+fieldExpTyConName      = thTc (fsLit "FieldExp")       fieldExpTyConKey+patTyConName           = thTc (fsLit "Pat")            patTyConKey+fieldPatTyConName      = thTc (fsLit "FieldPat")       fieldPatTyConKey+expTyConName           = thTc (fsLit "Exp")            expTyConKey+decTyConName           = thTc (fsLit "Dec")            decTyConKey+decsTyConName          = libTc (fsLit "Decs")           decsTyConKey+typeTyConName          = thTc (fsLit "Type")           typeTyConKey+matchTyConName         = thTc (fsLit "Match")          matchTyConKey+clauseTyConName        = thTc (fsLit "Clause")         clauseTyConKey+funDepTyConName        = thTc (fsLit "FunDep")         funDepTyConKey+predTyConName          = thTc (fsLit "Pred")           predTyConKey+codeTyConName          = thTc (fsLit "Code")           codeTyConKey+injAnnTyConName        = thTc (fsLit "InjectivityAnn") injAnnTyConKey+overlapTyConName       = thTc (fsLit "Overlap")        overlapTyConKey+modNameTyConName       = thTc (fsLit "ModName")        modNameTyConKey+quasiQuoterTyConName   = mk_known_key_name tcName qqLib (fsLit "QuasiQuoter") quasiQuoterTyConKey++returnQName, bindQName, sequenceQName, newNameName, liftName,+    mkNameName, mkNameG_vName, mkNameG_fldName, mkNameG_dName, mkNameG_tcName,+    mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName,+    unsafeCodeCoerceName, liftTypedName, mkModNameName, mkNameQName :: Name+returnQName    = thFun (fsLit "returnQ")   returnQIdKey+bindQName      = thFun (fsLit "bindQ")     bindQIdKey+sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey+newNameName    = thFun (fsLit "newName")   newNameIdKey+mkNameName     = thFun (fsLit "mkName")     mkNameIdKey+mkNameG_vName  = thFun (fsLit "mkNameG_v")  mkNameG_vIdKey+mkNameG_dName  = thFun (fsLit "mkNameG_d")  mkNameG_dIdKey+mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey+mkNameG_fldName= thFun (fsLit "mkNameG_fld") mkNameG_fldIdKey+mkNameLName    = thFun (fsLit "mkNameL")    mkNameLIdKey+mkNameQName    = thFun (fsLit "mkNameQ")    mkNameQIdKey+mkNameSName    = thFun (fsLit "mkNameS")    mkNameSIdKey+mkModNameName  = thFun (fsLit "mkModName")  mkModNameIdKey+unTypeName     = thFld (fsLit "TExp") (fsLit "unType") unTypeIdKey+unTypeCodeName    = thFun (fsLit "unTypeCode") unTypeCodeIdKey+unsafeCodeCoerceName = thFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey+liftName       = liftFun (fsLit "lift")      liftIdKey+liftStringName = liftFun (fsLit "liftString")  liftStringIdKey+liftTypedName = liftFun (fsLit "liftTyped") liftTypedIdKey+++-------------------- TH.Lib -----------------------+-- data Lit = ...+charLName, stringLName, integerLName, intPrimLName, wordPrimLName,+    floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,+    charPrimLName :: Name+charLName       = libFun (fsLit "charL")       charLIdKey+stringLName     = libFun (fsLit "stringL")     stringLIdKey+integerLName    = libFun (fsLit "integerL")    integerLIdKey+intPrimLName    = libFun (fsLit "intPrimL")    intPrimLIdKey+wordPrimLName   = libFun (fsLit "wordPrimL")   wordPrimLIdKey+floatPrimLName  = libFun (fsLit "floatPrimL")  floatPrimLIdKey+doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey+rationalLName   = libFun (fsLit "rationalL")     rationalLIdKey+stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey+charPrimLName   = libFun (fsLit "charPrimL")   charPrimLIdKey++-- data Pat = ...+litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName,+    infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName,+    sigPName, viewPName, typePName, invisPName, orPName :: Name+litPName   = libFun (fsLit "litP")   litPIdKey+varPName   = libFun (fsLit "varP")   varPIdKey+tupPName   = libFun (fsLit "tupP")   tupPIdKey+unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey+unboxedSumPName = libFun (fsLit "unboxedSumP") unboxedSumPIdKey+conPName   = libFun (fsLit "conP")   conPIdKey+infixPName = libFun (fsLit "infixP") infixPIdKey+tildePName = libFun (fsLit "tildeP") tildePIdKey+bangPName  = libFun (fsLit "bangP")  bangPIdKey+asPName    = libFun (fsLit "asP")    asPIdKey+wildPName  = libFun (fsLit "wildP")  wildPIdKey+recPName   = libFun (fsLit "recP")   recPIdKey+listPName  = libFun (fsLit "listP")  listPIdKey+sigPName   = libFun (fsLit "sigP")   sigPIdKey+viewPName  = libFun (fsLit "viewP")  viewPIdKey+orPName    = libFun (fsLit "orP")    orPIdKey+typePName  = libFun (fsLit "typeP")  typePIdKey+invisPName = libFun (fsLit "invisP") invisPIdKey++-- type FieldPat = ...+fieldPatName :: Name+fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey++-- data Match = ...+matchName :: Name+matchName = libFun (fsLit "match") matchIdKey++-- data Clause = ...+clauseName :: Name+clauseName = libFun (fsLit "clause") clauseIdKey++-- data Exp = ...+varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName,+    sectionLName, sectionRName, lamEName, lamCaseEName, lamCasesEName, tupEName,+    unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,+    caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,+    labelEName, implicitParamVarEName, getFieldEName, projectionEName, typeEName,+    forallEName, forallVisEName, constrainedEName :: Name+varEName              = libFun (fsLit "varE")              varEIdKey+conEName              = libFun (fsLit "conE")              conEIdKey+litEName              = libFun (fsLit "litE")              litEIdKey+appEName              = libFun (fsLit "appE")              appEIdKey+appTypeEName          = libFun (fsLit "appTypeE")          appTypeEIdKey+infixEName            = libFun (fsLit "infixE")            infixEIdKey+infixAppName          = libFun (fsLit "infixApp")          infixAppIdKey+sectionLName          = libFun (fsLit "sectionL")          sectionLIdKey+sectionRName          = libFun (fsLit "sectionR")          sectionRIdKey+lamEName              = libFun (fsLit "lamE")              lamEIdKey+lamCaseEName          = libFun (fsLit "lamCaseE")          lamCaseEIdKey+lamCasesEName         = libFun (fsLit "lamCasesE")         lamCasesEIdKey+tupEName              = libFun (fsLit "tupE")              tupEIdKey+unboxedTupEName       = libFun (fsLit "unboxedTupE")       unboxedTupEIdKey+unboxedSumEName       = libFun (fsLit "unboxedSumE")       unboxedSumEIdKey+condEName             = libFun (fsLit "condE")             condEIdKey+multiIfEName          = libFun (fsLit "multiIfE")          multiIfEIdKey+letEName              = libFun (fsLit "letE")              letEIdKey+caseEName             = libFun (fsLit "caseE")             caseEIdKey+doEName               = libFun (fsLit "doE")               doEIdKey+mdoEName              = libFun (fsLit "mdoE")              mdoEIdKey+compEName             = libFun (fsLit "compE")             compEIdKey+-- ArithSeq skips a level+fromEName, fromThenEName, fromToEName, fromThenToEName :: Name+fromEName             = libFun (fsLit "fromE")             fromEIdKey+fromThenEName         = libFun (fsLit "fromThenE")         fromThenEIdKey+fromToEName           = libFun (fsLit "fromToE")           fromToEIdKey+fromThenToEName       = libFun (fsLit "fromThenToE")       fromThenToEIdKey+-- end ArithSeq+listEName, sigEName, recConEName, recUpdEName :: Name+listEName             = libFun (fsLit "listE")             listEIdKey+sigEName              = libFun (fsLit "sigE")              sigEIdKey+recConEName           = libFun (fsLit "recConE")           recConEIdKey+recUpdEName           = libFun (fsLit "recUpdE")           recUpdEIdKey+staticEName           = libFun (fsLit "staticE")           staticEIdKey+unboundVarEName       = libFun (fsLit "unboundVarE")       unboundVarEIdKey+labelEName            = libFun (fsLit "labelE")            labelEIdKey+implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey+getFieldEName         = libFun (fsLit "getFieldE")         getFieldEIdKey+projectionEName       = libFun (fsLit "projectionE")       projectionEIdKey+typeEName             = libFun (fsLit "typeE")             typeEIdKey+forallEName           = libFun (fsLit "forallE")           forallEIdKey+forallVisEName        = libFun (fsLit "forallVisE")        forallVisEIdKey+constrainedEName      = libFun (fsLit "constrainedE")      constrainedEIdKey++-- type FieldExp = ...+fieldExpName :: Name+fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey++-- data Body = ...+guardedBName, normalBName :: Name+guardedBName = libFun (fsLit "guardedB") guardedBIdKey+normalBName  = libFun (fsLit "normalB")  normalBIdKey++-- data Guard = ...+normalGEName, patGEName :: Name+normalGEName = libFun (fsLit "normalGE") normalGEIdKey+patGEName    = libFun (fsLit "patGE")    patGEIdKey++-- data Stmt = ...+bindSName, letSName, noBindSName, parSName, recSName :: Name+bindSName   = libFun (fsLit "bindS")   bindSIdKey+letSName    = libFun (fsLit "letS")    letSIdKey+noBindSName = libFun (fsLit "noBindS") noBindSIdKey+parSName    = libFun (fsLit "parS")    parSIdKey+recSName    = libFun (fsLit "recS")    recSIdKey++-- data Dec = ...+funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName,+    instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,+    pragSpecDName, pragSpecInlDName, pragSpecEDName, pragSpecInlEDName,+    pragSpecInstDName, pragRuleDName,+    pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,+    standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,+    dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,+    openTypeFamilyDName, closedTypeFamilyDName, infixLWithSpecDName,+    infixRWithSpecDName, infixNWithSpecDName, roleAnnotDName, patSynDName,+    patSynSigDName, pragCompleteDName, implicitParamBindDName, pragOpaqueDName :: Name+funDName                         = libFun (fsLit "funD")                         funDIdKey+valDName                         = libFun (fsLit "valD")                         valDIdKey+dataDName                        = libFun (fsLit "dataD")                        dataDIdKey+newtypeDName                     = libFun (fsLit "newtypeD")                     newtypeDIdKey+typeDataDName                    = libFun (fsLit "typeDataD")                    typeDataDIdKey+tySynDName                       = libFun (fsLit "tySynD")                       tySynDIdKey+classDName                       = libFun (fsLit "classD")                       classDIdKey+instanceWithOverlapDName         = libFun (fsLit "instanceWithOverlapD")         instanceWithOverlapDIdKey+standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey+sigDName                         = libFun (fsLit "sigD")                         sigDIdKey+kiSigDName                       = libFun (fsLit "kiSigD")                       kiSigDIdKey+defaultDName                     = libFun (fsLit "defaultD")                     defaultDIdKey+defaultSigDName                  = libFun (fsLit "defaultSigD")                  defaultSigDIdKey+forImpDName                      = libFun (fsLit "forImpD")                      forImpDIdKey+pragInlDName                     = libFun (fsLit "pragInlD")                     pragInlDIdKey+pragOpaqueDName                  = libFun (fsLit "pragOpaqueD")                  pragOpaqueDIdKey+pragSpecDName                    = libFun (fsLit "pragSpecD")                    pragSpecDIdKey+pragSpecInlDName                 = libFun (fsLit "pragSpecInlD")                 pragSpecInlDIdKey+pragSpecEDName                   = libFun (fsLit "pragSpecED")                   pragSpecEDIdKey+pragSpecInlEDName                = libFun (fsLit "pragSpecInlED")                pragSpecInlEDIdKey+pragSpecInstDName                = libFun (fsLit "pragSpecInstD")                pragSpecInstDIdKey+pragRuleDName                    = libFun (fsLit "pragRuleD")                    pragRuleDIdKey+pragCompleteDName                = libFun (fsLit "pragCompleteD")                pragCompleteDIdKey+pragAnnDName                     = libFun (fsLit "pragAnnD")                     pragAnnDIdKey+pragSCCFunDName                  = libFun (fsLit "pragSCCFunD")                  pragSCCFunDKey+pragSCCFunNamedDName             = libFun (fsLit "pragSCCFunNamedD")             pragSCCFunNamedDKey+dataInstDName                    = libFun (fsLit "dataInstD")                    dataInstDIdKey+newtypeInstDName                 = libFun (fsLit "newtypeInstD")                 newtypeInstDIdKey+tySynInstDName                   = libFun (fsLit "tySynInstD")                   tySynInstDIdKey+openTypeFamilyDName              = libFun (fsLit "openTypeFamilyD")              openTypeFamilyDIdKey+closedTypeFamilyDName            = libFun (fsLit "closedTypeFamilyD")            closedTypeFamilyDIdKey+dataFamilyDName                  = libFun (fsLit "dataFamilyD")                  dataFamilyDIdKey+infixLWithSpecDName              = libFun (fsLit "infixLWithSpecD")              infixLWithSpecDIdKey+infixRWithSpecDName              = libFun (fsLit "infixRWithSpecD")              infixRWithSpecDIdKey+infixNWithSpecDName              = libFun (fsLit "infixNWithSpecD")              infixNWithSpecDIdKey+roleAnnotDName                   = libFun (fsLit "roleAnnotD")                   roleAnnotDIdKey+patSynDName                      = libFun (fsLit "patSynD")                      patSynDIdKey+patSynSigDName                   = libFun (fsLit "patSynSigD")                   patSynSigDIdKey+implicitParamBindDName           = libFun (fsLit "implicitParamBindD")           implicitParamBindDIdKey++-- type Ctxt = ...+cxtName :: Name+cxtName = libFun (fsLit "cxt") cxtIdKey++-- data SourceUnpackedness = ...+noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName :: Name+noSourceUnpackednessName = libFun (fsLit "noSourceUnpackedness") noSourceUnpackednessKey+sourceNoUnpackName       = libFun (fsLit "sourceNoUnpack")       sourceNoUnpackKey+sourceUnpackName         = libFun (fsLit "sourceUnpack")         sourceUnpackKey++-- data SourceStrictness = ...+noSourceStrictnessName, sourceLazyName, sourceStrictName :: Name+noSourceStrictnessName = libFun (fsLit "noSourceStrictness") noSourceStrictnessKey+sourceLazyName         = libFun (fsLit "sourceLazy")         sourceLazyKey+sourceStrictName       = libFun (fsLit "sourceStrict")       sourceStrictKey++-- data Con = ...+normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName :: Name+normalCName  = libFun (fsLit "normalC" ) normalCIdKey+recCName     = libFun (fsLit "recC"    ) recCIdKey+infixCName   = libFun (fsLit "infixC"  ) infixCIdKey+forallCName  = libFun (fsLit "forallC" ) forallCIdKey+gadtCName    = libFun (fsLit "gadtC"   ) gadtCIdKey+recGadtCName = libFun (fsLit "recGadtC") recGadtCIdKey++-- data Bang = ...+bangName :: Name+bangName = libFun (fsLit "bang") bangIdKey++-- type BangType = ...+bangTypeName :: Name+bangTypeName = libFun (fsLit "bangType") bangTKey++-- type VarBangType = ...+varBangTypeName :: Name+varBangTypeName = libFun (fsLit "varBangType") varBangTKey++-- data PatSynDir = ...+unidirPatSynName, implBidirPatSynName, explBidirPatSynName :: Name+unidirPatSynName    = libFun (fsLit "unidir")    unidirPatSynIdKey+implBidirPatSynName = libFun (fsLit "implBidir") implBidirPatSynIdKey+explBidirPatSynName = libFun (fsLit "explBidir") explBidirPatSynIdKey++-- data PatSynArgs = ...+prefixPatSynName, infixPatSynName, recordPatSynName :: Name+prefixPatSynName = libFun (fsLit "prefixPatSyn") prefixPatSynIdKey+infixPatSynName  = libFun (fsLit "infixPatSyn")  infixPatSynIdKey+recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey++-- data Type = ...+forallTName, forallVisTName, varTName, conTName, infixTName, tupleTName,+    unboxedTupleTName, unboxedSumTName, arrowTName, mulArrowTName, listTName,+    appTName, appKindTName, sigTName, equalityTName, litTName, promotedTName,+    promotedTupleTName, promotedNilTName, promotedConsTName,+    wildCardTName, implicitParamTName :: Name+forallTName         = libFun (fsLit "forallT")        forallTIdKey+forallVisTName      = libFun (fsLit "forallVisT")     forallVisTIdKey+varTName            = libFun (fsLit "varT")           varTIdKey+conTName            = libFun (fsLit "conT")           conTIdKey+tupleTName          = libFun (fsLit "tupleT")         tupleTIdKey+unboxedTupleTName   = libFun (fsLit "unboxedTupleT")  unboxedTupleTIdKey+unboxedSumTName     = libFun (fsLit "unboxedSumT")    unboxedSumTIdKey+arrowTName          = libFun (fsLit "arrowT")         arrowTIdKey+mulArrowTName       = libFun (fsLit "mulArrowT")      mulArrowTIdKey+listTName           = libFun (fsLit "listT")          listTIdKey+appTName            = libFun (fsLit "appT")           appTIdKey+appKindTName        = libFun (fsLit "appKindT")       appKindTIdKey+sigTName            = libFun (fsLit "sigT")           sigTIdKey+equalityTName       = libFun (fsLit "equalityT")      equalityTIdKey+litTName            = libFun (fsLit "litT")           litTIdKey+promotedTName       = libFun (fsLit "promotedT")      promotedTIdKey+promotedTupleTName  = libFun (fsLit "promotedTupleT") promotedTupleTIdKey+promotedNilTName    = libFun (fsLit "promotedNilT")   promotedNilTIdKey+promotedConsTName   = libFun (fsLit "promotedConsT")  promotedConsTIdKey+wildCardTName       = libFun (fsLit "wildCardT")      wildCardTIdKey+infixTName          = libFun (fsLit "infixT")         infixTIdKey+implicitParamTName  = libFun (fsLit "implicitParamT") implicitParamTIdKey++-- data TyLit = ...+numTyLitName, strTyLitName, charTyLitName :: Name+numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey+strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey+charTyLitName = libFun (fsLit "charTyLit") charTyLitIdKey++-- data TyVarBndr = ...+plainTVName, kindedTVName :: Name+plainTVName  = libFun (fsLit "plainTV")  plainTVIdKey+kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey++plainInvisTVName, kindedInvisTVName :: Name+plainInvisTVName  = libFun (fsLit "plainInvisTV")  plainInvisTVIdKey+kindedInvisTVName = libFun (fsLit "kindedInvisTV") kindedInvisTVIdKey++plainBndrTVName, kindedBndrTVName :: Name+plainBndrTVName  = libFun (fsLit "plainBndrTV")  plainBndrTVIdKey+kindedBndrTVName = libFun (fsLit "kindedBndrTV") kindedBndrTVIdKey++-- data Specificity = ...+specifiedSpecName, inferredSpecName :: Name+specifiedSpecName = libFun (fsLit "specifiedSpec") specifiedSpecKey+inferredSpecName  = libFun (fsLit "inferredSpec")  inferredSpecKey++-- data BndrVis = ...+bndrReqName, bndrInvisName :: Name+bndrReqName   = libFun (fsLit "bndrReq")   bndrReqKey+bndrInvisName = libFun (fsLit "bndrInvis") bndrInvisKey++-- data Role = ...+nominalRName, representationalRName, phantomRName, inferRName :: Name+nominalRName          = libFun (fsLit "nominalR")          nominalRIdKey+representationalRName = libFun (fsLit "representationalR") representationalRIdKey+phantomRName          = libFun (fsLit "phantomR")          phantomRIdKey+inferRName            = libFun (fsLit "inferR")            inferRIdKey++-- data Kind = ...+starKName, constraintKName :: Name+starKName       = libFun (fsLit "starK")        starKIdKey+constraintKName = libFun (fsLit "constraintK")  constraintKIdKey++-- data FamilyResultSig = ...+noSigName, kindSigName, tyVarSigName :: Name+noSigName    = libFun (fsLit "noSig")    noSigIdKey+kindSigName  = libFun (fsLit "kindSig")  kindSigIdKey+tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey++-- data InjectivityAnn = ...+injectivityAnnName :: Name+injectivityAnnName = libFun (fsLit "injectivityAnn") injectivityAnnIdKey++-- data Callconv = ...+cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name+cCallName = libFun (fsLit "cCall") cCallIdKey+stdCallName = libFun (fsLit "stdCall") stdCallIdKey+cApiCallName = libFun (fsLit "cApi") cApiCallIdKey+primCallName = libFun (fsLit "prim") primCallIdKey+javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey++-- data Safety = ...+unsafeName, safeName, interruptibleName :: Name+unsafeName     = libFun (fsLit "unsafe") unsafeIdKey+safeName       = libFun (fsLit "safe") safeIdKey+interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey++-- data RuleBndr = ...+ruleVarName, typedRuleVarName :: Name+ruleVarName      = libFun (fsLit ("ruleVar"))      ruleVarIdKey+typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey++-- data FunDep = ...+funDepName :: Name+funDepName     = libFun (fsLit "funDep") funDepIdKey++-- data TySynEqn = ...+tySynEqnName :: Name+tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey++-- data AnnTarget = ...+valueAnnotationName, typeAnnotationName, moduleAnnotationName :: Name+valueAnnotationName  = libFun (fsLit "valueAnnotation")  valueAnnotationIdKey+typeAnnotationName   = libFun (fsLit "typeAnnotation")   typeAnnotationIdKey+moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey++-- type DerivClause = ...+derivClauseName :: Name+derivClauseName = libFun (fsLit "derivClause") derivClauseIdKey++-- data DerivStrategy = ...+stockStrategyName, anyclassStrategyName, newtypeStrategyName,+  viaStrategyName :: Name+stockStrategyName    = libFun (fsLit "stockStrategy")    stockStrategyIdKey+anyclassStrategyName = libFun (fsLit "anyclassStrategy") anyclassStrategyIdKey+newtypeStrategyName  = libFun (fsLit "newtypeStrategy")  newtypeStrategyIdKey+viaStrategyName      = libFun (fsLit "viaStrategy")      viaStrategyIdKey++patQTyConName, expQTyConName, stmtTyConName,+    conTyConName, bangTypeTyConName,+    varBangTypeTyConName, typeQTyConName,+    decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName,+    derivClauseTyConName, kindTyConName,+    tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, tyVarBndrVisTyConName,+    derivStrategyTyConName :: Name+-- These are only used for the types of top-level splices+expQTyConName           = libTc (fsLit "ExpQ")           expQTyConKey+decsQTyConName          = libTc (fsLit "DecsQ")          decsQTyConKey  -- Q [Dec]+typeQTyConName          = libTc (fsLit "TypeQ")          typeQTyConKey+patQTyConName           = libTc (fsLit "PatQ")           patQTyConKey++-- These are used in GHC.HsToCore.Quote but always wrapped in a type variable+stmtTyConName           = thTc (fsLit "Stmt")            stmtTyConKey+conTyConName            = thTc (fsLit "Con")             conTyConKey+bangTypeTyConName       = thTc (fsLit "BangType")      bangTypeTyConKey+varBangTypeTyConName    = thTc (fsLit "VarBangType")     varBangTypeTyConKey+ruleBndrTyConName      = thTc (fsLit "RuleBndr")      ruleBndrTyConKey+tySynEqnTyConName       = thTc  (fsLit "TySynEqn")       tySynEqnTyConKey+roleTyConName           = libTc (fsLit "Role")           roleTyConKey+derivClauseTyConName   = thTc (fsLit "DerivClause")   derivClauseTyConKey+kindTyConName          = thTc (fsLit "Kind")          kindTyConKey+tyVarBndrUnitTyConName = libTc (fsLit "TyVarBndrUnit") tyVarBndrUnitTyConKey+tyVarBndrSpecTyConName = libTc (fsLit "TyVarBndrSpec") tyVarBndrSpecTyConKey+tyVarBndrVisTyConName  = libTc (fsLit "TyVarBndrVis")  tyVarBndrVisTyConKey+derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey++-- quasiquoting+quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name+quoteExpName  = qqFld (fsLit "quoteExp")  quoteExpKey+quotePatName  = qqFld (fsLit "quotePat")  quotePatKey+quoteDecName  = qqFld (fsLit "quoteDec")  quoteDecKey+quoteTypeName = qqFld (fsLit "quoteType") quoteTypeKey++-- data Inline = ...+noInlineDataConName, inlineDataConName, inlinableDataConName :: Name+noInlineDataConName  = thCon (fsLit "NoInline")  noInlineDataConKey+inlineDataConName    = thCon (fsLit "Inline")    inlineDataConKey+inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey++-- data RuleMatch = ...+conLikeDataConName, funLikeDataConName :: Name+conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey+funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey++-- data Phases = ...+allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name+allPhasesDataConName   = thCon (fsLit "AllPhases")   allPhasesDataConKey+fromPhaseDataConName   = thCon (fsLit "FromPhase")   fromPhaseDataConKey+beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey++-- data Overlap = ...+overlappableDataConName,+  overlappingDataConName,+  overlapsDataConName,+  incoherentDataConName :: Name+overlappableDataConName = thCon (fsLit "Overlappable") overlappableDataConKey+overlappingDataConName  = thCon (fsLit "Overlapping")  overlappingDataConKey+overlapsDataConName     = thCon (fsLit "Overlaps")     overlapsDataConKey+incoherentDataConName   = thCon (fsLit "Incoherent")   incoherentDataConKey++-- data NamespaceSpecifier = ...+noNamespaceSpecifierDataConName,+  typeNamespaceSpecifierDataConName,+  dataNamespaceSpecifierDataConName :: Name+noNamespaceSpecifierDataConName =+  thCon (fsLit "NoNamespaceSpecifier") noNamespaceSpecifierDataConKey+typeNamespaceSpecifierDataConName =+  thCon (fsLit "TypeNamespaceSpecifier") typeNamespaceSpecifierDataConKey+dataNamespaceSpecifierDataConName =+  thCon (fsLit "DataNamespaceSpecifier") dataNamespaceSpecifierDataConKey++{- *********************************************************************+*                                                                      *+                     Class keys+*                                                                      *+********************************************************************* -}++-- ClassUniques available: 200-299+-- Check in GHC.Builtin.Names if you want to change this++liftClassKey :: Unique+liftClassKey = mkPreludeClassUnique 200++quoteClassKey :: Unique+quoteClassKey = mkPreludeClassUnique 201++{- *********************************************************************+*                                                                      *+                     TyCon keys+*                                                                      *+********************************************************************* -}++-- TyConUniques available: 200-299+-- Check in GHC.Builtin.Names if you want to change this++expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,+    patTyConKey,+    stmtTyConKey, conTyConKey, typeQTyConKey, typeTyConKey,+    tyVarBndrUnitTyConKey, tyVarBndrSpecTyConKey, tyVarBndrVisTyConKey,+    decTyConKey, bangTypeTyConKey, varBangTypeTyConKey,+    fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,+    funDepTyConKey, predTyConKey,+    predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey,+    roleTyConKey, codeTyConKey, injAnnTyConKey, kindTyConKey,+    overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey,+    modNameTyConKey, quasiQuoterTyConKey :: Unique+expTyConKey             = mkPreludeTyConUnique 200+matchTyConKey           = mkPreludeTyConUnique 201+clauseTyConKey          = mkPreludeTyConUnique 202+qTyConKey               = mkPreludeTyConUnique 203+expQTyConKey            = mkPreludeTyConUnique 204+patTyConKey             = mkPreludeTyConUnique 206+stmtTyConKey            = mkPreludeTyConUnique 209+conTyConKey             = mkPreludeTyConUnique 210+typeQTyConKey           = mkPreludeTyConUnique 211+typeTyConKey            = mkPreludeTyConUnique 212+decTyConKey             = mkPreludeTyConUnique 213+bangTypeTyConKey        = mkPreludeTyConUnique 214+varBangTypeTyConKey     = mkPreludeTyConUnique 215+fieldExpTyConKey        = mkPreludeTyConUnique 216+fieldPatTyConKey        = mkPreludeTyConUnique 217+nameTyConKey            = mkPreludeTyConUnique 218+patQTyConKey            = mkPreludeTyConUnique 219+funDepTyConKey          = mkPreludeTyConUnique 222+predTyConKey            = mkPreludeTyConUnique 223+predQTyConKey           = mkPreludeTyConUnique 224+tyVarBndrUnitTyConKey   = mkPreludeTyConUnique 225+decsQTyConKey           = mkPreludeTyConUnique 226+ruleBndrTyConKey        = mkPreludeTyConUnique 227+tySynEqnTyConKey        = mkPreludeTyConUnique 228+roleTyConKey            = mkPreludeTyConUnique 229+injAnnTyConKey          = mkPreludeTyConUnique 231+kindTyConKey            = mkPreludeTyConUnique 232+overlapTyConKey         = mkPreludeTyConUnique 233+derivClauseTyConKey     = mkPreludeTyConUnique 234+derivStrategyTyConKey   = mkPreludeTyConUnique 235+decsTyConKey            = mkPreludeTyConUnique 236+tyVarBndrSpecTyConKey   = mkPreludeTyConUnique 237+codeTyConKey            = mkPreludeTyConUnique 238+modNameTyConKey         = mkPreludeTyConUnique 239+tyVarBndrVisTyConKey    = mkPreludeTyConUnique 240+quasiQuoterTyConKey     = mkPreludeTyConUnique 241++{- *********************************************************************+*                                                                      *+                     DataCon keys+*                                                                      *+********************************************************************* -}++-- DataConUniques available: 100-150+-- If you want to change this, make sure you check in GHC.Builtin.Names++-- data Inline = ...+noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique+noInlineDataConKey  = mkPreludeDataConUnique 200+inlineDataConKey    = mkPreludeDataConUnique 201+inlinableDataConKey = mkPreludeDataConUnique 202++-- data RuleMatch = ...+conLikeDataConKey, funLikeDataConKey :: Unique+conLikeDataConKey = mkPreludeDataConUnique 204+funLikeDataConKey = mkPreludeDataConUnique 205++-- data Phases = ...+allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique+allPhasesDataConKey   = mkPreludeDataConUnique 206+fromPhaseDataConKey   = mkPreludeDataConUnique 207+beforePhaseDataConKey = mkPreludeDataConUnique 208++-- data Overlap = ..+overlappableDataConKey,+  overlappingDataConKey,+  overlapsDataConKey,+  incoherentDataConKey :: Unique+overlappableDataConKey = mkPreludeDataConUnique 209+overlappingDataConKey  = mkPreludeDataConUnique 210+overlapsDataConKey     = mkPreludeDataConUnique 211+incoherentDataConKey   = mkPreludeDataConUnique 212++-- data NamespaceSpecifier = ...+noNamespaceSpecifierDataConKey,+  typeNamespaceSpecifierDataConKey,+  dataNamespaceSpecifierDataConKey :: Unique+noNamespaceSpecifierDataConKey = mkPreludeDataConUnique 213+typeNamespaceSpecifierDataConKey = mkPreludeDataConUnique 214+dataNamespaceSpecifierDataConKey = mkPreludeDataConUnique 215+{- *********************************************************************+*                                                                      *+                     Id keys+*                                                                      *+********************************************************************* -}++-- IdUniques available: 200-499+-- If you want to change this, make sure you check in GHC.Builtin.Names++returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,+    mkNameIdKey, mkNameG_vIdKey, mkNameG_fldIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,+    mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey,+    unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey, mkNameQIdKey :: Unique+returnQIdKey        = mkPreludeMiscIdUnique 200+bindQIdKey          = mkPreludeMiscIdUnique 201+sequenceQIdKey      = mkPreludeMiscIdUnique 202+liftIdKey           = mkPreludeMiscIdUnique 203+newNameIdKey         = mkPreludeMiscIdUnique 204+mkNameIdKey          = mkPreludeMiscIdUnique 205+mkNameG_vIdKey       = mkPreludeMiscIdUnique 206+mkNameG_dIdKey       = mkPreludeMiscIdUnique 207+mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208+mkNameLIdKey         = mkPreludeMiscIdUnique 209+mkNameSIdKey         = mkPreludeMiscIdUnique 210+unTypeIdKey          = mkPreludeMiscIdUnique 211+unTypeCodeIdKey      = mkPreludeMiscIdUnique 212+liftTypedIdKey        = mkPreludeMiscIdUnique 214+mkModNameIdKey        = mkPreludeMiscIdUnique 215+unsafeCodeCoerceIdKey = mkPreludeMiscIdUnique 216+mkNameQIdKey         = mkPreludeMiscIdUnique 217+mkNameG_fldIdKey     = mkPreludeMiscIdUnique 218+++-- data Lit = ...+charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,+    floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey, stringPrimLIdKey,+    charPrimLIdKey:: Unique+charLIdKey        = mkPreludeMiscIdUnique 220+stringLIdKey      = mkPreludeMiscIdUnique 221+integerLIdKey     = mkPreludeMiscIdUnique 222+intPrimLIdKey     = mkPreludeMiscIdUnique 223+wordPrimLIdKey    = mkPreludeMiscIdUnique 224+floatPrimLIdKey   = mkPreludeMiscIdUnique 225+doublePrimLIdKey  = mkPreludeMiscIdUnique 226+rationalLIdKey    = mkPreludeMiscIdUnique 227+stringPrimLIdKey  = mkPreludeMiscIdUnique 228+charPrimLIdKey    = mkPreludeMiscIdUnique 229++liftStringIdKey :: Unique+liftStringIdKey     = mkPreludeMiscIdUnique 230++-- data Pat = ...+litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey,+  infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey,+  listPIdKey, sigPIdKey, viewPIdKey, typePIdKey, invisPIdKey, orPIdKey :: Unique+litPIdKey         = mkPreludeMiscIdUnique 240+varPIdKey         = mkPreludeMiscIdUnique 241+tupPIdKey         = mkPreludeMiscIdUnique 242+unboxedTupPIdKey  = mkPreludeMiscIdUnique 243+unboxedSumPIdKey  = mkPreludeMiscIdUnique 244+conPIdKey         = mkPreludeMiscIdUnique 245+infixPIdKey       = mkPreludeMiscIdUnique 246+tildePIdKey       = mkPreludeMiscIdUnique 247+bangPIdKey        = mkPreludeMiscIdUnique 248+asPIdKey          = mkPreludeMiscIdUnique 249+wildPIdKey        = mkPreludeMiscIdUnique 250+recPIdKey         = mkPreludeMiscIdUnique 251+listPIdKey        = mkPreludeMiscIdUnique 252+sigPIdKey         = mkPreludeMiscIdUnique 253+viewPIdKey        = mkPreludeMiscIdUnique 254+typePIdKey        = mkPreludeMiscIdUnique 255+invisPIdKey       = mkPreludeMiscIdUnique 256+orPIdKey          = mkPreludeMiscIdUnique 257++-- type FieldPat = ...+fieldPatIdKey :: Unique+fieldPatIdKey       = mkPreludeMiscIdUnique 260++-- data Match = ...+matchIdKey :: Unique+matchIdKey          = mkPreludeMiscIdUnique 261++-- data Clause = ...+clauseIdKey :: Unique+clauseIdKey         = mkPreludeMiscIdUnique 262+++-- data Exp = ...+varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,+    infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey,+    lamCasesEIdKey, tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey,+    multiIfEIdKey, letEIdKey, caseEIdKey, doEIdKey, compEIdKey,+    fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,+    listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,+    unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey,+    getFieldEIdKey, projectionEIdKey, typeEIdKey, forallEIdKey,+    forallVisEIdKey, constrainedEIdKey :: Unique+varEIdKey              = mkPreludeMiscIdUnique 270+conEIdKey              = mkPreludeMiscIdUnique 271+litEIdKey              = mkPreludeMiscIdUnique 272+appEIdKey              = mkPreludeMiscIdUnique 273+appTypeEIdKey          = mkPreludeMiscIdUnique 274+infixEIdKey            = mkPreludeMiscIdUnique 275+infixAppIdKey          = mkPreludeMiscIdUnique 276+sectionLIdKey          = mkPreludeMiscIdUnique 277+sectionRIdKey          = mkPreludeMiscIdUnique 278+lamEIdKey              = mkPreludeMiscIdUnique 279+lamCaseEIdKey          = mkPreludeMiscIdUnique 280+lamCasesEIdKey         = mkPreludeMiscIdUnique 281+tupEIdKey              = mkPreludeMiscIdUnique 282+unboxedTupEIdKey       = mkPreludeMiscIdUnique 283+unboxedSumEIdKey       = mkPreludeMiscIdUnique 284+condEIdKey             = mkPreludeMiscIdUnique 285+multiIfEIdKey          = mkPreludeMiscIdUnique 286+letEIdKey              = mkPreludeMiscIdUnique 287+caseEIdKey             = mkPreludeMiscIdUnique 288+doEIdKey               = mkPreludeMiscIdUnique 289+compEIdKey             = mkPreludeMiscIdUnique 290+fromEIdKey             = mkPreludeMiscIdUnique 291+fromThenEIdKey         = mkPreludeMiscIdUnique 292+fromToEIdKey           = mkPreludeMiscIdUnique 293+fromThenToEIdKey       = mkPreludeMiscIdUnique 294+listEIdKey             = mkPreludeMiscIdUnique 295+sigEIdKey              = mkPreludeMiscIdUnique 296+recConEIdKey           = mkPreludeMiscIdUnique 297+recUpdEIdKey           = mkPreludeMiscIdUnique 298+staticEIdKey           = mkPreludeMiscIdUnique 299+unboundVarEIdKey       = mkPreludeMiscIdUnique 300+labelEIdKey            = mkPreludeMiscIdUnique 301+implicitParamVarEIdKey = mkPreludeMiscIdUnique 302+mdoEIdKey              = mkPreludeMiscIdUnique 303+getFieldEIdKey         = mkPreludeMiscIdUnique 304+projectionEIdKey       = mkPreludeMiscIdUnique 305+typeEIdKey             = mkPreludeMiscIdUnique 306+forallEIdKey           = mkPreludeMiscIdUnique 802+forallVisEIdKey        = mkPreludeMiscIdUnique 803+constrainedEIdKey      = mkPreludeMiscIdUnique 804++-- type FieldExp = ...+fieldExpIdKey :: Unique+fieldExpIdKey       = mkPreludeMiscIdUnique 307++-- data Body = ...+guardedBIdKey, normalBIdKey :: Unique+guardedBIdKey     = mkPreludeMiscIdUnique 308+normalBIdKey      = mkPreludeMiscIdUnique 309++-- data Guard = ...+normalGEIdKey, patGEIdKey :: Unique+normalGEIdKey     = mkPreludeMiscIdUnique 310+patGEIdKey        = mkPreludeMiscIdUnique 311++-- data Stmt = ...+bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique+bindSIdKey       = mkPreludeMiscIdUnique 312+letSIdKey        = mkPreludeMiscIdUnique 313+noBindSIdKey     = mkPreludeMiscIdUnique 314+parSIdKey        = mkPreludeMiscIdUnique 315+recSIdKey        = mkPreludeMiscIdUnique 316++-- data Dec = ...+funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,+    instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey,+    pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey,+    pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey,+    openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,+    newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,+    infixLWithSpecDIdKey, infixRWithSpecDIdKey, infixNWithSpecDIdKey,+    roleAnnotDIdKey, patSynDIdKey, patSynSigDIdKey, pragCompleteDIdKey,+    implicitParamBindDIdKey, kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey,+    typeDataDIdKey, pragSCCFunDKey, pragSCCFunNamedDKey,+    pragSpecEDIdKey, pragSpecInlEDIdKey :: Unique+funDIdKey                         = mkPreludeMiscIdUnique 320+valDIdKey                         = mkPreludeMiscIdUnique 321+dataDIdKey                        = mkPreludeMiscIdUnique 322+newtypeDIdKey                     = mkPreludeMiscIdUnique 323+tySynDIdKey                       = mkPreludeMiscIdUnique 324+classDIdKey                       = mkPreludeMiscIdUnique 325+instanceWithOverlapDIdKey         = mkPreludeMiscIdUnique 326+instanceDIdKey                    = mkPreludeMiscIdUnique 327+sigDIdKey                         = mkPreludeMiscIdUnique 328+forImpDIdKey                      = mkPreludeMiscIdUnique 329+pragInlDIdKey                     = mkPreludeMiscIdUnique 330+pragSpecDIdKey                    = mkPreludeMiscIdUnique 331+pragSpecInlDIdKey                 = mkPreludeMiscIdUnique 332+pragSpecInstDIdKey                = mkPreludeMiscIdUnique 333+pragRuleDIdKey                    = mkPreludeMiscIdUnique 334+pragAnnDIdKey                     = mkPreludeMiscIdUnique 335+dataFamilyDIdKey                  = mkPreludeMiscIdUnique 336+openTypeFamilyDIdKey              = mkPreludeMiscIdUnique 337+dataInstDIdKey                    = mkPreludeMiscIdUnique 338+newtypeInstDIdKey                 = mkPreludeMiscIdUnique 339+tySynInstDIdKey                   = mkPreludeMiscIdUnique 340+closedTypeFamilyDIdKey            = mkPreludeMiscIdUnique 341+infixLWithSpecDIdKey              = mkPreludeMiscIdUnique 342+infixRWithSpecDIdKey              = mkPreludeMiscIdUnique 343+infixNWithSpecDIdKey              = mkPreludeMiscIdUnique 344+roleAnnotDIdKey                   = mkPreludeMiscIdUnique 345+standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346+defaultSigDIdKey                  = mkPreludeMiscIdUnique 347+patSynDIdKey                      = mkPreludeMiscIdUnique 348+patSynSigDIdKey                   = mkPreludeMiscIdUnique 349+pragCompleteDIdKey                = mkPreludeMiscIdUnique 350+implicitParamBindDIdKey           = mkPreludeMiscIdUnique 351+kiSigDIdKey                       = mkPreludeMiscIdUnique 352+defaultDIdKey                     = mkPreludeMiscIdUnique 353+pragOpaqueDIdKey                  = mkPreludeMiscIdUnique 354+typeDataDIdKey                    = mkPreludeMiscIdUnique 355+pragSCCFunDKey                    = mkPreludeMiscIdUnique 356+pragSCCFunNamedDKey               = mkPreludeMiscIdUnique 357+pragSpecEDIdKey                   = mkPreludeMiscIdUnique 358+pragSpecInlEDIdKey                = mkPreludeMiscIdUnique 359++-- type Cxt = ...+cxtIdKey :: Unique+cxtIdKey               = mkPreludeMiscIdUnique 361++-- data SourceUnpackedness = ...+noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique+noSourceUnpackednessKey = mkPreludeMiscIdUnique 362+sourceNoUnpackKey       = mkPreludeMiscIdUnique 363+sourceUnpackKey         = mkPreludeMiscIdUnique 364++-- data SourceStrictness = ...+noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique+noSourceStrictnessKey   = mkPreludeMiscIdUnique 365+sourceLazyKey           = mkPreludeMiscIdUnique 366+sourceStrictKey         = mkPreludeMiscIdUnique 367++-- data Con = ...+normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey,+  recGadtCIdKey :: Unique+normalCIdKey      = mkPreludeMiscIdUnique 368+recCIdKey         = mkPreludeMiscIdUnique 369+infixCIdKey       = mkPreludeMiscIdUnique 370+forallCIdKey      = mkPreludeMiscIdUnique 371+gadtCIdKey        = mkPreludeMiscIdUnique 372+recGadtCIdKey     = mkPreludeMiscIdUnique 373++-- data Bang = ...+bangIdKey :: Unique+bangIdKey         = mkPreludeMiscIdUnique 374++-- type BangType = ...+bangTKey :: Unique+bangTKey          = mkPreludeMiscIdUnique 375++-- type VarBangType = ...+varBangTKey :: Unique+varBangTKey       = mkPreludeMiscIdUnique 376++-- data PatSynDir = ...+unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique+unidirPatSynIdKey    = mkPreludeMiscIdUnique 377+implBidirPatSynIdKey = mkPreludeMiscIdUnique 378+explBidirPatSynIdKey = mkPreludeMiscIdUnique 379++-- data PatSynArgs = ...+prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique+prefixPatSynIdKey = mkPreludeMiscIdUnique 380+infixPatSynIdKey  = mkPreludeMiscIdUnique 381+recordPatSynIdKey = mkPreludeMiscIdUnique 382++-- data Type = ...+forallTIdKey, forallVisTIdKey, varTIdKey, conTIdKey, tupleTIdKey,+    unboxedTupleTIdKey, unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey,+    appKindTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey,+    promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey,+    wildCardTIdKey, implicitParamTIdKey, infixTIdKey :: Unique+forallTIdKey        = mkPreludeMiscIdUnique 390+forallVisTIdKey     = mkPreludeMiscIdUnique 391+varTIdKey           = mkPreludeMiscIdUnique 392+conTIdKey           = mkPreludeMiscIdUnique 393+tupleTIdKey         = mkPreludeMiscIdUnique 394+unboxedTupleTIdKey  = mkPreludeMiscIdUnique 395+unboxedSumTIdKey    = mkPreludeMiscIdUnique 396+arrowTIdKey         = mkPreludeMiscIdUnique 397+listTIdKey          = mkPreludeMiscIdUnique 398+appTIdKey           = mkPreludeMiscIdUnique 399+appKindTIdKey       = mkPreludeMiscIdUnique 400+sigTIdKey           = mkPreludeMiscIdUnique 401+equalityTIdKey      = mkPreludeMiscIdUnique 402+litTIdKey           = mkPreludeMiscIdUnique 403+promotedTIdKey      = mkPreludeMiscIdUnique 404+promotedTupleTIdKey = mkPreludeMiscIdUnique 405+promotedNilTIdKey   = mkPreludeMiscIdUnique 406+promotedConsTIdKey  = mkPreludeMiscIdUnique 407+wildCardTIdKey      = mkPreludeMiscIdUnique 408+implicitParamTIdKey = mkPreludeMiscIdUnique 409+infixTIdKey         = mkPreludeMiscIdUnique 410++-- data TyLit = ...+numTyLitIdKey, strTyLitIdKey, charTyLitIdKey :: Unique+numTyLitIdKey  = mkPreludeMiscIdUnique 411+strTyLitIdKey  = mkPreludeMiscIdUnique 412+charTyLitIdKey = mkPreludeMiscIdUnique 413++-- data TyVarBndr = ...+plainTVIdKey, kindedTVIdKey :: Unique+plainTVIdKey       = mkPreludeMiscIdUnique 414+kindedTVIdKey      = mkPreludeMiscIdUnique 415++plainInvisTVIdKey, kindedInvisTVIdKey :: Unique+plainInvisTVIdKey       = mkPreludeMiscIdUnique 482+kindedInvisTVIdKey      = mkPreludeMiscIdUnique 483++plainBndrTVIdKey, kindedBndrTVIdKey :: Unique+plainBndrTVIdKey       = mkPreludeMiscIdUnique 484+kindedBndrTVIdKey      = mkPreludeMiscIdUnique 485++-- data Role = ...+nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique+nominalRIdKey          = mkPreludeMiscIdUnique 416+representationalRIdKey = mkPreludeMiscIdUnique 417+phantomRIdKey          = mkPreludeMiscIdUnique 418+inferRIdKey            = mkPreludeMiscIdUnique 419++-- data Kind = ...+starKIdKey, constraintKIdKey :: Unique+starKIdKey        = mkPreludeMiscIdUnique 425+constraintKIdKey  = mkPreludeMiscIdUnique 426++-- data FamilyResultSig = ...+noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique+noSigIdKey        = mkPreludeMiscIdUnique 427+kindSigIdKey      = mkPreludeMiscIdUnique 428+tyVarSigIdKey     = mkPreludeMiscIdUnique 429++-- data InjectivityAnn = ...+injectivityAnnIdKey :: Unique+injectivityAnnIdKey = mkPreludeMiscIdUnique 430++-- data Callconv = ...+cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey,+  javaScriptCallIdKey :: Unique+cCallIdKey          = mkPreludeMiscIdUnique 431+stdCallIdKey        = mkPreludeMiscIdUnique 432+cApiCallIdKey       = mkPreludeMiscIdUnique 433+primCallIdKey       = mkPreludeMiscIdUnique 434+javaScriptCallIdKey = mkPreludeMiscIdUnique 435++-- data Safety = ...+unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique+unsafeIdKey        = mkPreludeMiscIdUnique 440+safeIdKey          = mkPreludeMiscIdUnique 441+interruptibleIdKey = mkPreludeMiscIdUnique 442++-- data FunDep = ...+funDepIdKey :: Unique+funDepIdKey = mkPreludeMiscIdUnique 445++-- mulArrow+mulArrowTIdKey :: Unique+mulArrowTIdKey = mkPreludeMiscIdUnique 446++-- data TySynEqn = ...+tySynEqnIdKey :: Unique+tySynEqnIdKey = mkPreludeMiscIdUnique 460++-- quasiquoting+quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique+quoteExpKey  = mkPreludeMiscIdUnique 470+quotePatKey  = mkPreludeMiscIdUnique 471+quoteDecKey  = mkPreludeMiscIdUnique 472+quoteTypeKey = mkPreludeMiscIdUnique 473++-- data RuleBndr = ...+ruleVarIdKey, typedRuleVarIdKey :: Unique+ruleVarIdKey      = mkPreludeMiscIdUnique 480+typedRuleVarIdKey = mkPreludeMiscIdUnique 481++-- data AnnTarget = ...+valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique+valueAnnotationIdKey  = mkPreludeMiscIdUnique 490+typeAnnotationIdKey   = mkPreludeMiscIdUnique 491+moduleAnnotationIdKey = mkPreludeMiscIdUnique 492++-- type DerivPred = ...+derivClauseIdKey :: Unique+derivClauseIdKey = mkPreludeMiscIdUnique 493++-- data DerivStrategy = ...+stockStrategyIdKey, anyclassStrategyIdKey, newtypeStrategyIdKey,+  viaStrategyIdKey :: Unique+stockStrategyIdKey    = mkPreludeDataConUnique 494+anyclassStrategyIdKey = mkPreludeDataConUnique 495+newtypeStrategyIdKey  = mkPreludeDataConUnique 496+viaStrategyIdKey      = mkPreludeDataConUnique 497++-- data Specificity = ...+specifiedSpecKey, inferredSpecKey :: Unique+specifiedSpecKey = mkPreludeMiscIdUnique 498+inferredSpecKey  = mkPreludeMiscIdUnique 499++-- data BndrVis = ...+bndrReqKey, bndrInvisKey :: Unique+bndrReqKey   = mkPreludeMiscIdUnique 800  -- TODO (int-index): make up some room in the 5** numberspace?+bndrInvisKey = mkPreludeMiscIdUnique 801++{-+************************************************************************+*                                                                      *+                        RdrNames+*                                                                      *+************************************************************************+-}++lift_RDR, liftTyped_RDR, unsafeCodeCoerce_RDR :: RdrName+lift_RDR     = nameRdrName liftName+liftTyped_RDR = nameRdrName liftTypedName+unsafeCodeCoerce_RDR = nameRdrName unsafeCodeCoerceName
compiler/GHC/Builtin/PrimOps/Ids.hs view
@@ -16,6 +16,7 @@ import {-# SOURCE #-} GHC.Core.Opt.ConstantFold (primOpRules) import GHC.Core.TyCo.Rep ( scaledThing ) import GHC.Core.Type+import GHC.Core.Predicate( tyCoVarsOfTypeWellScoped ) import GHC.Core.FVs (mkRuleInfo)  import GHC.Builtin.PrimOps@@ -98,7 +99,7 @@       | tv `elem` [ runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar                   , levity1TyVar, levity2TyVar ]       = listToMaybe $-          mapMaybe (\ (i,arg) -> Argument i <$> positiveKindPos_maybe tv arg)+          mapMaybe (\ (i,arg) -> mkArgPos i <$> positiveKindPos_maybe tv arg)             (zip [1..] arg_tys)       | otherwise       = Nothing@@ -123,7 +124,7 @@       )   where     recur (pos, scaled_ty)-      = Argument pos <$> positiveKindPos_maybe tv (scaledThing scaled_ty)+      = mkArgPos pos <$> positiveKindPos_maybe tv (scaledThing scaled_ty)     -- (assumes we don't have any function types nested inside other types)  -- | Does this type variable appear in a kind in a positive position in the@@ -144,7 +145,7 @@       )   where     recur (pos, scaled_ty)-      = Argument pos <$> negativeKindPos_maybe tv (scaledThing scaled_ty)+      = mkArgPos pos <$> negativeKindPos_maybe tv (scaledThing scaled_ty)     -- (assumes we don't have any function types nested inside other types)     finish ty       | tv `elemVarSet` tyCoVarsOfType (typeKind ty)
compiler/GHC/Builtin/Types.hs view
@@ -20,8 +20,9 @@         mkWiredInIdName,    -- used in GHC.Types.Id.Make          -- * All wired in things-        wiredInTyCons, isBuiltInOcc_maybe, isTupleTyOcc_maybe, isSumTyOcc_maybe,-        isPunOcc_maybe,+        wiredInTyCons, isBuiltInOcc, isBuiltInOcc_maybe,+        isTupleTyOrigName_maybe, isSumTyOrigName_maybe,+        isInfiniteFamilyOrigName_maybe,          -- * Bool         boolTy, boolTyCon, boolTyCon_RDR, boolTyConName,@@ -82,12 +83,12 @@         pairTyCon, mkPromotedPairTy, isPromotedPairType,         unboxedUnitTy,         unboxedUnitTyCon, unboxedUnitDataCon,+        unboxedSoloTyCon, unboxedSoloTyConName, unboxedSoloDataConName,         unboxedTupleKind, unboxedSumKind,-        filterCTuple, mkConstraintTupleTy,+        mkConstraintTupleTy,          -- ** Constraint tuples         cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName,-        cTupleTyConNameArity_maybe,         cTupleDataCon, cTupleDataConName, cTupleDataConNames,         cTupleSelId, cTupleSelIdName, @@ -99,6 +100,7 @@          -- * Sums         mkSumTy, sumTyCon, sumDataCon,+        unboxedSumTyConName, unboxedSumDataConName,          -- * Kinds         typeSymbolKindCon, typeSymbolKind,@@ -206,6 +208,7 @@ import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE ) import GHC.Unit.Module        ( Module ) +import Data.Maybe import Data.Array import GHC.Data.FastString import GHC.Data.BooleanFormula ( mkAnd )@@ -214,13 +217,14 @@ import GHC.Utils.Misc import GHC.Utils.Panic -import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Short as SBS+import qualified Data.ByteString.Short.Internal as SBS (unsafeIndex)  import Data.Foldable-import Data.List        ( elemIndex, intersperse )+import Data.List        ( intersperse ) import Numeric          ( showInt ) -import Data.Char (ord, isDigit)+import Data.Word (Word8) import Control.Applicative ((<|>))  alpha_tyvar :: [TyVar]@@ -278,38 +282,22 @@ -}  --- This list is used only to define GHC.Builtin.Utils.wiredInThings. That in turn+-- This list is used only to define GHC.Builtin.Utils.knownKeyNames. That in turn -- is used to initialise the name environment carried around by the renamer. -- This means that if we look up the name of a TyCon (or its implicit binders) -- that occurs in this list that name will be assigned the wired-in key we -- define here. -- -- Because of their infinite nature, this list excludes---   * tuples, including boxed, unboxed and constraint tuples----       (mkTupleTyCon, unitTyCon, pairTyCon)---   * unboxed sums (sumTyCon)+--   * Tuples of all sorts (boxed, unboxed, constraint) (mkTupleTyCon)+--   * Unboxed sums (sumTyCon) -- See Note [Infinite families of known-key names] in GHC.Builtin.Names -- -- See also Note [Known-key names] wiredInTyCons :: [TyCon]  wiredInTyCons = map (dataConTyCon . snd) boxingDataCons-             ++ [ -- Units are not treated like other tuples, because they-                  -- are defined in GHC.Base, and there's only a few of them. We-                  -- put them in wiredInTyCons so that they will pre-populate-                  -- the name cache, so the parser in isBuiltInOcc_maybe doesn't-                  -- need to look out for them.-                  unitTyCon-                , unboxedUnitTyCon--                -- 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-                -- have known keys) in GHC.Builtin.Types.-                , soloTyCon--                , anyTyCon+             ++ [ anyTyCon                 , zonkAnyTyCon                 , boolTyCon                 , charTyCon@@ -332,6 +320,7 @@                 , constraintKindTyCon                 , liftedTypeKindTyCon                 , unliftedTypeKindTyCon+                , unrestrictedFunTyCon                 , multiplicityTyCon                 , naturalTyCon                 , integerTyCon@@ -521,6 +510,17 @@      See examples in ghc-prim:GHC.Types +(Any8) Warning about unused bindings of type `Any` and `ZonkAny` are suppressed,+    following the same rationale of supressing warning about the unit type.++    For example, consider (#25895):++     do { forever (return ()); blah }++    where forever :: forall a b. IO a -> IO b+    Nothing constrains `b`, so it will be instantiates with `Any` or `ZonkAny`.+    But we certainly don't want to complain about a discarded do-binding.+ The Any tycon used to be quite magic, but we have since been able to implement it merely with an empty kind polymorphic type family. See #10886 for a bit of history.@@ -709,10 +709,12 @@     -- See Note [Constructor tag allocation] and #14657     data_con = mkDataCon dc_name declared_infix prom_info                 (map (const no_bang) arg_tys)+                (map (const HsLazy) arg_tys)+                (map (const NotMarkedStrict) arg_tys)                 []      -- No labelled fields                 tyvars ex_tyvars                 conc_tyvars-                (mkTyVarBinders SpecifiedSpec user_tyvars)+                (mkTyVarBinders Specified user_tyvars)                 []      -- No equality spec                 theta                 arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))@@ -723,7 +725,7 @@                 (mkDataConWorkId wrk_name data_con)                 NoDataConRep    -- Wired-in types are too simple to need wrappers -    no_bang = mkHsSrcBang NoSourceText NoSrcUnpack NoSrcStrict+    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict      wrk_name = mkDataConWorkerName data_con wrk_key @@ -806,10 +808,8 @@   E.g. tupleTyCon has a Boxity argument  * When looking up an OccName in the original-name cache-  (GHC.Iface.Env.lookupOrigNameCache), we spot the tuple OccName to make sure-  we get the right wired-in name.  This guy can't tell the difference-  between BoxedTuple and ConstraintTuple (same OccName!), so tuples-  are not serialised into interface files using OccNames at all.+  (GHC.Types.Name.Cache.lookupOrigNameCache), we spot the tuple OccName to make+  sure we get the right wired-in name.  * Serialization to interface files works via the usual mechanism for known-key   things: instead of serializing the OccName we just serialize the key. During@@ -849,181 +849,467 @@ There is nothing special about one-tuples in Core; in particular, they have no custom pretty-printing, just using `Solo`. -Note that there is *not* a unary constraint tuple, unlike for other forms of-tuples. See [Ignore unary constraint tuples] in GHC.Tc.Gen.HsType for more-details.- See also Note [Flattening one-tuples] in GHC.Core.Make and Note [Don't flatten tuples from HsSyn] in GHC.Core.Make. --------- Wrinkle: Make boxed one-tuple names have known keys------+Note [isBuiltInOcc_maybe]+~~~~~~~~~~~~~~~~~~~~~~~~~+`isBuiltInOcc_maybe` matches and resolves names that are occurrences of built-in+syntax, i.e. unqualified names that can be unambiguously resolved even without+knowing what's currently in scope (such names also can't be imported, exported,+or redefined in another module).+More on that in Note [Built-in syntax and the OrigNameCache] in GHC.Types.Name.Cache. -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:+In GHC, there are two use cases for `isBuiltInOcc_maybe`: -  case $( tupE [ [| "ok" |] ] ) of MkSolo x -> putStrLn x+1. Making TH's `mkName` work with built-in syntax,+   e.g. $(conT (mkName "[]")) is the same as [] -Unless Solo has a known key, the type of `$( tupE [ [| "ok" |] ] )` (an-ExplicitTuple of length 1) will not match the type of Solo (an ordinary-data constructor used in a pattern). Making Solo known-key allows GHC to make-this connection.+2. Detecting bulit-in syntax in `infix` declarations,+   e.g. users can't write `infixl 6 :` (#15233) -Unlike Solo, every other tuple is /not/ known-key-(see Note [Infinite families of known-key names] in GHC.Builtin.Names). The-main reason for this exception is that other tuples are written with special-syntax, and as a result, they are renamed using a special `isBuiltInOcc_maybe`-function (see Note [Built-in syntax and the OrigNameCache] in GHC.Types.Name.Cache).-In contrast, Solo is just an ordinary data type with no special syntax, so it-doesn't really make sense to handle it in `isBuiltInOcc_maybe`. Making Solo-known-key is the next-best way to teach the internals of the compiler about it.+The parser takes a shortcut and produces Exact RdrNames directly,+so it doesn't need to match on an OccName with isBuiltInOcc_maybe.++And here are the properties of `isBuiltInOcc_maybe`:++* The set of names recognized by `isBuiltInOcc_maybe` is essentialy the+  same as the set of names that the parser resolves to Exact RdrNames,+  e.g. "[]", "(,)", or "->".++  We could leave it at that, but we also recognize unboxed sum syntax+  "(#|#)" even though the parser can't handle it. This makes TH's `mkName`+  more permissive than the parser.++* The namespace of the input OccName is treated as a hint, not a+  requirement. For example,++    mkOccName dataName  ":"          maps to  consDataConName+    mkOccName tcClsName ":"   /also/ maps to  consDataConName++  The rationale behind this is that with DataKind or RequiredTypeArguments+  we may get an OccName with the wrong namespace and need to fallback to the+  other one.++* There is a `listTuplePuns :: Bool` parameter to account for the+  ListTuplePuns extension. It has /no/ effect on whether the predicate+  matches (i.e. if the result is Just or Nothing), but it can influence+  which name is returned (TyCon name or DataCon name). For example,++    isBuiltInOcc_maybe False (mkOccName dataName  "[]")  ==  Just nilDataConName+    isBuiltInOcc_maybe False (mkOccName tcClsName "[]")  ==  Just nilDataConName+    isBuiltInOcc_maybe True  (mkOccName dataName  "[]")  ==  Just nilDataConName+    isBuiltInOcc_maybe True  (mkOccName tcClsName "[]")  ==  Just listTyConName++* There is no `Module` parameter because we are matching unqualified+  occurrences of built-in names. It is illegal to qualify built-in syntax,+  e.g. GHC.Types.(,) is a parse error.++* The /input/ to `isBuiltInOcc_maybe` needs to be built-in syntax for the+  predicate to match, but the /output/ is not necessarily built-in syntax.+  For example,++    1) input:   mkTcOcc "[]"          -- built-in syntax+       output:  Just listTyConName    -- user syntax (GHC.Types.List)++    2) input:   mkDataOcc "[]"        -- built-in syntax+       output:  Just nilDataConName   -- built-in syntax []++    3) input:   mkTcOcc "List"        -- user syntax+       output:  Nothing               -- no match++    4) input:   mkTcOcc "(,)"                       -- built-in syntax+       output:  Just (tupleTyConName BoxedTuple 2)  -- user syntax (GHC.Types.Tuple2)++    5) input:   mkTcOcc "(#|#)"               -- built-in syntax+       output:  Just (unboxedSumTyConName 2)  -- user syntax (GHC.Types.Sum2#)++  Therefore, `GHC.Types.Name.isBuiltInSyntax` may or may not hold for the name+  returned by `isBuiltInOcc_maybe`. -} --- | Built-in syntax isn't "in scope" so these OccNames map to wired-in Names--- with BuiltInSyntax. However, this should only be necessary while resolving--- names produced by Template Haskell splices since we take care to encode--- built-in syntax names specially in interface files. See--- Note [Symbol table representation of names] in GHC.Iface.Binary.+-- | Match on built-in syntax as it occurs at use sites.+-- See Note [isBuiltInOcc_maybe]+isBuiltInOcc_maybe :: Bool -> OccName -> Maybe Name+isBuiltInOcc_maybe listTuplePuns occ+  | fs == "->" = Just unrestrictedFunTyConName+  | fs == "[]" = Just (pun listTyConName nilDataConName)+  | fs == ":"  = Just consDataConName+  | Just n <- (is_boxed_tup_syntax fs) = Just (tup_name Boxed n)+  | Just n <- (is_unboxed_tup_syntax fs) = Just (tup_name Unboxed n)+  | Just n <- (is_unboxed_sum_type_syntax fs) = Just (unboxedSumTyConName n)+  | Just (k, n) <- (is_unboxed_sum_data_syntax fs) = Just (unboxedSumDataConName k n)+  | otherwise = Nothing+  where+    fs = occNameFS occ+    ns = occNameSpace occ++    pun :: Name -> Name -> Name+    pun p n+      | listTuplePuns, isTcClsNameSpace ns = p+      | otherwise = n++    tup_name :: Boxity -> Arity -> Name+    tup_name boxity arity+      = pun (tyConName   (tupleTyCon   boxity arity))+            (dataConName (tupleDataCon boxity arity))++-- | Check if the OccName is an occurrence of built-in syntax. ----- Moreover, there is no need to include names of things that the user can't--- write (e.g. type representation bindings like $tc(,,,)).-isBuiltInOcc_maybe :: OccName -> Maybe Name-isBuiltInOcc_maybe occ =-    case name of-      "[]" -> Just $ choose_ns listTyConName nilDataConName-      ":"    -> Just consDataConName+-- This is a variant of `isBuiltInOcc_maybe` that returns a `Bool`.+-- See Note [isBuiltInOcc_maybe]+--+-- `isBuiltInOcc` holds for:+--   * function arrow `->`+--   * list syntax `[]`, `:`+--   * boxed tuple syntax `()`, `(,)`, `(,,)`, `(,,,)`, ...+--   * unboxed tuple syntax `(##)`, `(#,#)`, `(#,,#)`, ...+--   * unboxed sum type syntax `(#|#)`, `(#||#)`, `(#|||#)`, ...+--   * unboxed sum data syntax `(#_|#)`, `(#|_#)`, `(#_||#), ...+isBuiltInOcc :: OccName -> Bool+isBuiltInOcc = isJust . isBuiltInOcc_maybe listTuplePuns+  where+    listTuplePuns = False+      -- True/False here is inconsequential because ListTuplePuns doesn't affect+      -- whether isBuiltInOcc_maybe matches. See Note [isBuiltInOcc_maybe] -      -- function tycon-      "->"  -> Just unrestrictedFunTyConName+-- Match on original names of infinite families (tuples and sums).+-- See Note [Infinite families of known-key names] in GHC.Builtin.Names+isInfiniteFamilyOrigName_maybe :: Module -> OccName -> Maybe Name+isInfiniteFamilyOrigName_maybe mod occ = -      -- tuple data/tycon-      -- We deliberately exclude Solo (the boxed 1-tuple).-      -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys)-      "()"    -> Just $ tup_name Boxed 0-      _ | Just rest <- "(" `BS.stripPrefix` name-        , (commas, rest') <- BS.span (==',') rest-        , ")" <- rest'-             -> Just $ tup_name Boxed (1+BS.length commas)+  -- Tuples, boxed and unboxed+  isTupleTyOrigName_maybe mod occ+  <|> isTupleDataOrigName_maybe mod occ -      -- unboxed tuple data/tycon-      "(##)"  -> Just $ tup_name Unboxed 0-      "(# #)" -> Just $ tup_name Unboxed 1-      _ | Just rest <- "(#" `BS.stripPrefix` name-        , (commas, rest') <- BS.span (==',') rest-        , "#)" <- rest'-             -> Just $ tup_name Unboxed (1+BS.length commas)+  -- Constraint tuples+  <|> isCTupleOrigName_maybe mod occ -      -- unboxed sum tycon-      _ | Just rest <- "(#" `BS.stripPrefix` name-        , (nb_pipes, rest') <- span_pipes rest-        , "#)" <- rest'-             -> Just $ tyConName $ sumTyCon (1+nb_pipes)+  -- Unboxed sums+  <|> isSumTyOrigName_maybe mod occ+  <|> isSumDataOrigName_maybe mod occ -      -- unboxed sum datacon-      _ | Just rest <- "(#" `BS.stripPrefix` name-        , (nb_pipes1, rest') <- span_pipes rest-        , Just rest'' <- "_" `BS.stripPrefix` rest'-        , (nb_pipes2, rest''') <- span_pipes rest''-        , "#)" <- rest'''-             -> let arity = nb_pipes1 + nb_pipes2 + 1-                    alt = nb_pipes1 + 1-                in Just $ dataConName $ sumDataCon alt arity+-- Check if the string has form "()", "(,)", "(,,)", etc,+-- and return the corresponding tuple arity.+is_boxed_tup_syntax :: FastString -> Maybe Arity+is_boxed_tup_syntax fs+  | fs == "()" = Just 0+  | n >= 2+  , SBS.unsafeIndex sbs 0     == 40  -- ord '('+  , SBS.unsafeIndex sbs (n-1) == 41  -- ord ')'+  , sbs_all sbs 1 (n-1)          44  -- ord ','+  = Just (n-1)+  where+    n   = SBS.length sbs                   -- O(1)+    sbs = fastStringToShortByteString fs   -- O(1) field access+is_boxed_tup_syntax _ = Nothing -      _ -> Nothing+-- Check if the string has form "(##)", "(# #)", (#,#)", "(#,,#)", etc,+-- and return the corresponding tuple arity.+is_unboxed_tup_syntax :: FastString -> Maybe Arity+is_unboxed_tup_syntax fs+  | fs == "(##)"  = Just 0+  | fs == "(# #)" = Just 1+  | sbs_unboxed sbs+  , sbs_all sbs 2 (n-2) 44  -- ord ','+  = Just (n-3)   where-    name = bytesFS $ occNameFS occ+    n   = SBS.length sbs                   -- O(1)+    sbs = fastStringToShortByteString fs   -- O(1) field access+is_unboxed_tup_syntax _ = Nothing -    span_pipes :: BS.ByteString -> (Int, BS.ByteString)-    span_pipes = go 0-      where-        go nb_pipes bs = case BS.uncons bs of-          Just ('|',rest) -> go (nb_pipes + 1) rest-          Just (' ',rest) -> go nb_pipes       rest-          _               -> (nb_pipes, bs)+-- Check if the string has form "(#|#)", "(#||#)", (#|||#)", etc,+-- and return the corresponding sum arity.+is_unboxed_sum_type_syntax :: FastString -> Maybe Arity+is_unboxed_sum_type_syntax fs+  | sbs_unboxed sbs+  , Just k <- sbs_pipes sbs 2 (n-2)+  , k > 0+  = Just (k+1)+  where+    n   = SBS.length sbs                   -- O(1)+    sbs = fastStringToShortByteString fs   -- O(1) field access+is_unboxed_sum_type_syntax _ = Nothing -    choose_ns :: Name -> Name -> Name-    choose_ns tc dc-      | isTcClsNameSpace ns   = tc-      | isDataConNameSpace ns = dc-      | otherwise             = pprPanic "tup_name" (ppr occ <+> parens (pprNameSpace ns))-      where ns = occNameSpace occ+-- Check if the string has form "(#_|#)", "(#_||#)", (#|_|#)", etc,+-- and return the corresponding sum tag and sum arity.+is_unboxed_sum_data_syntax :: FastString -> Maybe (ConTag, Arity)+is_unboxed_sum_data_syntax fs+  | sbs_unboxed sbs+  , Just u <- SBS.elemIndex 95 sbs        -- ord '_'+  , Just k1 <- sbs_pipes sbs 2 u          -- pipes to the left  of '_'+  , Just k2 <- sbs_pipes sbs (u+1) (n-2)  -- pipes to the right of '_'+  = Just (k1+1, k1+k2+1)+  where+    n   = SBS.length sbs                   -- O(1)+    sbs = fastStringToShortByteString fs   -- O(1) field access+is_unboxed_sum_data_syntax _ = Nothing -    tup_name boxity arity-      = choose_ns (getName (tupleTyCon   boxity arity))-                  (getName (tupleDataCon boxity arity))+-- (sbs_all sbs i n x) checks if all bytes in the slice [i..n) are equal to x.+sbs_all :: SBS.ShortByteString -> Int -> Int -> Word8 -> Bool+sbs_all !sbs !i !n !x+  | i < n     = SBS.unsafeIndex sbs i == x && sbs_all sbs (i+1) n x+  | otherwise = True -isTupleTyOcc_maybe :: Module -> OccName -> Maybe Name-isTupleTyOcc_maybe mod occ-  | mod == gHC_INTERNAL_TUPLE || mod == gHC_TYPES-  = match_occ+-- (sbs_pipes sbs i n) checks if all bytes in the slice [i..n) are equal to '|'+-- or ' ', and returns the number of encountered '|'.+sbs_pipes :: SBS.ShortByteString -> Int -> Int -> Maybe Int+sbs_pipes !sbs = go 0   where-    match_occ+    go :: Int -> Int -> Int -> Maybe Int+    go !k !i !n+      | i < n =+        if | SBS.unsafeIndex sbs i == 124 -> go (k+1) (i+1) n -- ord '|'+           | SBS.unsafeIndex sbs i == 32  -> go k     (i+1) n -- ord ' '+           | otherwise                    -> Nothing+      | otherwise = Just k++-- (sbs_unboxed sbs) checks if the string starts with "(#" and ends with "#)".+sbs_unboxed :: SBS.ShortByteString -> Bool+sbs_unboxed !sbs =+  n >= 4 && SBS.unsafeIndex sbs 0     == 40  -- ord '('+         && SBS.unsafeIndex sbs 1     == 35  -- ord '#'+         && SBS.unsafeIndex sbs (n-2) == 35  -- ord '#'+         && SBS.unsafeIndex sbs (n-1) == 41  -- ord ')'+  where+    n = SBS.length sbs -- O(1)++-- (sbs_Sum sbs) checks if the string has form "SumN#" or "SumNM#",+-- where "N" or "NM" is a decimal numeral in the [2..mAX_SUM_SIZE] range.+sbs_Sum :: SBS.ShortByteString -> Maybe Arity+sbs_Sum !sbs+  | n >= 3 && SBS.unsafeIndex sbs 0 == 83   -- ord 'S'+           && SBS.unsafeIndex sbs 1 == 117  -- ord 'u'+           && SBS.unsafeIndex sbs 2 == 109  -- ord 'm'+  , Just (Unboxed, arity) <- sbs_arity_boxity sbs 3+  , arity >= 2, arity <= mAX_SUM_SIZE+  = Just arity+  | otherwise = Nothing+  where+    n = SBS.length sbs -- O(1)++-- (sbs_Tuple sbs) checks if the string has form "TupleN", "TupleNM", "TupleN#" or "TupleNM#",+-- where "N" or "NM" is a decimal numeral in the [2..mAX_TUPLE_SIZE] range.+sbs_Tuple :: SBS.ShortByteString -> Maybe (Boxity, Arity)+sbs_Tuple !sbs+  | n >= 5 && SBS.unsafeIndex sbs 0 == 84   -- ord 'T'+           && SBS.unsafeIndex sbs 1 == 117  -- ord 'u'+           && SBS.unsafeIndex sbs 2 == 112  -- ord 'p'+           && SBS.unsafeIndex sbs 3 == 108  -- ord 'l'+           && SBS.unsafeIndex sbs 4 == 101  -- ord 'e'+  , Just r@(_, arity) <- sbs_arity_boxity sbs 5+  , arity >= 2, arity <= mAX_TUPLE_SIZE+  = Just r+  | otherwise = Nothing+  where+    n = SBS.length sbs -- O(1)++-- (sbs_CTuple sbs) checks if the string has form "CTupleN" or "CTupleNM",+-- where "N" or "NM" is a decimal numeral in the [2..mAX_CTUPLE_SIZE] range.+sbs_CTuple :: SBS.ShortByteString -> Maybe Arity+sbs_CTuple !sbs+  | n >= 6 && SBS.unsafeIndex sbs 0 == 67   -- ord 'C'+           && SBS.unsafeIndex sbs 1 == 84   -- ord 'T'+           && SBS.unsafeIndex sbs 2 == 117  -- ord 'u'+           && SBS.unsafeIndex sbs 3 == 112  -- ord 'p'+           && SBS.unsafeIndex sbs 4 == 108  -- ord 'l'+           && SBS.unsafeIndex sbs 5 == 101  -- ord 'e'+  , Just (Boxed, arity) <- sbs_arity_boxity sbs 6+  , arity >= 2, arity <= mAX_CTUPLE_SIZE+  = Just arity+  | otherwise = Nothing+  where+    n = SBS.length sbs -- O(1)++-- (sbs_arity_boxity sbs i) parses bytes from position `i` to the end,+-- matching single- and double-digit decimals numerals (i.e. from 0 to 99)+-- possibly followed by '#'. See Note [Small Ints parsing]+sbs_arity_boxity :: SBS.ShortByteString -> Int -> Maybe (Boxity, Arity)+sbs_arity_boxity !sbs !i =+  case n - i of  -- bytes to parse+    1 -> parse1 (SBS.unsafeIndex sbs i)+    2 -> parse2 (SBS.unsafeIndex sbs i) (SBS.unsafeIndex sbs (i+1))+    3 -> parse3 (SBS.unsafeIndex sbs i) (SBS.unsafeIndex sbs (i+1)) (SBS.unsafeIndex sbs (i+2))+    _ -> Nothing+  where+    n = SBS.length sbs -- O(1)++    is_digit :: Word8 -> Bool+    is_digit x = x >= 48 && x <= 57  -- between (ord '0') and (ord '9')++    from_digit :: Word8 -> Int+    from_digit x = fromIntegral (x - 48)++    -- single-digit number+    parse1 :: Word8 -> Maybe (Boxity, Arity)+    parse1 x1 | is_digit x1 = Just (Boxed, from_digit x1)+    parse1 _ = Nothing++    -- double-digit number, or a single-digit number followed by '#'+    parse2 :: Word8 -> Word8 -> Maybe (Boxity, Arity)+    parse2 x1 35  -- ord '#'+      | is_digit x1 = Just (Unboxed, from_digit x1)+    parse2 x1 x2+      | is_digit x1, is_digit x2+      = Just (Boxed, from_digit x1 * 10 + from_digit x2)+    parse2 _ _ = Nothing++    -- double-digit number followed by '#'+    parse3 :: Word8 -> Word8 -> Word8 -> Maybe (Boxity, Arity)+    parse3 x1 x2 35 -- ord '#'+      | is_digit x1, is_digit x2+      = Just (Unboxed, from_digit x1 * 10 + from_digit x2)+    parse3 _ _ _ = Nothing++-- Identify original names of boxed and unboxed tuple type constructors.+-- Examples:+--   0b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Unit")    =  Just <wired-in Name for 0-tuples>+--   1b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Solo")    =  Just <wired-in Name for 1-tuples>+--   2b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Tuple2")  =  Just <wired-in Name for 2-tuples>+--   0u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Unit#")   =  Just <wired-in Name for unboxed 0-tuples>+--   1u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Solo#")   =  Just <wired-in Name for unboxed 1-tuples>+--   2u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Tuple2#") =  Just <wired-in Name for unboxed 2-tuples>+--   ...+--   64b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Tuple64")  =  Just <wired-in Name for 64-tuples>+--   64u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Tuple64#") =  Just <wired-in Name for unboxed 64-tuples>+--+-- Non-examples: "()", "(##)", "(,)", "(#,#)", "(,,)", "(#,,#)", etc.+-- As far as tuple /types/ are concerned, these are not the original names+-- but rather punned names under ListTuplePuns.+--+-- Also non-examples: "Tuple0", "Tuple0#", "Tuple1", and "Tuple1#".+-- These are merely type synonyms for "Unit", "Unit#", "Solo", and "Solo#".+isTupleTyOrigName_maybe :: Module -> OccName -> Maybe Name+isTupleTyOrigName_maybe mod occ+  | mod == gHC_INTERNAL_TUPLE = match_occ_boxed+  | mod == gHC_TYPES          = match_occ_unboxed+  where+    fs  = occNameFS occ+    ns  = occNameSpace occ+    sbs = fastStringToShortByteString fs   -- O(1) field access++    match_occ_boxed       | occ == occName unitTyConName = Just unitTyConName       | occ == occName soloTyConName = Just soloTyConName+      | isTcClsNameSpace ns, Just (boxity@Boxed, n) <- sbs_Tuple sbs, n >= 2+      = Just (tyConName (tupleTyCon boxity n))+      | otherwise = Nothing++    match_occ_unboxed       | occ == occName unboxedUnitTyConName = Just unboxedUnitTyConName       | occ == occName unboxedSoloTyConName = Just unboxedSoloTyConName-      | otherwise = isTupleNTyOcc_maybe occ-isTupleTyOcc_maybe _ _ = Nothing+      | isTcClsNameSpace ns, Just (boxity@Unboxed, n) <- sbs_Tuple sbs, n >= 2+      = Just (tyConName (tupleTyCon boxity n))+      | otherwise = Nothing -isCTupleOcc_maybe :: Module -> OccName -> Maybe Name-isCTupleOcc_maybe mod occ+isTupleTyOrigName_maybe _ _ = Nothing++-- Identify original names of boxed and unboxed tuple data constructors.+-- Examples:+--   0b) isTupleDataOrigName_maybe GHC.Tuple (mkDataOcc "()")      =  Just <wired-in Name for 0-tuples>+--   1b) isTupleDataOrigName_maybe GHC.Tuple (mkDataOcc "MkSolo")  =  Just <wired-in Name for 1-tuples>+--   2b) isTupleDataOrigName_maybe GHC.Tuple (mkDataOcc "(,)")     =  Just <wired-in Name for 2-tuples>+--   ...+--   0u) isTupleDataOrigName_maybe GHC.Types (mkDataOcc "(##)")    =  Just <wired-in Name for unboxed 0-tuples>+--   1u) isTupleDataOrigName_maybe GHC.Types (mkDataOcc "MkSolo#") =  Just <wired-in Name for unboxed 1-tuples>+--   2u) isTupleDataOrigName_maybe GHC.Types (mkDataOcc "(#,#)")   =  Just <wired-in Name for unboxed 2-tuples>+--   ...+--+-- Non-examples: Tuple<n> or Tuple<n>#, as this is the name format of tuple /type/ constructors.+isTupleDataOrigName_maybe :: Module -> OccName -> Maybe Name+isTupleDataOrigName_maybe mod occ+  | mod == gHC_INTERNAL_TUPLE = match_occ_boxed+  | mod == gHC_TYPES          = match_occ_unboxed+  where+    match_occ_boxed+      | occ == occName soloDataConName = Just soloDataConName+      | isDataConNameSpace ns, Just n <- (is_boxed_tup_syntax fs)+      = Just (tupleDataConName Boxed n)+      | otherwise = Nothing+    match_occ_unboxed+      | occ == occName unboxedSoloDataConName = Just unboxedSoloDataConName+      | isDataConNameSpace ns, Just n <- (is_unboxed_tup_syntax fs)+      = Just (tupleDataConName Unboxed n)+      | otherwise = Nothing+    fs = occNameFS occ+    ns = occNameSpace occ+isTupleDataOrigName_maybe _ _ = Nothing++-- Identify original names of constraint tuples.+-- Examples:+--   0) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CUnit")    =  Just <wired-in Name for 0-ctuples>+--   1) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CSolo")    =  Just <wired-in Name for 1-ctuples>+--   2) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CTuple2")  =  Just <wired-in Name for 2-ctuples>+--   ...+--   64) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CTuple64")  =  Just <wired-in Name for 64-ctuples>+--+-- Non-examples: "()", "(,)", "(,,)", etc.+-- As far as constraint tuples are concerned, these are not the original names+-- but rather punned names under ListTuplePuns.+--+-- Also non-examples: "CTuple0" and "CTuple1".+-- These are merely type synonyms for "CUnit" and "CSolo".+isCTupleOrigName_maybe :: Module -> OccName -> Maybe Name+isCTupleOrigName_maybe mod occ   | mod == gHC_CLASSES   = match_occ   where+    fs  = occNameFS occ+    sbs = fastStringToShortByteString fs   -- O(1) field access     match_occ-      | occ == occName (cTupleTyConName 0) = Just (cTupleTyConName 0)-      | occ == occName (cTupleTyConName 1) = Just (cTupleTyConName 1)-      | 'C':'T':'u':'p':'l':'e' : rest <- occNameString occ-      , Just (BoxedTuple, num) <- arity_and_boxity rest-      , num >= 2 && num <= 64-           = Just $ cTupleTyConName num-      | otherwise = Nothing--isCTupleOcc_maybe _ _ = Nothing+      | occ == occName (cTupleTyConName 0) = Just (cTupleTyConName 0)  -- CUnit+      | occ == occName (cTupleTyConName 1) = Just (cTupleTyConName 1)  -- CSolo --- | This is only for Tuple<n>, not for Unit or Solo-isTupleNTyOcc_maybe :: OccName -> Maybe Name-isTupleNTyOcc_maybe occ =-  case occNameString occ of-    'T':'u':'p':'l':'e':str | Just (sort, n) <- arity_and_boxity str, n > 1-      -> Just (tupleTyConName sort n)-    _ -> Nothing+      | Just num <- sbs_CTuple sbs, num >= 2+      = Just $ cTupleTyConName num -isSumTyOcc_maybe :: Module -> OccName -> Maybe Name-isSumTyOcc_maybe mod occ | mod == gHC_TYPES =-  isSumNTyOcc_maybe occ-isSumTyOcc_maybe _ _ = Nothing+      | otherwise = Nothing -isSumNTyOcc_maybe :: OccName -> Maybe Name-isSumNTyOcc_maybe occ =-  case occNameString occ of-    'S':'u':'m':str | Just (UnboxedTuple, n) <- arity_and_boxity str, n > 1-      -> Just (tyConName (sumTyCon n))-    _ -> Nothing+isCTupleOrigName_maybe _ _ = Nothing --- | See Note [Small Ints parsing]+-- Identify original names of unboxed sum type constructors.+-- Examples:+--   2) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum2#") =  Just <wired-in Name for unboxed 2-sums>+--   3) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum3#") =  Just <wired-in Name for unboxed 3-sums>+--   4) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum4#") =  Just <wired-in Name for unboxed 4-sums>+--   ...+--   64) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum64#") =  Just <wired-in Name for unboxed 64-sums> ----- Analyze a string as the suffix of an OccName of a tuple or sum tycon to--- determine its arity and boxity (based on the presence of a @#@).-arity_and_boxity :: String -> Maybe (TupleSort, Int)-arity_and_boxity s = case s of-  c1 : t1 | isDigit c1 -> case t1 of-    [] -> Just (BoxedTuple, digit_to_int c1)-    ['#'] -> Just (UnboxedTuple, digit_to_int c1)-    c2 : t2 | isDigit c2 ->-      let ar = digit_to_int c1 * 10 + digit_to_int c2-      in case t2 of-        [] -> Just (BoxedTuple, ar)-        ['#'] -> Just (UnboxedTuple, ar)-        _ -> Nothing-    _ -> Nothing-  _ -> Nothing+-- Non-examples: "(#|#)", "(#||#)", "(#|||#)", etc. These are not valid syntax.+-- Also non-examples: "Sum0#", "Sum1#". These do not exist.+isSumTyOrigName_maybe :: Module -> OccName -> Maybe Name+isSumTyOrigName_maybe mod occ+  | mod == gHC_TYPES+  , isTcClsNameSpace ns+  , Just n <- sbs_Sum sbs+  , n >= 2+  = Just (tyConName (sumTyCon n))   where-    digit_to_int :: Char -> Int-    digit_to_int c = ord c - ord '0'+    fs  = occNameFS occ+    ns  = occNameSpace occ+    sbs = fastStringToShortByteString fs   -- O(1) field access+isSumTyOrigName_maybe _ _ = Nothing +-- Identify original names of unboxed sum data constructors.+-- "(#_|#)", "(#_||#)", (#|_|#)"+--+-- Examples:+--   1/2) isSumTyOrigName_maybe GHC.Types (mkDataOcc "(#_|#)")  =  Just <wired-in Name for 1st alt of unboxed 2-sums>+--   1/3) isSumTyOrigName_maybe GHC.Types (mkDataOcc "(#_||#)") =  Just <wired-in Name for 1st alt of unboxed 3-sums>+--   2/3) isSumTyOrigName_maybe GHC.Types (mkDataOcc "(#|_|#)") =  Just <wired-in Name for 2nd alt of unboxed 3-sums>+--   ...+--+-- Non-examples: Sum<n>#, as this is the name format of unboxed sum /type/ constructors.+isSumDataOrigName_maybe :: Module -> OccName -> Maybe Name+isSumDataOrigName_maybe mod occ+  | mod == gHC_TYPES+  , isDataConNameSpace ns+  , Just (k,n) <- (is_unboxed_sum_data_syntax fs)+  = Just (unboxedSumDataConName k n)+  where fs = occNameFS occ+        ns = occNameSpace occ+isSumDataOrigName_maybe _ _ = Nothing+ {- Note [Small Ints parsing] ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1034,26 +1320,6 @@ `readMaybe @Int` on my machine. -} --- When resolving names produced by Template Haskell (see thOrigRdrName--- in GHC.ThToHs), we want ghc-prim:GHC.Types.List to yield an Exact name, not--- an Orig name.------ This matters for pretty-printing under ListTuplePuns. If we don't do it,--- then -ddump-splices will print ''[] as ''GHC.Types.List.------ Test case: th/T13776----isPunOcc_maybe :: Module -> OccName -> Maybe Name-isPunOcc_maybe mod occ-  | mod == gHC_TYPES, occ == occName listTyConName-  = Just listTyConName-  | mod == gHC_TYPES, occ == occName unboxedSoloDataConName-  = Just unboxedSoloDataConName-  | otherwise-  = isTupleTyOcc_maybe mod occ <|>-    isCTupleOcc_maybe  mod occ <|>-    isSumTyOcc_maybe   mod occ- mkTupleOcc :: NameSpace -> Boxity -> Arity -> (OccName, BuiltInSyntax) mkTupleOcc ns b ar = (mkOccName ns str, built_in)   where (str, built_in) = mkTupleStr' ns b ar@@ -1112,16 +1378,6 @@  = assertPpr (isExternalName n) (ppr n) $    getUnique n `memberUniqueSet` cTupleTyConKeys --- | If the given name is that of a constraint tuple, return its arity.-cTupleTyConNameArity_maybe :: Name -> Maybe Arity-cTupleTyConNameArity_maybe n-  | not (isCTupleTyConName n) = Nothing-  | otherwise = fmap adjustArity (n `elemIndex` cTupleTyConNames)-  where-    -- Since `cTupleTyConNames` jumps straight from the `0` to the `2`-    -- case, we have to adjust accordingly our calculated arity.-    adjustArity a = if a > 0 then a + 1 else a- cTupleDataCon :: Arity -> DataCon cTupleDataCon i   | i > mAX_CTUPLE_SIZE = sndOf3 (mk_ctuple i) -- Build one specially@@ -1202,14 +1458,6 @@ -- tuple and the inner array is indexed by the superclass position. cTupleArr :: Array Int (TyCon, DataCon, Array Int Id) cTupleArr = listArray (0,mAX_CTUPLE_SIZE) [mk_ctuple i | i <- [0..mAX_CTUPLE_SIZE]]-  -- Although GHC does not make use of unary constraint tuples-  -- (see Note [Ignore unary constraint tuples] in GHC.Tc.Gen.HsType),-  -- this array creates one anyway. This is primarily motivated by the fact-  -- that (1) the indices of an Array must be contiguous, and (2) we would like-  -- the index of a constraint tuple in this Array to correspond to its Arity.-  -- We could envision skipping over the unary constraint tuple and having index-  -- 1 correspond to a 2-constraint tuple (and so on), but that's more-  -- complicated than it's worth.  -- | Given the TupleRep/SumRep tycon and list of RuntimeReps of the unboxed -- tuple/sum arguments, produces the return kind of an unboxed tuple/sum type@@ -1400,6 +1648,9 @@   | otherwise   = fst (unboxedSumArr ! arity) +unboxedSumTyConName :: Arity -> Name+unboxedSumTyConName arity = tyConName (sumTyCon arity)+ -- | Data constructor for i-th alternative of a n-ary unboxed sum. sumDataCon :: ConTag -- Alternative            -> Arity  -- Arity@@ -1423,6 +1674,9 @@   | otherwise   = snd (unboxedSumArr ! arity) ! (alt - 1) +unboxedSumDataConName :: ConTag -> Arity -> Name+unboxedSumDataConName alt arity = dataConName (sumDataCon alt arity)+ -- | Cached type and data constructors for sums. The outer array is -- indexed by the arity of the sum and the inner array is indexed by -- the alternative.@@ -1511,6 +1765,9 @@     binders   = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])     roles     = [Nominal, Nominal, Nominal]     rhs       = mkDataTyConRhs [datacon]+                -- rhs: a DataTyCon, not a UnaryClassTyCon!  Yes it has one+                --      field, but it has unboxed type (a ~# b),+                --      so the class must provide the box.      tvs@[k,a,b] = binderVars binders     sc_pred     = mkTyConApp eqPrimTyCon (mkTyVarTys [k,k,a,b])@@ -2633,13 +2890,6 @@ naturalNBDataCon :: DataCon naturalNBDataCon = pcDataCon naturalNBDataConName [] [byteArrayPrimTy] naturalTyCon ---- | Replaces constraint tuple names with corresponding boxed ones.-filterCTuple :: RdrName -> RdrName-filterCTuple (Exact n)-  | Just arity <- cTupleTyConNameArity_maybe n-  = Exact $ tupleTyConName BoxedTuple arity-filterCTuple rdr = rdr  {- ************************************************************************
compiler/GHC/Builtin/Types/Prim.hs view
@@ -77,7 +77,6 @@         mutVarPrimTyCon, mkMutVarPrimTy,          mVarPrimTyCon,                  mkMVarPrimTy,-        ioPortPrimTyCon,                mkIOPortPrimTy,         tVarPrimTyCon,                  mkTVarPrimTy,         stablePtrPrimTyCon,             mkStablePtrPrimTy,         stableNamePrimTyCon,            mkStableNamePrimTy,@@ -278,7 +277,6 @@     , mutableByteArrayPrimTyCon     , smallMutableArrayPrimTyCon     , mVarPrimTyCon-    , ioPortPrimTyCon     , tVarPrimTyCon     , mutVarPrimTyCon     , realWorldTyCon@@ -310,7 +308,7 @@   arrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName,   mutableArrayPrimTyConName, mutableByteArrayPrimTyConName,   smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName,-  ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName,+  tVarPrimTyConName, stablePtrPrimTyConName,   stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName,   weakPrimTyConName, threadIdPrimTyConName,   eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName,@@ -342,7 +340,6 @@ mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon smallMutableArrayPrimTyConName= mkPrimTc (fsLit "SmallMutableArray#") smallMutableArrayPrimTyConKey smallMutableArrayPrimTyCon mutVarPrimTyConName           = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon-ioPortPrimTyConName           = mkPrimTc (fsLit "IOPort#") ioPortPrimTyConKey ioPortPrimTyCon mVarPrimTyConName             = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPrimTyCon tVarPrimTyConName             = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon stablePtrPrimTyConName        = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon@@ -1017,7 +1014,7 @@     -------------------------- This is The Type Of Equality in GHC. It classifies nominal coercions. This type is used in the solver for recording equality constraints.-It responds "yes" to Type.isEqPrimPred and classifies as an EqPred in+It responds "yes" to Type.isEqPred and classifies as an EqPred in Type.classifyPredType.  All wanted constraints of this type are built with coercion holes.@@ -1279,20 +1276,6 @@  mkMutVarPrimTy :: Type -> Type -> Type mkMutVarPrimTy s elt        = TyConApp mutVarPrimTyCon [getLevity elt, s, elt]--{--************************************************************************-*                                                                      *-\subsection[TysPrim-io-port-var]{The synchronizing I/O Port type}-*                                                                      *-************************************************************************--}--ioPortPrimTyCon :: TyCon-ioPortPrimTyCon = pcPrimTyCon_LevPolyLastArg ioPortPrimTyConName [Nominal, Representational] unliftedRepTy--mkIOPortPrimTy :: Type -> Type -> Type-mkIOPortPrimTy s elt          = TyConApp ioPortPrimTyCon [getLevity elt, s, elt]  {- ************************************************************************
compiler/GHC/Builtin/Uniques.hs view
@@ -26,6 +26,7 @@     , mkCTupleTyConUnique     , mkCTupleDataConUnique     , mkCTupleSelIdUnique+    , isCTupleTyConUnique        -- ** Making built-in uniques     , mkAlphaTyVarUnique@@ -122,6 +123,7 @@               -- alternative     mkUniqueInt 'z' (arity `shiftL` 8 .|. 0xfc) +-- | Inverse of 'mkSumTyConUnique' isSumTyConUnique :: Unique -> Maybe Arity isSumTyConUnique u =   case (tag, n .&. 0xfc) of@@ -234,6 +236,17 @@   | otherwise   = mkUniqueInt 'j' (arity `shiftL` cTupleSelIdArityBits + sc_pos) +-- | Inverse of 'mkCTupleTyConUnique'+isCTupleTyConUnique :: Unique -> Maybe Arity+isCTupleTyConUnique u =+  case (tag, i) of+    ('k', 0) -> Just arity+    _        -> Nothing+  where+    (tag, n) = unpkUnique u+    (arity', i) = quotRem n 2+    arity = word64ToInt arity'+ getCTupleTyConName :: Int -> Name getCTupleTyConName n =     case n `divMod` 2 of@@ -282,7 +295,7 @@ mkTupleTyConUnique Boxed           a  = mkUniqueInt '4' (2*a) mkTupleTyConUnique Unboxed         a  = mkUniqueInt '5' (2*a) --- | This function is an inverse of `mkTupleTyConUnique`+-- | Inverse of 'mkTupleTyConUnique' isTupleTyConUnique :: Unique -> Maybe (Boxity, Arity) isTupleTyConUnique u =   case (tag, i) of@@ -294,7 +307,7 @@     (arity', i) = quotRem n 2     arity = word64ToInt arity' --- | This function is an inverse of `mkTupleTyDataUnique` that also matches the worker and promoted tycon.+-- | Inverse of 'mkTupleTyDataUnique' that also matches the worker and promoted tycon. isTupleDataConLikeUnique :: Unique -> Maybe (Boxity, Arity) isTupleDataConLikeUnique u =   case tag of
+ compiler/GHC/Builtin/Utils.hs view
@@ -0,0 +1,341 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++-}++++-- | The @GHC.Builtin.Utils@ interface to the compiler's prelude knowledge.+--+-- This module serves as the central gathering point for names which the+-- compiler knows something about. This includes functions for,+--+--  * discerning whether a 'Name' is known-key+--+--  * given a 'Unique', looking up its corresponding known-key 'Name'+--+-- See Note [Known-key names] and Note [About wired-in things] for information+-- about the two types of prelude things in GHC.+--+module GHC.Builtin.Utils (+        -- * Known-key names+        isKnownKeyName,+        lookupKnownKeyName,+        lookupKnownNameInfo,++        -- ** Internal use+        -- | 'knownKeyNames' is exported to seed the original name cache only;+        -- if you find yourself wanting to look at it you might consider using+        -- 'lookupKnownKeyName' or 'isKnownKeyName'.+        knownKeyNames,++        -- * Miscellaneous+        wiredInIds, ghcPrimIds,++        ghcPrimExports,+        ghcPrimDeclDocs,+        ghcPrimWarns,+        ghcPrimFixities,++        -- * Random other things+        maybeCharLikeCon, maybeIntLikeCon,++        -- * Class categories+        isNumericClass, isStandardClass++    ) where++import GHC.Prelude++import GHC.Builtin.Uniques+import GHC.Builtin.PrimOps+import GHC.Builtin.PrimOps.Ids+import GHC.Builtin.Types+import GHC.Builtin.Types.Literals ( typeNatTyCons )+import GHC.Builtin.Types.Prim+import GHC.Builtin.Names.TH ( templateHaskellNames )+import GHC.Builtin.Names++import GHC.Core.ConLike ( ConLike(..) )+import GHC.Core.DataCon+import GHC.Core.Class+import GHC.Core.TyCon++import GHC.Types.Avail+import GHC.Types.Id+import GHC.Types.Fixity+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Id.Make+import GHC.Types.SourceText+import GHC.Types.Unique.FM+import GHC.Types.Unique.Map+import GHC.Types.TyThing+import GHC.Types.Unique ( isValidKnownKeyUnique, pprUniqueAlways )++import GHC.Utils.Outputable+import GHC.Utils.Misc as Utils+import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)+import GHC.Parser.Annotation+import GHC.Hs.Doc+import GHC.Unit.Module.ModIface (IfaceExport)+import GHC.Unit.Module.Warnings++import GHC.Data.List.SetOps++import Control.Applicative ((<|>))+import Data.Maybe++{-+************************************************************************+*                                                                      *+\subsection[builtinNameInfo]{Lookup built-in names}+*                                                                      *+************************************************************************++Note [About wired-in things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Wired-in things are Ids\/TyCons that are completely known to the compiler.+  They are global values in GHC, (e.g.  listTyCon :: TyCon).++* A wired-in Name contains the thing itself inside the Name:+        see Name.wiredInNameTyThing_maybe+  (E.g. listTyConName contains listTyCon.++* The name cache is initialised with (the names of) all wired-in things+  (except tuples and sums; see Note [Infinite families of known-key names])++* The type environment itself contains no wired in things. The type+  checker sees if the Name is wired in before looking up the name in+  the type environment.++* GHC.Iface.Make prunes out wired-in things before putting them in an interface file.+  So interface files never contain wired-in things.+-}+++-- | This list is used to ensure that when you say "Prelude.map" in your source+-- code, or in an interface file, you get a Name with the correct known key (See+-- Note [Known-key names] in "GHC.Builtin.Names")+knownKeyNames :: [Name]+knownKeyNames+  | debugIsOn+  , Just badNamesDoc <- knownKeyNamesOkay all_names+  = pprPanic "badAllKnownKeyNames" badNamesDoc+  | otherwise+  = all_names+  where+    all_names =+      concat [ concatMap wired_tycon_kk_names primTyCons+             , concatMap wired_tycon_kk_names wiredInTyCons+             , concatMap wired_tycon_kk_names typeNatTyCons+             , map idName wiredInIds+             , map idName allThePrimOpIds+             , map (idName . primOpWrapperId) allThePrimOps+             , basicKnownKeyNames+             , templateHaskellNames+             ]+    -- All of the names associated with a wired-in TyCon.+    -- This includes the TyCon itself, its DataCons and promoted TyCons.+    wired_tycon_kk_names :: TyCon -> [Name]+    wired_tycon_kk_names tc =+        tyConName tc : (rep_names tc ++ implicits)+      where implicits = concatMap thing_kk_names (implicitTyConThings tc)++    wired_datacon_kk_names :: DataCon -> [Name]+    wired_datacon_kk_names dc =+      dataConName dc : rep_names (promoteDataCon dc)++    thing_kk_names :: TyThing -> [Name]+    thing_kk_names (ATyCon tc)                 = wired_tycon_kk_names tc+    thing_kk_names (AConLike (RealDataCon dc)) = wired_datacon_kk_names dc+    thing_kk_names thing                       = [getName thing]++    -- The TyConRepName for a known-key TyCon has a known key,+    -- but isn't itself an implicit thing.  Yurgh.+    -- NB: if any of the wired-in TyCons had record fields, the record+    --     field names would be in a similar situation.  Ditto class ops.+    --     But it happens that there aren't any+    rep_names tc = case tyConRepName_maybe tc of+                        Just n  -> [n]+                        Nothing -> []++-- | Check the known-key names list of consistency.+knownKeyNamesOkay :: [Name] -> Maybe SDoc+knownKeyNamesOkay all_names+  | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names+  = Just $ text "    Out-of-range known-key uniques: " <>+           brackets (pprWithCommas (ppr . nameOccName) ns)+  | null badNamesPairs+  = Nothing+  | otherwise+  = Just badNamesDoc+  where+    namesEnv      = foldl' (\m n -> extendNameEnv_Acc (:) Utils.singleton m n n)+                           emptyUFM all_names+    badNamesEnv   = filterNameEnv (\ns -> ns `lengthExceeds` 1) namesEnv+    badNamesPairs = nonDetUFMToList badNamesEnv+      -- It's OK to use nonDetUFMToList here because the ordering only affects+      -- the message when we get a panic+    badNamesDoc :: SDoc+    badNamesDoc  = vcat $ map pairToDoc badNamesPairs++    pairToDoc :: (Unique, [Name]) -> SDoc+    pairToDoc (uniq, ns) = text "        " <>+                           pprUniqueAlways uniq <>+                           text ": " <>+                           brackets (pprWithCommas (ppr . nameOccName) ns)++-- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a+-- known-key thing.+lookupKnownKeyName :: Unique -> Maybe Name+lookupKnownKeyName u =+    knownUniqueName u <|> lookupUFM_Directly knownKeysMap u++-- | Is a 'Name' known-key?+isKnownKeyName :: Name -> Bool+isKnownKeyName n =+    isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap++-- | Maps 'Unique's to known-key names.+--+-- The type is @UniqFM Name Name@ to denote that the 'Unique's used+-- in the domain are 'Unique's associated with 'Name's (as opposed+-- to some other namespace of 'Unique's).+knownKeysMap :: UniqFM Name Name+knownKeysMap = listToIdentityUFM knownKeyNames++-- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by+-- GHCi's ':info' command.+lookupKnownNameInfo :: Name -> SDoc+lookupKnownNameInfo name = case lookupNameEnv knownNamesInfo name of+    -- If we do find a doc, we add comment delimiters to make the output+    -- of ':info' valid Haskell.+    Nothing  -> empty+    Just doc -> vcat [text "{-", doc, text "-}"]++-- A map from Uniques to SDocs, used in GHCi's ':info' command. (#12390)+knownNamesInfo :: NameEnv SDoc+knownNamesInfo = unitNameEnv coercibleTyConName $+    vcat [ text "Coercible is a special constraint with custom solving rules."+         , text "It is not a class."+         , text "Please see section `The Coercible constraint`"+         , text "of the user's guide for details." ]++{-+We let a lot of "non-standard" values be visible, so that we can make+sense of them in interface pragmas. It's cool, though they all have+"non-standard" names, so they won't get past the parser in user code.+-}++{-+************************************************************************+*                                                                      *+            Export lists for pseudo-modules (GHC.Prim)+*                                                                      *+************************************************************************+-}++ghcPrimExports :: [IfaceExport]+ghcPrimExports+ = map (Avail . idName) ghcPrimIds +++   map (Avail . idName) allThePrimOpIds +++   [ AvailTC n [n]+   | tc <- exposedPrimTyCons, let n = tyConName tc ]++ghcPrimDeclDocs :: Docs+ghcPrimDeclDocs = emptyDocs { docs_decls = listToUniqMap $ mapMaybe findName primOpDocs }+  where+    findName (nameStr, doc)+      | Just name <- lookupFsEnv ghcPrimNames nameStr+      = Just (name, [WithHsDocIdentifiers (mkGeneratedHsDocString doc) []])+      | otherwise = Nothing++ghcPrimNames :: FastStringEnv Name+ghcPrimNames+  = mkFsEnv+    [ (occNameFS $ nameOccName name, name)+    | name <-+        map idName ghcPrimIds +++        map idName allThePrimOpIds +++        map tyConName exposedPrimTyCons+    ]++-- See Note [GHC.Prim Deprecations]+ghcPrimWarns :: Warnings a+ghcPrimWarns = WarnSome+  -- declaration warnings+  (map mk_decl_dep primOpDeprecations)+  -- export warnings+  []+  where+    mk_txt msg =+      DeprecatedTxt NoSourceText [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText msg Nothing) []]+    mk_decl_dep (occ, msg) = (occ, mk_txt msg)++ghcPrimFixities :: [(OccName,Fixity)]+ghcPrimFixities = fixities+  where+    -- The fixity listed here for @`seq`@ should match+    -- those in primops.txt.pp (from which Haddock docs are generated).+    fixities = (getOccName seqId, Fixity 0 InfixR)+             : mapMaybe mkFixity allThePrimOps+    mkFixity op = (,) (primOpOcc op) <$> primOpFixity op++{-+Note [GHC.Prim Docs]+~~~~~~~~~~~~~~~~~~~~+For haddocks of GHC.Prim we generate a dummy haskell file (gen_hs_source) that+contains the type signatures and the comments (but no implementations)+specifically for consumption by haddock.++GHCi's :doc command reads directly from ModIface's though, and GHC.Prim has a+wired-in iface that has nothing to do with the above haskell file. The code+below converts primops.txt into an intermediate form that would later be turned+into a proper DeclDocMap.++We output the docs as a list of pairs (name, docs). We use stringy names here+because mapping names to "Name"s is difficult for things like primtypes and+pseudoops.++Note [GHC.Prim Deprecations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Like Haddock documentation, we must record deprecation pragmas in two places:+in the GHC.Prim source module consumed by Haddock, and in the+declarations wired-in to GHC. To do the following we generate+GHC.Builtin.PrimOps.primOpDeprecations, a list of (OccName, DeprecationMessage)+pairs. We insert these deprecations into the mi_warns field of GHC.Prim's ModIface,+as though they were written in a source module.+-}+++{-+************************************************************************+*                                                                      *+            Built-in keys+*                                                                      *+************************************************************************++ToDo: make it do the ``like'' part properly (as in 0.26 and before).+-}++maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool+maybeCharLikeCon con = con `hasKey` charDataConKey+maybeIntLikeCon  con = con `hasKey` intDataConKey++{-+************************************************************************+*                                                                      *+            Class predicates+*                                                                      *+************************************************************************+-}++isNumericClass, isStandardClass :: Class -> Bool++isNumericClass     clas = classKey clas `is_elem` numericClassKeys+isStandardClass    clas = classKey clas `is_elem` standardClassKeys++is_elem :: Eq a => a -> [a] -> Bool+is_elem = isIn "is_X_Class"
+ compiler/GHC/ByteCode/Breakpoints.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Breakpoint information constructed during ByteCode generation.+--+-- Specifically, code-generation breakpoints are referred to as "internal+-- breakpoints", the internal breakpoint data for a module is stored in+-- 'InternalModBreaks', and is uniquely identified at runtime by an+-- 'InternalBreakpointId'.+--+-- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers]+module GHC.ByteCode.Breakpoints+  ( -- * Internal Mod Breaks+    InternalModBreaks(..), CgBreakInfo(..)+  , mkInternalModBreaks, imodBreaks_module++    -- ** Internal breakpoint identifier+  , InternalBreakpointId(..), BreakInfoIndex+  , InternalBreakLoc(..)++    -- * Operations++    -- ** Internal-level operations+  , getInternalBreak++    -- ** Source-level information operations+  , getBreakLoc, getBreakVars, getBreakDecls, getBreakCCS+  , getBreakSourceId, getBreakSourceMod++    -- * Utils+  , seqInternalModBreaks++  )+  where++import GHC.Prelude+import GHC.Types.SrcLoc+import GHC.Types.Name.Occurrence+import Control.DeepSeq+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IM++import GHC.HsToCore.Breakpoints+import GHC.Iface.Syntax++import GHC.Unit.Module (Module)+import GHC.Utils.Outputable+import GHC.Utils.Panic+import Data.Array++{-+Note [ModBreaks vs InternalModBreaks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'ModBreaks' and 'BreakpointId's must not to be confused with+'InternalModBreaks' and 'InternalBreakId's.++'ModBreaks' is constructed once during HsToCore from the information attached+to source-level breakpoint ticks and is never changed afterwards. A 'ModBreaks'+can be queried using 'BreakpointId's, which uniquely identifies a breakpoint+within the list of breakpoint information for a given module's 'ModBreaks'.++'InternalModBreaks' are constructed during bytecode generation and are indexed+by a 'InternalBreakpointId'. They contain all the information relevant to a+breakpoint for code generation that can be accessed during runtime execution+(such as a 'BreakArray' for triggering breakpoints). 'InternalBreakpointId's+are used at runtime to trigger and inspect breakpoints -- a 'BRK_FUN'+instruction receives 'InternalBreakpointId' as an argument.++We keep a mapping from 'InternalModBreaks' to a 'BreakpointId', which can then be used+to get source-level information about a breakpoint via the corresponding 'ModBreaks'.++Notably, 'InternalModBreaks' can contain entries for so-called internal+breakpoints, which do not necessarily have a source-level location attached to+it (i.e. do not have a matching entry in 'ModBreaks'). We may leverage this to+introduce breakpoints during code generation for features such as stepping-out.++Note [Breakpoint identifiers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before optimization a breakpoint is identified uniquely with a tick module+and a tick index. See 'BreakpointId'. A tick module contains an array, indexed+with the tick indexes, which indicates breakpoint status.++When we generate ByteCode, we collect information for every breakpoint at+their *occurrence sites* (see CgBreakInfo) and these info+are stored in the ModIface of the occurrence module. Because of inlining, we+can't reuse the tick index to uniquely identify an occurrence; because of+cross-module inlining, we can't assume that the occurrence module is the same+as the tick module (#24712).++So every breakpoint occurrence gets assigned a module-unique *info index* and+we store it alongside the occurrence module (*info module*) in the+'InternalBreakpointId' datatype. This is the index that we use at runtime to+identify a breakpoint.++When the internal breakpoint has a matching tick-level breakpoint we can fetch+the related tick-level information by first looking up a mapping+@'InternalBreakpointId' -> 'BreakpointId'@ in @'CgBreakInfo'@.+-}++--------------------------------------------------------------------------------+-- * Internal breakpoint identifiers+--------------------------------------------------------------------------------++-- | Internal breakpoint info index+type BreakInfoIndex = Int++-- | Internal breakpoint identifier+--+-- Indexes into the structures in the @'InternalModBreaks'@ produced during ByteCode generation.+-- See Note [Breakpoint identifiers]+data InternalBreakpointId = InternalBreakpointId+  { ibi_info_mod   :: !Module         -- ^ Breakpoint info module+  , ibi_info_index :: !BreakInfoIndex -- ^ Breakpoint info index+  }+  deriving (Eq, Ord)++--------------------------------------------------------------------------------+-- * Internal Mod Breaks+--------------------------------------------------------------------------------++-- | Internal mod breaks store the runtime-relevant information of breakpoints.+--+-- Importantly, it maps 'InternalBreakpointId's to 'CgBreakInfo'.+--+-- 'InternalModBreaks' are constructed during bytecode generation and stored in+-- 'CompiledByteCode' afterwards.+data InternalModBreaks = InternalModBreaks+      { imodBreaks_breakInfo :: !(IntMap CgBreakInfo)+        -- ^ Access code-gen time information about a breakpoint, indexed by+        -- 'InternalBreakpointId'.++      , imodBreaks_modBreaks :: !ModBreaks+        -- ^ Store the ModBreaks for this module+        --+        -- Recall Note [Breakpoint identifiers]: for some module A, an+        -- *occurrence* of a breakpoint in A may have been inlined from some+        -- breakpoint *defined* in module B.+        --+        -- This 'ModBreaks' contains information regarding all the breakpoints+        -- defined in the module this 'InternalModBreaks' corresponds to. It+        -- /does not/ necessarily have information regarding all the breakpoint+        -- occurrences registered in 'imodBreaks_breakInfo'. Some of those+        -- occurrences may refer breakpoints inlined from other modules.+      }++-- | Construct an 'InternalModBreaks'.+--+-- INVARIANT: The given 'ModBreaks' correspond to the same module as this+-- 'InternalModBreaks' module (the first argument) and its breakpoint infos+-- (the @IntMap CgBreakInfo@ argument)+mkInternalModBreaks :: Module -> IntMap CgBreakInfo -> ModBreaks -> InternalModBreaks+mkInternalModBreaks mod im mbs =+  assertPpr (mod == modBreaks_module mbs)+    (text "Constructing InternalModBreaks with the ModBreaks of a different module!") $+      InternalModBreaks im mbs++-- | Get the module to which these 'InternalModBreaks' correspond+imodBreaks_module :: InternalModBreaks -> Module+imodBreaks_module = modBreaks_module . imodBreaks_modBreaks++-- | Information about a breakpoint that we know at code-generation time+-- In order to be used, this needs to be hydrated relative to the current HscEnv by+-- 'hydrateCgBreakInfo'. Everything here can be fully forced and that's critical for+-- preventing space leaks (see #22530)+data CgBreakInfo+   = CgBreakInfo+   { cgb_tyvars  :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint+   , cgb_vars    :: ![Maybe (IfaceIdBndr, Word)]+   , cgb_resty   :: !IfaceType+   , cgb_tick_id :: !(Either InternalBreakLoc BreakpointId)+     -- ^ This field records the original breakpoint tick identifier for this+     -- internal breakpoint info. It is used to convert a breakpoint+     -- *occurrence* index ('InternalBreakpointId') into a *definition* index+     -- ('BreakpointId').+     --+     -- The modules of breakpoint occurrence and breakpoint definition are not+     -- necessarily the same: See Note [Breakpoint identifiers].+     --+     -- If there is no original tick identifier (that is, the breakpoint was+     -- created during code generation), we re-use the BreakpointId of something else.+     -- It would also be reasonable to have an @Either something BreakpointId@+     -- for @cgb_tick_id@, but currently we can always re-use a source-level BreakpointId.+     -- In the case of step-out, see Note [Debugger: Stepout internal break locs]+   }+-- See Note [Syncing breakpoint info] in GHC.Runtime.Eval++-- | Breakpoints created during code generation don't have a source-level tick+-- location. Instead, we re-use an existing one.+newtype InternalBreakLoc = InternalBreakLoc { internalBreakLoc :: BreakpointId }+  deriving newtype (Eq, NFData, Outputable)++-- | Get an internal breakpoint info by 'InternalBreakpointId'+getInternalBreak :: InternalBreakpointId -> InternalModBreaks -> CgBreakInfo+getInternalBreak (InternalBreakpointId mod ix) imbs =+  assert_modules_match mod (imodBreaks_module imbs) $+    imodBreaks_breakInfo imbs IM.! ix++-- | Assert that the module in the 'InternalBreakpointId' and in+-- 'InternalModBreaks' match.+assert_modules_match :: Module -> Module -> a -> a+assert_modules_match ibi_mod imbs_mod =+  assertPpr (ibi_mod == imbs_mod)+    (text "Tried to query the InternalModBreaks of module" <+> ppr imbs_mod+        <+> text "with an InternalBreakpointId for module" <+> ppr ibi_mod)++--------------------------------------------------------------------------------+-- Tick-level Breakpoint information+--------------------------------------------------------------------------------++-- | Get the source module and tick index for this breakpoint+-- (as opposed to the module where this breakpoint occurs, which is in 'InternalBreakpointId')+getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> BreakpointId+getBreakSourceId (InternalBreakpointId ibi_mod ibi_ix) imbs =+  assert_modules_match ibi_mod (imodBreaks_module imbs) $+    let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix+     in either internalBreakLoc id (cgb_tick_id cgb)++-- | Get the source module for this breakpoint (where the breakpoint is defined)+getBreakSourceMod :: InternalBreakpointId -> InternalModBreaks -> Module+getBreakSourceMod (InternalBreakpointId ibi_mod ibi_ix) imbs =+  assert_modules_match ibi_mod (imodBreaks_module imbs) $+    let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix+     in either (bi_tick_mod . internalBreakLoc) bi_tick_mod (cgb_tick_id cgb)++-- | Get the source span for this breakpoint+getBreakLoc :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO SrcSpan+getBreakLoc = getBreakXXX modBreaks_locs++-- | Get the vars for this breakpoint+getBreakVars :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [OccName]+getBreakVars = getBreakXXX modBreaks_vars++-- | Get the decls for this breakpoint+getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String]+getBreakDecls = getBreakXXX modBreaks_decls++-- | Get the decls for this breakpoint+getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO ((String, String))+getBreakCCS = getBreakXXX modBreaks_ccs++-- | Internal utility to access a ModBreaks field at a particular breakpoint index+--+-- Recall Note [Breakpoint identifiers]: the internal breakpoint module (the+-- *occurrence* module) doesn't necessarily match the module where the+-- tick breakpoint was defined with the relevant 'ModBreaks'.+--+-- When the tick module is the same as the internal module, we use the stored+-- 'ModBreaks'. When the tick module is different, we need to look up the+-- 'ModBreaks' in the HUG for that other module.+--+-- When there is no tick module (the breakpoint was generated at codegen), use+-- the function on internal mod breaks.+--+-- To avoid cyclic dependencies, we instead receive a function that looks up+-- the 'ModBreaks' given a 'Module'+getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a+getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs =+  assert_modules_match ibi_mod (imodBreaks_module imbs) $ do+    let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix+    case either internalBreakLoc id (cgb_tick_id cgb) of+      BreakpointId{bi_tick_mod, bi_tick_index}+        | bi_tick_mod == ibi_mod+        -> do+          let these_mbs = imodBreaks_modBreaks imbs+          return $ view these_mbs ! bi_tick_index+        | otherwise+        -> do+          other_mbs <- lookupModule bi_tick_mod+          return $ view other_mbs ! bi_tick_index++--------------------------------------------------------------------------------+-- Instances+--------------------------------------------------------------------------------++-- | Fully force an 'InternalModBreaks' value+seqInternalModBreaks :: InternalModBreaks -> ()+seqInternalModBreaks InternalModBreaks{..} =+    rnf (fmap seqCgBreakInfo imodBreaks_breakInfo)+  where+    seqCgBreakInfo :: CgBreakInfo -> ()+    seqCgBreakInfo CgBreakInfo{..} =+        rnf cgb_tyvars `seq`+        rnf cgb_vars `seq`+        rnf cgb_resty `seq`+        rnf cgb_tick_id++instance Outputable InternalBreakpointId where+  ppr InternalBreakpointId{..} =+    text "InternalBreakpointId" <+> ppr ibi_info_mod <+> ppr ibi_info_index++instance NFData InternalBreakpointId where+  rnf InternalBreakpointId{..} =+    rnf ibi_info_mod `seq` rnf ibi_info_index++instance Outputable CgBreakInfo where+   ppr info = text "CgBreakInfo" <+>+              parens (ppr (cgb_vars info) <+>+                      ppr (cgb_resty info) <+>+                      ppr (cgb_tick_id info))
compiler/GHC/ByteCode/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP                        #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards            #-} {-# LANGUAGE TypeApplications           #-}@@ -18,10 +19,15 @@   , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)   , ItblEnv, ItblPtr(..)   , AddrEnv, AddrPtr(..)-  , CgBreakInfo(..)-  , ModBreaks (..), BreakIndex, emptyModBreaks-  , CCostCentre-  , FlatBag, sizeFlatBag, fromSizedSeq, elemsFlatBag+  , FlatBag, sizeFlatBag, fromSmallArray, elemsFlatBag++  -- * Mod Breaks+  , ModBreaks (..), BreakpointId(..), BreakTickIndex++  -- * Internal Mod Breaks+  , InternalModBreaks(..), CgBreakInfo(..), seqInternalModBreaks+  -- ** Internal breakpoint identifier+  , InternalBreakpointId(..), BreakInfoIndex   ) where  import GHC.Prelude@@ -33,23 +39,19 @@ import GHC.Utils.Outputable import GHC.Builtin.PrimOps import GHC.Types.SptEntry-import GHC.Types.SrcLoc-import GHCi.BreakArray+import GHC.HsToCore.Breakpoints+import GHC.ByteCode.Breakpoints+import GHCi.Message import GHCi.RemoteTypes import GHCi.FFI import Control.DeepSeq import GHCi.ResolvedBCO ( BCOByteArray(..), mkBCOByteArray )  import Foreign-import Data.Array import Data.ByteString (ByteString)-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap import qualified GHC.Exts.Heap as Heap-import GHC.Stack.CCS import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )-import GHC.Iface.Syntax-import Language.Haskell.Syntax.Module.Name (ModuleName)+import GHC.Unit.Module  -- ----------------------------------------------------------------------------- -- Compiled Byte Code@@ -58,27 +60,29 @@   { bc_bcos   :: FlatBag UnlinkedBCO     -- ^ Bunch of interpretable bindings -  , bc_itbls  :: ItblEnv+  , bc_itbls  :: [(Name, ConInfoTable)]     -- ^ Mapping from DataCons to their info tables -  , bc_ffis   :: [FFIInfo]-    -- ^ ffi blocks we allocated--  , bc_strs   :: AddrEnv+  , bc_strs   :: [(Name, ByteString)]     -- ^ top-level strings (heap allocated) -  , bc_breaks :: Maybe ModBreaks-    -- ^ breakpoint info (Nothing if breakpoints are disabled)+  , bc_breaks :: Maybe InternalModBreaks+    -- ^ All breakpoint information (no information if breakpoints are disabled).+    --+    -- This information is used when loading a bytecode object: we will+    -- construct the arrays to be used at runtime to trigger breakpoints at load time+    -- from it (in 'allocateBreakArrays' and 'allocateCCS' in 'GHC.ByteCode.Loader').    , bc_spt_entries :: ![SptEntry]     -- ^ Static pointer table entries which should be loaded along with the     -- BCOs. See Note [Grand plan for static forms] in     -- "GHC.Iface.Tidy.StaticPtrTable".   }-                -- ToDo: we're not tracking strings that we malloc'd-newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif)-  deriving (Show, NFData) +-- | A libffi ffi_cif function prototype.+data FFIInfo = FFIInfo { ffiInfoArgs :: ![FFIType], ffiInfoRet :: !FFIType }+  deriving (Show)+ instance Outputable CompiledByteCode where   ppr CompiledByteCode{..} = ppr $ elemsFlatBag bc_bcos @@ -87,10 +91,11 @@ seqCompiledByteCode :: CompiledByteCode -> () seqCompiledByteCode CompiledByteCode{..} =   rnf bc_bcos `seq`-  seqEltsNameEnv rnf bc_itbls `seq`-  rnf bc_ffis `seq`-  seqEltsNameEnv rnf bc_strs `seq`-  rnf (fmap seqModBreaks bc_breaks)+  rnf bc_itbls `seq`+  rnf bc_strs `seq`+  case bc_breaks of+    Nothing -> ()+    Just ibks -> seqInternalModBreaks ibks  newtype ByteOff = ByteOff Int     deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable)@@ -166,6 +171,80 @@ newtype AddrPtr = AddrPtr (RemotePtr ())   deriving (NFData) +{-+--------------------------------------------------------------------------------+-- * Byte Code Objects (BCOs)+--------------------------------------------------------------------------------++Note [Case continuation BCOs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++A stack with a BCO stack frame at the top looks like:++                                      (an StgBCO)+         |       ...        |      +---> +---------[1]--++         +------------------+      |     | info_tbl_ptr | ------++         |    OTHER FRAME   |      |     +--------------+       |+         +------------------+      |     | StgArrBytes* | <--- the byte code+         |       ...        |      |     +--------------+       |+         +------------------+      |     |     ...      |       |+         |       fvs1       |      |                            |+         +------------------+      |                            |+         |       ...        |      |        (StgInfoTable)      |+         +------------------+      |           +----------+ <---++         |      args1       |      |           |    ...   |+         +------------------+      |           +----------++         |   some StgBCO*   | -----+           | type=BCO |+         +------------------+                  +----------++      Sp | stg_apply_interp | -----+           |   ...    |+         +------------------+      |+                                   |+                                   |   (StgInfoTable)+                                   +----> +--------------++                                          |     ...      |+                                          +--------------++                                          | type=RET_BCO |+                                          +--------------++                                          |     ...      |+++In the case of bytecode objects found on the heap (e.g. thunks and functions),+the bytecode may refer to free variables recorded in the BCO closure itself.+By contrast, in /case continuation/ BCOs the code may additionally refer to free+variables in their stack frame. These are references by way of statically known+stack offsets (tracked using `BCEnv` in `StgToByteCode`).++For instance, consider the function:++    f x y = case y of ... -> g x++Here the RHS of the alternative refers to `x`, which will be recorded in the+continuation stack frame of the `case`.++Even less obvious is that case continuation BCOs may also refer to free+variables in *parent* stack frames. For instance,++    f x y = case y of+      ... -> case g x of+        ... -> x++Here, the RHS of the first alternative still refers to the `x` in the stack+frame of the `case`. Additionally, the RHS of the second alternative also+refers to `x` but it must traverse to its case's *parent* stack frame to find `x`.++However, in /case continuation/ BCOs, the code may additionally refer to free+variables that are outside of that BCO's stack frame -- some free variables of a+case continuation BCO may only be found in the stack frame of a parent BCO.++Yet, references to these out-of-frame variables are also done in terms of stack+offsets. Thus, they rely on the position of /another frame/ to be fixed. (See+Note [PUSH_L underflow] for more information about references to previous+frames and nested BCOs)++This makes case continuation BCOs special: unlike normal BCOs, case cont BCO+frames cannot be moved on the stack independently from their parent BCOs.+-}+ data UnlinkedBCO    = UnlinkedBCO {         unlinkedBCOName   :: !Name,@@ -185,8 +264,8 @@   = BCOPtrName   !Name   | BCOPtrPrimOp !PrimOp   | BCOPtrBCO    !UnlinkedBCO-  | BCOPtrBreakArray (ForeignRef BreakArray)-    -- ^ a pointer to a breakpoint's module's BreakArray in GHCi's memory+  | BCOPtrBreakArray !Module+    -- ^ Converted to the actual 'BreakArray' remote pointer at link-time  instance NFData BCOPtr where   rnf (BCOPtrBCO bco) = rnf bco@@ -199,100 +278,22 @@   -- | A reference to a top-level string literal; see   -- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode.   | BCONPtrAddr  !Name-  -- | Only used internally in the assembler in an intermediate representation;-  -- should never appear in a fully-assembled UnlinkedBCO.+  -- | A top-level string literal.   -- Also see Note [Allocating string literals] in GHC.ByteCode.Asm.   | BCONPtrStr   !ByteString+  -- | Same as 'BCONPtrStr' but with benefits of 'FastString' interning logic.+  | BCONPtrFS    !FastString+  -- | A libffi ffi_cif function prototype.+  | BCONPtrFFIInfo !FFIInfo+  -- | A 'CostCentre' remote pointer array's respective 'BreakpointId'+  | BCONPtrCostCentre !InternalBreakpointId  instance NFData BCONPtr where   rnf x = x `seq` () --- | Information about a breakpoint that we know at code-generation time--- In order to be used, this needs to be hydrated relative to the current HscEnv by--- 'hydrateCgBreakInfo'. Everything here can be fully forced and that's critical for--- preventing space leaks (see #22530)-data CgBreakInfo-   = CgBreakInfo-   { cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint-   , cgb_vars   :: ![Maybe (IfaceIdBndr, Word)]-   , cgb_resty  :: !IfaceType-   }--- See Note [Syncing breakpoint info] in GHC.Runtime.Eval--seqCgBreakInfo :: CgBreakInfo -> ()-seqCgBreakInfo CgBreakInfo{..} =-    rnf cgb_tyvars `seq`-    rnf cgb_vars `seq`-    rnf cgb_resty- instance Outputable UnlinkedBCO where    ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)       = sep [text "BCO", ppr nm, text "with",              ppr (sizeFlatBag lits), text "lits",              ppr (sizeFlatBag ptrs), text "ptrs" ] -instance Outputable CgBreakInfo where-   ppr info = text "CgBreakInfo" <+>-              parens (ppr (cgb_vars info) <+>-                      ppr (cgb_resty info))---- -------------------------------------------------------------------------------- Breakpoints---- | Breakpoint index-type BreakIndex = Int---- | C CostCentre type-data CCostCentre---- | All the information about the breakpoints for a module-data ModBreaks-   = ModBreaks-   { modBreaks_flags :: ForeignRef BreakArray-        -- ^ The array of flags, one per breakpoint,-        -- indicating which breakpoints are enabled.-   , modBreaks_locs :: !(Array BreakIndex SrcSpan)-        -- ^ An array giving the source span of each breakpoint.-   , modBreaks_vars :: !(Array BreakIndex [OccName])-        -- ^ An array giving the names of the free variables at each breakpoint.-   , modBreaks_decls :: !(Array BreakIndex [String])-        -- ^ An array giving the names of the declarations enclosing each breakpoint.-        -- See Note [Field modBreaks_decls]-   , modBreaks_ccs :: !(Array BreakIndex (RemotePtr CostCentre))-        -- ^ Array pointing to cost centre for each breakpoint-   , modBreaks_breakInfo :: IntMap CgBreakInfo-        -- ^ info about each breakpoint from the bytecode generator-   , modBreaks_module :: RemotePtr ModuleName-   }--seqModBreaks :: ModBreaks -> ()-seqModBreaks ModBreaks{..} =-  rnf modBreaks_flags `seq`-  rnf modBreaks_locs `seq`-  rnf modBreaks_vars `seq`-  rnf modBreaks_decls `seq`-  rnf modBreaks_ccs `seq`-  rnf (fmap seqCgBreakInfo modBreaks_breakInfo) `seq`-  rnf modBreaks_module---- | Construct an empty ModBreaks-emptyModBreaks :: ModBreaks-emptyModBreaks = ModBreaks-   { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised"-         -- ToDo: can we avoid this?-   , modBreaks_locs  = array (0,-1) []-   , modBreaks_vars  = array (0,-1) []-   , modBreaks_decls = array (0,-1) []-   , modBreaks_ccs = array (0,-1) []-   , modBreaks_breakInfo = IntMap.empty-   , modBreaks_module = toRemotePtr nullPtr-   }--{--Note [Field modBreaks_decls]-~~~~~~~~~~~~~~~~~~~~~~-A value of eg ["foo", "bar", "baz"] in a `modBreaks_decls` field means:-The breakpoint is in the function called "baz" that is declared in a `let`-or `where` clause of a declaration called "bar", which itself is declared-in a `let` or `where` clause of the top-level function called "foo".--}
compiler/GHC/Cmm/CLabel.hs view
@@ -1729,6 +1729,9 @@       | platformArch platform == ArchRISCV64       = ppLbl +      | platformArch platform == ArchLoongArch64+      = ppLbl+       | platformArch platform == ArchX86_64       = case dllInfo of           CodeStub        -> ppLbl <> text "@plt"
compiler/GHC/Cmm/Dataflow/Label.hs view
@@ -63,10 +63,12 @@     , mapToList     , mapFromList     , mapFromListWith+    , mapMapMaybe     ) where  import GHC.Prelude +import GHC.Utils.Misc import GHC.Utils.Outputable  import GHC.Types.Unique (Uniquable(..), mkUniqueGrimily)@@ -82,7 +84,6 @@ import GHC.Data.TrieMap  import Data.Word (Word64)-import Data.List (foldl1')   -----------------------------------------------------------------------------@@ -139,8 +140,7 @@  {-# INLINE setUnions #-} setUnions :: [LabelSet] -> LabelSet-setUnions [] = setEmpty-setUnions sets = foldl1' setUnion sets+setUnions = foldl1WithDefault' setEmpty setUnion  setDifference :: LabelSet -> LabelSet -> LabelSet setDifference (LS x) (LS y) = LS (S.difference x y)@@ -219,8 +219,7 @@  {-# INLINE mapUnions #-} mapUnions :: [LabelMap a] -> LabelMap a-mapUnions [] = mapEmpty-mapUnions maps = foldl1' mapUnion maps+mapUnions = foldl1WithDefault' mapEmpty mapUnion  mapUnionWithKey :: (Label -> v -> v -> v) -> LabelMap v -> LabelMap v -> LabelMap v mapUnionWithKey f (LM x) (LM y) = LM (M.unionWithKey (f . mkHooplLabel) x y)@@ -282,6 +281,9 @@ mapFromListWith :: (v -> v -> v) -> [(Label, v)] -> LabelMap v mapFromListWith f assocs = LM (M.fromListWith f [(lblToUnique k, v) | (k, v) <- assocs]) +mapMapMaybe :: (a -> Maybe b) -> LabelMap a -> LabelMap b+mapMapMaybe f (LM m) = LM (M.mapMaybe f m)+ ----------------------------------------------------------------------------- -- Instances @@ -300,7 +302,8 @@   lookupTM k m  = mapLookup k m   alterTM k f m = mapAlter f k m   foldTM k m z  = mapFoldr k z m-  filterTM f m  = mapFilter f m+  filterTM f    = mapFilter f+  mapMaybeTM f  = mapMapMaybe f  ----------------------------------------------------------------------------- -- FactBase
compiler/GHC/Cmm/MachOp.hs view
@@ -1,13 +1,10 @@ {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.Cmm.MachOp     ( MachOp(..)     , pprMachOp, isCommutableMachOp, isAssociativeMachOp     , isComparisonMachOp, maybeIntComparison, machOpResultType     , machOpArgReps, maybeInvertComparison, isFloatComparison-    , isCommutableCallishMachOp      -- MachOp builders     , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot@@ -25,6 +22,7 @@     , CallishMachOp(..), callishMachOpHints     , pprCallishMachOp     , machOpMemcpyishAlign+    , callishMachOpArgTys      -- Atomic read-modify-write     , MemoryOrdering(..)@@ -40,7 +38,10 @@ import GHC.Platform import GHC.Cmm.Type import GHC.Utils.Outputable+import GHC.Utils.Misc (expectNonEmpty) +import Data.List.NonEmpty (NonEmpty (..))+ ----------------------------------------------------------------------------- --              MachOp -----------------------------------------------------------------------------@@ -169,16 +170,8 @@   | MO_V_Add Length Width   | MO_V_Sub Length Width   | MO_V_Mul Length Width--  -- Signed vector multiply/divide-  | MO_VS_Quot Length Width-  | MO_VS_Rem  Length Width   | MO_VS_Neg  Length Width -  -- Unsigned vector multiply/divide-  | MO_VU_Quot Length Width-  | MO_VU_Rem  Length Width-   -- Vector shuffles   | MO_V_Shuffle  Length Width [Int]   | MO_VF_Shuffle Length Width [Int]@@ -514,14 +507,10 @@     MO_V_Sub l w        -> cmmVec l (cmmBits w)     MO_V_Mul l w        -> cmmVec l (cmmBits w) -    MO_VS_Quot l w      -> cmmVec l (cmmBits w)-    MO_VS_Rem  l w      -> cmmVec l (cmmBits w)     MO_VS_Neg  l w      -> cmmVec l (cmmBits w)     MO_VS_Min  l w      -> cmmVec l (cmmBits w)     MO_VS_Max  l w      -> cmmVec l (cmmBits w) -    MO_VU_Quot l w      -> cmmVec l (cmmBits w)-    MO_VU_Rem  l w      -> cmmVec l (cmmBits w)     MO_VU_Min  l w      -> cmmVec l (cmmBits w)     MO_VU_Max  l w      -> cmmVec l (cmmBits w) @@ -543,7 +532,7 @@     MO_RelaxedRead w    -> cmmBits w     MO_AlignmentCheck _ _ -> ty1   where-    (ty1:_) = tys+    ty1:|_ = expectNonEmpty tys  comparisonResultRep :: Platform -> CmmType comparisonResultRep = bWord  -- is it?@@ -631,14 +620,10 @@     MO_V_Sub l w        -> [vecwidth l w, vecwidth l w]     MO_V_Mul l w        -> [vecwidth l w, vecwidth l w] -    MO_VS_Quot l w      -> [vecwidth l w, vecwidth l w]-    MO_VS_Rem  l w      -> [vecwidth l w, vecwidth l w]     MO_VS_Neg  l w      -> [vecwidth l w]     MO_VS_Min  l w      -> [vecwidth l w, vecwidth l w]     MO_VS_Max  l w      -> [vecwidth l w, vecwidth l w] -    MO_VU_Quot l w      -> [vecwidth l w, vecwidth l w]-    MO_VU_Rem  l w      -> [vecwidth l w, vecwidth l w]     MO_VU_Min  l w      -> [vecwidth l w, vecwidth l w]     MO_VU_Max  l w      -> [vecwidth l w, vecwidth l w] @@ -752,6 +737,20 @@   | MO_SubIntC   Width   | MO_U_Mul2    Width +  -- Signed vector divide+  | MO_VS_Quot Length Width+  | MO_VS_Rem  Length Width++  -- Unsigned vector divide+  | MO_VU_Quot Length Width+  | MO_VU_Rem  Length Width++  -- Int64X2/Word64X2 min/max+  | MO_I64X2_Min+  | MO_I64X2_Max+  | MO_W64X2_Min+  | MO_W64X2_Max+   | MO_Touch         -- Keep variables live (when using interior pointers)    -- Prefetch@@ -847,16 +846,143 @@   MO_Memcmp  align -> Just align   _                -> Nothing -isCommutableCallishMachOp :: CallishMachOp -> Bool-isCommutableCallishMachOp op =-  case op of-    MO_x64_Add  -> True-    MO_x64_Mul  -> True-    MO_x64_Eq   -> True-    MO_x64_Ne   -> True-    MO_x64_And  -> True-    MO_x64_Or   -> True-    MO_x64_Xor  -> True-    MO_S_Mul2 _ -> True-    MO_U_Mul2 _ -> True-    _ -> False+-- | Like 'machOpArgReps', but for 'CallishMachOp'.+--+-- Used only in Cmm lint.+callishMachOpArgTys :: Platform -> CallishMachOp -> [CmmType]+callishMachOpArgTys platform = \case+  MO_F64_Pwr -> [f64, f64]+  MO_F64_Sin -> [f64]+  MO_F64_Cos -> [f64]+  MO_F64_Tan -> [f64]+  MO_F64_Sinh -> [f64]+  MO_F64_Cosh -> [f64]+  MO_F64_Tanh -> [f64]+  MO_F64_Asin -> [f64]+  MO_F64_Acos -> [f64]+  MO_F64_Atan -> [f64]+  MO_F64_Asinh -> [f64]+  MO_F64_Acosh -> [f64]+  MO_F64_Atanh -> [f64]+  MO_F64_Log -> [f64]+  MO_F64_Log1P -> [f64]+  MO_F64_Exp -> [f64]+  MO_F64_ExpM1 -> [f64]+  MO_F64_Fabs -> [f64]+  MO_F64_Sqrt -> [f64]+  MO_F32_Pwr -> [f32, f32]+  MO_F32_Sin -> [f32]+  MO_F32_Cos -> [f32]+  MO_F32_Tan -> [f32]+  MO_F32_Sinh -> [f32]+  MO_F32_Cosh -> [f32]+  MO_F32_Tanh -> [f32]+  MO_F32_Asin -> [f32]+  MO_F32_Acos -> [f32]+  MO_F32_Atan -> [f32]+  MO_F32_Asinh -> [f32]+  MO_F32_Acosh -> [f32]+  MO_F32_Atanh -> [f32]+  MO_F32_Log -> [f32]+  MO_F32_Log1P -> [f32]+  MO_F32_Exp -> [f32]+  MO_F32_ExpM1 -> [f32]+  MO_F32_Fabs -> [f32]+  MO_F32_Sqrt -> [f32]+  MO_I64_ToI -> [b64]+  MO_I64_FromI -> [bWord platform]+  MO_W64_ToW -> [b64]+  MO_W64_FromW -> [bWord platform]+  MO_x64_Neg -> [b64]+  MO_x64_Add -> [b64]+  MO_x64_Sub -> [b64]+  MO_x64_Mul -> [b64]+  MO_I64_Quot -> [b64,b64]+  MO_I64_Rem -> [b64,b64]+  MO_W64_Quot -> [b64,b64]+  MO_W64_Rem -> [b64,b64]+  MO_x64_And -> [b64,b64]+  MO_x64_Or -> [b64,b64]+  MO_x64_Xor -> [b64,b64]+  MO_x64_Not -> [b64]+  MO_x64_Shl -> [b64,b64]+  MO_I64_Shr -> [b64,b64]+  MO_W64_Shr -> [b64,b64]+  MO_x64_Eq -> [b64,b64]+  MO_x64_Ne -> [b64,b64]+  MO_I64_Ge -> [b64,b64]+  MO_I64_Gt -> [b64,b64]+  MO_I64_Le -> [b64,b64]+  MO_I64_Lt -> [b64,b64]+  MO_W64_Ge -> [b64,b64]+  MO_W64_Gt -> [b64,b64]+  MO_W64_Le -> [b64,b64]+  MO_W64_Lt -> [b64,b64]+  MO_UF_Conv _w -> [bWord platform] -- Word to Float/Double+  MO_S_Mul2    w -> [cmmBits w, cmmBits w]+  MO_S_QuotRem w -> [cmmBits w, cmmBits w]+  MO_U_QuotRem w -> [cmmBits w, cmmBits w]+  MO_U_QuotRem2 w -> [cmmBits w, cmmBits w]+  MO_Add2      w -> [cmmBits w, cmmBits w]+  MO_AddWordC  w -> [cmmBits w, cmmBits w]+  MO_SubWordC  w -> [cmmBits w, cmmBits w]+  MO_AddIntC   w -> [cmmBits w, cmmBits w]+  MO_SubIntC   w -> [cmmBits w, cmmBits w]+  MO_U_Mul2    w -> [cmmBits w, cmmBits w]+  MO_VS_Quot l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)]+  MO_VS_Rem  l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)]+  MO_VU_Quot l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)]+  MO_VU_Rem  l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)]+  MO_I64X2_Min -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)]+  MO_I64X2_Max -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)]+  MO_W64X2_Min -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)]+  MO_W64X2_Max -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)]+  MO_Touch -> [gcWord platform]+  MO_Prefetch_Data _n -> [addr]+  MO_Memcpy _align -> [addr, addr, bWord platform]+  MO_Memset _align ->+    [ addr+    , bWord platform -- byte to set: supplied as an int, converted to a byte+    , bWord platform]+  MO_Memmove _align -> [addr, addr, bWord platform]+  MO_Memcmp _align -> [addr, addr, bWord platform]+  MO_PopCnt w ->+    case w of+      W64 -> [cmmBits W64]+      _   -> [bWord platform]+  MO_Pdep w ->+    case w of+      W64 -> [cmmBits W64, cmmBits W64]+      _   -> [bWord platform, bWord platform]+  MO_Pext w ->+    case w of+      W64 -> [cmmBits W64, cmmBits W64]+      _   -> [bWord platform, bWord platform]+  MO_Clz w ->+    case w of+      W64 -> [cmmBits W64]+      _   -> [bWord platform]+  MO_Ctz w ->+    case w of+      W64 -> [cmmBits W64]+      _   -> [bWord platform]+  MO_BSwap w ->+    case w of+      W64 -> [cmmBits W64]+      _   -> [bWord platform]+  MO_BRev w ->+    case w of+      W64 -> [cmmBits W64]+      _   -> [bWord platform]+  MO_AcquireFence -> []+  MO_ReleaseFence -> []+  MO_SeqCstFence -> []+  MO_AtomicRMW w _op -> [addr, cmmBits w]+  MO_AtomicRead _w _mem_ordering -> [addr]+  MO_AtomicWrite w _mem_ordering -> [addr, cmmBits w]+  MO_Cmpxchg w -> [addr, cmmBits w, cmmBits w]+  MO_Xchg w -> [addr, cmmBits w]+  MO_SuspendThread -> []+  MO_ResumeThread -> []+  where+    addr = bWord platform
compiler/GHC/Cmm/Type.hs view
@@ -57,12 +57,14 @@   deriving Show  data CmmCat                -- "Category" (not exported)-   = GcPtrCat              -- GC pointer-   | BitsCat               -- Non-pointer-   | FloatCat              -- Float-   | VecCat Length CmmCat  -- Vector+   = GcPtrCat              -- ^ GC pointer+   | BitsCat               -- ^ Integer (including non-GC pointer addresses)+                           --+                           -- Makes no distinction between signed and unsigned integers,+                           -- see Note [Signed vs unsigned] in GHC.Cmm.Type.+   | FloatCat              -- ^ Float+   | VecCat Length CmmCat  -- ^ Vector    deriving( Eq, Show )-        -- See Note [Signed vs unsigned] at the end  instance Outputable CmmType where   ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid)
compiler/GHC/Cmm/Utils.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- ----------------------------------------------------------------------------- -- -- Cmm utilities.@@ -83,6 +81,7 @@  import Data.ByteString (ByteString) import qualified Data.ByteString as BS+import Data.Foldable (toList) import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Block@@ -520,14 +519,12 @@  -- | like 'toBlockList', but the entry block always comes first toBlockListEntryFirst :: CmmGraph -> [CmmBlock]-toBlockListEntryFirst g-  | mapNull m  = []-  | otherwise  = entry_block : others+toBlockListEntryFirst g = do+    entry_block <- toList $ mapLookup entry_id m+    entry_block : filter ((/= entry_id) . entryLabel) (mapElems m)   where     m = toBlockMap g     entry_id = g_entry g-    Just entry_block = mapLookup entry_id m-    others = filter ((/= entry_id) . entryLabel) (mapElems m)  -- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks -- so that the false case of a conditional jumps to the next block in the output@@ -538,13 +535,10 @@ -- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode -- defined in "GHC.Cmm.Node". -GBM toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]-toBlockListEntryFirstFalseFallthrough g-  | mapNull m  = []-  | otherwise  = dfs setEmpty [entry_block]+toBlockListEntryFirstFalseFallthrough g = dfs setEmpty $ toList $ mapLookup entry_id m   where     m = toBlockMap g     entry_id = g_entry g-    Just entry_block = mapLookup entry_id m      dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]     dfs _ [] = []
compiler/GHC/CmmToLlvm/Version/Bounds.hs view
@@ -16,4 +16,4 @@  -- | The (not-inclusive) upper bound  bound on the LLVM Version that is currently supported. supportedLlvmVersionUpperBound :: LlvmVersion-supportedLlvmVersionUpperBound = LlvmVersion (20 NE.:| [])+supportedLlvmVersionUpperBound = LlvmVersion (21 NE.:| [])
compiler/GHC/Core.hs view
@@ -14,9 +14,10 @@          -- * In/Out type synonyms         InId, InBind, InExpr, InAlt, InArg, InType, InKind,-               InBndr, InVar, InCoercion, InTyVar, InCoVar,+               InBndr, InVar, InCoercion, InTyVar, InCoVar, InTyCoVar,         OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutKind,-               OutBndr, OutVar, OutCoercion, OutTyVar, OutCoVar, MOutCoercion,+               OutBndr, OutVar, OutCoercion, OutTyVar, OutCoVar,+               OutTyCoVar, MOutCoercion,          -- ** 'Expr' construction         mkLet, mkLets, mkLetNonRec, mkLetRec, mkLams,@@ -38,11 +39,11 @@         isId, cmpAltCon, cmpAlt, ltAlt,          -- ** Simple 'Expr' access functions and predicates-        bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,+        bindersOf, bindersOfBinds, rhssOfBind, rhssOfBinds, rhssOfAlts,         foldBindersOfBindStrict, foldBindersOfBindsStrict,         collectBinders, collectTyBinders, collectTyAndValBinders,         collectNBinders, collectNValBinders_maybe,-        collectArgs, stripNArgs, collectArgsTicks, flattenBinds,+        collectArgs, collectValArgs, stripNArgs, collectArgsTicks, flattenBinds,         collectFunSimple,          exprToType,@@ -59,7 +60,7 @@         unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk,          -- ** Predicates and deconstruction on 'Unfolding'-        unfoldingTemplate, expandUnfolding_maybe,+        expandUnfolding_maybe,         maybeUnfoldingTemplate, otherCons,         isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,         isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,@@ -115,8 +116,12 @@  import Data.Data hiding (TyCon) import Data.Int+import Data.List.NonEmpty (nonEmpty)+import qualified Data.List.NonEmpty as NE import Data.Word +import Control.DeepSeq+ infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps` -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys) @@ -1029,6 +1034,73 @@ operationally, casts are vacuous, so this is a bit unfortunate! See #14610 for ideas how to fix this. +Note [Strict fields in Core]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Core, evaluating a data constructor worker evaluates its strict fields.++In other words, let's say we have the following data type++  data T a b = MkT !a b++Now if `xs` reduces to `error "boom"`, then `MkT xs b` will throw that error.+Consequently, it is sound to seq the field before the call to the constructor,+e.g., with `case xs of xs' { __DEFAULT -> MkT xs' b }`.+Let's call this transformation "field eval insertion".++Note in particular that the data constructor application `MkT xs b` above is+*not* a value, unless `xs` is!++This has pervasive effect on the Core pipeline:++(SFC1) `exprIsHNF`/`exprIsConLike`/`exprOkForSpeculation` need to assert that the+    strict arguments of a DataCon worker are values/ok-for-spec themselves.++(SFC2) `exprIsConApp_maybe` inserts field evals in the `FloatBind`s it returns, so+    that the Simplifier, Constant-folding, the pattern-match checker, etc. all+    see the inserted field evals when they match on strict workers.++    For example,+      exprIsConApp_maybe (MkT e1 e2)+        = Just ([FloatCase e1 x], MkT, [x,e2])+    Meaning that (MkT e1 e2) is indeed a data constructor application, but if+    you want to decompose it (which is the purpose of exprIsConApp_maybe) you+    must evaluate e1 first.+    In case of case-of-known constructor, we get the rewrite+      case MkT e1 e2 of MkT xs' b' -> b'+      ==>+      case e1 of xs' { __DEFAULT -> e2 }+    which crucially retains the eval on e1.++(SFC3) The demand signature of a data constructor is strict in strict field+    position and lazy in non-strict fields. Likewise the demand *transformer*+    of a DataCon worker can stricten up demands on strict field args.+    See Note [Demand transformer for data constructors].++(SFC4) In the absence of `-fpedantic-bottoms`, it is still possible that some seqs+    are ultimately dropped or delayed due to eta-expansion.+    See Note [Dealing with bottom].++Strict field semantics is exploited and lowered in STG during EPT enforcement;+see Note [EPT enforcement lowers strict constructor worker semantics] for the+connection.++It might be tempting to think that strict fields could be implemented in terms+of unlifted fields. However, unlifted fields behave differently when the data+constructor is partially applied; see Note [exprIsHNF for function applications]+for an example.++Historical Note:+The delightfully simple description of strict field semantics is the result of+a long saga (#20749, the bits about strict data constructors in #21497, #22475),+where we tried a more lenient (but actually not) semantics first that would+allow both strict and lazy implementations of DataCon workers. This was favoured+because the "pervasive effect" throughout the compiler was deemed too large+(when it really turned out to be quite modest).+Alas, this semantics would require us to implement `exprIsHNF` in *exactly* the+same way as above, otherwise the analysis would not be conservative wrt. the+lenient semantics (which includes the strict one). It is also much harder to+explain and maintain, as it turned out.+ ************************************************************************ *                                                                      *             In/Out type synonyms@@ -1097,11 +1169,9 @@ -- -- NB: 'minimum' use Ord, and (Ord OccName) works lexicographically ---chooseOrphanAnchor local_names-  | isEmptyNameSet local_names = IsOrphan-  | otherwise                  = NotOrphan (minimum occs)-  where-    occs = map nameOccName $ nonDetEltsUniqSet local_names+chooseOrphanAnchor local_names = case nonEmpty $ nonDetEltsUniqSet local_names of+    Nothing -> IsOrphan+    Just local_names -> NotOrphan (minimum (NE.map nameOccName local_names))     -- It's OK to use nonDetEltsUFM here, see comments above  instance Binary IsOrphan where@@ -1117,6 +1187,10 @@                 n <- get bh                 return $ NotOrphan n +instance NFData IsOrphan where+  rnf IsOrphan = ()+  rnf (NotOrphan n) = rnf n+ {- Note [Orphans] ~~~~~~~~~~~~~~@@ -1267,7 +1341,7 @@  -- | The number of arguments the 'ru_fn' must be applied -- to before the rule can match on it-ruleArity :: CoreRule -> Int+ruleArity :: CoreRule -> FullArgCount ruleArity (BuiltinRule {ru_nargs = n}) = n ruleArity (Rule {ru_args = args})      = length args @@ -1287,7 +1361,8 @@ ruleIdName = ru_fn  isLocalRule :: CoreRule -> Bool-isLocalRule = ru_local+isLocalRule (BuiltinRule {})               = False+isLocalRule (Rule { ru_local = is_local }) = is_local  -- | Set the 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side setRuleIdName :: Name -> CoreRule -> CoreRule@@ -1513,10 +1588,6 @@ mkOtherCon :: [AltCon] -> Unfolding mkOtherCon = OtherCon --- | 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 when specialising, and we do -- want to specialise DFuns, so it's important to return a template@@ -2083,6 +2154,11 @@ rhssOfBind (NonRec _ rhs) = [rhs] rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs] +rhssOfBinds :: [Bind b] -> [Expr b]+rhssOfBinds []             = []+rhssOfBinds (NonRec _ rhs : bs) = rhs : rhssOfBinds bs+rhssOfBinds (Rec pairs    : bs) = map snd pairs ++ rhssOfBinds bs+ rhssOfAlts :: [Alt b] -> [Expr b] rhssOfAlts alts = [e | Alt _ _ e <- alts] @@ -2156,6 +2232,17 @@   = go expr []   where     go (App f a) as = go f (a:as)+    go e         as = (e, as)++-- | Takes a nested application expression and returns the function+-- being applied and the arguments to which it is applied+collectValArgs :: Expr b -> (Expr b, [Arg b])+collectValArgs expr+  = go expr []+  where+    go (App f a) as+      | isValArg a  = go f (a:as)+      | otherwise   = go f as     go e         as = (e, as)  -- | Takes a nested application expression and returns the function
compiler/GHC/Core/Class.hs view
@@ -18,7 +18,12 @@         classKey, className, classATs, classATItems, classTyCon, classMethods,         classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,         classHasSCs, classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef,-        classHasFds, isAbstractClass,+        classHasFds,++        -- Predicates+        -- NB: other isXXlass predicates are defined in GHC.Core.Predicate+        --     to avoid module loops+        isAbstractClass     ) where  import GHC.Prelude@@ -26,6 +31,7 @@ import {-# SOURCE #-} GHC.Core.TyCon    ( TyCon ) import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, PredType ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType )+import GHC.Hs.Extension (GhcRn) import GHC.Types.Var import GHC.Types.Name import GHC.Types.Basic@@ -35,7 +41,7 @@ import GHC.Types.SrcLoc import GHC.Types.Var.Set import GHC.Utils.Outputable-import GHC.Data.BooleanFormula (BooleanFormula, mkTrue)+import Language.Haskell.Syntax.BooleanFormula ( BooleanFormula, mkTrue )  import qualified Data.Data as Data @@ -131,7 +137,7 @@       -- Note [Type-checking default assoc decls] in GHC.Tc.TyCl.     } -type ClassMinimalDef = BooleanFormula Name -- Required methods+type ClassMinimalDef = BooleanFormula GhcRn -- Required methods  data ClassBody   = AbstractClass
compiler/GHC/Core/Coercion.hs view
@@ -41,18 +41,15 @@         mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo,         mkFunCo, mkFunCo2, mkFunCoNoFTF, mkFunResCo,         mkNakedFunCo,-        mkNakedForAllCo, mkForAllCo, mkHomoForAllCos,-        mkPhantomCo,+        mkNakedForAllCo, mkForAllCo, mkForAllVisCos, mkHomoForAllCos,+        mkPhantomCo, mkAxiomCo,         mkHoleCo, mkUnivCo, mkSubCo,         mkProofIrrelCo,-        downgradeRole, mkAxiomCo,+        downgradeRole,         mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo,         mkKindCo,         castCoercionKind, castCoercionKind1, castCoercionKind2, -        mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,-        mkNomPrimEqPred,-         -- ** Decomposition         instNewTyCon_maybe, @@ -96,9 +93,10 @@         liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx,         emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope,         liftCoSubstVarBndrUsing, isMappedByLC, extendLiftingContextCvSubst,+        updateLCSubst,          mkSubstLiftingContext, liftingContextSubst, zapLiftingContext,-        substForAllCoBndrUsingLC, lcLookupCoVar, lcInScopeSet,+        lcLookupCoVar, lcInScopeSet,          LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight,         substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight,@@ -123,8 +121,7 @@          multToCo, mkRuntimeRepCo, -        hasCoercionHoleTy, hasCoercionHoleCo, hasThisCoercionHoleTy,-+        hasCoercionHole,         setCoHoleType        ) where @@ -140,6 +137,7 @@ import GHC.Core.TyCo.Tidy import GHC.Core.TyCo.Compare import GHC.Core.Type+import GHC.Core.Predicate( mkNomEqPred, mkReprEqPred ) import GHC.Core.TyCon import GHC.Core.TyCon.RecWalk import GHC.Core.Coercion.Axiom@@ -168,6 +166,7 @@ import Data.Function ( on ) import Data.Char( isDigit ) import qualified Data.Monoid as Monoid+import Data.List.NonEmpty ( NonEmpty (..) ) import Control.DeepSeq  {-@@ -250,14 +249,14 @@ ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc)                  -> TyCon -> CoAxBranch -> SDoc ppr_co_ax_branch ppr_rhs fam_tc branch-  = foldr1 (flip hangNotEmpty 2)-    [ pprUserForAll (mkForAllTyBinders Inferred bndrs')+  = foldr1 (flip hangNotEmpty 2) $+    pprUserForAll (mkForAllTyBinders Inferred bndrs') :|          -- See Note [Printing foralls in type family instances] in GHC.Iface.Type-    , pp_lhs <+> ppr_rhs tidy_env ee_rhs-    , vcat [ text "-- Defined" <+> pp_loc+    (pp_lhs <+> ppr_rhs tidy_env ee_rhs) :+    ( vcat [ text "-- Defined" <+> pp_loc            , ppUnless (null incomps) $ whenPprDebug $-             text "-- Incomps:" <+> vcat (map (pprCoAxBranch fam_tc) incomps) ]-    ]+             text "-- Incomps:" <+> vcat (map (pprCoAxBranch fam_tc) incomps) ] ) :+    []   where     incomps = coAxBranchIncomps branch     loc = coAxBranchSpan branch@@ -950,6 +949,15 @@   | otherwise   = mkForAllCo_NoRefl v visL visR kind_co co +-- mkForAllVisCos [tv{vis}] constructs a cast+--   forall tv. res  ~R#   forall tv{vis} res`.+-- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep+mkForAllVisCos :: HasDebugCallStack => [ForAllTyBinder] -> Coercion -> Coercion+mkForAllVisCos bndrs orig_co = foldr go orig_co bndrs+  where+    go (Bndr tv vis)+      = mkForAllCo tv coreTyLamForAllTyFlag vis (mkNomReflCo (varType tv))+ -- | Make a Coercion quantified over a type/coercion variable; -- the variable has the same kind and visibility in both sides of the coercion mkHomoForAllCos :: [ForAllTyBinder] -> Coercion -> Coercion@@ -1742,7 +1750,7 @@   = mkFunCoNoFTF role mult arg_co res_co   where     arg_co = mkReflCo role (varType id)-    mult   = multToCo (varMult id)+    mult   = multToCo (idMult id)  -- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2 -- The first coercion might be lifted or unlifted; thus the ~? above@@ -2015,20 +2023,20 @@      -- Also maps coercion variables to ProofIrrelCos.  -- like liftCoSubstWith, but allows for existentially-bound types as well-liftCoSubstWithEx :: Role          -- desired role for output coercion-                  -> [TyVar]       -- universally quantified tyvars+liftCoSubstWithEx :: [TyVar]       -- universally quantified tyvars                   -> [Coercion]    -- coercions to substitute for those                   -> [TyCoVar]     -- existentially quantified tycovars                   -> [Type]        -- types and coercions to be bound to ex vars-                  -> (Type -> Coercion, [Type]) -- (lifting function, converted ex args)-liftCoSubstWithEx role univs omegas exs rhos-  = let theta = mkLiftingContext (zipEqual "liftCoSubstWithExU" univs omegas)-        psi   = extendLiftingContextEx theta (zipEqual "liftCoSubstWithExX" exs rhos)-    in (ty_co_subst psi role, substTys (lcSubstRight psi) (mkTyCoVarTys exs))+                  -> (Type -> CoercionR, [Type]) -- (lifting function, converted ex args)+                      -- Returned coercion has Representational role+liftCoSubstWithEx univs omegas exs rhos+  = let theta = mkLiftingContext (zipEqual univs omegas)+        psi   = extendLiftingContextEx theta (zipEqual exs rhos)+    in (ty_co_subst psi Representational, substTys (lcSubstRight psi) (mkTyCoVarTys exs))  liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion liftCoSubstWith r tvs cos ty-  = liftCoSubst r (mkLiftingContext $ zipEqual "liftCoSubstWith" tvs cos) ty+  = liftCoSubst r (mkLiftingContext $ zipEqual tvs cos) ty  -- | @liftCoSubst role lc ty@ produces a coercion (at role @role@) -- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where@@ -2129,15 +2137,11 @@ zapLiftingContext :: LiftingContext -> LiftingContext zapLiftingContext (LC subst _) = LC (zapSubst subst) emptyVarEnv --- | Like 'substForAllCoBndr', but works on a lifting context-substForAllCoBndrUsingLC :: SwapFlag-                         -> (Coercion -> Coercion)-                         -> LiftingContext -> TyCoVar -> Coercion-                         -> (LiftingContext, TyCoVar, Coercion)-substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co-  = (LC subst' lc_env, tv', co')+updateLCSubst :: LiftingContext -> (Subst -> (Subst, a)) -> (LiftingContext, a)+-- Lift a Subst-update function over LiftingContext+updateLCSubst (LC subst lc_env) upd = (LC subst' lc_env, res)   where-    (subst', tv', co') = substForAllCoBndrUsing sym sco subst tv co+    (subst', res) = upd subst  -- | The \"lifting\" operation which substitutes coercions for type --   variables in a type to produce a coercion.@@ -2155,7 +2159,7 @@     go r ty                 | Just ty' <- coreView ty                             = go r ty'     go Phantom ty           = lift_phantom ty-    go r (TyVarTy tv)       = expectJust "ty_co_subst bad roles" $+    go r (TyVarTy tv)       = expectJust $                               liftCoSubstTyVar lc r tv     go r (AppTy ty1 ty2)    = mkAppCo (go r ty1) (go Nominal ty2)     go r (TyConApp tc tys)  = mkTyConAppCo r tc (zipWith go (tyConRoleListX r tc) tys)@@ -2285,7 +2289,7 @@     stuff    = fun lc old_kind     eta      = view_co stuff     k1       = coercionLKind eta-    new_var  = uniqAway (getSubstInScope subst) (setVarType old_var k1)+    new_var  = uniqAway (substInScopeSet subst) (setVarType old_var k1)      lifted   = mkGReflRightCo Nominal (TyVarTy new_var) eta                -- :: new_var ~ new_var |> eta@@ -2305,7 +2309,7 @@     stuff    = fun lc old_kind     eta      = view_co stuff     k1       = coercionLKind eta-    new_var  = uniqAway (getSubstInScope subst) (setVarType old_var k1)+    new_var  = uniqAway (substInScopeSet subst) (setVarType old_var k1)      -- old_var :: s1  ~r s2     -- eta     :: (s1' ~r s2') ~N (t1 ~r t2)@@ -2389,7 +2393,7 @@  -- | Get the 'InScopeSet' from a 'LiftingContext' lcInScopeSet :: LiftingContext -> InScopeSet-lcInScopeSet (LC subst _) = getSubstInScope subst+lcInScopeSet (LC subst _) = substInScopeSet subst  {- %************************************************************************@@ -2667,45 +2671,14 @@ -- | Makes a coercion type from two types: the types whose equality -- is proven by the relevant 'Coercion' mkCoercionType :: Role -> Type -> Type -> Type-mkCoercionType Nominal          = mkPrimEqPred-mkCoercionType Representational = mkReprPrimEqPred+mkCoercionType Nominal          = mkNomEqPred+mkCoercionType Representational = mkReprEqPred mkCoercionType Phantom          = \ty1 ty2 ->   let ki1 = typeKind ty1       ki2 = typeKind ty2   in   TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2] --- | Creates a primitive nominal type equality predicate.---      t1 ~# t2--- Invariant: the types are not Coercions-mkPrimEqPred :: Type -> Type -> Type-mkPrimEqPred ty1 ty2-  = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2]-  where-    k1 = typeKind ty1-    k2 = typeKind ty2---- | Creates a primitive representational type equality predicate.---      t1 ~R# t2--- Invariant: the types are not Coercions-mkReprPrimEqPred :: Type -> Type -> Type-mkReprPrimEqPred ty1  ty2-  = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2]-  where-    k1 = typeKind ty1-    k2 = typeKind ty2---- | Makes a lifted equality predicate at the given role-mkPrimEqPredRole :: Role -> Type -> Type -> PredType-mkPrimEqPredRole Nominal          = mkPrimEqPred-mkPrimEqPredRole Representational = mkReprPrimEqPred-mkPrimEqPredRole Phantom          = panic "mkPrimEqPredRole phantom"---- | Creates a primitive nominal type equality predicate with an explicit---   (but homogeneous) kind: (~#) k k ty1 ty2-mkNomPrimEqPred :: Kind -> Type -> Type -> Type-mkNomPrimEqPred k ty1 ty2 = mkTyConApp eqPrimTyCon [k, k, ty1, ty2]- -- | Assuming that two types are the same, ignoring coercions, find -- a nominal coercion between the types. This is useful when optimizing -- transitivity over coercion applications, where splitting two@@ -2813,39 +2786,22 @@ -}  has_co_hole_ty :: Type -> Monoid.Any-has_co_hole_co :: Coercion -> Monoid.Any-(has_co_hole_ty, _, has_co_hole_co, _)+(has_co_hole_ty, _, _, _)   = foldTyCo folder ()   where     folder = TyCoFolder { tcf_view  = noView                         , tcf_tyvar = const2 (Monoid.Any False)                         , tcf_covar = const2 (Monoid.Any False)-                        , tcf_hole  = \_ hole -> Monoid.Any (isHeteroKindCoHole hole)+                        , tcf_hole  = \_ _ -> Monoid.Any True                         , tcf_tycobinder = const2                         } --- | Is there a hetero-kind coercion hole in this type?---   (That is, a coercion hole with ch_hetero_kind=True.)--- See wrinkle (EIK2) of Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality-hasCoercionHoleTy :: Type -> Bool-hasCoercionHoleTy = Monoid.getAny . has_co_hole_ty---- | Is there a hetero-kind coercion hole in this coercion?-hasCoercionHoleCo :: Coercion -> Bool-hasCoercionHoleCo = Monoid.getAny . has_co_hole_co--hasThisCoercionHoleTy :: Type -> CoercionHole -> Bool-hasThisCoercionHoleTy ty hole = Monoid.getAny (f ty)-  where-    (f, _, _, _) = foldTyCo folder ()--    folder = TyCoFolder { tcf_view  = noView-                        , tcf_tyvar = const2 (Monoid.Any False)-                        , tcf_covar = const2 (Monoid.Any False)-                        , tcf_hole  = \ _ h -> Monoid.Any (getUnique h == getUnique hole)-                        , tcf_tycobinder = const2-                        }+-- | Is there a coercion hole in this type?+-- See wrinkle (DE6) of Note [Defaulting equalities] in GHC.Tc.Solver.Default+hasCoercionHole :: Type -> Bool+hasCoercionHole = Monoid.getAny . has_co_hole_ty  -- | Set the type of a 'CoercionHole' setCoHoleType :: CoercionHole -> Type -> CoercionHole setCoHoleType h t = setCoHoleCoVar h (setVarType (coHoleCoVar h) t)+
compiler/GHC/Core/Coercion/Axiom.hs view
@@ -58,6 +58,7 @@ import qualified Data.Data as Data import Data.Array import Data.List ( mapAccumL )+import Control.DeepSeq  {- Note [Coercion axiom branches]@@ -558,6 +559,11 @@                           2 -> return Representational                           3 -> return Phantom                           _ -> panic ("get Role " ++ show tag)++instance NFData Role where+  rnf Nominal = ()+  rnf Representational = ()+  rnf Phantom = ()  {- ************************************************************************
compiler/GHC/Core/Coercion/Opt.hs view
@@ -208,10 +208,12 @@     in     warnPprTrace (not (isReflCo out_co) && isReflexiveCo out_co)                  "optCoercion: reflexive but not refl" details $---    assertPpr (substTyUnchecked env in_ty1 `eqType` out_ty1 &&---               substTyUnchecked env in_ty2 `eqType` out_ty2 &&---               in_role == out_role)---              (hang (text "optCoercion changed types!") 2 details) $+    -- The coercion optimiser should usually optimise+    --     co:ty~ty   -->  Refl ty+    -- But given a silly `newtype N = MkN N`, the axiom has type (N ~ N),+    -- and so that can trigger this warning (e.g. test str002).+    -- Maybe we should optimise that coercion to (Refl N), but it+    -- just doesn't seem worth the bother     out_co    | otherwise@@ -356,12 +358,12 @@             (opt_co4 env sym False Nominal co2)  opt_co4' env sym rep r (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR-                                , fco_kind = k_co, fco_body = co })-  = case optForAllCoBndr env sym tv k_co of-      (env', tv', k_co') -> mkForAllCo tv' visL' visR' k_co' $-                            opt_co4 env' sym rep r co+                                 , fco_kind = k_co, fco_body = co })+  = mkForAllCo tv' visL' visR' k_co' $+    opt_co4 env' sym rep r co      -- Use the "mk" functions to check for nested Refls   where+    !(env', tv', k_co') = optForAllCoBndr env sym tv k_co     !(visL', visR') = swapSym sym (visL, visR)  opt_co4' env sym rep r (FunCo _r afl afr cow co1 co2)@@ -687,7 +689,7 @@  ------------- opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]-opt_transList is = zipWithEqual "opt_transList" (opt_trans is)+opt_transList is = zipWithEqual (opt_trans is)   -- The input lists must have identical length.  opt_trans :: HasDebugCallStack => InScopeSet -> NormalCo -> NormalCo -> NormalCo@@ -1113,7 +1115,7 @@   :: Equal (Id Int) (Id Bool) ~ False  which is bogus! This is because the type system isn't smart enough to know-that (Id Int) and (Id Bool) are Surely Apart, as they're headed by type+that (Id Int) and (Id Bool) are SurelyApart, as they're headed by type families. At the time of writing, I (Richard Eisenberg) couldn't think of a way of detecting this any more efficient than just building the optimised coercion and checking.@@ -1399,10 +1401,68 @@  -} +{- Note [Optimising ForAllCo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If sym=NotSwapped, optimising ForAllCo is relatively easy:+   opt env (ForAllCo tcv kco bodyco)+     = ForAllCo tcv' (opt env kco) (opt env' bodyco)+     where+       (env', tcv') = substBndr env tcv++Just apply the substitution to the kind of the binder, deal with+shadowing etc, and recurse.  Remember in (ForAllCo tcv kco bodyco)+    varKind tcv = coercionLKind kco++But if sym=Swapped, things are trickier.  Here is an identity that helps:+   Sym (ForAllCo (tv:k1) (kco:k1~k2) bodyco)+   = ForAllCo (tv:k2) (Sym kco : k2~k1)+              (Sym (bodyco[tv:->tv:k2 |> Sym kco]))++* We re-type tv:k1 to become tv:k2.+* We push Sym into kco+* We push Sym into bodyco+* BUT we must /also/ remember to replace all occurrences of+      of tv:k1 in bodyco by (tv:k2 |> Sym kco)+  This mirrors what happens in the typing rule for ForAllCo+  See Note [ForAllCo] in GHC.Core.TyCo.Rep++-} optForAllCoBndr :: LiftingContext -> SwapFlag-                -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion)-optForAllCoBndr env sym-  = substForAllCoBndrUsingLC sym (opt_co4 env sym False Nominal) env+                -> TyCoVar -> Coercion+                -> (LiftingContext, TyCoVar, Coercion)+-- See Note [Optimising ForAllCo]+optForAllCoBndr env sym tcv kco+  = (env', tcv', kco')+  where+    kco' = opt_co4 env sym False Nominal kco  -- Push sym into kco+    (env', tcv') = updateLCSubst env upd_subst++    upd_subst :: Subst -> (Subst, TyCoVar)+    upd_subst subst+      | isTyVar tcv = upd_subst_tv subst+      | otherwise   = upd_subst_cv subst++    upd_subst_tv subst+      | notSwapped sym || isReflCo kco' = (subst1, tv1)+      | otherwise                       = (subst2, tv2)+      where+        -- subst1,tv1: apply the substitution to the binder and its kind+        -- NB: varKind tv = coercionLKind kco+        (subst1, tv1) = substTyVarBndr subst tcv+        -- In the Swapped case, we re-kind the type variable, AND+        -- override the substitution for the original variable to the+        -- re-kinded one, suitably casted+        tv2    = tv1 `setTyVarKind` coercionLKind kco'+        subst2 = (extendTvSubst subst1 tcv (mkTyVarTy tv2 `CastTy` kco'))+                 `extendSubstInScope` tv2++    upd_subst_cv subst   -- ToDo: probably not right yet+      | notSwapped sym || isReflCo kco' = (subst1, cv1)+      | otherwise                       = (subst2, cv2)+      where+        (subst1, cv1) = substCoVarBndr subst tcv+        cv2    = cv1 `setTyVarKind` coercionLKind kco'+        subst2 = subst1 `extendSubstInScope` cv2   {- **********************************************************************
compiler/GHC/Core/ConLike.hs view
@@ -12,6 +12,7 @@         , conLikeConLikeName         , isVanillaConLike         , conLikeArity+        , conLikeVisArity         , conLikeFieldLabels         , conLikeConInfo         , conLikeInstOrigArgTys@@ -23,7 +24,6 @@         , conLikeFullSig         , conLikeResTy         , conLikeFieldType-        , conLikesWithFields         , conLikeIsInfix         , conLikeHasBuilder     ) where@@ -48,7 +48,6 @@  import Data.Maybe( isJust ) import qualified Data.Data as Data-import qualified Data.List as List  {- ************************************************************************@@ -114,11 +113,16 @@     gunfold _ _  = error "gunfold"     dataTypeOf _ = mkNoRepType "ConLike" --- | Number of arguments+-- | Number of value arguments conLikeArity :: ConLike -> Arity conLikeArity (RealDataCon data_con) = dataConSourceArity data_con conLikeArity (PatSynCon pat_syn)    = patSynArity pat_syn +-- | Number of visible arguments+conLikeVisArity :: ConLike -> VisArity+conLikeVisArity (RealDataCon data_con) = dataConVisArity data_con+conLikeVisArity (PatSynCon pat_syn)    = patSynVisArity pat_syn+ -- | Names of fields used for selectors conLikeFieldLabels :: ConLike -> [FieldLabel] conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con@@ -149,10 +153,11 @@ -- followed by the existentially quantified type variables. For data -- constructors, the situation is slightly more complicated—see -- @Note [DataCon user type variable binders]@ in "GHC.Core.DataCon".-conLikeUserTyVarBinders :: ConLike -> [InvisTVBinder]+conLikeUserTyVarBinders :: ConLike -> [TyVarBinder] conLikeUserTyVarBinders (RealDataCon data_con) =     dataConUserTyVarBinders data_con conLikeUserTyVarBinders (PatSynCon pat_syn) =+    tyVarSpecToBinders $     patSynUnivTyVarBinders pat_syn ++ patSynExTyVarBinders pat_syn     -- The order here is because of the order in `GHC.Tc.TyCl.PatSyn`. @@ -230,15 +235,6 @@ conLikeFieldType :: ConLike -> FieldLabelString -> Type conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label----- | The ConLikes that have *all* the given fields-conLikesWithFields :: [ConLike] -> [FieldLabelString]-                   -> ( [ConLike]   -- ConLikes containing the fields-                      , [ConLike] ) -- ConLikes not containing the fields-conLikesWithFields con_likes lbls = List.partition has_flds con_likes-  where has_flds dc = all (has_fld dc) lbls-        has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc)  conLikeIsInfix :: ConLike -> Bool conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc
compiler/GHC/Core/DataCon.hs view
@@ -12,7 +12,7 @@         -- * Main data types         DataCon, DataConRep(..),         SrcStrictness(..), SrcUnpackedness(..),-        HsSrcBang(..), HsBang(..), HsImplBang(..),+        HsSrcBang(..), HsImplBang(..),         StrictnessMark(..),         ConTag,         DataConEnv,@@ -25,7 +25,7 @@         FieldLabel(..), flLabel, FieldLabelString,          -- ** Type construction-        mkHsSrcBang, mkDataCon, fIRST_TAG,+        mkDataCon, fIRST_TAG,          -- ** Type deconstruction         dataConRepType, dataConInstSig, dataConFullSig,@@ -45,22 +45,24 @@         dataConInstUnivs,         dataConFieldLabels, dataConFieldType, dataConFieldType_maybe,         dataConSrcBangs,-        dataConSourceArity, dataConRepArity,+        dataConSourceArity, dataConVisArity, dataConRepArity,         dataConIsInfix,         dataConWorkId, dataConWrapId, dataConWrapId_maybe,         dataConImplicitTyThings,-        dataConRepStrictness, dataConImplBangs, dataConBoxer,+        dataConRepStrictness,+        dataConImplBangs, dataConBoxer,          splitDataProductType_maybe,          -- ** Predicates on DataCons         isNullarySrcDataCon, isNullaryRepDataCon,+        isLazyDataConRep,         isTupleDataCon, isBoxedTupleDataCon, isUnboxedTupleDataCon,-        isUnboxedSumDataCon, isCovertGadtDataCon,+        isUnboxedSumDataCon, isCovertGadtDataCon, isUnaryClassDataCon,         isVanillaDataCon, isNewDataCon, isTypeDataCon,         classDataCon, dataConCannotMatch,-        dataConUserTyVarsNeedWrapper, checkDataConTyVars,-        isBanged, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked,+        dataConUserTyVarBindersNeedWrapper, checkDataConTyVars,+        isBanged, isUnpacked, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked,         specialPromotedDc,          -- ** Promotion related functions@@ -78,7 +80,7 @@ import GHC.Core.Unify import GHC.Core.TyCon import GHC.Core.TyCo.Subst-import GHC.Core.TyCo.Compare( eqType )+import GHC.Core.TyCo.Compare( eqType, eqForAllVis ) import GHC.Core.Multiplicity import {-# SOURCE #-} GHC.Types.TyThing import GHC.Types.FieldLabel@@ -110,6 +112,7 @@ import qualified Data.Data as Data import Data.Char import Data.List( find )+import Control.DeepSeq  {- Note [Data constructor representation]@@ -460,7 +463,7 @@         --    with the set of dcUnivTyVars whose tyvars do not appear in dcEqSpec         -- So dcUserTyVarBinders is a subset of (dcUnivTyVars ++ dcExTyCoVars)         -- See Note [DataCon user type variable binders]-        dcUserTyVarBinders :: [InvisTVBinder],+        dcUserTyVarBinders :: [TyVarBinder],          dcEqSpec :: [EqSpec],   -- Equalities derived from the result type,                                 -- _as written by the programmer_.@@ -519,6 +522,18 @@                 -- Matches 1-1 with dcOrigArgTys                 -- Hence length = dataConSourceArity dataCon +        dcImplBangs :: [HsImplBang],+                -- The actual decisions made (including failures)+                -- about the original arguments; 1-1 with orig_arg_tys+                -- See Note [Bangs on data constructor arguments]++        dcStricts :: [StrictnessMark],+                -- One mark for every field of the DataCon worker;+                -- if it's empty, then all fields are lazy,+                -- otherwise 1-1 with dataConRepArgTys.+                -- See also Note [Strict fields in Core] in GHC.Core+                -- for the effect on the strictness signature+         dcFields  :: [FieldLabel],                 -- Field labels for this constructor, in the                 -- same order as the dcOrigArgTys;@@ -565,22 +580,8 @@   }  -{- Note [TyVarBinders in DataCons]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For the TyVarBinders in a DataCon and PatSyn,-each argument flag is either Inferred or Specified, never Required.-Lifting this restriction is tracked at #18389 (DataCon) and #23704 (PatSyn).--Why do we need the TyVarBinders, rather than just the TyVars?  So that-we can construct the right type for the DataCon with its foralls-attributed the correct visibility.  That in turn governs whether you-can use visible type application at a call of the data constructor.--See also [DataCon user type variable binders] for an extended discussion on the-order in which TyVarBinders appear in a DataCon.--Note [Existential coercion variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Existential coercion variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For now (Aug 2018) we can't write coercion quantifications in source Haskell, but we can in Core. Consider having: @@ -641,25 +642,42 @@ A DataCon has two different sets of type variables:  * dcUserTyVarBinders, for the type variables binders in the order in which they-  originally arose in the user-written type signature.+  originally arose in the user-written type signature, and with user-specified+  visibilities.    - They are the forall'd binders of the data con /wrapper/, which the user calls. -  - Their order *does* matter for TypeApplications, so they are full TyVarBinders,-    complete with visibilities.+  - With RequiredTypeArguments, some of the foralls may be visible, e.g.+      MkT :: forall a b. forall c -> (a, b, c) -> T a b c+    so the binders are full TyVarBinders, complete with visibilities. +  - Even if we only consider invisible foralls, the order and specificity of+    binders matter for TypeApplications.+ * dcUnivTyVars and dcExTyCoVars, for the "true underlying" (i.e. of the data   con worker) universal type variable and existential type/coercion variables,   respectively.    - They (i.e. univ ++ ex) are the forall'd variables of the data con /worker/ -  - Their order is irrelevant for the purposes of TypeApplications,-    and as a consequence, they do not come equipped with visibilities-    (that is, they are TyVars/TyCoVars instead of ForAllTyBinders).+  - They do not come equipped with visibilities:+        dcUnivTyVars :: [TyVar]     -- not [TyVarBinder]+        dcExTyCoVars :: [TyCoVar]   -- not [ForAllTyBinder]+    Instead, we treat them as having the Specified (coreTyLamForAllTyFlag)+    visibility. For example:+        wrapper type: forall {a} b. forall c -> ...+        worker type:  forall a b c. ...+    This is a design choice. Reasons:+      * Workers are never called by the user. They are part of the Core+        language where visibilities don't matter as much.+      * Consistency with type lambdas in Core. As Note [Required foralls in Core]+        in GHC.Core.TyCo.Rep explains, (/\a. e) :: (forall a. e_ty), and we need+        a coercion to cast it to (forall a -> e_ty).+    As a consequence, we may need to adjust visibilities with a cast in the+    wrapper. See Note [Flag cast in data con wrappers]. -Often (dcUnivTyVars ++ dcExTyCoVars) = dcUserTyVarBinders; but they may differ-for two reasons, coming next:+Often (dcUnivTyVars ++ dcExTyCoVars) = binderVars dcUserTyVarBinders; but they+may differ for two reasons, coming next:  --- Reason (R1): Order of quantification in GADT syntax --- @@ -821,13 +839,6 @@                                           -- after unboxing and flattening,                                           -- and *including* all evidence args -        , dcr_stricts :: [StrictnessMark]  -- 1-1 with dcr_arg_tys-                -- See also Note [Data-con worker strictness]--        , dcr_bangs :: [HsImplBang]  -- The actual decisions made (including failures)-                                     -- about the original arguments; 1-1 with orig_arg_tys-                                     -- See Note [Bangs on data constructor arguments]-     }  type DataConEnv a = UniqFM DataCon a     -- Keyed by DataCon@@ -839,14 +850,16 @@ -- Bangs on data constructor arguments as written by the user, including the -- source code for exact-printing. ----- In the AST, the SourceText is deconstructed and hidden inside--- 'Language.Haskell.Syntax.Extension.XBangTy' extension point.+-- @(HsSrcBang _ SrcUnpack SrcLazy)@ and+-- @(HsSrcBang _ SrcUnpack NoSrcStrict)@ (without StrictData) makes no sense, we+-- emit a warning (in checkValidDataCon) and treat it like+-- @(HsSrcBang _ NoSrcUnpack SrcLazy)@+--+-- In the AST, the @SourceText@ is hidden inside the extension point+-- 'Language.Haskell.Syntax.Extension.XConDeclField'. data HsSrcBang-  = HsSrcBang SourceText HsBang -- See Note [Pragma source text] in "GHC.Types.SourceText"---- | Make a 'HsSrcBang' from all parts-mkHsSrcBang :: SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang-mkHsSrcBang stext u s = HsSrcBang stext (HsBang u s)+  = HsSrcBang SourceText SrcUnpackedness SrcStrictness -- See Note [Pragma source text] in "GHC.Types.SourceText"+  deriving Data.Data  -- | Haskell Implementation Bang --@@ -889,49 +902,14 @@ eqSpecPair (EqSpec tv ty) = (tv, ty)  eqSpecPreds :: [EqSpec] -> ThetaType-eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty+eqSpecPreds spec = [ mkNomEqPred (mkTyVarTy tv) ty                    | EqSpec tv ty <- spec ]  instance Outputable EqSpec where   ppr (EqSpec tv ty) = ppr (tv, ty) -{- Note [Data-con worker strictness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Notice that we do *not* say the worker Id is strict even if the data-constructor is declared strict-     e.g.    data T = MkT ![Int] Bool-Even though most often the evals are done by the *wrapper* $WMkT, there are-situations in which tag inference will re-insert evals around the worker.-So for all intents and purposes the *worker* MkT is strict, too!--Unfortunately, if we exposed accurate strictness of DataCon workers, we'd-see the following transformation:--  f xs = case xs of xs' { __DEFAULT -> ... case MkT xs b of x { __DEFAULT -> [x] } } -- DmdAnal: Strict in xs-  ==> { drop-seq, binder swap on xs' }-  f xs = case MkT xs b of x { __DEFAULT -> [x] } -- DmdAnal: Still strict in xs-  ==> { case-to-let }-  f xs = let x = MkT xs' b in [x] -- DmdAnal: No longer strict in xs!--I.e., we are ironically losing strictness in `xs` by dropping the eval on `xs`-and then doing case-to-let. The issue is that `exprIsHNF` currently says that-every DataCon worker app is a value. The implicit assumption is that surrounding-evals will have evaluated strict fields like `xs` before! But now that we had-just dropped the eval on `xs`, that assumption is no longer valid.--Long story short: By keeping the demand signature lazy, the Simplifier will not-drop the eval on `xs` and using `exprIsHNF` to decide case-to-let and others-remains sound.--Similarly, during demand analysis in dmdTransformDataConSig, we bump up the-field demand with `C_01`, *not* `C_11`, because the latter exposes too much-strictness that will drop the eval on `xs` above.--This issue is discussed at length in-"Failed idea: no wrappers for strict data constructors" in #21497 and #22475.--Note [Bangs on data constructor arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Bangs on data constructor arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider   data T = MkT !Int {-# UNPACK #-} !Int Bool @@ -957,8 +935,8 @@   the flag settings in the importing module.   Also see Note [Bangs on imported data constructors] in GHC.Types.Id.Make -* The dcr_bangs field of the dcRep field records the [HsImplBang]-  If T was defined in this module, Without -O the dcr_bangs might be+* The dcImplBangs field records the [HsImplBang]+  If T was defined in this module, Without -O the dcImplBangs might be     [HsStrict _, HsStrict _, HsLazy]   With -O it might be     [HsStrict _, HsUnpack _, HsLazy]@@ -967,6 +945,20 @@   With -XStrictData it might be     [HsStrict _, HsUnpack _, HsStrict _] +* Core passes will often need to know whether the DataCon worker or wrapper in+  an application is strict in some (lifted) field or not. This is tracked in the+  demand signature attached to a DataCon's worker resp. wrapper Id.++  So if you've got a DataCon dc, you can get the demand signature by+  `idDmdSig (dataConWorkId dc)` and make out strict args by testing with+  `isStrictDmd`. Similarly, `idDmdSig <$> dataConWrapId_maybe dc` gives+  you the demand signature of the wrapper, if it exists.++  These demand signatures are set in GHC.Types.Id.Make.mkDataConWorkId,+  computed from the single source of truth `dataConRepStrictness`, which is+  generated from `dcStricts`.+  Note that `dataConRepStrictness` lines up 1-1 with `idDmdSig (dataConWorkId dc)`.+ Note [Detecting useless UNPACK pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want to issue a warning when there's an UNPACK pragma in the source code,@@ -1002,7 +994,6 @@ The boolean flag is used only for this warning. See #11270 for motivation. - ************************************************************************ *                                                                      * \subsection{Instances}@@ -1034,10 +1025,7 @@     dataTypeOf _ = mkNoRepType "DataCon"  instance Outputable HsSrcBang where-    ppr (HsSrcBang _source_text bang) = ppr bang--instance Outputable HsBang where-    ppr (HsBang prag mark) = ppr prag <+> ppr mark+    ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark  instance Outputable HsImplBang where     ppr HsLazy                  = text "Lazy"@@ -1093,6 +1081,16 @@            1 -> return SrcUnpack            _ -> return NoSrcUnpack +instance NFData SrcStrictness where+  rnf SrcLazy = ()+  rnf SrcStrict = ()+  rnf NoSrcStrict = ()++instance NFData SrcUnpackedness where+  rnf SrcNoUnpack = ()+  rnf SrcUnpack = ()+  rnf NoSrcUnpack = ()+ -- | Compare strictness annotations eqHsBang :: HsImplBang -> HsImplBang -> Bool eqHsBang HsLazy               HsLazy              = True@@ -1107,6 +1105,11 @@ isBanged (HsStrict {}) = True isBanged HsLazy        = False +isUnpacked :: HsImplBang -> Bool+isUnpacked (HsUnpack {}) = True+isUnpacked (HsStrict {}) = False+isUnpacked HsLazy        = False+ isSrcStrict :: SrcStrictness -> Bool isSrcStrict SrcStrict = True isSrcStrict _ = False@@ -1132,19 +1135,19 @@  -- | Build a new data constructor mkDataCon :: Name-          -> Bool           -- ^ Is the constructor declared infix?-          -> TyConRepName   -- ^  TyConRepName for the promoted TyCon-          -> [HsSrcBang]    -- ^ Strictness/unpack annotations, from user-          -> [FieldLabel]   -- ^ Field labels for the constructor,-                            -- if it is a record, otherwise empty-          -> [TyVar]        -- ^ Universals.-          -> [TyCoVar]      -- ^ Existentials.+          -> Bool               -- ^ Is the constructor declared infix?+          -> TyConRepName       -- ^  TyConRepName for the promoted TyCon+          -> [HsSrcBang]        -- ^ Strictness/unpack annotations, from user+          -> [HsImplBang]       -- ^ Strictness/unpack annotations, as inferred by the compiler+          -> [StrictnessMark]   -- ^ Strictness marks for the DataCon worker's fields in Core+          -> [FieldLabel]       -- ^ Field labels for the constructor,+                                -- if it is a record, otherwise empty+          -> [TyVar]            -- ^ Universals.+          -> [TyCoVar]          -- ^ Existentials.           -> ConcreteTyVars                                 -- ^ TyVars which must be instantiated with                                 -- concrete types-          -> [InvisTVBinder]    -- ^ User-written 'TyVarBinder's.-                                --   These must be Inferred/Specified.-                                --   See @Note [TyVarBinders in DataCons]@+          -> [TyVarBinder]      -- ^ User-written 'TyVarBinder's           -> [EqSpec]           -- ^ GADT equalities           -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper           -> [KnotTied (Scaled Type)]    -- ^ Original argument types@@ -1160,7 +1163,9 @@   -- Can get the tag from the TyCon  mkDataCon name declared_infix prom_info-          arg_stricts   -- Must match orig_arg_tys 1-1+          arg_stricts  -- Must match orig_arg_tys 1-1+          impl_bangs   -- Must match orig_arg_tys 1-1+          str_marks    -- Must be empty or match dataConRepArgTys 1-1           fields           univ_tvs ex_tvs conc_tvs user_tvbs           eq_spec theta@@ -1177,6 +1182,8 @@   = con   where     is_vanilla = null ex_tvs && null eq_spec && null theta+    str_marks' | not $ any isMarkedStrict str_marks = []+               | otherwise                          = str_marks      con = MkData {dcName = name, dcUnique = nameUnique name,                   dcVanilla = is_vanilla, dcInfix = declared_infix,@@ -1189,7 +1196,8 @@                   dcStupidTheta = stupid_theta,                   dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,                   dcRepTyCon = rep_tycon,-                  dcSrcBangs = arg_stricts,+                  dcSrcBangs = arg_stricts, dcImplBangs = impl_bangs,+                  dcStricts = str_marks',                   dcFields = fields, dcTag = tag, dcRepType = rep_ty,                   dcWorkId = work_id,                   dcRep = rep,@@ -1218,8 +1226,8 @@                  -- Hence using mkScaledFunctionTys.        -- See Note [Promoted data constructors] in GHC.Core.TyCon-    prom_tv_bndrs = [ mkNamedTyConBinder (Invisible spec) tv-                    | Bndr tv spec <- user_tvbs ]+    prom_tv_bndrs = [ mkNamedTyConBinder vis tv+                    | Bndr tv vis <- user_tvbs ]      fresh_names = freshNames (map getName user_tvbs)       -- fresh_names: make sure that the "anonymous" tyvars don't@@ -1316,9 +1324,9 @@ dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs  -- See Note [DataCon user type variable binders]--- | 'InvisTVBinder's for the type variables of the constructor, in the order the+-- | 'TyVarBinder's for the type variables of the constructor, in the order the -- user wrote them-dataConUserTyVarBinders :: DataCon -> [InvisTVBinder]+dataConUserTyVarBinders :: DataCon -> [TyVarBinder] dataConUserTyVarBinders = dcUserTyVarBinders  -- | Dependent (kind-level) equalities in a constructor.@@ -1405,10 +1413,18 @@ dataConSrcBangs :: DataCon -> [HsSrcBang] dataConSrcBangs = dcSrcBangs --- | Source-level arity of the data constructor+-- | Number of value arguments of the data constructor dataConSourceArity :: DataCon -> Arity dataConSourceArity (MkData { dcSourceArity = arity }) = arity +-- | Number of visible arguments of the data constructor+dataConVisArity :: DataCon -> VisArity+dataConVisArity (MkData { dcUserTyVarBinders = tvbs, dcSourceArity = arity })+  = n_of_required_ty_args + n_of_val_args+  where+    n_of_val_args         = arity+    n_of_required_ty_args = count isVisibleForAllTyBinder tvbs+ -- | Gives the number of value arguments (including zero-width coercions) -- stored by the given `DataCon`'s worker in its Core representation. This may -- differ from the number of arguments that appear in the source code; see also@@ -1432,20 +1448,25 @@ isNullaryRepDataCon :: DataCon -> Bool isNullaryRepDataCon dc = dataConRepArity dc == 0 +isLazyDataConRep :: DataCon -> Bool+-- ^ True <==> All fields are lazy+isLazyDataConRep dc = null (dcStricts dc)+ dataConRepStrictness :: DataCon -> [StrictnessMark]--- ^ Give the demands on the arguments of a--- Core constructor application (Con dc args)-dataConRepStrictness dc = case dcRep dc of-                            NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc]-                            DCR { dcr_stricts = strs } -> strs+-- ^ Give the demands on the runtime arguments of a Core DataCon worker+-- application.+-- The length of the list matches `dataConRepArgTys` (e.g., the number+-- of runtime arguments).+dataConRepStrictness dc+  | isLazyDataConRep dc+  = replicate (dataConRepArity dc) NotMarkedStrict+  | otherwise+  = dcStricts dc  dataConImplBangs :: DataCon -> [HsImplBang] -- The implementation decisions about the strictness/unpack of each -- source program argument to the data constructor-dataConImplBangs dc-  = case dcRep dc of-      NoDataConRep              -> replicate (dcSourceArity dc) HsLazy-      DCR { dcr_bangs = bangs } -> bangs+dataConImplBangs dc = dcImplBangs dc  dataConBoxer :: DataCon -> Maybe DataConBoxer dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer@@ -1562,7 +1583,7 @@                              dcOtherTheta = theta, dcOrigArgTys = arg_tys,                              dcOrigResTy = res_ty,                              dcStupidTheta = stupid_theta })-  = mkInvisForAllTys user_tvbs $+  = mkForAllTys user_tvbs $     mkInvisFunTys (stupid_theta ++ theta) $     mkScaledFunTys arg_tys $     res_ty@@ -1574,7 +1595,7 @@                                dcOtherTheta = theta, dcOrigArgTys = arg_tys,                                dcOrigResTy = res_ty,                                dcStupidTheta = stupid_theta })-  = mkInvisForAllTys user_tvbs $+  = mkForAllTys user_tvbs $     mkInvisFunTys (stupid_theta ++ theta) $     mkScaledFunTys arg_tys' $     res_ty@@ -1771,10 +1792,15 @@          && not (isTyVarTy ty)  -- See Note [isCovertGadtDataCon] for                                 -- an example where 'ty' is a tyvar +isUnaryClassDataCon :: DataCon -> Bool+isUnaryClassDataCon dc = isUnaryClassTyCon (dataConTyCon dc)+ {- Note [isCovertGadtDataCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (isCovertGadtDataCon K) returns True if K is a GADT data constructor, but-does not /look/ like it. Consider (#21447)+does not /look/ like it. It is used only to help in error message printing.++Consider (#21447)     type T :: TYPE r -> Type     data T a where { MkT :: b -> T b } Here MkT doesn't look GADT-like, but it is. If we make the kind applications@@ -1892,21 +1918,53 @@      wrapper_vars = dataConUserTyVars dc -dataConUserTyVarsNeedWrapper :: DataCon -> Bool--- Check whether the worker and wapper have the same type variables--- in the same order. If not, we need a wrapper to swizzle them.+dataConUserTyVarBindersNeedWrapper :: DataCon -> Bool+-- Check whether the worker and wrapper have the same type variables+-- in the same order and with the same visibility. If not, we need a+-- wrapper to swizzle them. -- See Note [DataCon user type variable binders], as well as -- Note [Data con wrappers and GADT syntax] for an explanation of what -- mkDataConRep is doing with this function.-dataConUserTyVarsNeedWrapper dc@(MkData { dcUnivTyVars = univ_tvs-                                        , dcExTyCoVars = ex_tvs-                                        , dcEqSpec = eq_spec })+dataConUserTyVarBindersNeedWrapper (MkData { dcUnivTyVars = univ_tvs+                                           , dcExTyCoVars = ex_tvs+                                           , dcUserTyVarBinders = user_tvbs+                                           , dcEqSpec = eq_spec })   = assert (null eq_spec || answer)  -- all GADTs should say "yes" here     answer   where-    answer = (univ_tvs ++ ex_tvs) /= dataConUserTyVars dc-              -- Worker tyvars         Wrapper tyvars+    answer = need_reorder || need_flag_cast+    need_reorder   = (univ_tvs ++ ex_tvs) /= binderVars user_tvbs+    need_flag_cast = any (not . eqForAllVis coreTyLamForAllTyFlag)+                         (binderFlags user_tvbs)+      -- See Note [Flag cast in data con wrappers] +{- Note [Flag cast in data con wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the data declaration++  data G a where+    MkG :: forall a -> a -> G a++The user-facing type of MkG has a 'Required' forall. Workers, on the other hand,+always use 'Specified' foralls (coreTyLamForAllTyFlag). So we need a wrapper:++  wrapper type: forall a -> a -> G a+  worker type:  forall a.   a -> G a++Concretely, it looks like this:++   $WMkG = /\a. \(x:a). MkG a x |> co++where 'co' is a coercion constructed by GHC.Core.Coercion.mkForAllVisCos.+The cast is added by the call to mkCoreTyLams in GHC.Types.Id.Make.mkDataConRep.++In general, wrappers may use 'Inferred', 'Specified', or 'Required' foralls.+However, we do /not/ need a cast to convert 'Inferred' to 'Specified' because they are+'eqType'-equal. Only a 'Required' forall necessitates a cast in the wrapper.++See Note [ForAllTy and type equality], Note [Comparing visibility],+and Note [Required foralls in Core].+-}  {- %************************************************************************
compiler/GHC/Core/DataCon.hs-boot view
@@ -1,7 +1,7 @@ module GHC.Core.DataCon where  import GHC.Prelude-import {-# SOURCE #-} GHC.Types.Var( Id, TyVar, TyCoVar, InvisTVBinder )+import {-# SOURCE #-} GHC.Types.Var( Id, TyVar, TyCoVar, TyVarBinder ) import {-# SOURCE #-} GHC.Types.Name( Name, NamedThing ) import {-# SOURCE #-} GHC.Core.TyCon( TyCon ) import GHC.Types.FieldLabel ( FieldLabel )@@ -19,7 +19,7 @@ dataConTyCon     :: DataCon -> TyCon dataConExTyCoVars :: DataCon -> [TyCoVar] dataConUserTyVars :: DataCon -> [TyVar]-dataConUserTyVarBinders :: DataCon -> [InvisTVBinder]+dataConUserTyVarBinders :: DataCon -> [TyVarBinder] dataConSourceArity  :: DataCon -> Arity dataConFieldLabels :: DataCon -> [FieldLabel] dataConInstOrigArgTys  :: DataCon -> [Type] -> [Scaled Type]
compiler/GHC/Core/FVs.hs view
@@ -36,7 +36,7 @@         ruleLhsFreeIds, ruleLhsFreeIdsList,         ruleRhsFreeVars, rulesRhsFreeIds, -        exprFVs,+        exprFVs, exprLocalFVs, addBndrFV, addBndrsFV,          -- * Orphan names         orphNamesOfType, orphNamesOfTypes, orphNamesOfAxiomLHS,@@ -96,23 +96,23 @@ -- | Find all locally-defined free Ids or type variables in an expression -- returning a non-deterministic set. exprFreeVars :: CoreExpr -> VarSet-exprFreeVars = fvVarSet . exprFVs+exprFreeVars = fvVarSet . exprLocalFVs  -- | Find all locally-defined free Ids or type variables in an expression -- returning a composable FV computation. See Note [FV naming conventions] in "GHC.Utils.FV" -- for why export it.-exprFVs :: CoreExpr -> FV-exprFVs = filterFV isLocalVar . expr_fvs+exprLocalFVs :: CoreExpr -> FV+exprLocalFVs = filterFV isLocalVar . exprFVs  -- | Find all locally-defined free Ids or type variables in an expression -- returning a deterministic set. exprFreeVarsDSet :: CoreExpr -> DVarSet-exprFreeVarsDSet = fvDVarSet . exprFVs+exprFreeVarsDSet = fvDVarSet . exprLocalFVs  -- | Find all locally-defined free Ids or type variables in an expression -- returning a deterministically ordered list. exprFreeVarsList :: CoreExpr -> [Var]-exprFreeVarsList = fvVarList . exprFVs+exprFreeVarsList = fvVarList . exprLocalFVs  -- | Find all locally-defined free Ids in an expression exprFreeIds :: CoreExpr -> IdSet        -- Find all locally-defined free Ids@@ -144,68 +144,65 @@ -- | Find all locally-defined free Ids or type variables in several expressions -- returning a non-deterministic set. exprsFreeVars :: [CoreExpr] -> VarSet-exprsFreeVars = fvVarSet . exprsFVs+exprsFreeVars = fvVarSet . exprsLocalFVs  -- | Find all locally-defined free Ids or type variables in several expressions -- returning a composable FV computation. See Note [FV naming conventions] in "GHC.Utils.FV" -- for why export it.-exprsFVs :: [CoreExpr] -> FV-exprsFVs exprs = mapUnionFV exprFVs exprs+exprsLocalFVs :: [CoreExpr] -> FV+exprsLocalFVs exprs = mapUnionFV exprLocalFVs exprs  -- | Find all locally-defined free Ids or type variables in several expressions -- returning a deterministically ordered list. exprsFreeVarsList :: [CoreExpr] -> [Var]-exprsFreeVarsList = fvVarList . exprsFVs+exprsFreeVarsList = fvVarList . exprsLocalFVs  -- | Find all locally defined free Ids in a binding group bindFreeVars :: CoreBind -> VarSet bindFreeVars (NonRec b r) = fvVarSet $ filterFV isLocalVar $ rhs_fvs (b,r) bindFreeVars (Rec prs)    = fvVarSet $ filterFV isLocalVar $-                                addBndrs (map fst prs)+                                addBndrsFV (map fst prs)                                      (mapUnionFV rhs_fvs prs)  -- | Finds free variables in an expression selected by a predicate exprSomeFreeVars :: InterestingVarFun   -- ^ Says which 'Var's are interesting                  -> CoreExpr                  -> VarSet-exprSomeFreeVars fv_cand e = fvVarSet $ filterFV fv_cand $ expr_fvs e+exprSomeFreeVars fv_cand e = fvVarSet $ filterFV fv_cand $ exprFVs e  -- | Finds free variables in an expression selected by a predicate -- returning a deterministically ordered list. exprSomeFreeVarsList :: InterestingVarFun -- ^ Says which 'Var's are interesting                      -> CoreExpr                      -> [Var]-exprSomeFreeVarsList fv_cand e = fvVarList $ filterFV fv_cand $ expr_fvs e+exprSomeFreeVarsList fv_cand e = fvVarList $ filterFV fv_cand $ exprFVs e  -- | Finds free variables in an expression selected by a predicate -- returning a deterministic set. exprSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting                      -> CoreExpr                      -> DVarSet-exprSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ expr_fvs e+exprSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ exprFVs e  -- | Finds free variables in several expressions selected by a predicate exprsSomeFreeVars :: InterestingVarFun  -- Says which 'Var's are interesting                   -> [CoreExpr]                   -> VarSet-exprsSomeFreeVars fv_cand es =-  fvVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs es+exprsSomeFreeVars fv_cand es = fvVarSet $ filterFV fv_cand $ mapUnionFV exprFVs es  -- | Finds free variables in several expressions selected by a predicate -- returning a deterministically ordered list. exprsSomeFreeVarsList :: InterestingVarFun  -- Says which 'Var's are interesting                       -> [CoreExpr]                       -> [Var]-exprsSomeFreeVarsList fv_cand es =-  fvVarList $ filterFV fv_cand $ mapUnionFV expr_fvs es+exprsSomeFreeVarsList fv_cand es = fvVarList $ filterFV fv_cand $ mapUnionFV exprFVs es  -- | Finds free variables in several expressions selected by a predicate -- returning a deterministic set. exprsSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting                       -> [CoreExpr]                       -> DVarSet-exprsSomeFreeVarsDSet fv_cand e =-  fvDVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs e+exprsSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ mapUnionFV exprFVs e  --      Comment about obsolete code -- We used to gather the free variables the RULES at a variable occurrence@@ -235,59 +232,59 @@ --                          | otherwise                    = set --      SLPJ Feb06 -addBndr :: CoreBndr -> FV -> FV-addBndr bndr fv fv_cand in_scope acc+addBndrFV :: CoreBndr -> FV -> FV+addBndrFV bndr fv fv_cand in_scope acc   = (varTypeTyCoFVs bndr `unionFV`         -- Include type variables in the binder's type         --      (not just Ids; coercion variables too!)      FV.delFV bndr fv) fv_cand in_scope acc -addBndrs :: [CoreBndr] -> FV -> FV-addBndrs bndrs fv = foldr addBndr fv bndrs+addBndrsFV :: [CoreBndr] -> FV -> FV+addBndrsFV bndrs fv = foldr addBndrFV fv bndrs -expr_fvs :: CoreExpr -> FV-expr_fvs (Type ty) fv_cand in_scope acc =+exprsFVs :: [CoreExpr] -> FV+exprsFVs exprs = mapUnionFV exprFVs exprs++exprFVs :: CoreExpr -> FV+exprFVs (Type ty) fv_cand in_scope acc =   tyCoFVsOfType ty fv_cand in_scope acc-expr_fvs (Coercion co) fv_cand in_scope acc =+exprFVs (Coercion co) fv_cand in_scope acc =   tyCoFVsOfCo co fv_cand in_scope acc-expr_fvs (Var var) fv_cand in_scope acc = FV.unitFV var fv_cand in_scope acc-expr_fvs (Lit _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc-expr_fvs (Tick t expr) fv_cand in_scope acc =-  (tickish_fvs t `unionFV` expr_fvs expr) fv_cand in_scope acc-expr_fvs (App fun arg) fv_cand in_scope acc =-  (expr_fvs fun `unionFV` expr_fvs arg) fv_cand in_scope acc-expr_fvs (Lam bndr body) fv_cand in_scope acc =-  addBndr bndr (expr_fvs body) fv_cand in_scope acc-expr_fvs (Cast expr co) fv_cand in_scope acc =-  (expr_fvs expr `unionFV` tyCoFVsOfCo co) fv_cand in_scope acc+exprFVs (Var var) fv_cand in_scope acc = FV.unitFV var fv_cand in_scope acc+exprFVs (Lit _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc+exprFVs (Tick t expr) fv_cand in_scope acc =+  (tickish_fvs t `unionFV` exprFVs expr) fv_cand in_scope acc+exprFVs (App fun arg) fv_cand in_scope acc =+  (exprFVs fun `unionFV` exprFVs arg) fv_cand in_scope acc+exprFVs (Lam bndr body) fv_cand in_scope acc =+  addBndrFV bndr (exprFVs body) fv_cand in_scope acc+exprFVs (Cast expr co) fv_cand in_scope acc =+  (exprFVs expr `unionFV` tyCoFVsOfCo co) fv_cand in_scope acc -expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc-  = (expr_fvs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndr bndr+exprFVs (Case scrut bndr ty alts) fv_cand in_scope acc+  = (exprFVs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndrFV bndr       (mapUnionFV alt_fvs alts)) fv_cand in_scope acc   where-    alt_fvs (Alt _ bndrs rhs) = addBndrs bndrs (expr_fvs rhs)+    alt_fvs (Alt _ bndrs rhs) = addBndrsFV bndrs (exprFVs rhs) -expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc-  = (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body))+exprFVs (Let (NonRec bndr rhs) body) fv_cand in_scope acc+  = (rhs_fvs (bndr, rhs) `unionFV` addBndrFV bndr (exprFVs body))       fv_cand in_scope acc -expr_fvs (Let (Rec pairs) body) fv_cand in_scope acc-  = addBndrs (map fst pairs)-             (mapUnionFV rhs_fvs pairs `unionFV` expr_fvs body)+exprFVs (Let (Rec pairs) body) fv_cand in_scope acc+  = addBndrsFV (map fst pairs)+               (mapUnionFV rhs_fvs pairs `unionFV` exprFVs body)                fv_cand in_scope acc  --------- rhs_fvs :: (Id, CoreExpr) -> FV-rhs_fvs (bndr, rhs) = expr_fvs rhs `unionFV`+rhs_fvs (bndr, rhs) = exprFVs rhs `unionFV`                       bndrRuleAndUnfoldingFVs bndr         -- Treat any RULES as extra RHSs of the binding  ----------exprs_fvs :: [CoreExpr] -> FV-exprs_fvs exprs = mapUnionFV expr_fvs exprs- tickish_fvs :: CoreTickish -> FV-tickish_fvs (Breakpoint _ _ ids _) = FV.mkFVs ids+tickish_fvs (Breakpoint _ _ ids) = FV.mkFVs ids tickish_fvs _ = emptyFV  {- **********************************************************************@@ -434,7 +431,7 @@                      -- See Note [Rule free var hack]                    , ru_bndrs = bndrs                    , ru_rhs = rhs, ru_args = args })-  = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs exprs)+  = filterFV isLocalVar $ addBndrsFV bndrs (exprsFVs exprs)   where     exprs = case from of       LhsOnly   -> args@@ -653,9 +650,9 @@   = case unf of       CoreUnfolding { uf_tmpl = rhs, uf_src = src }          | isStableSource src-         -> Just (filterFV isLocalVar $ expr_fvs rhs)+         -> Just (exprLocalFVs rhs)       DFunUnfolding { df_bndrs = bndrs, df_args = args }-         -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprs_fvs args)+         -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprsFVs args)             -- DFuns are top level, so no fvs from types of bndrs       _other -> Nothing @@ -702,7 +699,7 @@       | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs `unionFVs` mult_vars, AnnVar v)       | otherwise    = (emptyDVarSet,                 AnnVar v)       where-        mult_vars = tyCoVarsOfTypeDSet (varMult v)+        mult_vars = tyCoVarsOfTypeDSet (idMult v)         ty_fvs = dVarTypeTyCoVars v                  -- See Note [The FVAnn invariant] @@ -759,8 +756,8 @@         , AnnTick tickish expr2 )       where         expr2 = go expr-        tickishFVs (Breakpoint _ _ ids _) = mkDVarSet ids-        tickishFVs _                      = emptyDVarSet+        tickishFVs (Breakpoint _ _ ids) = mkDVarSet ids+        tickishFVs _                    = emptyDVarSet      go (Type ty)     = (tyCoVarsOfTypeDSet ty, AnnType ty)     go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co)
compiler/GHC/Core/FamInstEnv.hs view
@@ -42,6 +42,7 @@ import GHC.Core.Unify import GHC.Core.Type as Type import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Tidy import GHC.Core.TyCo.Compare( eqType, eqTypes ) import GHC.Core.TyCon import GHC.Core.Coercion@@ -247,10 +248,10 @@     ppr_tc_sort = case flavor of                      SynFamilyInst             -> text "type"                      DataFamilyInst tycon-                       | isDataTyCon     tycon -> text "data"-                       | isNewTyCon      tycon -> text "newtype"-                       | isAbstractTyCon tycon -> text "data"-                       | otherwise             -> text "WEIRD" <+> ppr tycon+                       | isBoxedDataTyCon tycon -> text "data"+                       | isNewTyCon       tycon -> text "newtype"+                       | isAbstractTyCon  tycon -> text "data"+                       | otherwise              -> text "WEIRD" <+> ppr tycon      debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax                        , text "Tvs:" <+> ppr tvs@@ -487,8 +488,8 @@ apart(target, pattern) = not (unify(flatten(target), pattern))  where flatten (implemented in flattenTys, below) converts all type-family-applications into fresh variables. (See-Note [Flattening type-family applications when matching instances] in GHC.Core.Unify.)+applications into fresh variables. (See Note [Apartness and type families]+in GHC.Core.Unify.)  Note [Compatibility] ~~~~~~~~~~~~~~~~~~~~@@ -512,11 +513,11 @@ only when we can be sure that 'a' is not Int.  To achieve this, after finding a possible match within the equations, we have to-go back to all previous equations and check that, under the-substitution induced by the match, other branches are surely apart. (See-Note [Apartness].) This is similar to what happens with class-instance selection, when we need to guarantee that there is only a match and-no unifiers. The exact algorithm is different here because the+go back to all previous equations and check that, under the substitution induced+by the match, other branches are surely apart, using `tcUnifyTysFG`. (See+Note [Apartness and type families] in GHC.Core.Unify.) This is similar to what+happens with class instance selection, when we need to guarantee that there is+only a match and no unifiers. The exact algorithm is different here because the potentially-overlapping group is closed.  As another example, consider this:@@ -579,7 +580,7 @@ compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 })                    (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 })-  = case tcUnifyTysFG alwaysBindFun commonlhs1 commonlhs2 of+  = case tcUnifyTysFG alwaysBindFam alwaysBindTv commonlhs1 commonlhs2 of       -- Here we need the cab_tvs of the two branches to be disinct.       -- See Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom.       SurelyApart     -> True@@ -610,7 +611,8 @@   -- See Note [Verifying injectivity annotation], case 1.   = let getInjArgs  = filterByList injectivity         in_scope    = mkInScopeSetList (tvs1 ++ tvs2)-    in case tcUnifyTyWithTFs True in_scope rhs1 rhs2 of -- True = two-way pre-unification+    in case tcUnifyTyForInjectivity True in_scope rhs1 rhs2 of+             -- True = two-way pre-unification        Nothing -> InjectivityAccepted          -- RHS are different, so equations are injective.          -- This is case 1A from Note [Verifying injectivity annotation]@@ -1228,22 +1230,16 @@        -> Maybe (BranchIndex, [Type], [Coercion])     go (index, branch) other       = let (CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs-                        , cab_lhs = tpl_lhs-                        , cab_incomps = incomps }) = branch-            in_scope = mkInScopeSet (unionVarSets $-                            map (tyCoVarsOfTypes . coAxBranchLHS) incomps)-            -- See Note [Flattening type-family applications when matching instances]-            -- in GHC.Core.Unify-            flattened_target = flattenTys in_scope target_tys+                        , cab_lhs = tpl_lhs }) = branch         in case tcMatchTys tpl_lhs target_tys of-        Just subst -- matching worked. now, check for apartness.-          |  apartnessCheck flattened_target branch-          -> -- matching worked & we're apart from all incompatible branches.+        Just subst -- Matching worked. now, check for apartness.+          |  apartnessCheck target_tys branch+          -> -- Matching worked & we're apart from all incompatible branches.              -- success              assert (all (isJust . lookupCoVar subst) tpl_cvs) $              Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs) -        -- failure. keep looking+        -- Failure. keep looking         _ -> other  -- | Do an apartness check, as described in the "Closed Type Families" paper@@ -1251,15 +1247,12 @@ -- ('CoAxBranch') of a closed type family can be used to reduce a certain target -- type family application. apartnessCheck :: [Type]-  -- ^ /flattened/ target arguments. Make sure they're flattened! See-  -- Note [Flattening type-family applications when matching instances]-  -- in GHC.Core.Unify.-               -> CoAxBranch -- ^ the candidate equation we wish to use+               -> CoAxBranch -- ^ The candidate equation we wish to use                              -- Precondition: this matches the target                -> Bool       -- ^ True <=> equation can fire-apartnessCheck flattened_target (CoAxBranch { cab_incomps = incomps })+apartnessCheck target (CoAxBranch { cab_incomps = incomps })   = all (isSurelyApart-         . tcUnifyTysFG alwaysBindFun flattened_target+         . tcUnifyTysFG alwaysBindFam alwaysBindTv target          . coAxBranchLHS) incomps   where     isSurelyApart SurelyApart = True@@ -1343,7 +1336,7 @@ --      * newtypes -- returning an appropriate Representational coercion.  Specifically, if --   topNormaliseType_maybe env ty = Just (co, ty')--- then+-- then postconditions: --   (a) co :: ty ~R ty' --   (b) ty' is not a newtype, and is not a type-family or data-family redex --
compiler/GHC/Core/InstEnv.hs view
@@ -174,7 +174,7 @@ Reason for freshness: we use unification when checking for overlap etc, and that requires the tyvars to be distinct. -The invariant is checked by the ASSERT in lookupInstEnv'.+The invariant is checked by the ASSERT in instEnvMatchesAndUnifiers.  Note [Proper-match fields] ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -947,11 +947,8 @@ * That info is recorded in the `cir_is_coherent` field of `OneInst`, and thence   transferred to the `ep_is_coherent` field of the `EvBind` for the dictionary. -* `GHC.HsToCore.Binds.dsHsWrapper` desugars the evidence application (f d) into-  (nospec f d) if `d` is incoherent. It has to do a dependency analysis to-  determine transitive dependencies, but we need to do that anyway.-  See Note [Desugaring non-canonical evidence] in GHC.HsToCore.Binds.-+* In the desugarer we exploit this info:+  see Note [Desugaring non-canonical evidence] in GHC.HsToCore.Expr.   See also Note [nospecId magic] in GHC.Types.Id.Make.  @@ -1247,10 +1244,14 @@                 -- Unification will break badly if the variables overlap                 -- They shouldn't because we allocate separate uniques for them                 -- See Note [Template tyvars are fresh]-        case tcUnifyTysFG instanceBindFun tpl_tys tys of+        case tcUnifyTysFG alwaysBindFam instanceBindFun tpl_tys tys of+          -- alwaysBindFam: the family-application can't be in the instance head,+          -- but it certainly can be in the Wanted constraint we are matching!+          --           -- We consider MaybeApart to be a case where the instance might           -- apply in the future. This covers an instance like C Int and           -- a target like [W] C (F a), where F is a type family.+          -- See (ATF1) in Note [Apartness and type families] in GHC.Core.Unify             SurelyApart              -> check_unifiers items               -- See Note [Infinitary substitution in lookup]             MaybeApart MARInfinite _ -> check_unifiers items@@ -1670,14 +1671,14 @@ ************************************************************************ -} -instanceBindFun :: BindFun-instanceBindFun tv _rhs_ty | isOverlappableTyVar tv = Apart+instanceBindFun :: BindTvFun+instanceBindFun tv _rhs_ty | isOverlappableTyVar tv = DontBindMe                            | otherwise              = BindMe-   -- Note [Binding when looking up instances]+   -- Note [Super skolems: binding when looking up instances]  {--Note [Binding when looking up instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Super skolems: binding when looking up instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When looking up in the instance environment, or family-instance environment, we are careful about multiple matches, as described above in Note [Overlapping instances]@@ -1693,9 +1694,9 @@         f :: T -> Int         f (MkT x) = op [x,x] The op [x,x] means we need (Foo [a]). This `a` will never be instantiated, and-so it is a super skolem. (See the use of tcInstSuperSkolTyVarsX in+so it is a "super skolem". (See the use of tcInstSuperSkolTyVarsX in GHC.Tc.Gen.Pat.tcDataConPat.) Super skolems respond True to-isOverlappableTyVar, and the use of Apart in instanceBindFun, above, means+isOverlappableTyVar, and the use of DontBindMe in instanceBindFun, above, means that these will be treated as fresh constants in the unification algorithm during instance lookup. Without this treatment, GHC would complain, saying that the choice of instance depended on the instantiation of 'a'; but of
compiler/GHC/Core/Lint.hs view
@@ -82,3773 +82,3860 @@  import GHC.Builtin.Names import GHC.Builtin.Types.Prim-import GHC.Builtin.Types ( multiplicityTy )--import GHC.Data.Bag-import GHC.Data.List.SetOps--import GHC.Utils.Monad-import GHC.Utils.Outputable as Outputable-import GHC.Utils.Panic-import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Misc-import GHC.Utils.Error-import qualified GHC.Utils.Error as Err-import GHC.Utils.Logger--import Control.Monad-import Data.Foldable      ( for_, toList )-import Data.List.NonEmpty ( NonEmpty(..), groupWith )-import Data.List          ( partition )-import Data.Maybe-import Data.IntMap.Strict ( IntMap )-import qualified Data.IntMap.Strict as IntMap ( lookup, keys, empty, fromList )-import GHC.Data.Pair-import GHC.Base (oneShot)-import GHC.Data.Unboxed--{--Note [Core Lint guarantee]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Core Lint is the type-checker for Core. Using it, we get the following guarantee:--If all of:-1. Core Lint passes,-2. there are no unsafe coercions (i.e. unsafeEqualityProof),-3. all plugin-supplied coercions (i.e. PluginProv) are valid, and-4. all case-matches are complete-then running the compiled program will not seg-fault, assuming no bugs downstream-(e.g. in the code generator). This guarantee is quite powerful, in that it allows us-to decouple the safety of the resulting program from the type inference algorithm.--However, do note point (4) above. Core Lint does not check for incomplete case-matches;-see Note [Case expression invariants] in GHC.Core, invariant (4). As explained there,-an incomplete case-match might slip by Core Lint and cause trouble at runtime.--Note [GHC Formalism]-~~~~~~~~~~~~~~~~~~~~-This file implements the type-checking algorithm for System FC, the "official"-name of the Core language. Type safety of FC is heart of the claim that-executables produced by GHC do not have segmentation faults. Thus, it is-useful to be able to reason about System FC independently of reading the code.-To this purpose, there is a document core-spec.pdf built in docs/core-spec that-contains a formalism of the types and functions dealt with here. If you change-just about anything in this file or you change other types/functions throughout-the Core language (all signposted to this note), you should update that-formalism. See docs/core-spec/README for more info about how to do so.--Note [check vs lint]-~~~~~~~~~~~~~~~~~~~~-This file implements both a type checking algorithm and also general sanity-checking. For example, the "sanity checking" checks for TyConApp on the left-of an AppTy, which should never happen. These sanity checks don't really-affect any notion of type soundness. Yet, it is convenient to do the sanity-checks at the same time as the type checks. So, we use the following naming-convention:--- Functions that begin with 'lint'... are involved in type checking. These-  functions might also do some sanity checking.--- Functions that begin with 'check'... are *not* involved in type checking.-  They exist only for sanity checking.--Issues surrounding variable naming, shadowing, and such are considered *not*-to be part of type checking, as the formalism omits these details.--Summary of checks-~~~~~~~~~~~~~~~~~-Checks that a set of core bindings is well-formed.  The PprStyle and String-just control what we print in the event of an error.  The Bool value-indicates whether we have done any specialisation yet (in which case we do-some extra checks).--We check for-        (a) type errors-        (b) Out-of-scope type variables-        (c) Out-of-scope local variables-        (d) Ill-kinded types-        (e) Incorrect unsafe coercions--If we have done specialisation the we check that there are-        (a) No top-level bindings of primitive (unboxed type)--Note [Linting function types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-All saturated applications of funTyCon are represented with the FunTy constructor.-See Note [Function type constructors and FunTy] in GHC.Builtin.Types.Prim-- We check this invariant in lintType.--Note [Linting type lets]-~~~~~~~~~~~~~~~~~~~~~~~~-In the desugarer, it's very very convenient to be able to say (in effect)-        let a = Type Bool in-        let x::a = True in <body>-That is, use a type let.  See Note [Core type and coercion invariant] in "GHC.Core".-One place it is used is in mkWwBodies; see Note [Join points and beta-redexes]-in GHC.Core.Opt.WorkWrap.Utils.  (Maybe there are other "clients" of this feature; I'm not sure).--* Hence when linting <body> we need to remember that a=Int, else we-  might reject a correct program.  So we carry a type substitution (in-  this example [a -> Bool]) and apply this substitution before-  comparing types. In effect, in Lint, type equality is always-  equality-modulo-le-subst.  This is in the le_subst field of-  LintEnv.  But nota bene:--  (SI1) The le_subst substitution is applied to types and coercions only--  (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 substitution does not outlive the CoreLint pass.--  (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders.--* The function-        lintInTy :: Type -> LintM (Type, Kind)-  returns a substituted type.--* When we encounter a binder (like x::a) we must apply the substitution-  to the type of the binding variable.  lintBinders does this.--* Clearly we need to clone tyvar binders as we go.--* But take care (#17590)! We must also clone CoVar binders:-    let a = TYPE (ty |> cv)-    in \cv -> blah-  blindly substituting for `a` might capture `cv`.--* Alas, when cloning a coercion variable we might choose a unique-  that happens to clash with an inner Id, thus-      \cv_66 -> let wild_X7 = blah in blah-  We decide to clone `cv_66` because it's already in scope.  Fine,-  choose a new unique.  Aha, X7 looks good.  So we check the lambda-  body with le_subst of [cv_66 :-> cv_X7]--  This is all fine, even though we use the same unique as wild_X7.-  As (SI2) says, we do /not/ return a new lambda-     (\cv_X7 -> let wild_X7 = blah in ...)-  We simply use the le_subst substitution in types/coercions only, when-  checking for equality.--* We still need to check that Id occurrences are bound by some-  enclosing binding.  We do /not/ use the InScopeSet for the le_subst-  for this purpose -- it contains only TyCoVars.  Instead we have a separate-  le_ids for the in-scope Id binders.--Sigh.  We might want to explore getting rid of type-let!--Note [Bad unsafe coercion]-~~~~~~~~~~~~~~~~~~~~~~~~~~-For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions-Linter introduces additional rules that checks improper coercion between-different types, called bad coercions. Following coercions are forbidden:--  (a) coercions between boxed and unboxed values;-  (b) coercions between unlifted values of the different sizes, here-      active size is checked, i.e. size of the actual value but not-      the space allocated for value;-  (c) coercions between floating and integral boxed values, this check-      is not yet supported for unboxed tuples, as no semantics were-      specified for that;-  (d) coercions from / to vector type-  (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be-      coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules-      (a-e) holds.--Note [Join points]-~~~~~~~~~~~~~~~~~~-We check the rules listed in Note [Invariants on join points] in GHC.Core. The-only one that causes any difficulty is the first: All occurrences must be tail-calls. To this end, along with the in-scope set, we remember in le_joins the-subset of in-scope Ids that are valid join ids. For example:--  join j x = ... in-  case e of-    A -> jump j y -- good-    B -> case (jump j z) of -- BAD-           C -> join h = jump j w in ... -- good-           D -> let x = jump j v in ... -- BAD--A join point remains valid in case branches, so when checking the A-branch, j is still valid. When we check the scrutinee of the inner-case, however, we set le_joins to empty, and catch the-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%.--Note [MCInfo for Lint]-~~~~~~~~~~~~~~~~~~~~~~-When printing a Lint message, use the MCInfo severity so that the-message is printed on stderr rather than stdout (#13342).--************************************************************************-*                                                                      *-                 Beginning and ending passes-*                                                                      *-************************************************************************--}---- | Configuration for boilerplate operations at the end of a--- compilation pass producing Core.-data EndPassConfig = EndPassConfig-  { ep_dumpCoreSizes :: !Bool-  -- ^ Whether core bindings should be dumped with the size of what they-  -- are binding (i.e. the size of the RHS of the binding).--  , ep_lintPassResult :: !(Maybe LintPassResultConfig)-  -- ^ Whether we should lint the result of this pass.--  , ep_namePprCtx :: !NamePprCtx--  , ep_dumpFlag :: !(Maybe DumpFlag)--  , ep_prettyPass :: !SDoc--  , ep_passDetails :: !SDoc-  }--endPassIO :: Logger-          -> EndPassConfig-          -> CoreProgram -> [CoreRule]-          -> IO ()--- Used by the IO-is CorePrep too-endPassIO logger cfg binds rules-  = do { dumpPassResult logger (ep_dumpCoreSizes cfg) (ep_namePprCtx cfg) mb_flag-                        (renderWithContext defaultSDocContext (ep_prettyPass cfg))-                        (ep_passDetails cfg) binds rules-       ; for_ (ep_lintPassResult cfg) $ \lp_cfg ->-           lintPassResult logger lp_cfg binds-       }-  where-    mb_flag = case ep_dumpFlag cfg of-                Just flag | logHasDumpFlag logger flag                    -> Just flag-                          | logHasDumpFlag logger Opt_D_verbose_core2core -> Just flag-                _ -> Nothing--dumpPassResult :: Logger-               -> Bool                  -- dump core sizes?-               -> NamePprCtx-               -> Maybe DumpFlag        -- Just df => show details in a file whose-                                        --            name is specified by df-               -> String                -- Header-               -> SDoc                  -- Extra info to appear after header-               -> CoreProgram -> [CoreRule]-               -> IO ()-dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr extra_info binds rules-  = do { forM_ mb_flag $ \flag -> do-           logDumpFile logger (mkDumpStyle name_ppr_ctx) flag hdr FormatCore dump_doc--         -- Report result size-         -- This has the side effect of forcing the intermediate to be evaluated-         -- if it's not already forced by a -ddump flag.-       ; Err.debugTraceMsg logger 2 size_doc-       }--  where-    size_doc = sep [text "Result size of" <+> text hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]--    dump_doc  = vcat [ nest 2 extra_info-                     , size_doc-                     , blankLine-                     , if dump_core_sizes-                        then pprCoreBindingsWithSize binds-                        else pprCoreBindings         binds-                     , ppUnless (null rules) pp_rules ]-    pp_rules = vcat [ blankLine-                    , text "------ Local rules for imported ids --------"-                    , pprRules rules ]--{--************************************************************************-*                                                                      *-                 Top-level interfaces-*                                                                      *-************************************************************************--}--data LintPassResultConfig = LintPassResultConfig-  { lpr_diagOpts         :: !DiagOpts-  , lpr_platform         :: !Platform-  , lpr_makeLintFlags    :: !LintFlags-  , lpr_showLintWarnings :: !Bool-  , lpr_passPpr          :: !SDoc-  , lpr_localsInScope    :: ![Var]-  }--lintPassResult :: Logger -> LintPassResultConfig-               -> CoreProgram -> IO ()-lintPassResult logger cfg binds-  = do { let warns_and_errs = lintCoreBindings'-               (LintConfig-                { l_diagOpts = lpr_diagOpts cfg-                , l_platform = lpr_platform cfg-                , l_flags    = lpr_makeLintFlags cfg-                , l_vars     = lpr_localsInScope cfg-                })-               binds-       ; Err.showPass logger $-           "Core Linted result of " ++-           renderWithContext defaultSDocContext (lpr_passPpr cfg)-       ; displayLintResults logger-                            (lpr_showLintWarnings cfg) (lpr_passPpr cfg)-                            (pprCoreBindings binds) warns_and_errs-       }--displayLintResults :: Logger-                   -> Bool -- ^ If 'True', display linter warnings.-                           --   If 'False', ignore linter warnings.-                   -> SDoc -- ^ The source of the linted program-                   -> SDoc -- ^ The linted program, pretty-printed-                   -> WarnsAndErrs-                   -> IO ()-displayLintResults logger display_warnings pp_what pp_pgm (warns, errs)-  | not (isEmptyBag errs)-  = do { logMsg logger Err.MCInfo noSrcSpan  -- See Note [MCInfo for Lint]-           $ withPprStyle defaultDumpStyle-           (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs-                 , text "*** Offending Program ***"-                 , pp_pgm-                 , text "*** End of Offense ***" ])-       ; Err.ghcExit logger 1 }--  | not (isEmptyBag warns)-  , log_enable_debug (logFlags logger)-  , display_warnings-  = logMsg logger Err.MCInfo noSrcSpan  -- See Note [MCInfo for Lint]-      $ withPprStyle defaultDumpStyle-        (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))--  | otherwise = return ()--lint_banner :: String -> SDoc -> SDoc-lint_banner string pass = text "*** Core Lint"      <+> text string-                          <+> text ": in result of" <+> pass-                          <+> text "***"---- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].-lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs---   Returns (warnings, errors)--- If you edit this function, you may need to update the GHC formalism--- See Note [GHC Formalism]-lintCoreBindings' cfg binds-  = initL cfg $-    addLoc TopLevelBindings           $-    do { checkL (null dups) (dupVars dups)-       ; checkL (null ext_dups) (dupExtVars ext_dups)-       ; lintRecBindings TopLevel all_pairs $ \_ ->-         return () }-  where-    all_pairs = flattenBinds binds-     -- Put all the top-level binders in scope at the start-     -- This is because rewrite rules can bring something-     -- into use 'unexpectedly'; see Note [Glomming] in "GHC.Core.Opt.OccurAnal"-    binders = map fst all_pairs--    (_, dups) = removeDups compare binders--    -- ext_dups checks for names with different uniques-    -- but the same External name M.n.  We don't-    -- allow this at top level:-    --    M.n{r3}  = ...-    --    M.n{r29} = ...-    -- because they both get the same linker symbol-    ext_dups = snd $ removeDupsOn ord_ext $-               filter isExternalName $ map Var.varName binders-    ord_ext n = (nameModule n, nameOccName n)--{--************************************************************************-*                                                                      *-\subsection[lintUnfolding]{lintUnfolding}-*                                                                      *-************************************************************************--Note [Linting Unfoldings from Interfaces]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We use this to check all top-level unfoldings that come in from interfaces-(it is very painful to catch errors otherwise).--We do not need to call lintUnfolding on unfoldings that are nested within-top-level unfoldings; they are linted when we lint the top-level unfolding;-hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore.---}--lintUnfolding :: Bool             -- ^ True <=> is a compulsory unfolding-              -> LintConfig-              -> SrcLoc-              -> CoreExpr-              -> Maybe (Bag SDoc) -- Nothing => OK--lintUnfolding is_compulsory cfg locn expr-  | isEmptyBag errs = Nothing-  | otherwise       = Just errs-  where-    (_warns, errs) = initL cfg $-                     if is_compulsory-                       -- See Note [Checking for representation polymorphism]-                     then noFixedRuntimeRepChecks linter-                     else linter-    linter = addLoc (ImportedUnfolding locn) $-             lintCoreExpr expr--lintExpr :: LintConfig-         -> CoreExpr-         -> Maybe (Bag SDoc)  -- Nothing => OK--lintExpr cfg expr-  | isEmptyBag errs = Nothing-  | otherwise       = Just errs-  where-    (_warns, errs) = initL cfg linter-    linter = addLoc TopLevelBindings $-             lintCoreExpr expr--{--************************************************************************-*                                                                      *-\subsection[lintCoreBinding]{lintCoreBinding}-*                                                                      *-************************************************************************--Check a core binding, returning the list of variables bound.--}---- Returns a UsageEnv because this function is called in lintCoreExpr for--- Let--lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)]-                -> ([LintedId] -> LintM a) -> LintM (a, [UsageEnv])-lintRecBindings top_lvl pairs thing_inside-  = lintIdBndrs top_lvl bndrs $ \ bndrs' ->-    do { ues <- zipWithM lint_pair bndrs' rhss-       ; a <- thing_inside bndrs'-       ; return (a, ues) }-  where-    (bndrs, rhss) = unzip pairs-    lint_pair bndr' rhs-      = addLoc (RhsOf bndr') $-        do { (rhs_ty, ue) <- lintRhs bndr' rhs         -- Check the rhs-           ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty-           ; return ue }--lintLetBody :: LintLocInfo -> [LintedId] -> CoreExpr -> LintM (LintedType, UsageEnv)-lintLetBody loc bndrs body-  = do { (body_ty, body_ue) <- addLoc loc (lintCoreExpr body)-       ; mapM_ (lintJoinBndrType body_ty) bndrs-       ; return (body_ty, body_ue) }--lintLetBind :: TopLevelFlag -> RecFlag -> LintedId-              -> CoreExpr -> LintedType -> LintM ()--- Binder's type, and the RHS, have already been linted--- This function checks other invariants-lintLetBind top_lvl rec_flag binder rhs rhs_ty-  = do { let binder_ty = idType binder-       ; ensureEqTys binder_ty rhs_ty (mkRhsMsg binder (text "RHS") rhs_ty)--       -- If the binding is for a CoVar, the RHS should be (Coercion co)-       -- See Note [Core type and coercion invariant] in GHC.Core-       ; checkL (not (isCoVar binder) || isCoArg rhs)-                (mkLetErr binder rhs)--        -- Check the let-can-float invariant-        -- See Note [Core let-can-float invariant] in GHC.Core-       ; checkL ( isJoinId binder-               || mightBeLiftedType binder_ty-               || (isNonRec rec_flag && exprOkForSpeculation rhs)-               || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed-               || exprIsTickedString rhs)-           (badBndrTyMsg binder (text "unlifted"))--        -- Check that if the binder is at the top level and has type Addr#,-        -- that it is a string literal.-        -- See Note [Core top-level string literals].-       ; checkL (not (isTopLevel top_lvl && binder_ty `eqType` addrPrimTy)-                 || exprIsTickedString rhs)-           (mkTopNonLitStrMsg binder)--       ; flags <- getLintFlags--         -- Check that a join-point binder has a valid type-         -- NB: lintIdBinder has checked that it is not top-level bound-       ; case idJoinPointHood binder of-            NotJoinPoint    -> return ()-            JoinPoint arity ->  checkL (isValidJoinPointType arity binder_ty)-                                       (mkInvalidJoinPointMsg binder binder_ty)--       ; when (lf_check_inline_loop_breakers flags-               && isStableUnfolding (realIdUnfolding binder)-               && isStrongLoopBreaker (idOccInfo binder)-               && isInlinePragma (idInlinePragma binder))-              (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder))-              -- Only non-rule loop breakers inhibit inlining--       -- We used to check that the dmdTypeDepth of a demand signature never-       -- exceeds idArity, but that is an unnecessary complication, see-       -- Note [idArity varies independently of dmdTypeDepth] in GHC.Core.Opt.DmdAnal--       -- Check that the binder's arity is within the bounds imposed by the type-       -- and the strictness signature. See Note [Arity invariants for bindings]-       -- and Note [Trimming arity]--       ; checkL (typeArity (idType binder) >= idArity binder)-           (text "idArity" <+> ppr (idArity binder) <+>-           text "exceeds typeArity" <+>-           ppr (typeArity (idType binder)) <> colon <+>-           ppr binder)--       -- See Note [idArity varies independently of dmdTypeDepth]-       --     in GHC.Core.Opt.DmdAnal-       ; case splitDmdSig (idDmdSig binder) of-           (demands, result_info) | isDeadEndDiv result_info ->-              if (demands `lengthAtLeast` idArity binder)-              then return ()-              else pprTrace "Hack alert: lintLetBind #24623"-                       (ppr (idArity binder) $$ ppr (idDmdSig binder)) $-                   return ()---             checkL (demands `lengthAtLeast` idArity binder)---               (text "idArity" <+> ppr (idArity binder) <+>---               text "exceeds arity imposed by the strictness signature" <+>---               ppr (idDmdSig binder) <> colon <+>---               ppr binder)--           _ -> return ()--       ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)--       ; addLoc (UnfoldingOf binder) $-         lintIdUnfolding binder binder_ty (idUnfolding binder)-       ; return () }--        -- We should check the unfolding, if any, but this is tricky because-        -- the unfolding is a SimplifiableCoreExpr. Give up for now.---- | Checks the RHS of bindings. It only differs from 'lintCoreExpr'--- in that it doesn't reject occurrences of the function 'makeStatic' when they--- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and--- for join points, it skips the outer lambdas that take arguments to the--- join point.------ See Note [Checking StaticPtrs].-lintRhs :: Id -> CoreExpr -> LintM (LintedType, UsageEnv)--- NB: the Id can be Linted or not -- it's only used for---     its OccInfo and join-pointer-hood-lintRhs bndr rhs-    | JoinPoint arity <- idJoinPointHood bndr-    = lintJoinLams arity (Just bndr) rhs-    | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)-    = lintJoinLams arity Nothing rhs---- Allow applications of the data constructor @StaticPtr@ at the top--- but produce errors otherwise.-lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go-  where-    -- Allow occurrences of 'makeStatic' at the top-level but produce errors-    -- otherwise.-    go :: StaticPtrCheck -> LintM (OutType, UsageEnv)-    go AllowAtTopLevel-      | (binders0, rhs') <- collectTyBinders rhs-      , Just (fun, t, info, e) <- collectMakeStaticArgs rhs'-      = markAllJoinsBad $-        foldr-        -- imitate @lintCoreExpr (Lam ...)@-        lintLambda-        -- imitate @lintCoreExpr (App ...)@-        (do fun_ty_ue <- lintCoreExpr fun-            lintCoreArgs fun_ty_ue [Type t, info, e]-        )-        binders0-    go _ = markAllJoinsBad $ lintCoreExpr rhs---- | Lint the RHS of a join point with expected join arity of @n@ (see Note--- [Join points] in "GHC.Core").-lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (LintedType, UsageEnv)-lintJoinLams join_arity enforce rhs-  = go join_arity rhs-  where-    go 0 expr            = lintCoreExpr expr-    go n (Lam var body)  = lintLambda var $ go (n-1) body-    go n expr | Just bndr <- enforce -- Join point with too few RHS lambdas-              = failWithL $ mkBadJoinArityMsg bndr join_arity n rhs-              | otherwise -- Future join point, not yet eta-expanded-              = markAllJoinsBad $ lintCoreExpr expr-                -- Body of lambda is not a tail position--lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()-lintIdUnfolding bndr bndr_ty uf-  | isStableUnfolding uf-  , Just rhs <- maybeUnfoldingTemplate uf-  = do { ty <- fst <$> (if isCompulsoryUnfolding uf-                        then noFixedRuntimeRepChecks $ lintRhs bndr rhs-            --               ^^^^^^^^^^^^^^^^^^^^^^^-            -- See Note [Checking for representation polymorphism]-                        else lintRhs bndr rhs)-       ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) }-lintIdUnfolding  _ _ _-  = return ()       -- Do not Lint unstable unfoldings, because that leads-                    -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars--{- Note [Checking for INLINE loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's very suspicious if a strong loop breaker is marked INLINE.--However, the desugarer generates instance methods with INLINE pragmas-that form a mutually recursive group.  Only after a round of-simplification are they unravelled.  So we suppress the test for-the desugarer.  Here is an example:-  instance Eq T where-    t1 == t2 = blah-    t1 /= t2 = not (t1 == t2)-    {-# INLINE (/=) #-}--This will generate something like-    -- From the class decl for Eq-    data Eq a = EqDict (a->a->Bool) (a->a->Bool)-    eq_sel :: Eq a -> (a->a->Bool)-    eq_sel (EqDict eq _) = eq--    -- From the instance Eq T-    $ceq :: T -> T -> Bool-    $ceq = blah--    Rec { $dfEqT :: Eq T {-# DFunId #-}-          $dfEqT = EqDict $ceq $cnoteq--          $cnoteq :: T -> T -> Bool  {-# INLINE #-}-          $cnoteq x y = not (eq_sel $dfEqT x y) }--Notice that--* `$dfEqT` and `$cnotEq` are mutually recursive.--* We do not want `$dfEqT` to be the loop breaker: it's a DFunId, and-  we want to let it "cancel" with "eq_sel" (see Note [ClassOp/DFun-  selection] in GHC.Tc.TyCl.Instance, which it can't do if it's a loop-  breaker.--So we make `$cnoteq` into the loop breaker. That means it can't-inline, despite the INLINE pragma. That's what gives rise to the-warning, which is perfectly appropriate for, say-   Rec { {-# INLINE f #-}  f = \x -> ...f.... }-We can't inline a recursive function -- it's a loop breaker.--But now we can optimise `eq_sel $dfEqT` to `$ceq`, so we get-  Rec {-    $dfEqT :: Eq T {-# DFunId #-}-    $dfEqT = EqDict $ceq $cnoteq--    $cnoteq :: T -> T -> Bool  {-# INLINE #-}-    $cnoteq x y = not ($ceq x y) }--and now the dependencies of the Rec have gone, and we can split it up to give-    NonRec {  $dfEqT :: Eq T {-# DFunId #-}-              $dfEqT = EqDict $ceq $cnoteq }--    NonRec {  $cnoteq :: T -> T -> Bool  {-# INLINE #-}-              $cnoteq x y = not ($ceq x y) }--Now $cnoteq is not a loop breaker any more, so the INLINE pragma can-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 result of the desugarer.  See-lf_check_inline_loop_breakers in GHC.Core.Lint.---Note [Checking for representation polymorphism]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We ordinarily want to check for bad representation polymorphism. See-Note [Representation polymorphism invariants] in GHC.Core. However, we do *not*-want to do this in a compulsory unfolding. Compulsory unfoldings arise-only internally, for things like newtype wrappers, dictionaries, and-(notably) unsafeCoerce#. These might legitimately be representation-polymorphic;-indeed representation-polymorphic unfoldings are a primary reason for the-very existence of compulsory unfoldings (we can't compile code for-the original, representation-polymorphic, binding).--It is vitally important that we do representation polymorphism checks *after*-performing the unfolding, but not beforehand. This is all safe because-we will check any unfolding after it has been unfolded; checking the-unfolding beforehand is merely an optimization, and one that actively-hurts us here.--Note [Linting of runRW#]-~~~~~~~~~~~~~~~~~~~~~~~~-runRW# has some very special behavior (see Note [runRW magic] in-GHC.CoreToStg.Prep) which CoreLint must accommodate, by allowing-join points in its argument.  For example, this is fine:--    join j x = ...-    in runRW#  (\s. case v of-                       A -> j 3-                       B -> j 4)--Usually those calls to the join point 'j' would not be valid tail calls,-because they occur in a function argument.  But in the case of runRW#-they are fine, because runRW# (\s.e) behaves operationally just like e.-(runRW# is ultimately inlined in GHC.CoreToStg.Prep.)--In the case that the continuation is /not/ a lambda we simply disable this-special behaviour.  For example, this is /not/ fine:--    join j = ...-    in runRW# @r @ty (jump j)--Note [Coercions in terms]-~~~~~~~~~~~~~~~~~~~~~~~~~-The expression (Type ty) can occur only as the argument of an application,-or the RHS of a non-recursive Let.  But what about (Coercion co)?--Currently it appears in ghc-prim:GHC.Types.coercible_sel, a WiredInId whose-definition is:-   coercible_sel :: Coercible a b => (a ~R# b)-   coercible_sel d = case d of-                         MkCoercibleDict (co :: a ~# b) -> Coercion co--So this function has a (Coercion co) in the alternative of a case.--Richard says (!11908): it shouldn't appear outside of arguments, but we've been-loose about this. coercible_sel is some thin ice. Really we should be unpacking-Coercible using case, not a selector. I recall looking into this a few years-back and coming to the conclusion that the fix was worse than the disease. Don't-remember the details, but could probably recover it if we want to revisit.--So Lint current accepts (Coercion co) in arbitrary places.  There is no harm in-that: it really is a value, albeit a zero-bit value.--************************************************************************-*                                                                      *-\subsection[lintCoreExpr]{lintCoreExpr}-*                                                                      *-************************************************************************--}---- Linted things: substitution applied, and type is linted-type LintedType     = Type-type LintedKind     = Kind-type LintedCoercion = Coercion-type LintedTyCoVar  = TyCoVar-type LintedId       = Id---- | Lint an expression cast through the given coercion, returning the type--- resulting from the cast.-lintCastExpr :: CoreExpr -> LintedType -> Coercion -> LintM LintedType-lintCastExpr expr expr_ty co-  = do { co' <- lintCoercion co-       ; let (Pair from_ty to_ty, role) = coercionKindRole co'-       ; checkValueType to_ty $-         text "target of cast" <+> quotes (ppr co')-       ; lintRole co' Representational role-       ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)-       ; return to_ty }--lintCoreExpr :: CoreExpr -> LintM (LintedType, UsageEnv)--- The returned type has the substitution from the monad--- already applied to it:---      lintCoreExpr e subst = exprType (subst e)------ The returned "type" can be a kind, if the expression is (Type ty)---- If you edit this function, you may need to update the GHC formalism--- See Note [GHC Formalism]--lintCoreExpr (Var var)-  = do-      var_pair@(var_ty, _) <- lintIdOcc var 0-      -- See Note [Linting representation-polymorphic builtins]-      checkRepPolyBuiltin (Var var) [] var_ty-      --checkDataToTagPrimOpTyCon (Var var) []-      return var_pair--lintCoreExpr (Lit lit)-  = return (literalType lit, zeroUE)--lintCoreExpr (Cast expr co)-  = do (expr_ty, ue) <- markAllJoinsBad (lintCoreExpr expr)-            -- markAllJoinsBad: see Note [Join points and casts]-       to_ty <- lintCastExpr expr expr_ty co-       return (to_ty, ue)--lintCoreExpr (Tick tickish expr)-  = do case tickish of-         Breakpoint _ _ ids _ -> forM_ ids $ \id -> do-                                   checkDeadIdOcc id-                                   lookupIdInScope id-         _                    -> return ()-       markAllJoinsBadIf block_joins $ lintCoreExpr expr-  where-    block_joins = not (tickish `tickishScopesLike` SoftScope)-      -- TODO Consider whether this is the correct rule. It is consistent with-      -- the simplifier's behaviour - cost-centre-scoped ticks become part of-      -- the continuation, and thus they behave like part of an evaluation-      -- context, but soft-scoped and non-scoped ticks simply wrap the result-      -- (see Simplify.simplTick).--lintCoreExpr (Let (NonRec tv (Type ty)) body)-  | isTyVar tv-  =     -- See Note [Linting type lets]-    do  { ty' <- lintType ty-        ; lintTyBndr tv              $ \ tv' ->-    do  { addLoc (RhsOf tv) $ lintTyKind tv' ty'-                -- Now extend the substitution so we-                -- take advantage of it in the body-        ; extendTvSubstL tv ty'        $-          addLoc (BodyOfLet tv) $-          lintCoreExpr body } }--lintCoreExpr (Let (NonRec bndr rhs) body)-  | isId bndr-  = do { -- First Lint the RHS, before bringing the binder into scope-         (rhs_ty, let_ue) <- lintRhs bndr rhs--          -- See Note [Multiplicity of let binders] in Var-         -- Now lint the binder-       ; lintBinder LetBind bndr $ \bndr' ->-    do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty-       ; addAliasUE bndr let_ue (lintLetBody (BodyOfLet bndr') [bndr'] body) } }--  | otherwise-  = failWithL (mkLetErr bndr rhs)       -- Not quite accurate--lintCoreExpr e@(Let (Rec pairs) body)-  = do  { -- Check that the list of pairs is non-empty-          checkL (not (null pairs)) (emptyRec e)--          -- Check that there are no duplicated binders-        ; let (_, dups) = removeDups compare bndrs-        ; checkL (null dups) (dupVars dups)--          -- Check that either all the binders are joins, or none-        ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $-          mkInconsistentRecMsg bndrs--          -- See Note [Multiplicity of let binders] in Var-        ; ((body_type, body_ue), ues) <--            lintRecBindings NotTopLevel pairs $ \ bndrs' ->-            lintLetBody (BodyOfLetRec bndrs') bndrs' body-        ; return (body_type, body_ue  `addUE` scaleUE ManyTy (foldr1 addUE ues)) }-  where-    bndrs = map fst pairs--lintCoreExpr e@(App _ _)-  | Var fun <- fun-  , fun `hasKey` runRWKey-    -- N.B. we may have an over-saturated application of the form:-    --   runRW (\s -> \x -> ...) y-  , ty_arg1 : ty_arg2 : arg3 : rest <- args-  = do { fun_pair1      <- lintCoreArg (idType fun, zeroUE) ty_arg1-       ; (fun_ty2, ue2) <- lintCoreArg fun_pair1            ty_arg2-         -- See Note [Linting of runRW#]-       ; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv)-             lintRunRWCont expr@(Lam _ _) =-                lintJoinLams 1 (Just fun) expr-             lintRunRWCont other = markAllJoinsBad $ lintCoreExpr other-             -- TODO: Look through ticks?-       ; (arg3_ty, ue3) <- lintRunRWCont arg3-       ; app_ty <- lintValApp arg3 fun_ty2 arg3_ty ue2 ue3-       ; lintCoreArgs app_ty rest }--  | otherwise-  = do { fun_pair <- lintCoreFun fun (length args)-       ; app_pair@(app_ty, _) <- lintCoreArgs fun_pair args--       -- See Note [Linting representation-polymorphic builtins]-       ; checkRepPolyBuiltin fun args app_ty-       ; --checkDataToTagPrimOpTyCon fun args--       ; return app_pair}-  where-    skipTick t = case collectFunSimple e of-      (Var v) -> etaExpansionTick v t-      _ -> tickishFloatable t-    (fun, args, _source_ticks) = collectArgsTicks skipTick e-      -- We must look through source ticks to avoid #21152, for example:-      ---      -- reallyUnsafePtrEquality-      --   = \ @a ->-      --       (src<loc> reallyUnsafePtrEquality#)-      --         @Lifted @a @Lifted @a-      ---      -- To do this, we use `collectArgsTicks tickishFloatable` to match-      -- the eta expansion behaviour, as per Note [Eta expansion and source notes]-      -- in GHC.Core.Opt.Arity.-      -- Sadly this was not quite enough. So we now also accept things that CorePrep will allow.-      -- See Note [Ticks and mandatory eta expansion]--lintCoreExpr (Lam var expr)-  = markAllJoinsBad $-    lintLambda var $ lintCoreExpr expr--lintCoreExpr (Case scrut var alt_ty alts)-  = lintCaseExpr scrut var alt_ty alts---- This case can't happen; linting types in expressions gets routed through--- lintCoreArgs-lintCoreExpr (Type ty)-  = failWithL (text "Type found as expression" <+> ppr ty)--lintCoreExpr (Coercion co)-  -- See Note [Coercions in terms]-  = do { co' <- addLoc (InCo co) $-                lintCoercion co-       ; return (coercionType co', zeroUE) }-------------------------lintIdOcc :: Var -> Int -- Number of arguments (type or value) being passed-          -> LintM (LintedType, UsageEnv) -- returns type of the *variable*-lintIdOcc var nargs-  = addLoc (OccOf var) $-    do  { checkL (isNonCoVarId var)-                 (text "Non term variable" <+> ppr var)-                 -- See GHC.Core Note [Variable occurrences in Core]--        -- Check that the type of the occurrence is the same-        -- as the type of the binding site.  The inScopeIds are-        -- /un-substituted/, so this checks that the occurrence type-        -- is identical to the binder type.-        -- This makes things much easier for things like:-        --    /\a. \(x::Maybe a). /\a. ...(x::Maybe a)...-        -- The "::Maybe a" on the occurrence is referring to the /outer/ a.-        -- If we compared /substituted/ types we'd risk comparing-        -- (Maybe a) from the binding site with bogus (Maybe a1) from-        -- the occurrence site.  Comparing un-substituted types finesses-        -- this altogether-        ; (bndr, linted_bndr_ty) <- lookupIdInScope var-        ; let occ_ty  = idType var-              bndr_ty = idType bndr-        ; ensureEqTys occ_ty bndr_ty $-          mkBndrOccTypeMismatchMsg bndr var bndr_ty occ_ty--          -- Check for a nested occurrence of the StaticPtr constructor.-          -- See Note [Checking StaticPtrs].-        ; lf <- getLintFlags-        ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $-            checkL (idName var /= makeStaticName) $-              text "Found makeStatic nested in an expression"--        ; checkDeadIdOcc var-        ; checkJoinOcc var nargs-        ; case isDataConId_maybe var of-             Nothing -> return ()-             Just dc -> checkTypeDataConOcc "expression" dc--        ; usage <- varCallSiteUsage var--        ; return (linted_bndr_ty, usage) }--lintCoreFun :: CoreExpr-            -> Int                          -- Number of arguments (type or val) being passed-            -> LintM (LintedType, UsageEnv) -- Returns type of the *function*-lintCoreFun (Var var) nargs-  = lintIdOcc var nargs--lintCoreFun (Lam var body) nargs-  -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad;-  -- See Note [Beta redexes]-  | nargs /= 0-  = lintLambda var $ lintCoreFun body (nargs - 1)--lintCoreFun expr nargs-  = markAllJoinsBadIf (nargs /= 0) $-      -- See Note [Join points are less general than the paper]-    lintCoreExpr expr--------------------lintLambda :: Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)-lintLambda var lintBody =-    addLoc (LambdaBodyOf var) $-    lintBinder LambdaBind var $ \ var' ->-    do { (body_ty, ue) <- lintBody-       ; ue' <- checkLinearity ue var'-       ; return (mkLamType var' body_ty, ue') }--------------------checkDeadIdOcc :: Id -> LintM ()--- Occurrences of an Id should never be dead....--- except when we are checking a case pattern-checkDeadIdOcc id-  | isDeadOcc (idOccInfo id)-  = do { in_case <- inCasePat-       ; checkL in_case-                (text "Occurrence of a dead Id" <+> ppr id) }-  | otherwise-  = return ()---------------------lintJoinBndrType :: LintedType -- Type of the body-                 -> LintedId   -- Possibly a join Id-                -> LintM ()--- Checks that the return type of a join Id matches the body--- E.g. join j x = rhs in body---      The type of 'rhs' must be the same as the type of 'body'-lintJoinBndrType body_ty bndr-  | JoinPoint arity <- idJoinPointHood bndr-  , let bndr_ty = idType bndr-  , (bndrs, res) <- splitPiTys bndr_ty-  = checkL (length bndrs >= arity-            && body_ty `eqType` mkPiTys (drop arity bndrs) res) $-    hang (text "Join point returns different type than body")-       2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr)-               , text "Join arity:" <+> ppr arity-               , text "Body type:" <+> ppr body_ty ])-  | otherwise-  = return ()--checkJoinOcc :: Id -> JoinArity -> LintM ()--- Check that if the occurrence is a JoinId, then so is the--- binding site, and it's a valid join Id-checkJoinOcc var n_args-  | JoinPoint join_arity_occ <- idJoinPointHood var-  = do { mb_join_arity_bndr <- lookupJoinId var-       ; case mb_join_arity_bndr of {-           NotJoinPoint -> do { join_set <- getValidJoins-                              ; addErrL (text "join set " <+> ppr join_set $$-                                invalidJoinOcc var) } ;--           JoinPoint join_arity_bndr ->--    do { checkL (join_arity_bndr == join_arity_occ) $-           -- Arity differs at binding site and occurrence-         mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ--       ; checkL (n_args == join_arity_occ) $-           -- Arity doesn't match #args-         mkBadJumpMsg var join_arity_occ n_args } } }--  | otherwise-  = return ()--checkTypeDataConOcc :: String -> DataCon -> LintM ()--- Check that the Id is not a data constructor of a `type data` declaration--- Invariant (I1) of Note [Type data declarations] in GHC.Rename.Module-checkTypeDataConOcc what dc-  = checkL (not (isTypeDataTyCon (dataConTyCon dc))) $-    (text "type data constructor found in a" <+> text what <> colon <+> ppr dc)--{---- | Check that a use of a dataToTag# primop satisfies conditions DTT2--- and DTT3 from Note [DataToTag overview] in GHC.Tc.Instance.Class------ Ignores applications not headed by dataToTag# primops.---- Commented out because GHC.PrimopWrappers doesn't respect this condition yet.--- See wrinkle DTW7 in Note [DataToTag overview].-checkDataToTagPrimOpTyCon-  :: CoreExpr   -- ^ the function (head of the application) we are checking-  -> [CoreArg]  -- ^ The arguments to the application-  -> LintM ()-checkDataToTagPrimOpTyCon (Var fun_id) args-  | Just op <- isPrimOpId_maybe fun_id-  , op == DataToTagSmallOp || op == DataToTagLargeOp-  = case args of-      Type _levity : Type dty : _rest-        | Just (tc, _) <- splitTyConApp_maybe dty-        , isValidDTT2TyCon tc-          -> do  platform <- getPlatform-                 let  numConstrs = tyConFamilySize tc-                      isSmallOp = op == DataToTagSmallOp-                 checkL (isSmallFamily platform numConstrs == isSmallOp) $-                   text "dataToTag# primop-size/tycon-family-size mismatch"-        | otherwise -> failWithL $ text "dataToTagLarge# used at non-ADT type:"-                                   <+> ppr dty-      _ -> failWithL $ text "dataToTagLarge# needs two type arguments but has args:"-                       <+> ppr (take 2 args)--checkDataToTagPrimOpTyCon _ _ = pure ()--}---- | Check representation-polymorphic invariants in an application of a--- built-in function or newtype constructor.------ See Note [Linting representation-polymorphic builtins].-checkRepPolyBuiltin :: CoreExpr   -- ^ the function (head of the application) we are checking-                    -> [CoreArg]  -- ^ the arguments to the application-                    -> LintedType -- ^ the instantiated type of the overall application-                    -> LintM ()-checkRepPolyBuiltin (Var fun_id) args app_ty-  = do { do_rep_poly_checks <- lf_check_fixed_rep <$> getLintFlags-       ; when (do_rep_poly_checks && hasNoBinding fun_id) $-           if-             -- (2) representation-polymorphic unlifted newtypes-             | Just dc <- isDataConId_maybe fun_id-             , isNewDataCon dc-             -> if tcHasFixedRuntimeRep $ dataConTyCon dc-                then return ()-                else checkRepPolyNewtypeApp dc args app_ty--             -- (1) representation-polymorphic builtins-             | otherwise-             -> checkRepPolyBuiltinApp fun_id args-       }-checkRepPolyBuiltin _ _ _ = return ()--checkRepPolyNewtypeApp :: DataCon -> [CoreArg] -> LintedType -> LintM ()-checkRepPolyNewtypeApp nt args app_ty-  -- If the newtype is saturated, we're OK.-  | any isValArg args-  = return ()-  -- Otherwise, check we can eta-expand.-  | otherwise-  = case getRuntimeArgTys app_ty of-      (Scaled _ first_val_arg_ty, _):_-        | not $ typeHasFixedRuntimeRep first_val_arg_ty-        -> failWithL (err_msg first_val_arg_ty)-      _ -> return ()--  where--      err_msg :: Type -> SDoc-      err_msg bad_arg_ty-        = vcat [ text "Cannot eta expand unlifted newtype constructor" <+> quotes (ppr nt) <> dot-               , text "Its argument type does not have a fixed runtime representation:"-               , nest 2 $ ppr_ty_ki bad_arg_ty ]--      ppr_ty_ki :: Type -> SDoc-      ppr_ty_ki ty = bullet <+> ppr ty <+> dcolon <+> ppr (typeKind ty)--checkRepPolyBuiltinApp :: Id -> [CoreArg] -> LintM ()-checkRepPolyBuiltinApp fun_id args = checkL (null not_concs) err_msg-  where--    conc_binder_positions :: IntMap ConcreteTvOrigin-    conc_binder_positions-      = concreteTyVarPositions fun_id-      $ idDetailsConcreteTvs-      $ idDetails fun_id--    max_pos :: Int-    max_pos =-      case IntMap.keys conc_binder_positions of-        [] -> 0-        positions -> maximum positions--    not_concs :: [(SDoc, ConcreteTvOrigin)]-    not_concs =-      mapMaybe is_bad (zip [1..max_pos] (map Just args ++ repeat Nothing))-        -- NB: 1-indexed--    is_bad :: (Int, Maybe CoreArg) -> Maybe (SDoc, ConcreteTvOrigin)-    is_bad (pos, mb_arg)-      | Just conc_reason <- IntMap.lookup pos conc_binder_positions-      , Just bad_ty <- case mb_arg of-          Just (Type ki)-            | isConcreteType ki-            -> Nothing-            | otherwise-            -- Here we handle the situation in which a "must be concrete" TyVar-            -- has been instantiated with a type that is not concrete.-            -> Just $ quotes (ppr ki) <+> text "is not concrete."-          -- We expected a type argument in this position, and got something else: panic!-          Just arg ->-            pprPanic "checkRepPolyBuiltinApp: expected a type in this position" $-              vcat [ text "fun_id:" <+> ppr fun_id <+> dcolon <+> ppr (idType fun_id)-                   , text "pos:" <+> ppr pos-                   , text "arg:" <+> ppr arg ]-          Nothing ->-            -- Here we handle the situation in which a "must be concrete" TyVar-            -- has not been instantiated at all.-            case conc_reason of-              ConcreteFRR frr_orig ->-                let ty = frr_type frr_orig-                in  Just $ ppr ty <+> dcolon <+> ppr (typeKind ty)-      = Just (bad_ty, conc_reason)-      | otherwise-      = Nothing--    err_msg :: SDoc-    err_msg-      = vcat $ map ((bullet <+>) . ppr_not_conc) not_concs--    ppr_not_conc :: (SDoc, ConcreteTvOrigin) -> SDoc-    ppr_not_conc (bad_ty, conc) =-      vcat-       [ ppr_conc_orig conc-       , nest 2 bad_ty ]--    ppr_conc_orig :: ConcreteTvOrigin -> SDoc-    ppr_conc_orig (ConcreteFRR frr_orig) =-      case frr_orig of-        FixedRuntimeRepOrigin { frr_context = ctxt } ->-          hsep [ ppr ctxt, text "does not have a fixed runtime representation:" ]---- | Compute the 1-indexed positions in the outer forall'd quantified type variables--- of the type in which the concrete type variables occur.------ See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete.-concreteTyVarPositions :: Id -> ConcreteTyVars -> IntMap ConcreteTvOrigin-concreteTyVarPositions fun_id conc_tvs-  | isNullUFM conc_tvs-  = IntMap.empty-  | otherwise-  = case splitForAllTyCoVars (idType fun_id) of-    ([], _)  -> IntMap.empty-    (tvs, _) ->-      let positions =-            IntMap.fromList-              [ (pos, conc_orig)-              | (tv, pos) <- zip tvs [1..]-              , conc_orig <- maybeToList $ lookupNameEnv conc_tvs (tyVarName tv)-              ]-         -- Assert that we have as many positions as concrete type variables,-         -- i.e. we are not missing any concreteness information.-      in assertPpr (sizeUFM conc_tvs == length positions)-           (vcat [ text "concreteTyVarPositions: missing concreteness information"-                 , text "fun_id:" <+> ppr fun_id-                 , text "tvs:" <+> ppr tvs-                 , text "Expected # of concrete tvs:" <+> ppr (sizeUFM conc_tvs)-                 , text "  Actual # of concrete tvs:" <+> ppr (length positions) ])-           positions---- Check that the usage of var is consistent with var itself, and pop the var--- from the usage environment (this is important because of shadowing).-checkLinearity :: UsageEnv -> Var -> LintM UsageEnv-checkLinearity body_ue lam_var =-  case varMultMaybe lam_var of-    Just mult -> do-      let (lhs, body_ue') = popUE body_ue lam_var-          err_msg = text "Linearity failure in lambda:" <+> ppr lam_var-                    $$ ppr lhs <+> text "⊈" <+> ppr mult-      ensureSubUsage lhs mult err_msg-      return body_ue'-    Nothing    -> return body_ue -- A type variable--{- Note [Join points and casts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-You might think that this should be OK:-   join j x = rhs-   in (case e of-          A   -> alt1-          B x -> (jump j x) |> co)--You might think that, since the cast is ultimately erased, the jump to-`j` should still be OK as a join point.  But no!  See #21716. Suppose--  newtype Age = MkAge Int   -- axAge :: Age ~ Int-  f :: Int -> ...           -- f strict in it's first argument--and consider the expression--  f (join j :: Bool -> Age-          j x = (rhs1 :: Age)-     in case v of-         Just x  -> (j x |> axAge :: Int)-         Nothing -> rhs2)--Then, if the Simplifier pushes the strict call into the join points-and alternatives we'll get--   join j' x = f (rhs1 :: Age)-   in case v of-      Just x  -> j' x |> axAge-      Nothing -> f rhs2--Utterly bogus.  `f` expects an `Int` and we are giving it an `Age`.-No no no.  Casts destroy the tail-call property.  Henc markAllJoinsBad-in the (Cast expr co) case of lintCoreExpr.--Note [No alternatives lint check]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Case expressions with no alternatives are odd beasts, and it would seem-like they would worth be looking at in the linter (cf #10180). We-used to check two things:--* exprIsHNF is false: it would *seem* to be terribly wrong if-  the scrutinee was already in head normal form.--* exprIsDeadEnd is true: we should be able to see why GHC believes the-  scrutinee is diverging for sure.--It was already known that the second test was not entirely reliable.-Unfortunately (#13990), the first test turned out not to be reliable-either. Getting the checks right turns out to be somewhat complicated.--For example, suppose we have (comment 8)--  data T a where-    TInt :: T Int--  absurdTBool :: T Bool -> a-  absurdTBool v = case v of--  data Foo = Foo !(T Bool)--  absurdFoo :: Foo -> a-  absurdFoo (Foo x) = absurdTBool x--GHC initially accepts the empty case because of the GADT conditions. But then-we inline absurdTBool, getting--  absurdFoo (Foo x) = case x of--x is in normal form (because the Foo constructor is strict) but the-case is empty. To avoid this problem, GHC would have to recognize-that matching on Foo x is already absurd, which is not so easy.--More generally, we don't really know all the ways that GHC can-lose track of why an expression is bottom, so we shouldn't make too-much fuss when that happens.---Note [Beta redexes]-~~~~~~~~~~~~~~~~~~~-Consider:--  join j @x y z = ... in-  (\@x y z -> jump j @x y z) @t e1 e2--This is clearly ill-typed, since the jump is inside both an application and a-lambda, either of which is enough to disqualify it as a tail call (see Note-[Invariants on join points] in GHC.Core). However, strictly from a-lambda-calculus perspective, the term doesn't go wrong---after the two beta-reductions, the jump *is* a tail call and everything is fine.--Why would we want to allow this when we have let? One reason is that a compound-beta redex (that is, one with more than one argument) has different scoping-rules: naively reducing the above example using lets will capture any free-occurrence of y in e2. More fundamentally, type lets are tricky; many passes,-such as Float Out, tacitly assume that the incoming program's type lets have-all been dealt with by the simplifier. Thus we don't want to let-bind any types-in, say, GHC.Core.Subst.simpleOptPgm, which in some circumstances can run immediately-before Float Out.--All that said, currently GHC.Core.Subst.simpleOptPgm is the only thing using this-loophole, doing so to avoid re-traversing large functions (beta-reducing a type-lambda without introducing a type let requires a substitution). TODO: Improve-simpleOptPgm so that we can forget all this ever happened.--************************************************************************-*                                                                      *-\subsection[lintCoreArgs]{lintCoreArgs}-*                                                                      *-************************************************************************--The basic version of these functions checks that the argument is a-subtype of the required type, as one would expect.--}---- Takes the functions type and arguments as argument.--- Returns the *result* of applying the function to arguments.--- e.g. f :: Int -> Bool -> Int would return `Int` as result type.-lintCoreArgs  :: (LintedType, UsageEnv) -> [CoreArg] -> LintM (LintedType, UsageEnv)-lintCoreArgs (fun_ty, fun_ue) args = foldM lintCoreArg (fun_ty, fun_ue) args--lintCoreArg  :: (LintedType, UsageEnv) -> CoreArg -> LintM (LintedType, UsageEnv)---- Type argument-lintCoreArg (fun_ty, ue) (Type arg_ty)-  = do { checkL (not (isCoercionTy arg_ty))-                (text "Unnecessary coercion-to-type injection:"-                  <+> ppr arg_ty)-       ; arg_ty' <- lintType arg_ty-       ; res <- lintTyApp fun_ty arg_ty'-       ; return (res, ue) }---- Coercion argument-lintCoreArg (fun_ty, ue) (Coercion co)-  = do { co' <- addLoc (InCo co) $-                lintCoercion co-       ; res <- lintCoApp fun_ty co'-       ; return (res, ue) }---- Other value argument-lintCoreArg (fun_ty, fun_ue) arg-  = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg-           -- See Note [Representation polymorphism invariants] in GHC.Core-       ; flags <- getLintFlags--       ; when (lf_check_fixed_rep flags) $-         -- Only check that 'arg_ty' has a fixed RuntimeRep-         -- if 'lf_check_fixed_rep' is on.-         do { checkL (typeHasFixedRuntimeRep arg_ty)-                     (text "Argument does not have a fixed runtime representation"-                      <+> ppr arg <+> dcolon-                      <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))) }--       ; lintValApp arg fun_ty arg_ty fun_ue arg_ue }--------------------lintAltBinders :: UsageEnv-               -> Var         -- Case binder-               -> LintedType     -- Scrutinee type-               -> LintedType     -- Constructor type-               -> [(Mult, OutVar)]    -- Binders-               -> LintM UsageEnv--- If you edit this function, you may need to update the GHC formalism--- See Note [GHC Formalism]-lintAltBinders rhs_ue _case_bndr scrut_ty con_ty []-  = do { ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty)-       ; return rhs_ue }-lintAltBinders rhs_ue case_bndr scrut_ty con_ty ((var_w, bndr):bndrs)-  | isTyVar bndr-  = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr)-       ; lintAltBinders rhs_ue case_bndr scrut_ty con_ty'  bndrs }-  | otherwise-  = do { (con_ty', _) <- lintValApp (Var bndr) con_ty (idType bndr) zeroUE zeroUE-         -- We can pass zeroUE to lintValApp because we ignore its usage-         -- calculation and compute it in the call for checkCaseLinearity below.-       ; rhs_ue' <- checkCaseLinearity rhs_ue case_bndr var_w bndr-       ; lintAltBinders rhs_ue' case_bndr scrut_ty con_ty' bndrs }---- | Implements the case rules for linearity-checkCaseLinearity :: UsageEnv -> Var -> Mult -> Var -> LintM UsageEnv-checkCaseLinearity ue case_bndr var_w bndr = do-  ensureSubUsage lhs rhs err_msg-  lintLinearBinder (ppr bndr) (case_bndr_w `mkMultMul` var_w) (varMult bndr)-  return $ deleteUE ue bndr-  where-    lhs = bndr_usage `addUsage` (var_w `scaleUsage` case_bndr_usage)-    rhs = case_bndr_w `mkMultMul` var_w-    err_msg  = (text "Linearity failure in variable:" <+> ppr bndr-                $$ ppr lhs <+> text "⊈" <+> ppr rhs-                $$ text "Computed by:"-                <+> text "LHS:" <+> lhs_formula-                <+> text "RHS:" <+> rhs_formula)-    lhs_formula = ppr bndr_usage <+> text "+"-                                 <+> parens (ppr case_bndr_usage <+> text "*" <+> ppr var_w)-    rhs_formula = ppr case_bndr_w <+> text "*" <+> ppr var_w-    case_bndr_w = varMult case_bndr-    case_bndr_usage = lookupUE ue case_bndr-    bndr_usage = lookupUE ue bndr----------------------lintTyApp :: LintedType -> LintedType -> LintM LintedType-lintTyApp fun_ty arg_ty-  | Just (tv,body_ty) <- splitForAllTyVar_maybe fun_ty-  = do  { lintTyKind tv arg_ty-        ; in_scope <- getInScope-        -- substTy needs the set of tyvars in scope to avoid generating-        -- uniques that are already in scope.-        -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst-        ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) }--  | otherwise-  = failWithL (mkTyAppMsg fun_ty arg_ty)--------------------lintCoApp :: LintedType -> LintedCoercion -> LintM LintedType-lintCoApp fun_ty co-  | Just (cv,body_ty) <- splitForAllCoVar_maybe fun_ty-  , let co_ty = coercionType co-        cv_ty = idType cv-  , cv_ty `eqType` co_ty-  = do { in_scope <- getInScope-       ; let init_subst = mkEmptySubst in_scope-             subst = extendCvSubst init_subst cv co-       ; return (substTy subst body_ty) }--  | Just (_, _, arg_ty', res_ty') <- splitFunTy_maybe fun_ty-  , co_ty `eqType` arg_ty'-  = return (res_ty')--  | otherwise-  = failWithL (mkCoAppMsg fun_ty co)--  where-    co_ty = coercionType co----------------------- | @lintValApp arg fun_ty arg_ty@ lints an application of @fun arg@--- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the--- application.-lintValApp :: CoreExpr -> LintedType -> LintedType -> UsageEnv -> UsageEnv-           -> LintM (LintedType, UsageEnv)-lintValApp arg fun_ty arg_ty fun_ue arg_ue-  | Just (_, w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty-  = do { ensureEqTys arg_ty' arg_ty (mkAppMsg arg_ty' arg_ty arg)-       ; let app_ue =  addUE fun_ue (scaleUE w arg_ue)-       ; return (res_ty', app_ue) }-  | otherwise-  = failWithL err2-  where-    err2 = mkNonFunAppMsg fun_ty arg_ty arg--lintTyKind :: OutTyVar -> LintedType -> LintM ()--- Both args have had substitution applied---- If you edit this function, you may need to update the GHC formalism--- See Note [GHC Formalism]-lintTyKind tyvar arg_ty-  = unless (arg_kind `eqType` tyvar_kind) $-    addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind))-  where-    tyvar_kind = tyVarKind tyvar-    arg_kind = typeKind arg_ty--{--************************************************************************-*                                                                      *-\subsection[lintCoreAlts]{lintCoreAlts}-*                                                                      *-************************************************************************--}--lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM (LintedType, UsageEnv)-lintCaseExpr scrut var alt_ty alts =-  do { let e = Case scrut var alt_ty alts   -- Just for error messages--     -- Check the scrutinee-     ; (scrut_ty, scrut_ue) <- markAllJoinsBad $ lintCoreExpr scrut-          -- See Note [Join points are less general than the paper]-          -- in GHC.Core-     ; let scrut_mult = varMult var--     ; alt_ty <- addLoc (CaseTy scrut) $-                 lintValueType alt_ty-     ; var_ty <- addLoc (IdTy var) $-                 lintValueType (idType var)--     -- We used to try to check whether a case expression with no-     -- alternatives was legitimate, but this didn't work.-     -- See Note [No alternatives lint check] for details.--     -- Check that the scrutinee is not a floating-point type-     -- if there are any literal alternatives-     -- See GHC.Core Note [Case expression invariants] item (5)-     -- See Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold-     ; let isLitPat (Alt (LitAlt _) _  _) = True-           isLitPat _                     = False-     ; checkL (not $ isFloatingPrimTy scrut_ty && any isLitPat alts)-         (text "Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238)."-          $$ text "scrut" <+> ppr scrut)--     ; case tyConAppTyCon_maybe (idType var) of-         Just tycon-              | debugIsOn-              , isAlgTyCon tycon-              , not (isAbstractTyCon tycon)-              , null (tyConDataCons tycon)-              , not (exprIsDeadEnd scrut)-              -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))-                        -- This can legitimately happen for type families-                      $ return ()-         _otherwise -> return ()--        -- Don't use lintIdBndr on var, because unboxed tuple is legitimate--     ; subst <- getSubst-     ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)-       -- See GHC.Core Note [Case expression invariants] item (7)--     ; lintBinder CaseBind var $ \_ ->-       do { -- Check the alternatives-          ; alt_ues <- mapM (lintCoreAlt var scrut_ty scrut_mult alt_ty) alts-          ; let case_ue = (scaleUE scrut_mult scrut_ue) `addUE` supUEs alt_ues-          ; checkCaseAlts e scrut_ty alts-          ; return (alt_ty, case_ue) } }--checkCaseAlts :: CoreExpr -> LintedType -> [CoreAlt] -> LintM ()--- a) Check that the alts are non-empty--- b1) Check that the DEFAULT comes first, if it exists--- b2) Check that the others are in increasing order--- c) Check that there's a default for infinite types--- NB: Algebraic cases are not necessarily exhaustive, because---     the simplifier correctly eliminates case that can't---     possibly match.--checkCaseAlts e ty alts =-  do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)-         -- See GHC.Core Note [Case expression invariants] item (2)--     ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)-         -- See GHC.Core Note [Case expression invariants] item (3)--          -- For types Int#, Word# with an infinite (well, large!) number of-          -- possible values, there should usually be a DEFAULT case-          -- But (see Note [Empty case alternatives] in GHC.Core) it's ok to-          -- have *no* case alternatives.-          -- In effect, this is a kind of partial test. I suppose it's possible-          -- that we might *know* that 'x' was 1 or 2, in which case-          --   case x of { 1 -> e1; 2 -> e2 }-          -- would be fine.-     ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts)-              (nonExhaustiveAltsMsg e) }-  where-    (con_alts, maybe_deflt) = findDefault alts--        -- Check that successive alternatives have strictly increasing tags-    increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest-    increasing_tag _                         = True--    non_deflt (Alt DEFAULT _ _) = False-    non_deflt _                 = True--    is_infinite_ty = case tyConAppTyCon_maybe ty of-                        Nothing    -> False-                        Just tycon -> isPrimTyCon tycon--lintAltExpr :: CoreExpr -> LintedType -> LintM UsageEnv-lintAltExpr expr ann_ty-  = do { (actual_ty, ue) <- lintCoreExpr expr-       ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty)-       ; return ue }-         -- See GHC.Core Note [Case expression invariants] item (6)--lintCoreAlt :: Var              -- Case binder-            -> LintedType       -- Type of scrutinee-            -> Mult             -- Multiplicity of scrutinee-            -> LintedType       -- Type of the alternative-            -> CoreAlt-            -> LintM UsageEnv--- If you edit this function, you may need to update the GHC formalism--- See Note [GHC Formalism]-lintCoreAlt case_bndr _ scrut_mult alt_ty (Alt DEFAULT args rhs) =-  do { lintL (null args) (mkDefaultArgsMsg args)-     ; rhs_ue <- lintAltExpr rhs alt_ty-     ; let (case_bndr_usage, rhs_ue') = popUE rhs_ue case_bndr-           err_msg = text "Linearity failure in the DEFAULT clause:" <+> ppr case_bndr-                     $$ ppr case_bndr_usage <+> text "⊈" <+> ppr scrut_mult-     ; ensureSubUsage case_bndr_usage scrut_mult err_msg-     ; return rhs_ue' }--lintCoreAlt case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) args rhs)-  | litIsLifted lit-  = failWithL integerScrutinisedMsg-  | otherwise-  = do { lintL (null args) (mkDefaultArgsMsg args)-       ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)-       ; rhs_ue <- lintAltExpr rhs alt_ty-       ; return (deleteUE rhs_ue case_bndr) -- No need for linearity checks-       }-  where-    lit_ty = literalType lit--lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rhs)-  | isNewTyCon (dataConTyCon con)-  = zeroUE <$ addErrL (mkNewTyDataConAltMsg scrut_ty alt)-  | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty-  = addLoc (CaseAlt alt) $  do-    { checkTypeDataConOcc "pattern" con-    ; lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con)--      -- Instantiate the universally quantified-      -- type variables of the data constructor-    ; let { con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys-          ; binderMult (Named _)   = ManyTy-          ; binderMult (Anon st _) = scaledMult st-          -- See Note [Validating multiplicities in a case]-          ; multiplicities = map binderMult $ fst $ splitPiTys con_payload_ty }--        -- And now bring the new binders into scope-    ; lintBinders CasePatBind args $ \ args' -> do-      {-        rhs_ue <- lintAltExpr rhs alt_ty-      ; rhs_ue' <- addLoc (CasePat alt) (lintAltBinders rhs_ue case_bndr scrut_ty con_payload_ty (zipEqual "lintCoreAlt" multiplicities  args'))-      ; return $ deleteUE rhs_ue' case_bndr-      }-   }--  | otherwise   -- Scrut-ty is wrong shape-  = zeroUE <$ addErrL (mkBadAltMsg scrut_ty alt)--{--Note [Validating multiplicities in a case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose 'MkT :: a %m -> T m a'.-If we are validating 'case (x :: T Many a) of MkT y -> ...',-we have to substitute m := Many in the type of MkT - in particular,-y can be used Many times and that expression would still be linear in x.-We do this by looking at con_payload_ty, which is the type of the datacon-applied to the surrounding arguments.-Testcase: linear/should_compile/MultConstructor--Data constructors containing existential tyvars will then have-Named binders, which are always multiplicity Many.-Testcase: indexed-types/should_compile/GADT1--}--lintLinearBinder :: SDoc -> Mult -> Mult -> LintM ()-lintLinearBinder doc actual_usage described_usage-  = ensureSubMult actual_usage described_usage err_msg-    where-      err_msg = (text "Multiplicity of variable does not agree with its context"-                $$ doc-                $$ ppr actual_usage-                $$ text "Annotation:" <+> ppr described_usage)--{--************************************************************************-*                                                                      *-\subsection[lint-types]{Types}-*                                                                      *-************************************************************************--}---- When we lint binders, we (one at a time and in order):---  1. Lint var types or kinds (possibly substituting)---  2. Add the binder to the in scope set, and if its a coercion var,---     we may extend the substitution to reflect its (possibly) new kind-lintBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a-lintBinders _    []         linterF = linterF []-lintBinders site (var:vars) linterF = lintBinder site var $ \var' ->-                                      lintBinders site vars $ \ vars' ->-                                      linterF (var':vars')---- If you edit this function, you may need to update the GHC formalism--- See Note [GHC Formalism]-lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a-lintBinder site var linterF-  | isTyCoVar var = lintTyCoBndr var linterF-  | otherwise     = lintIdBndr NotTopLevel site var linterF--lintTyBndr :: TyVar -> (LintedTyCoVar -> LintM a) -> LintM a-lintTyBndr = lintTyCoBndr  -- We could specialise it, I guess--lintTyCoBndr :: TyCoVar -> (LintedTyCoVar -> LintM a) -> LintM a-lintTyCoBndr tcv thing_inside-  = do { subst <- getSubst-       ; tcv_type' <- lintType (varType tcv)-       ; let tcv' = uniqAway (getSubstInScope subst) $-                    setVarType tcv tcv_type'-             subst' = extendTCvSubstWithClone subst tcv tcv'--       -- See (FORALL1) and (FORALL2) in GHC.Core.Type-       ; if (isTyVar tcv)-         then -- Check that in (forall (a:ki). blah) we have ki:Type-              lintL (isLiftedTypeKind (typeKind tcv_type')) $-              hang (text "TyVar whose kind does not have kind Type:")-                 2 (ppr tcv' <+> dcolon <+> ppr tcv_type' <+> dcolon <+> ppr (typeKind tcv_type'))-         else -- Check that in (forall (cv::ty). blah),-              -- then ty looks like (t1 ~# t2)-              lintL (isCoVarType tcv_type') $-              text "CoVar with non-coercion type:" <+> pprTyVar tcv--       ; updateSubst subst' (thing_inside tcv') }--lintIdBndrs :: forall a. TopLevelFlag -> [Id] -> ([LintedId] -> LintM a) -> LintM a-lintIdBndrs top_lvl ids thing_inside-  = go ids thing_inside-  where-    go :: [Id] -> ([Id] -> LintM a) -> LintM a-    go []       thing_inside = thing_inside []-    go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id  $ \id' ->-                               go ids                         $ \ids' ->-                               thing_inside (id' : ids')--lintIdBndr :: TopLevelFlag -> BindingSite-           -> InVar -> (OutVar -> LintM a) -> LintM a--- Do substitution on the type of a binder and add the var with this--- new type to the in-scope set of the second argument--- ToDo: lint its rules-lintIdBndr top_lvl bind_site id thing_inside-  = assertPpr (isId id) (ppr id) $-    do { flags <- getLintFlags-       ; checkL (not (lf_check_global_ids flags) || isLocalId id)-                (text "Non-local Id binder" <+> ppr id)-                -- See Note [Checking for global Ids]--       -- Check that if the binder is nested, it is not marked as exported-       ; checkL (not (isExportedId id) || is_top_lvl)-           (mkNonTopExportedMsg id)--       -- Check that if the binder is nested, it does not have an external name-       ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl)-           (mkNonTopExternalNameMsg id)--          -- See Note [Representation polymorphism invariants] in GHC.Core-       ; lintL (isJoinId id || not (lf_check_fixed_rep flags)-                || typeHasFixedRuntimeRep id_ty) $-         text "Binder does not have a fixed runtime representation:" <+> ppr id <+> dcolon <+>-            parens (ppr id_ty <+> dcolon <+> ppr (typeKind id_ty))--       -- Check that a join-id is a not-top-level let-binding-       ; when (isJoinId id) $-         checkL (not is_top_lvl && is_let_bind) $-         mkBadJoinBindMsg id--       -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2);-       -- if so, it should be a CoVar, and checked by lintCoVarBndr-       ; lintL (not (isCoVarType id_ty))-               (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty)--       -- Check that the lambda binder has no value or OtherCon unfolding.-       -- See #21496-       ; lintL (not (bind_site == LambdaBind && isEvaldUnfolding (idUnfolding id)))-                (text "Lambda binder with value or OtherCon unfolding.")--       ; linted_ty <- addLoc (IdTy id) (lintValueType id_ty)--       ; addInScopeId id linted_ty $-         thing_inside (setIdType id linted_ty) }-  where-    id_ty = idType id--    is_top_lvl = isTopLevel top_lvl-    is_let_bind = case bind_site of-                    LetBind -> True-                    _       -> False--{--%************************************************************************-%*                                                                      *-             Types-%*                                                                      *-%************************************************************************--}--lintValueType :: Type -> LintM LintedType--- Types only, not kinds--- Check the type, and apply the substitution to it--- See Note [Linting type lets]-lintValueType ty-  = addLoc (InType ty) $-    do  { ty' <- lintType ty-        ; let sk = typeKind ty'-        ; lintL (isTYPEorCONSTRAINT sk) $-          hang (text "Ill-kinded type:" <+> ppr ty)-             2 (text "has kind:" <+> ppr sk)-        ; return ty' }--checkTyCon :: TyCon -> LintM ()-checkTyCon tc-  = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc)----------------------checkTyCoVarInScope :: Subst -> TyCoVar -> LintM ()-checkTyCoVarInScope subst tcv-  = checkL (tcv `isInScope` subst) $-    hang (text "The type or coercion variable" <+> pprBndr LetBind tcv)-       2 (text "is out of scope")----------------------lintType :: Type -> LintM LintedType---- If you edit this function, you may need to update the GHC formalism--- See Note [GHC Formalism]-lintType (TyVarTy tv)-  | not (isTyVar tv)-  = failWithL (mkBadTyVarMsg tv)--  | otherwise-  = do { subst <- getSubst-       ; case lookupTyVar subst tv of-           Just linted_ty -> return linted_ty--           -- In GHCi we may lint an expression with a free-           -- type variable.  Then it won't be in the-           -- substitution, but it should be in scope-           Nothing -> do { checkTyCoVarInScope subst tv-                         ; return (TyVarTy tv) }-     }--lintType ty@(AppTy t1 t2)-  | TyConApp {} <- t1-  = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty-  | otherwise-  = do { t1' <- lintType t1-       ; t2' <- lintType t2-       ; lint_ty_app ty (typeKind t1') [t2']-       ; return (AppTy t1' t2') }--lintType ty@(TyConApp tc tys)-  | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc-  = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags-       ; lintTySynFamApp report_unsat ty tc tys }--  | Just {} <- tyConAppFunTy_maybe tc tys-    -- We should never see a saturated application of funTyCon; such-    -- applications should be represented with the FunTy constructor.-    -- See Note [Linting function types]-  = failWithL (hang (text "Saturated application of" <+> quotes (ppr tc)) 2 (ppr ty))--  | otherwise  -- Data types, data families, primitive types-  = do { checkTyCon tc-       ; tys' <- mapM lintType tys-       ; lint_ty_app ty (tyConKind tc) tys'-       ; return (TyConApp tc tys') }---- arrows can related *unlifted* kinds, so this has to be separate from--- a dependent forall.-lintType ty@(FunTy af tw t1 t2)-  = do { t1' <- lintType t1-       ; t2' <- lintType t2-       ; tw' <- lintType tw-       ; lintArrow (text "type or kind" <+> quotes (ppr ty)) t1' t2' tw'-       ; let real_af = chooseFunTyFlag t1 t2-       ; unless (real_af == af) $ addErrL $-         hang (text "Bad FunTyFlag in FunTy")-            2 (vcat [ ppr ty-                    , text "FunTyFlag =" <+> ppr af-                    , text "Computed FunTyFlag =" <+> ppr real_af ])-       ; return (FunTy af tw' t1' t2') }--lintType ty@(ForAllTy (Bndr tcv vis) body_ty)-  | not (isTyCoVar tcv)-  = failWithL (text "Non-Tyvar or Non-Covar bound in type:" <+> ppr ty)-  | otherwise-  = lintTyCoBndr tcv $ \tcv' ->-    do { body_ty' <- lintType body_ty-       ; lintForAllBody tcv' body_ty'--       ; when (isCoVar tcv) $-         lintL (tcv `elemVarSet` tyCoVarsOfType body_ty) $-         text "Covar does not occur in the body:" <+> (ppr tcv $$ ppr body_ty)-         -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]--       ; return (ForAllTy (Bndr tcv' vis) body_ty') }--lintType ty@(LitTy l)-  = do { lintTyLit l; return ty }--lintType (CastTy ty co)-  = do { ty' <- lintType ty-       ; co' <- lintStarCoercion co-       ; let tyk = typeKind ty'-             cok = coercionLKind co'-       ; ensureEqTys tyk cok (mkCastTyErr ty co tyk cok)-       ; return (CastTy ty' co') }--lintType (CoercionTy co)-  = do { co' <- lintCoercion co-       ; return (CoercionTy co') }--------------------lintForAllBody :: LintedTyCoVar -> LintedType -> LintM ()--- Do the checks for the body of a forall-type-lintForAllBody tcv body_ty-  = do { checkValueType body_ty (text "the body of forall:" <+> ppr body_ty)--         -- For type variables, check for skolem escape-         -- See Note [Phantom type variables in kinds] in GHC.Core.Type-         -- The kind of (forall cv. th) is liftedTypeKind, so no-         -- need to check for skolem-escape in the CoVar case-       ; let body_kind = typeKind body_ty-       ; when (isTyVar tcv) $-         case occCheckExpand [tcv] body_kind of-           Just {} -> return ()-           Nothing -> failWithL $-                      hang (text "Variable escape in forall:")-                         2 (vcat [ text "tyvar:" <+> ppr tcv-                                 , text "type:" <+> ppr body_ty-                                 , text "kind:" <+> ppr body_kind ])-    }--------------------lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM LintedType--- The TyCon is a type synonym or a type family (not a data family)--- See Note [Linting type synonym applications]--- c.f. GHC.Tc.Validity.check_syn_tc_app-lintTySynFamApp report_unsat ty tc tys-  | report_unsat   -- Report unsaturated only if report_unsat is on-  , tys `lengthLessThan` tyConArity tc-  = failWithL (hang (text "Un-saturated type application") 2 (ppr ty))--  -- Deal with type synonyms-  | 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-         tys' <- setReportUnsat False (mapM lintType tys)--       ; when report_unsat $-         do { _ <- lintType expanded_ty-            ; return () }--       ; lint_ty_app ty (tyConKind tc) tys'-       ; return (TyConApp tc tys') }--  -- Otherwise this must be a type family-  | otherwise-  = do { tys' <- mapM lintType tys-       ; lint_ty_app ty (tyConKind tc) tys'-       ; return (TyConApp tc tys') }---------------------- Confirms that a type is really TYPE r or Constraint-checkValueType :: LintedType -> SDoc -> LintM ()-checkValueType ty doc-  = lintL (isTYPEorCONSTRAINT kind)-          (text "Non-Type-like kind when Type-like expected:" <+> ppr kind $$-           text "when checking" <+> doc)-  where-    kind = typeKind ty--------------------lintArrow :: SDoc -> LintedType -> LintedType -> LintedType -> LintM ()--- If you edit this function, you may need to update the GHC formalism--- See Note [GHC Formalism]-lintArrow what t1 t2 tw  -- Eg lintArrow "type or kind `blah'" k1 k2 kw-                         -- or lintArrow "coercion `blah'" k1 k2 kw-  = do { unless (isTYPEorCONSTRAINT k1) (report (text "argument") k1)-       ; unless (isTYPEorCONSTRAINT k2) (report (text "result")   k2)-       ; unless (isMultiplicityTy kw)         (report (text "multiplicity") kw) }-  where-    k1 = typeKind t1-    k2 = typeKind t2-    kw = typeKind tw-    report ar k = addErrL (vcat [ hang (text "Ill-kinded" <+> ar)-                                     2 (text "in" <+> what)-                                , what <+> text "kind:" <+> ppr k ])--------------------lint_ty_app :: Type -> LintedKind -> [LintedType] -> LintM ()-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 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 ()-lintTyLit (NumTyLit n)-  | n >= 0    = return ()-  | otherwise = failWithL msg-    where msg = text "Negative type literal:" <+> integer n-lintTyLit (StrTyLit _) = return ()-lintTyLit (CharTyLit _) = return ()--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]------ 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-         -- Forcing the in scope set eagerly here reduces allocations by up to 4%.-         ; go_app in_scope kfn arg_tys-         }-  where--    -- 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 _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 (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:tas)-      = do { let kv_kind = varType kv-                 ka      = typeKind ta-           ; unless (ka `eqType` 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)))-           ; let kind' = substTy (extendTCvSubst (mkEmptySubst in_scope) kv ta) kfn-           ; go_app in_scope kind' tas }--    go_app _ kfn 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-*                                                                      *-********************************************************************* -}--lintCoreRule :: OutVar -> LintedType -> CoreRule -> LintM ()-lintCoreRule _ _ (BuiltinRule {})-  = return ()  -- Don't bother--lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs-                                   , ru_args = args, ru_rhs = rhs })-  = lintBinders LambdaBind bndrs $ \ _ ->-    do { (lhs_ty, _) <- lintCoreArgs (fun_ty, zeroUE) args-       ; (rhs_ty, _) <- case idJoinPointHood fun of-                     JoinPoint join_arity-                       -> do { checkL (args `lengthIs` join_arity) $-                                mkBadJoinPointRuleMsg fun join_arity rule-                               -- See Note [Rules for join points]-                             ; lintCoreExpr rhs }-                     _ -> markAllJoinsBad $ lintCoreExpr rhs-       ; ensureEqTys lhs_ty rhs_ty $-         (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty-                            , text "rhs type:" <+> ppr rhs_ty-                            , text "fun_ty:" <+> ppr fun_ty ])-       ; let bad_bndrs = filter is_bad_bndr bndrs--       ; checkL (null bad_bndrs)-                (rule_doc <+> text "unbound" <+> ppr bad_bndrs)-            -- See Note [Linting rules]-    }-  where-    rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon--    lhs_fvs = exprsFreeVars args-    rhs_fvs = exprFreeVars rhs--    is_bad_bndr :: Var -> Bool-    -- See Note [Unbound RULE binders] in GHC.Core.Rules-    is_bad_bndr bndr = not (bndr `elemVarSet` lhs_fvs)-                    && bndr `elemVarSet` rhs_fvs-                    && isNothing (isReflCoVar_maybe bndr)---{- Note [Linting rules]-~~~~~~~~~~~~~~~~~~~~~~~-It's very bad if simplifying a rule means that one of the template-variables (ru_bndrs) that /is/ mentioned on the RHS becomes-not-mentioned in the LHS (ru_args).  How can that happen?  Well, in #10602,-SpecConstr stupidly constructed a rule like--  forall x,c1,c2.-     f (x |> c1 |> c2) = ....--But simplExpr collapses those coercions into one.  (Indeed in #10602,-it collapsed to the identity and was removed altogether.)--We don't have a great story for what to do here, but at least-this check will nail it.--NB (#11643): it's possible that a variable listed in the-binders becomes not-mentioned on both LHS and RHS.  Here's a silly-example:-   RULE forall x y. f (g x y) = g (x+1) (y-1)-And suppose worker/wrapper decides that 'x' is Absent.  Then-we'll end up with-   RULE forall x y. f ($gw y) = $gw (x+1)-This seems sufficiently obscure that there isn't enough payoff to-try to trim the forall'd binder list.--Note [Rules for join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A join point cannot be partially applied. However, the left-hand side of a rule-for a join point is effectively a *pattern*, not a piece of code, so there's an-argument to be made for allowing a situation like this:--  join $sj :: Int -> Int -> String-       $sj n m = ...-       j :: forall a. Eq a => a -> a -> String-       {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-}-       j @a $dEq x y = ...--Applying this rule can't turn a well-typed program into an ill-typed one, so-conceivably we could allow it. But we can always eta-expand such an-"undersaturated" rule (see 'GHC.Core.Opt.Arity.etaExpandToJoinPointRule'), and in fact-the simplifier would have to in order to deal with the RHS. So we take a-conservative view and don't allow undersaturated rules for join points. See-Note [Join points and unfoldings/rules] in "GHC.Core.Opt.OccurAnal" for further discussion.--}--{--************************************************************************-*                                                                      *-         Linting coercions-*                                                                      *-************************************************************************--}--{- Note [Asymptotic efficiency]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When linting coercions (and types actually) we return a linted-(substituted) coercion.  Then we often have to take the coercionKind of-that returned coercion. If we get long chains, that can be asymptotically-inefficient, notably in-* TransCo-* InstCo-* SelCo (cf #9233)-* LRCo--But the code is simple.  And this is only Lint.  Let's wait to see if-the bad perf bites us in practice.--A solution would be to return the kind and role of the coercion,-as well as the linted coercion.  Or perhaps even *only* the kind and role,-which is what used to happen.   But that proved tricky and error prone-(#17923), so now we return the coercion.--}----- lints a coercion, confirming that its lh kind and its rh kind are both *--- also ensures that the role is Nominal-lintStarCoercion :: InCoercion -> LintM LintedCoercion-lintStarCoercion g-  = do { g' <- lintCoercion g-       ; let Pair t1 t2 = coercionKind g'-       ; checkValueType t1 (text "the kind of the left type in" <+> ppr g)-       ; checkValueType t2 (text "the kind of the right type in" <+> ppr g)-       ; lintRole g Nominal (coercionRole g)-       ; return g' }--lintCoercion :: InCoercion -> LintM LintedCoercion--- If you edit this function, you may need to update the GHC formalism--- See Note [GHC Formalism]--lintCoercion (CoVarCo cv)-  | not (isCoVar cv)-  = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv)-                  2 (text "With offending type:" <+> ppr (varType cv)))--  | otherwise-  = do { subst <- getSubst-       ; case lookupCoVar subst cv of-           Just linted_co -> return linted_co ;-           Nothing        -> do { checkTyCoVarInScope subst cv-                                ; return (CoVarCo cv) }-     }---lintCoercion (Refl ty)-  = do { ty' <- lintType ty-       ; return (Refl ty') }--lintCoercion (GRefl r ty MRefl)-  = do { ty' <- lintType ty-       ; return (GRefl r ty' MRefl) }--lintCoercion (GRefl r ty (MCo co))-  = do { ty' <- lintType ty-       ; co' <- lintCoercion co-       ; let tk = typeKind ty'-             tl = coercionLKind co'-       ; ensureEqTys tk tl $-         hang (text "GRefl coercion kind mis-match:" <+> ppr co)-            2 (vcat [ppr ty', ppr tk, ppr tl])-       ; lintRole co' Nominal (coercionRole co')-       ; return (GRefl r ty' (MCo co')) }--lintCoercion co@(TyConAppCo r tc cos)-  | Just {} <- tyConAppFunCo_maybe r tc cos-  = failWithL (hang (text "Saturated application of" <+> quotes (ppr tc))-                  2 (ppr co))-    -- All saturated TyConAppCos should be FunCos--  | Just {} <- synTyConDefn_maybe tc-  = failWithL (text "Synonym in TyConAppCo:" <+> ppr co)--  | otherwise-  = do { checkTyCon tc-       ; cos' <- mapM lintCoercion cos-       ; let (co_kinds, co_roles) = unzip (map coercionKindRole cos')-       ; lint_co_app co (tyConKind tc) (map pFst co_kinds)-       ; lint_co_app co (tyConKind tc) (map pSnd co_kinds)-       ; zipWithM_ (lintRole co) (tyConRoleListX r tc) co_roles-       ; return (TyConAppCo r tc cos') }--lintCoercion co@(AppCo co1 co2)-  | TyConAppCo {} <- co1-  = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co)-  | Just (TyConApp {}, _) <- isReflCo_maybe co1-  = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co)-  | otherwise-  = do { co1' <- lintCoercion co1-       ; co2' <- lintCoercion co2-       ; let (Pair lk1 rk1, r1) = coercionKindRole co1'-             (Pair lk2 rk2, r2) = coercionKindRole co2'-       ; lint_co_app co (typeKind lk1) [lk2]-       ; lint_co_app co (typeKind rk1) [rk2]--       ; if r1 == Phantom-         then lintL (r2 == Phantom || r2 == Nominal)-                     (text "Second argument in AppCo cannot be R:" $$-                      ppr co)-         else lintRole co Nominal r2--       ; return (AppCo co1' co2') }-------------lintCoercion co@(ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR-                          , fco_kind = kind_co, fco_body = body_co })--- See Note [ForAllCo] in GHC.Core.TyCo.Rep,--- including the typing rule for ForAllCo--  | not (isTyCoVar tcv)-  = failWithL (text "Non tyco binder in ForAllCo:" <+> ppr co)--  | otherwise-  = do { kind_co' <- lintStarCoercion kind_co-       ; lintTyCoBndr tcv $ \tcv' ->-    do { body_co' <- lintCoercion body_co-       ; ensureEqTys (varType tcv') (coercionLKind kind_co') $-         text "Kind mis-match in ForallCo" <+> ppr co--       -- Assuming kind_co :: k1 ~ k2-       -- Need to check that-       --    (forall (tcv:k1). lty) and-       --    (forall (tcv:k2). rty[(tcv:k2) |> sym kind_co/tcv])-       -- are both well formed.  Easiest way is to call lintForAllBody-       -- for each; there is actually no need to do the funky substitution-       ; let (Pair lty rty, body_role) = coercionKindRole body_co'-       ; lintForAllBody tcv' lty-       ; lintForAllBody tcv' rty--       ; when (isCoVar tcv) $-         do { lintL (visL == coreTyLamForAllTyFlag && visR == coreTyLamForAllTyFlag) $-              text "Invalid visibility flags in CoVar ForAllCo" <+> ppr co-              -- See (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep-            ; lintL (almostDevoidCoVarOfCo tcv body_co) $-              text "Covar can only appear in Refl and GRefl: " <+> ppr co-              -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep-         }--       ; when (body_role == Nominal) $-         lintL (visL `eqForAllVis` visR) $-         text "Nominal ForAllCo has mismatched visibilities: " <+> ppr co--       ; return (co { fco_tcv = tcv', fco_kind = kind_co', fco_body = body_co' }) } }--lintCoercion co@(FunCo { fco_role = r, fco_afl = afl, fco_afr = afr-                       , fco_mult = cow, fco_arg = co1, fco_res = co2 })-  = do { co1' <- lintCoercion co1-       ; co2' <- lintCoercion co2-       ; cow' <- lintCoercion cow-       ; let Pair lt1 rt1 = coercionKind co1-             Pair lt2 rt2 = coercionKind co2-             Pair ltw rtw = coercionKind cow-       ; lintL (afl == chooseFunTyFlag lt1 lt2) (bad_co_msg "afl")-       ; lintL (afr == chooseFunTyFlag rt1 rt2) (bad_co_msg "afr")-       ; lintArrow (bad_co_msg "arrowl") lt1 lt2 ltw-       ; lintArrow (bad_co_msg "arrowr") rt1 rt2 rtw-       ; lintRole co1 r (coercionRole co1)-       ; lintRole co2 r (coercionRole co2)-       ; ensureEqTys (typeKind ltw) multiplicityTy (bad_co_msg "mult-l")-       ; ensureEqTys (typeKind rtw) multiplicityTy (bad_co_msg "mult-r")-       ; let expected_mult_role = case r of-                                    Phantom -> Phantom-                                    _ -> Nominal-       ; lintRole cow expected_mult_role (coercionRole cow)-       ; return (co { fco_mult = cow', fco_arg = co1', fco_res = co2' }) }-  where-    bad_co_msg s = hang (text "Bad coercion" <+> parens (text s))-                      2 (vcat [ text "afl:" <+> ppr afl-                              , text "afr:" <+> ppr afr-                              , text "arg_co:" <+> ppr co1-                              , text "res_co:" <+> ppr co2 ])---- See Note [Bad unsafe coercion]-lintCoercion co@(UnivCo { uco_role = r, uco_prov = prov-                        , uco_lty = ty1, uco_rty = ty2, uco_deps = deps })-  = do { -- Check the role.  PhantomProv must have Phantom role, otherwise any role is fine-         case prov of-            PhantomProv -> lintRole co Phantom r-            _           -> return ()--       -- Check the to and from types-       ; ty1' <- lintType ty1-       ; ty2' <- lintType ty2--       ; let k1 = typeKind ty1'-             k2 = typeKind ty2'-       ; when (r /= Phantom && isTYPEorCONSTRAINT k1-                            && isTYPEorCONSTRAINT k2)-              (checkTypes ty1 ty2)--       -- Check the coercions on which this UnivCo depends-       ; deps' <- mapM lintCoercion deps--       ; return (co { uco_lty = ty1', uco_rty = ty2', uco_deps = deps' }) }-   where-     report s = hang (text $ "Unsafe coercion: " ++ s)-                     2 (vcat [ text "From:" <+> ppr ty1-                             , text "  To:" <+> ppr ty2])-     isUnBoxed :: PrimRep -> Bool-     isUnBoxed = not . isGcPtrRep--       -- see #9122 for discussion of these checks-     checkTypes t1 t2-       = do { checkWarnL fixed_rep_1-                         (report "left-hand type does not have a fixed runtime representation")-            ; checkWarnL fixed_rep_2-                         (report "right-hand type does not have a fixed runtime representation")-            ; when (fixed_rep_1 && fixed_rep_2) $-              do { checkWarnL (reps1 `equalLength` reps2)-                              (report "between values with different # of reps")-                 ; zipWithM_ validateCoercion reps1 reps2 }}-       where-         fixed_rep_1 = typeHasFixedRuntimeRep t1-         fixed_rep_2 = typeHasFixedRuntimeRep t2--         -- don't look at these unless lev_poly1/2 are False-         -- Otherwise, we get #13458-         reps1 = typePrimRep t1-         reps2 = typePrimRep t2--     validateCoercion :: PrimRep -> PrimRep -> LintM ()-     validateCoercion rep1 rep2-       = do { platform <- getPlatform-            ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2)-                         (report "between unboxed and boxed value")-            ; checkWarnL (TyCon.primRepSizeB platform rep1-                           == TyCon.primRepSizeB platform rep2)-                         (report "between unboxed values of different size")-            ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1)-                                   (TyCon.primRepIsFloat rep2)-            ; case fl of-                Nothing    -> addWarnL (report "between vector types")-                Just False -> addWarnL (report "between float and integral values")-                _          -> return ()-            }--lintCoercion (SymCo co)-  = do { co' <- lintCoercion co-       ; return (SymCo co') }--lintCoercion co@(TransCo co1 co2)-  = do { co1' <- lintCoercion co1-       ; co2' <- lintCoercion co2-       ; let ty1b = coercionRKind co1'-             ty2a = coercionLKind co2'-       ; ensureEqTys ty1b ty2a-               (hang (text "Trans coercion mis-match:" <+> ppr co)-                   2 (vcat [ppr (coercionKind co1'), ppr (coercionKind co2')]))-       ; lintRole co (coercionRole co1) (coercionRole co2)-       ; return (TransCo co1' co2') }--lintCoercion the_co@(SelCo cs co)-  = do { co' <- lintCoercion co-       ; let (Pair s t, co_role) = coercionKindRole co'--       ; if -- forall (both TyVar and CoVar)-            | Just _ <- splitForAllTyCoVar_maybe s-            , Just _ <- splitForAllTyCoVar_maybe t-            , SelForAll <- cs-            ,   (isForAllTy_ty s && isForAllTy_ty t)-             || (isForAllTy_co s && isForAllTy_co t)-            -> return (SelCo cs co')--            -- function-            | isFunTy s-            , isFunTy t-            , SelFun {} <- cs-            -> return (SelCo cs co')--            -- TyCon-            | Just (tc_s, tys_s) <- splitTyConApp_maybe s-            , Just (tc_t, tys_t) <- splitTyConApp_maybe t-            , tc_s == tc_t-            , SelTyCon n r0 <- cs-            , isInjectiveTyCon tc_s co_role-                -- see Note [SelCo and newtypes] in GHC.Core.TyCo.Rep-            , tys_s `equalLength` tys_t-            , tys_s `lengthExceeds` n-            -> do { lintRole the_co (tyConRole co_role tc_s n) r0-                  ; return (SelCo cs co') }--            | otherwise-            -> failWithL (hang (text "Bad SelCo:")-                             2 (ppr the_co $$ ppr s $$ ppr t)) }--lintCoercion the_co@(LRCo lr co)-  = do { co' <- lintCoercion co-       ; let Pair s t = coercionKind co'-             r        = coercionRole co'-       ; lintRole co Nominal r-       ; case (splitAppTy_maybe s, splitAppTy_maybe t) of-           (Just _, Just _) -> return (LRCo lr co')-           _ -> failWithL (hang (text "Bad LRCo:")-                              2 (ppr the_co $$ ppr s $$ ppr t)) }--lintCoercion (InstCo co arg)-  = do { co'  <- lintCoercion co-       ; arg' <- lintCoercion arg-       ; let Pair t1 t2 = coercionKind co'-             Pair s1 s2 = coercionKind arg'--       ; lintRole arg Nominal (coercionRole arg')--      ; case (splitForAllTyVar_maybe t1, splitForAllTyVar_maybe t2) of-         -- forall over tvar-         { (Just (tv1,_), Just (tv2,_))-             | typeKind s1 `eqType` tyVarKind tv1-             , typeKind s2 `eqType` tyVarKind tv2-             -> return (InstCo co' arg')-             | otherwise-             -> failWithL (text "Kind mis-match in inst coercion1" <+> ppr co)--         ; _ -> case (splitForAllCoVar_maybe t1, splitForAllCoVar_maybe t2) of-         -- forall over covar-         { (Just (cv1, _), Just (cv2, _))-             | typeKind s1 `eqType` varType cv1-             , typeKind s2 `eqType` varType cv2-             , CoercionTy _ <- s1-             , CoercionTy _ <- s2-             -> return (InstCo co' arg')-             | otherwise-             -> failWithL (text "Kind mis-match in inst coercion2" <+> ppr co)--         ; _ -> failWithL (text "Bad argument of inst") }}}--lintCoercion this_co@(AxiomCo ax cos)-  = do { cos' <- mapM lintCoercion cos-       ; let arg_kinds :: [Pair Type] = map coercionKind cos'-       ; lint_roles 0 (coAxiomRuleArgRoles ax) cos'-       ; lint_ax ax arg_kinds-       ; return (AxiomCo ax cos') }-  where-    lint_ax :: CoAxiomRule -> [Pair Type] -> LintM ()-    lint_ax (BuiltInFamRew  bif) prs-      = checkL (isJust (bifrw_proves bif prs))  bad_bif-    lint_ax (BuiltInFamInj bif) prs-      = checkL (case prs of-                  [pr] -> isJust (bifinj_proves bif pr)-                  _    -> False)-               bad_bif-    lint_ax (UnbranchedAxiom ax) prs-      = lintBranch this_co (coAxiomTyCon ax) (coAxiomSingleBranch ax) prs-    lint_ax (BranchedAxiom ax ind) prs-      = do { checkL (0 <= ind && ind < numBranches (coAxiomBranches ax))-                    (bad_ax this_co (text "index out of range"))-           ; lintBranch this_co (coAxiomTyCon ax) (coAxiomNthBranch ax ind) prs }--    bad_bif = bad_ax this_co (text "Proves returns Nothing")--    err :: forall a. String -> [SDoc] -> LintM a-    err m xs  = failWithL $-                hang (text m) 2 $ vcat (text "Rule:" <+> ppr ax : xs)--    lint_roles n (e : es) (co : cos)-      | e == coercionRole co-      = lint_roles (n+1) es cos-      | otherwise = err "Argument roles mismatch"-                        [ text "In argument:" <+> int (n+1)-                        , text "Expected:" <+> ppr e-                        , text "Found:" <+> ppr (coercionRole co) ]-    lint_roles _ [] []  = return ()-    lint_roles n [] rs  = err "Too many coercion arguments"-                            [ text "Expected:" <+> int n-                            , text "Provided:" <+> int (n + length rs) ]--    lint_roles n es []  = err "Not enough coercion arguments"-                            [ text "Expected:" <+> int (n + length es)-                            , text "Provided:" <+> int n ]---lintCoercion (KindCo co)-  = do { co' <- lintCoercion co-       ; return (KindCo co') }--lintCoercion (SubCo co')-  = do { co' <- lintCoercion co'-       ; lintRole co' Nominal (coercionRole co')-       ; return (SubCo co') }--lintCoercion (HoleCo h)-  = do { addErrL $ text "Unfilled coercion hole:" <+> ppr h-       ; lintCoercion (CoVarCo (coHoleCoVar h)) }---{--Note [Conflict checking for axiom applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the following type family and axiom:--type family Equal (a :: k) (b :: k) :: Bool-type instance where-  Equal a a = True-  Equal a b = False----Equal :: forall k::*. k -> k -> Bool-axEqual :: { forall k::*. forall a::k. Equal k a a ~ True-           ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False }--The coercion (axEqual[1] <*> <Int> <Int) is ill-typed, and Lint should reject it.-(Recall that the index is 0-based, so this is the second branch of the axiom.)-The problem is that, on the surface, it seems that--  (axEqual[1] <*> <Int> <Int>) :: (Equal * Int Int ~ False)--and that all is OK. But, all is not OK: we want to use the first branch of the-axiom in this case, not the second. The problem is that the parameters of the-first branch can unify with the supplied coercions, thus meaning that the first-branch should be taken. See also Note [Apartness] in "GHC.Core.FamInstEnv".--For more details, see the section "Branched axiom conflict checking" in-docs/core-spec, which defines the corresponding no_conflict function used by the-Co_AxiomInstCo rule in the section "Coercion typing".--}---- | Check to make sure that an axiom application is internally consistent.--- Returns the conflicting branch, if it exists--- Note [Conflict checking for axiom applications]-lintBranch :: Coercion -> TyCon-> CoAxBranch -> [Pair Type] -> LintM ()--- defined here to avoid dependencies in GHC.Core.Coercion--- If you edit this function, you may need to update the GHC formalism--- See Note [GHC Formalism] in GHC.Core.Lint-lintBranch this_co fam_tc branch arg_kinds-  | CoAxBranch { cab_tvs = ktvs, cab_cvs = cvs } <- branch-  = do { checkL (arg_kinds `equalLength` (ktvs ++ cvs)) $-                (bad_ax this_co (text "lengths"))--       ; subst <- getSubst-       ; let empty_subst = zapSubst subst-       ; _ <- foldlM check_ki (empty_subst, empty_subst)-                              (zip (ktvs ++ cvs) arg_kinds)--       ; case check_no_conflict flattened_target incomps of-            Nothing -> return ()-            Just bad_branch -> failWithL $ bad_ax this_co $-                               text "inconsistent with" <+>-                                 pprCoAxBranch fam_tc bad_branch }-  where-    check_ki (subst_l, subst_r) (ktv, Pair s' t')-      = do { let sk' = typeKind s'-                 tk' = typeKind t'-           ; let ktv_kind_l = substTy subst_l (tyVarKind ktv)-                 ktv_kind_r = substTy subst_r (tyVarKind ktv)-           ; checkL (sk' `eqType` ktv_kind_l)-                    (bad_ax this_co (text "check_ki1" <+> vcat [ ppr this_co, ppr sk', ppr ktv, ppr ktv_kind_l ] ))-           ; checkL (tk' `eqType` ktv_kind_r)-                    (bad_ax this_co (text "check_ki2" <+> vcat [ ppr this_co, ppr tk', ppr ktv, ppr ktv_kind_r ] ))-           ; return (extendTCvSubst subst_l ktv s',-                     extendTCvSubst subst_r ktv t') }--    tvs          = coAxBranchTyVars branch-    cvs          = coAxBranchCoVars branch-    incomps      = coAxBranchIncomps branch-    (tys, cotys) = splitAtList tvs (map pFst arg_kinds)-    co_args      = map stripCoercionTy cotys-    subst        = zipTvSubst tvs tys `composeTCvSubst`-                   zipCvSubst cvs co_args-    target   = Type.substTys subst (coAxBranchLHS branch)-    in_scope = mkInScopeSet $-               unionVarSets (map (tyCoVarsOfTypes . coAxBranchLHS) incomps)-    flattened_target = flattenTys in_scope target--    check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch-    check_no_conflict _    [] = Nothing-    check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest)-         -- See Note [Apartness] in GHC.Core.FamInstEnv-      | SurelyApart <- tcUnifyTysFG alwaysBindFun flat lhs_incomp-      = check_no_conflict flat rest-      | otherwise-      = Just b--bad_ax :: Coercion -> SDoc -> SDoc-bad_ax this_co what-    = hang (text "Bad axiom application" <+> parens what) 2 (ppr this_co)---{--************************************************************************-*                                                                      *-              Axioms-*                                                                      *-************************************************************************--}--lintAxioms :: Logger-           -> LintConfig-           -> SDoc -- ^ The source of the linted axioms-           -> [CoAxiom Branched]-           -> IO ()-lintAxioms logger cfg what axioms =-  displayLintResults logger True what (vcat $ map pprCoAxiom axioms) $-  initL cfg $-  do { mapM_ lint_axiom axioms-     ; let axiom_groups = groupWith coAxiomTyCon axioms-     ; mapM_ lint_axiom_group axiom_groups }--lint_axiom :: CoAxiom Branched -> LintM ()-lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches-                       , co_ax_role = ax_role })-  = addLoc (InAxiom ax) $-    do { mapM_ (lint_branch tc) branch_list-       ; extra_checks }-  where-    branch_list = fromBranches branches--    extra_checks-      | isNewTyCon tc-      = do { CoAxBranch { cab_tvs     = ax_tvs-                        , cab_eta_tvs = eta_tvs-                        , cab_cvs     = cvs-                        , cab_roles   = roles-                        , cab_lhs     = lhs_tys }-              <- case branch_list of-               [branch] -> return branch-               _        -> failWithL (text "multi-branch axiom with newtype")--           -- The LHS of the axiom is (N lhs_tys)-           -- We expect it to be      (N ax_tvs)-           ; lintL (mkTyVarTys ax_tvs `eqTypes` lhs_tys)-                   (text "Newtype axiom LHS does not match newtype definition")-           ; lintL (null cvs)-                   (text "Newtype axiom binds coercion variables")-           ; lintL (null eta_tvs)  -- See Note [Eta reduction for data families]-                                   -- which is not about newtype axioms-                   (text "Newtype axiom has eta-tvs")-           ; lintL (ax_role == Representational)-                   (text "Newtype axiom role not representational")-           ; lintL (roles `equalLength` ax_tvs)-                   (text "Newtype axiom roles list is the wrong length." $$-                    text "roles:" <+> sep (map ppr roles))-           ; lintL (roles == takeList roles (tyConRoles tc))-                   (vcat [ text "Newtype axiom roles do not match newtype tycon's."-                         , text "axiom roles:" <+> sep (map ppr roles)-                         , text "tycon roles:" <+> sep (map ppr (tyConRoles tc)) ])-           }--      | isFamilyTyCon tc-      = do { if | isTypeFamilyTyCon tc-                  -> lintL (ax_role == Nominal)-                           (text "type family axiom is not nominal")--                | isDataFamilyTyCon tc-                  -> lintL (ax_role == Representational)-                           (text "data family axiom is not representational")--                | otherwise-                  -> addErrL (text "A family TyCon is neither a type family nor a data family:" <+> ppr tc)--           ; mapM_ (lint_family_branch tc) branch_list }--      | otherwise-      = addErrL (text "Axiom tycon is neither a newtype nor a family.")--lint_branch :: TyCon -> CoAxBranch -> LintM ()-lint_branch ax_tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs-                              , cab_lhs = lhs_args, cab_rhs = rhs })-  = lintBinders LambdaBind (tvs ++ cvs) $ \_ ->-    do { let lhs = mkTyConApp ax_tc lhs_args-       ; lhs' <- lintType lhs-       ; rhs' <- lintType rhs-       ; let lhs_kind = typeKind lhs'-             rhs_kind = typeKind rhs'-       ; lintL (not (lhs_kind `typesAreApart` rhs_kind)) $-         hang (text "Inhomogeneous axiom")-            2 (text "lhs:" <+> ppr lhs <+> dcolon <+> ppr lhs_kind $$-               text "rhs:" <+> ppr rhs <+> dcolon <+> ppr rhs_kind) }-         -- Type and Constraint are not Apart, so this test allows-         -- the newtype axiom for a single-method class.  Indeed the-         -- whole reason Type and Constraint are not Apart is to allow-         -- such axioms!---- these checks do not apply to newtype axioms-lint_family_branch :: TyCon -> CoAxBranch -> LintM ()-lint_family_branch fam_tc br@(CoAxBranch { cab_tvs     = tvs-                                         , cab_eta_tvs = eta_tvs-                                         , cab_cvs     = cvs-                                         , cab_roles   = roles-                                         , cab_lhs     = lhs-                                         , cab_incomps = incomps })-  = do { lintL (isDataFamilyTyCon fam_tc || null eta_tvs)-               (text "Type family axiom has eta-tvs")-       ; lintL (all (`elemVarSet` tyCoVarsOfTypes lhs) tvs)-               (text "Quantified variable in family axiom unused in LHS")-       ; lintL (all isTyFamFree lhs)-               (text "Type family application on LHS of family axiom")-       ; lintL (all (== Nominal) roles)-               (text "Non-nominal role in family axiom" $$-                text "roles:" <+> sep (map ppr roles))-       ; lintL (null cvs)-               (text "Coercion variables bound in family axiom")-       ; forM_ incomps $ \ br' ->-           lintL (not (compatibleBranches br br')) $-           hang (text "Incorrect incompatible branches:")-              2 (vcat [text "Branch:"       <+> ppr br,-                       text "Bogus incomp:" <+> ppr br']) }--lint_axiom_group :: NonEmpty (CoAxiom Branched) -> LintM ()-lint_axiom_group (_  :| []) = return ()-lint_axiom_group (ax :| axs)-  = do { lintL (isOpenFamilyTyCon tc)-               (text "Non-open-family with multiple axioms")-       ; let all_pairs = [ (ax1, ax2) | ax1 <- all_axs-                                      , ax2 <- all_axs ]-       ; mapM_ (lint_axiom_pair tc) all_pairs }-  where-    all_axs = ax : axs-    tc      = coAxiomTyCon ax--lint_axiom_pair :: TyCon -> (CoAxiom Branched, CoAxiom Branched) -> LintM ()-lint_axiom_pair tc (ax1, ax2)-  | Just br1@(CoAxBranch { cab_tvs = tvs1-                         , cab_lhs = lhs1-                         , cab_rhs = rhs1 }) <- coAxiomSingleBranch_maybe ax1-  , Just br2@(CoAxBranch { cab_tvs = tvs2-                         , cab_lhs = lhs2-                         , cab_rhs = rhs2 }) <- coAxiomSingleBranch_maybe ax2-  = lintL (compatibleBranches br1 br2) $-    vcat [ hsep [ text "Axioms", ppr ax1, text "and", ppr ax2-                , text "are incompatible" ]-         , text "tvs1 =" <+> pprTyVars tvs1-         , text "lhs1 =" <+> ppr (mkTyConApp tc lhs1)-         , text "rhs1 =" <+> ppr rhs1-         , text "tvs2 =" <+> pprTyVars tvs2-         , text "lhs2 =" <+> ppr (mkTyConApp tc lhs2)-         , text "rhs2 =" <+> ppr rhs2 ]--  | otherwise-  = addErrL (text "Open type family axiom has more than one branch: either" <+>-             ppr ax1 <+> text "or" <+> ppr ax2)--{--************************************************************************-*                                                                      *-\subsection[lint-monad]{The Lint monad}-*                                                                      *-************************************************************************--}---- If you edit this type, you may need to update the GHC formalism--- See Note [GHC Formalism]-data LintEnv-  = LE { le_flags :: LintFlags       -- Linting the result of this pass-       , le_loc   :: [LintLocInfo]   -- Locations--       , le_subst :: Subst  -- Current TyCo substitution-                               --    See Note [Linting type lets]-            -- /Only/ substitutes for type variables;-            --        but might clone CoVars-            -- We also use le_subst to keep track of-            -- in-scope TyVars and CoVars (but not Ids)-            -- Range of the Subst is LintedType/LintedCo--       , le_ids   :: VarEnv (Id, LintedType)    -- In-scope Ids-            -- Used to check that occurrences have an enclosing binder.-            -- The Id is /pre-substitution/, used to check that-            -- the occurrence has an identical type to the binder-            -- The LintedType is used to return the type of the occurrence,-            -- without having to lint it again.--       , le_joins :: IdSet     -- Join points in scope that are valid-                               -- A subset of the InScopeSet in le_subst-                               -- See Note [Join points]--       , le_ue_aliases :: NameEnv UsageEnv -- Assigns usage environments to the-                                           -- alias-like binders, as found in-                                           -- non-recursive lets.--       , le_platform   :: Platform         -- ^ Target platform-       , le_diagOpts   :: DiagOpts         -- ^ Target platform-       }--data LintFlags-  = LF { lf_check_global_ids           :: Bool -- See Note [Checking for global Ids]-       , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers]-       , lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs]-       , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications]-       , lf_check_linearity :: Bool -- ^ See Note [Linting linearity]-       , lf_check_fixed_rep :: Bool -- See Note [Checking for representation polymorphism]-    }---- See Note [Checking StaticPtrs]-data StaticPtrCheck-    = AllowAnywhere-        -- ^ Allow 'makeStatic' to occur anywhere.-    | AllowAtTopLevel-        -- ^ Allow 'makeStatic' calls at the top-level only.-    | RejectEverywhere-        -- ^ Reject any 'makeStatic' occurrence.-  deriving Eq--newtype LintM a =-   LintM' { unLintM ::-            LintEnv ->-            WarnsAndErrs ->           -- Warning and error messages so far-            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-top-level ones. See Note [Exported LocalIds] and #9857.--Note [Checking StaticPtrs]-~~~~~~~~~~~~~~~~~~~~~~~~~~-See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview.--Every occurrence of the function 'makeStatic' should be moved to the-top level by the FloatOut pass.  It's vital that we don't have nested-'makeStatic' occurrences after CorePrep, because we populate the Static-Pointer Table from the top-level bindings. See SimplCore Note [Grand-plan for static forms].--The linter checks that no occurrence is left behind, nested within an-expression. The check is enabled only after the FloatOut, CorePrep,-and CoreTidy passes and only if the module uses the StaticPointers-language extension. Checking more often doesn't help since the condition-doesn't hold until after the first FloatOut pass.--Note [Type substitution]-~~~~~~~~~~~~~~~~~~~~~~~~-Why do we need a type substitution?  Consider-        /\(a:*). \(x:a). /\(a:*). id a x-This is ill typed, because (renaming variables) it is really-        /\(a:*). \(x:a). /\(b:*). id b x-Hence, when checking an application, we can't naively compare x's type-(at its binding site) with its expected type (at a use site).  So we-rename type binders as we go, maintaining a substitution.--The same substitution also supports let-type, current expressed as-        (/\(a:*). body) ty-Here we substitute 'ty' for 'a' in 'body', on the fly.--Note [Linting type synonym applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When linting a type-synonym, or type-family, application-  S ty1 .. tyn-we behave as follows (#15057, #T15664):--* If lf_report_unsat_syns = True, and S has arity < n,-  complain about an unsaturated type synonym or type family--* Switch off lf_report_unsat_syns, and lint ty1 .. tyn.--  Reason: catch out of scope variables or other ill-kinded gubbins,-  even if S discards that argument entirely. E.g. (#15012):-     type FakeOut a = Int-     type family TF a-     type instance TF Int = FakeOut a-  Here 'a' is out of scope; but if we expand FakeOut, we conceal-  that out-of-scope error.--  Reason for switching off lf_report_unsat_syns: with-  LiberalTypeSynonyms, GHC allows unsaturated synonyms provided they-  are saturated when the type is expanded. Example-     type T f = f Int-     type S a = a -> a-     type Z = T S-  In Z's RHS, S appears unsaturated, but it is saturated when T is expanded.--* If lf_report_unsat_syns is on, expand the synonym application and-  lint the result.  Reason: want to check that synonyms are saturated-  when the type is expanded.--Note [Linting linearity]-~~~~~~~~~~~~~~~~~~~~~~~~-Lint ignores linearity unless `-dlinear-core-lint` is set.  For why, see below.--But first, "ignore linearity" specifically means two things. When ignoring linearity:-* In `ensureEqTypes`, use `eqTypeIgnoringMultiplicity`-* In `ensureSubMult`, do nothing--But why make `-dcore-lint` ignore linearity?  Because optimisation passes are-not (yet) guaranteed to maintain linearity.  They should do so semantically (GHC-is careful not to duplicate computation) but it is much harder to ensure that-the statically-checkable constraints of Linear Core are maintained. The current-Linear Core is described in the wiki at:-https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation.--Here are some examples of how the optimiser can break linearity checking.  Other-examples are documented in the linear-type implementation wiki page-[https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation#core-to-core-passes]--* EXAMPLE 1: the binder swap transformation-    Consider--      data T = MkT {-# UNPACK #-} !Int--    The wrapper for MkT is--      $wMkT :: Int %1 -> T-      $wMkT n = case %1 n of-        I# n' -> MkT n'--    This introduces, in particular, a `case %1` (this is not actual Haskell or-    Core syntax), where the `%1` means that the `case` expression consumes its-    scrutinee linearly.--    Now, `case %1` interacts with the binder swap optimisation in a non-trivial-    way. Take a slightly modified version of the code for $wMkT:--      case %1 x of z {-        I# n' -> (x, n')-      }--    Binder-swap changes this to--      case %1 x of z {-        I# n' -> let x = z in (x, n')-      }--    This is rejected by `-dlinear-core-lint` because 1/ n' must be used linearly-    2/ `-dlinear-core-lint` recognises a use of `z` as a use of `n'`. So it sees-    two uses of n' where there should be a single one.--* EXAMPLE 2: letrec-    Some optimisations can create a letrec which uses a variable-    linearly, e.g.--      letrec f True = f False-             f False = x-      in f True--    uses 'x' linearly, but this is not seen by the linter, which considers,-    conservatively, that a letrec always has multiplicity Many (in particular-    that every captured free variable must have multiplicity Many). This issue-    is discussed in ticket #18694.--* EXAMPLE 3: rewrite rules-    Ignoring linearity means in particular that `a -> b` and `a %1 -> b` must be-    treated the same by rewrite rules (see also Note [Rewrite rules ignore-    multiplicities in FunTy] in GHC.Core.Unify). Consider--      m :: Bool -> A-      m' :: (Bool -> Bool) -> A-      {- RULES "ex" forall f. m (f True) = m' f -}--      f :: Bool %1 -> A-      x = m (f True)--    The rule "ex" must match . So the linter must accept `m' f`.--* EXAMPLE 4: eta-reduction-   Eta-expansion can change linear functions into unrestricted functions--     f :: A %1 -> B--     g :: A %Many -> B-     g = \x -> f x--   Eta-reduction undoes this and produces:--     g :: A %Many -> B-     g = f--Historical note: In the original linear-types implementation, we had tried to-make every optimisation pass produce code that passes `-dlinear-core-lint`. It-had proved very difficult. We kept finding corner case after corner-case. Furthermore, to attempt to achieve that goal we ended up restricting-transformations when `-dlinear-core-lint` couldn't typecheck the result.--In the future, we may be able to lint the linearity of the output of-Core-to-Core passes (#19165). But this shouldn't be done at the expense of-producing efficient code. Therefore we lay the following principle.--PRINCIPLE: The type system bends to the optimisation, not the other way around.--There is a useful discussion at https://gitlab.haskell.org/ghc/ghc/-/issues/22123--Note [Linting representation-polymorphic builtins]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As described in Note [Representation-polymorphism checking built-ins], on-top of the two main representation-polymorphism invariants described in the-Note [Representation polymorphism invariants], we must perform additional-representation-polymorphism checks on builtin functions which don't have a-binding, for example to ensure that we don't run afoul of the-representation-polymorphism invariants when eta-expanding.--There are two situations:--  1. Builtins which have skolem type variables which must be instantiated to-     concrete types, such as the RuntimeRep type argument r to the catch# primop.--  2. Representation-polymorphic unlifted newtypes, which must always be instantiated-     at a fixed runtime representation.--For 1, consider for example 'coerce':--  coerce :: forall {r} (a :: TYPE r) (b :: TYPE r). Coercible a b => a -> b--We store in the IdDetails of the coerce Id that the first binder, r, must always-be instantiated to a concrete type. We thus check this in Core Lint: whenever we-see an application of the form--  coerce @{rep1} ...--we ensure that 'rep1' is concrete. This is done in the function "checkRepPolyBuiltinApp".-Moreover, not instantiating these type variables at all is also an error, as-we would again not be able to perform eta-expansion. (This is a bit more theoretical,-as in user programs the typechecker will insert these type applications when-instantiating, but it can still arise when constructing Core expressions).--For 2, whenever we have an unlifted newtype such as--  type RR :: Type -> RuntimeRep-  type family RR a--  type F :: forall (a :: Type) -> TYPE (RR a)-  type family F a--  type N :: forall (a :: Type) -> TYPE (RR a)-  newtype N a = MkN (F a)--and an unsaturated occurrence--  MkN @ty -- NB: no value argument!--we check that the (instantiated) argument type has a fixed runtime representation.-This is done in the function "checkRepPolyNewtypeApp".--}--instance Applicative LintM where-      pure x = LintM $ \ _ errs -> LResult (JustUB x) errs-                                   --(Just x, errs)-      (<*>) = ap--instance Monad LintM where-  m >>= k  = LintM (\ env errs ->-                       let res = unLintM m env errs in-                         case res of-                           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 -> (LResult (JustUB $ le_platform e) errs))--data LintLocInfo-  = RhsOf Id            -- The variable bound-  | OccOf Id            -- Occurrence of id-  | LambdaBodyOf Id     -- The lambda-binder-  | RuleOf Id           -- Rules attached to a binder-  | UnfoldingOf Id      -- Unfolding of a binder-  | BodyOfLet Id        -- The let-bound variable-  | BodyOfLetRec [Id]   -- The binders of the let-  | CaseAlt CoreAlt     -- Case alternative-  | CasePat CoreAlt     -- The *pattern* of the case alternative-  | CaseTy CoreExpr     -- The type field of a case expression-                        -- with this scrutinee-  | IdTy Id             -- The type field of an Id binder-  | AnExpr CoreExpr     -- Some expression-  | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)-  | TopLevelBindings-  | InType Type         -- Inside a type-  | InCo   Coercion     -- Inside a coercion-  | InAxiom (CoAxiom Branched)   -- Inside a CoAxiom--data LintConfig = LintConfig-  { l_diagOpts   :: !DiagOpts         -- ^ Diagnostics opts-  , l_platform   :: !Platform         -- ^ Target platform-  , l_flags      :: !LintFlags        -- ^ Linting the result of this pass-  , l_vars       :: ![Var]            -- ^ 'Id's that should be treated as being in scope-  }--initL :: LintConfig-      -> LintM a            -- ^ Action to run-      -> WarnsAndErrs-initL cfg m-  = case unLintM m env (emptyBag, emptyBag) of-      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-    env = LE { le_flags = l_flags cfg-             , le_subst = mkEmptySubst (mkInScopeSetList tcvs)-             , le_ids   = mkVarEnv [(id, (id,idType id)) | id <- ids]-             , le_joins = emptyVarSet-             , le_loc = []-             , le_ue_aliases = emptyNameEnv-             , le_platform = l_platform cfg-             , le_diagOpts = l_diagOpts cfg-             }--setReportUnsat :: Bool -> LintM a -> LintM a--- Switch off lf_report_unsat_syns-setReportUnsat ru thing_inside-  = LintM $ \ env errs ->-    let env' = env { le_flags = (le_flags env) { lf_report_unsat_syns = ru } }-    in unLintM thing_inside env' errs---- See Note [Checking for representation polymorphism]-noFixedRuntimeRepChecks :: LintM a -> LintM a-noFixedRuntimeRepChecks thing_inside-  = LintM $ \env errs ->-    let env' = env { le_flags = (le_flags env) { lf_check_fixed_rep = False } }-    in unLintM thing_inside env' errs--getLintFlags :: LintM LintFlags-getLintFlags = LintM $ \ env errs -> fromBoxedLResult (Just (le_flags env), errs)--checkL :: Bool -> SDoc -> LintM ()-checkL True  _   = return ()-checkL False msg = failWithL msg---- like checkL, but relevant to type checking-lintL :: Bool -> SDoc -> LintM ()-lintL = checkL--checkWarnL :: Bool -> SDoc -> LintM ()-checkWarnL True   _  = return ()-checkWarnL False msg = addWarnL msg--failWithL :: SDoc -> LintM a-failWithL msg = LintM $ \ env (warns,errs) ->-                fromBoxedLResult (Nothing, (warns, addMsg True env errs msg))--addErrL :: SDoc -> LintM ()-addErrL msg = LintM $ \ env (warns,errs) ->-              fromBoxedLResult (Just (), (warns, addMsg True env errs msg))--addWarnL :: SDoc -> LintM ()-addWarnL msg = LintM $ \ env (warns,errs) ->-              fromBoxedLResult (Just (), (addMsg False env warns msg, errs))--addMsg :: Bool -> LintEnv ->  Bag SDoc -> SDoc -> Bag SDoc-addMsg is_error env msgs msg-  = assertPpr (notNull loc_msgs) msg $-    msgs `snocBag` mk_msg msg-  where-   loc_msgs :: [(SrcLoc, SDoc)]  -- Innermost first-   loc_msgs = map dumpLoc (le_loc env)--   cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs-                  , text "Substitution:" <+> ppr (le_subst env) ]-   context | is_error  = cxt_doc-           | otherwise = whenPprDebug cxt_doc-     -- Print voluminous info for Lint errors-     -- but not for warnings--   msg_span = case [ span | (loc,_) <- loc_msgs-                          , let span = srcLocSpan loc-                          , isGoodSrcSpan span ] of-               []    -> noSrcSpan-               (s:_) -> s-   !diag_opts = le_diagOpts env-   mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) msg_span-                             (msg $$ context)--addLoc :: LintLocInfo -> LintM a -> LintM a-addLoc extra_loc m-  = LintM $ \ env errs ->-    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 -> fromBoxedLResult (Just (is_case_pat env), errs)-  where-    is_case_pat (LE { le_loc = CasePat {} : _ }) = True-    is_case_pat _other                           = False--addInScopeId :: Id -> LintedType -> LintM a -> LintM a-addInScopeId id linted_ty m-  = LintM $ \ env@(LE { le_ids = id_set, le_joins = join_set, le_ue_aliases = aliases }) errs ->-    unLintM m (env { le_ids   = extendVarEnv id_set id (id, linted_ty)-                   , le_joins = add_joins join_set-                   , le_ue_aliases = delFromNameEnv aliases (idName id) }) errs-                   -- When shadowing an alias, we need to make sure the Id is no longer-                   -- classified as such. E.g. in-                   -- let x = <e1> in case x of x { _DEFAULT -> <e2> }-                   -- Occurrences of 'x' in e2 shouldn't count as occurrences of e1.-  where-    add_joins join_set-      | isJoinId id = extendVarSet join_set id -- Overwrite with new arity-      | otherwise   = delVarSet    join_set id -- Remove any existing binding--getInScopeIds :: LintM (VarEnv (Id,LintedType))-getInScopeIds = LintM (\env errs -> fromBoxedLResult (Just (le_ids env), errs))--extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a-extendTvSubstL tv ty m-  = LintM $ \ env errs ->-    unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs--updateSubst :: Subst -> LintM a -> LintM a-updateSubst subst' m-  = LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs--markAllJoinsBad :: LintM a -> LintM a-markAllJoinsBad m-  = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs--markAllJoinsBadIf :: Bool -> LintM a -> LintM a-markAllJoinsBadIf True  m = markAllJoinsBad m-markAllJoinsBadIf False m = m--getValidJoins :: LintM IdSet-getValidJoins = LintM (\ env errs -> fromBoxedLResult (Just (le_joins env), errs))--getSubst :: LintM Subst-getSubst = LintM (\ env errs -> fromBoxedLResult (Just (le_subst env), errs))--getUEAliases :: LintM (NameEnv UsageEnv)-getUEAliases = LintM (\ env errs -> fromBoxedLResult (Just (le_ue_aliases env), errs))--getInScope :: LintM InScopeSet-getInScope = LintM (\ env errs -> fromBoxedLResult (Just (getSubstInScope $ le_subst env), errs))--lookupIdInScope :: Id -> LintM (Id, LintedType)-lookupIdInScope id_occ-  = do { in_scope_ids <- getInScopeIds-       ; case lookupVarEnv in_scope_ids id_occ of-           Just (id_bndr, linted_ty)-             -> do { checkL (not (bad_global id_bndr)) $ global_in_scope id_bndr-                   ; return (id_bndr, linted_ty) }-           Nothing -> do { checkL (not is_local) local_out_of_scope-                         ; return (id_occ, idType id_occ) } }-                      -- We don't bother to lint the type-                      -- of global (i.e. imported) Ids-  where-    is_local = mustHaveLocalBinding id_occ-    local_out_of_scope = text "Out of scope:" <+> pprBndr LetBind id_occ-    global_in_scope id_bndr = hang (text "Occurrence is GlobalId, but binding is LocalId")-                                 2 $ vcat [hang (text "occurrence:") 2 $ pprBndr LetBind id_occ-                                          ,hang (text "binder    :") 2 $ pprBndr LetBind id_bndr-                                          ]-    bad_global id_bnd = isGlobalId id_occ-                     && isLocalId id_bnd-                     && not (isWiredIn id_occ)-       -- 'bad_global' checks for the case where an /occurrence/ is-       -- a GlobalId, but there is an enclosing binding fora a LocalId.-       -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr,-       --     but GHCi adds GlobalIds from the interactive context.  These-       --     are fine; hence the test (isLocalId id == isLocalId v)-       -- NB: when compiling Control.Exception.Base, things like absentError-       --     are defined locally, but appear in expressions as (global)-       --     wired-in Ids after worker/wrapper-       --     So we simply disable the test in this case--lookupJoinId :: Id -> LintM JoinPointHood--- Look up an Id which should be a join point, valid here--- If so, return its arity, if not return Nothing-lookupJoinId id-  = do { join_set <- getValidJoins-       ; case lookupVarSet join_set id of-            Just id' -> return (idJoinPointHood id')-            Nothing  -> return NotJoinPoint }--addAliasUE :: Id -> UsageEnv -> LintM a -> LintM a-addAliasUE id ue thing_inside = LintM $ \ env errs ->-  let new_ue_aliases =-        extendNameEnv (le_ue_aliases env) (getName id) ue-  in-    unLintM thing_inside (env { le_ue_aliases = new_ue_aliases }) errs--varCallSiteUsage :: Id -> LintM UsageEnv-varCallSiteUsage id =-  do m <- getUEAliases-     return $ case lookupNameEnv m (getName id) of-         Nothing    -> singleUsageUE id-         Just id_ue -> id_ue--ensureEqTys :: LintedType -> LintedType -> SDoc -> LintM ()--- check ty2 is subtype of ty1 (ie, has same structure but usage--- annotations need only be consistent, not equal)--- Assumes ty1,ty2 are have already had the substitution applied-{-# INLINE ensureEqTys #-} -- See Note [INLINE ensureEqTys]-ensureEqTys ty1 ty2 msg-  = do { flags <- getLintFlags-       ; lintL (eq_type flags ty1 ty2) msg }--eq_type :: LintFlags -> Type -> Type -> Bool--- When `-dlinear-core-lint` is off, then consider `a -> b` and `a %1 -> b` to--- be equal. See Note [Linting linearity].-eq_type flags ty1 ty2 | lf_check_linearity flags = eqType                     ty1 ty2-                      | otherwise                = eqTypeIgnoringMultiplicity ty1 ty2--{- Note [INLINE ensureEqTys]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-To make Lint fast, we want to avoid allocating a thunk for <msg> in-      ensureEqTypes ty1 ty2 <msg>-because the test almost always succeeds, and <msg> isn't needed.-So we INLINE `ensureEqTys`.  This actually make a difference of-1-2% when compiling programs with -dcore-lint.--}--ensureSubUsage :: Usage -> Mult -> SDoc -> LintM ()-ensureSubUsage Bottom     _              _ = return ()-ensureSubUsage Zero       described_mult err_msg = ensureSubMult ManyTy described_mult err_msg-ensureSubUsage (MUsage m) described_mult err_msg = ensureSubMult m described_mult err_msg--ensureSubMult :: Mult -> Mult -> SDoc -> LintM ()-ensureSubMult actual_mult described_mult err_msg = do-    flags <- getLintFlags-    when (lf_check_linearity flags) $-      unless (deepSubMult actual_mult described_mult) $-        addErrL err_msg-  where-    -- Check for submultiplicity using the following rules:-    -- 1. x*y <= z when x <= z and y <= z.-    --    This rule follows from the fact that x*y = sup{x,y} for any-    --    multiplicities x,y.-    -- 2. x <= y*z when x <= y or x <= z.-    --    This rule is not complete: when x = y*z, we cannot-    --    change y*z <= y*z to y*z <= y or y*z <= z.-    --    However, we eliminate products on the LHS in step 1.-    -- 3. One <= x and x <= Many for any x, as checked by 'submult'.-    -- 4. x <= x.-    -- Otherwise, we fail.-    deepSubMult :: Mult -> Mult -> Bool-    deepSubMult m n-      | Just (m1, m2) <- isMultMul m = deepSubMult m1 n  && deepSubMult m2 n-      | Just (n1, n2) <- isMultMul n = deepSubMult m  n1 || deepSubMult m  n2-      | Submult <- m `submult` n = True-      | otherwise = m `eqType` n--lintRole :: Outputable thing-          => thing     -- where the role appeared-          -> Role      -- expected-          -> Role      -- actual-          -> LintM ()-lintRole co r1 r2-  = lintL (r1 == r2)-          (text "Role incompatibility: expected" <+> ppr r1 <> comma <+>-           text "got" <+> ppr r2 $$-           text "in" <+> ppr co)--{--************************************************************************-*                                                                      *-\subsection{Error messages}-*                                                                      *-************************************************************************--}--dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)--dumpLoc (RhsOf v)-  = (getSrcLoc v, text "In the RHS of" <+> pp_binders [v])--dumpLoc (OccOf v)-  = (getSrcLoc v, text "In an occurrence of" <+> pp_binder v)--dumpLoc (LambdaBodyOf b)-  = (getSrcLoc b, text "In the body of lambda with binder" <+> pp_binder b)--dumpLoc (RuleOf b)-  = (getSrcLoc b, text "In a rule attached to" <+> pp_binder b)--dumpLoc (UnfoldingOf b)-  = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b)--dumpLoc (BodyOfLet b)-  = (noSrcLoc, text "In the body of a let with binder" <+> pp_binder b)--dumpLoc (BodyOfLetRec [])-  = (noSrcLoc, text "In body of a letrec with no binders")--dumpLoc (BodyOfLetRec bs@(b:_))-  = ( getSrcLoc b, text "In the body of a letrec with binders" <+> pp_binders bs)--dumpLoc (AnExpr e)-  = (noSrcLoc, text "In the expression:" <+> ppr e)--dumpLoc (CaseAlt (Alt con args _))-  = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))--dumpLoc (CasePat (Alt con args _))-  = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))--dumpLoc (CaseTy scrut)-  = (noSrcLoc, hang (text "In the result-type of a case with scrutinee:")-                  2 (ppr scrut))--dumpLoc (IdTy b)-  = (getSrcLoc b, text "In the type of a binder:" <+> ppr b)--dumpLoc (ImportedUnfolding locn)-  = (locn, text "In an imported unfolding")-dumpLoc TopLevelBindings-  = (noSrcLoc, Outputable.empty)-dumpLoc (InType ty)-  = (noSrcLoc, text "In the type" <+> quotes (ppr ty))-dumpLoc (InCo co)-  = (noSrcLoc, text "In the coercion" <+> quotes (ppr co))-dumpLoc (InAxiom ax)-  = (getSrcLoc ax, hang (text "In the coercion axiom")-                      2 (pprCoAxiom ax))--pp_binders :: [Var] -> SDoc-pp_binders bs = sep (punctuate comma (map pp_binder bs))--pp_binder :: Var -> SDoc-pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]-            | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)]-----------------------------------------------------------      Messages for case expressions--mkDefaultArgsMsg :: [Var] -> SDoc-mkDefaultArgsMsg args-  = hang (text "DEFAULT case with binders")-         4 (ppr args)--mkCaseAltMsg :: CoreExpr -> Type -> Type -> SDoc-mkCaseAltMsg e ty1 ty2-  = hang (text "Type of case alternatives not the same as the annotation on case:")-         4 (vcat [ text "Actual type:" <+> ppr ty1,-                   text "Annotation on case:" <+> ppr ty2,-                   text "Alt Rhs:" <+> ppr e ])--mkScrutMsg :: Id -> Type -> Type -> Subst -> SDoc-mkScrutMsg var var_ty scrut_ty subst-  = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,-          text "Result binder type:" <+> ppr var_ty,--(idType var),-          text "Scrutinee type:" <+> ppr scrut_ty,-     hsep [text "Current TCv subst", ppr subst]]--mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> SDoc-mkNonDefltMsg e-  = hang (text "Case expression with DEFAULT not at the beginning") 4 (ppr e)-mkNonIncreasingAltsMsg e-  = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)--nonExhaustiveAltsMsg :: CoreExpr -> SDoc-nonExhaustiveAltsMsg e-  = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)--mkBadConMsg :: TyCon -> DataCon -> SDoc-mkBadConMsg tycon datacon-  = vcat [-        text "In a case alternative, data constructor isn't in scrutinee type:",-        text "Scrutinee type constructor:" <+> ppr tycon,-        text "Data con:" <+> ppr datacon-    ]--mkBadPatMsg :: Type -> Type -> SDoc-mkBadPatMsg con_result_ty scrut_ty-  = vcat [-        text "In a case alternative, pattern result type doesn't match scrutinee type:",-        text "Pattern result type:" <+> ppr con_result_ty,-        text "Scrutinee type:" <+> ppr scrut_ty-    ]--integerScrutinisedMsg :: SDoc-integerScrutinisedMsg-  = text "In a LitAlt, the literal is lifted (probably Integer)"--mkBadAltMsg :: Type -> CoreAlt -> SDoc-mkBadAltMsg scrut_ty alt-  = vcat [ text "Data alternative when scrutinee is not a tycon application",-           text "Scrutinee type:" <+> ppr scrut_ty,-           text "Alternative:" <+> pprCoreAlt alt ]--mkNewTyDataConAltMsg :: Type -> CoreAlt -> SDoc-mkNewTyDataConAltMsg scrut_ty alt-  = vcat [ text "Data alternative for newtype datacon",-           text "Scrutinee type:" <+> ppr scrut_ty,-           text "Alternative:" <+> pprCoreAlt alt ]------------------------------------------------------------      Other error messages--mkAppMsg :: Type -> Type -> CoreExpr -> SDoc-mkAppMsg expected_arg_ty actual_arg_ty arg-  = vcat [text "Argument value doesn't match argument type:",-              hang (text "Expected arg type:") 4 (ppr expected_arg_ty),-              hang (text "Actual arg type:") 4 (ppr actual_arg_ty),-              hang (text "Arg:") 4 (ppr arg)]--mkNonFunAppMsg :: Type -> Type -> CoreExpr -> SDoc-mkNonFunAppMsg fun_ty arg_ty arg-  = vcat [text "Non-function type in function position",-              hang (text "Fun type:") 4 (ppr fun_ty),-              hang (text "Arg type:") 4 (ppr arg_ty),-              hang (text "Arg:") 4 (ppr arg)]--mkLetErr :: TyVar -> CoreExpr -> SDoc-mkLetErr bndr rhs-  = vcat [text "Bad `let' binding:",-          hang (text "Variable:")-                 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)),-          hang (text "Rhs:")-                 4 (ppr rhs)]--mkTyAppMsg :: Type -> Type -> SDoc-mkTyAppMsg ty arg_ty-  = vcat [text "Illegal type application:",-              hang (text "Function type:")-                 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),-              hang (text "Type argument:")-                 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]--mkCoAppMsg :: Type -> Coercion -> SDoc-mkCoAppMsg fun_ty co-  = vcat [ text "Illegal coercion application:"-         , hang (text "Function type:")-              4 (ppr fun_ty)-         , hang (text "Coercion argument:")-              4 (ppr co <+> dcolon <+> ppr (coercionType co))]--emptyRec :: CoreExpr -> SDoc-emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e)--mkRhsMsg :: Id -> SDoc -> Type -> SDoc-mkRhsMsg binder what ty-  = vcat-    [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon,-            ppr binder],-     hsep [text "Binder's type:", ppr (idType binder)],-     hsep [text "Rhs type:", ppr ty]]--badBndrTyMsg :: Id -> SDoc -> SDoc-badBndrTyMsg binder what-  = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder-         , text "Binder's type:" <+> ppr (idType binder) ]--mkNonTopExportedMsg :: Id -> SDoc-mkNonTopExportedMsg binder-  = hsep [text "Non-top-level binder is marked as exported:", ppr binder]--mkNonTopExternalNameMsg :: Id -> SDoc-mkNonTopExternalNameMsg binder-  = hsep [text "Non-top-level binder has an external name:", ppr binder]--mkTopNonLitStrMsg :: Id -> SDoc-mkTopNonLitStrMsg binder-  = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder]--mkKindErrMsg :: TyVar -> Type -> SDoc-mkKindErrMsg tyvar arg_ty-  = vcat [text "Kinds don't match in type application:",-          hang (text "Type variable:")-                 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),-          hang (text "Arg type:")-                 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]--mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> SDoc-mkCastErr expr = mk_cast_err "expression" "type" (ppr expr)--mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> SDoc-mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty)--mk_cast_err :: String -- ^ What sort of casted thing this is-                      --   (\"expression\" or \"type\").-            -> String -- ^ What sort of coercion is being used-                      --   (\"type\" or \"kind\").-            -> SDoc   -- ^ The thing being casted.-            -> Coercion -> Type -> Type -> SDoc-mk_cast_err thing_str co_str pp_thing co from_ty thing_ty-  = vcat [from_msg <+> text "of Cast differs from" <+> co_msg-            <+> text "of" <+> enclosed_msg,-          from_msg <> colon <+> ppr from_ty,-          text (capitalise co_str) <+> text "of" <+> enclosed_msg <> colon-            <+> ppr thing_ty,-          text "Actual" <+> enclosed_msg <> colon <+> pp_thing,-          text "Coercion used in cast:" <+> ppr co-         ]-  where-    co_msg, from_msg, enclosed_msg :: SDoc-    co_msg       = text co_str-    from_msg     = text "From-" <> co_msg-    enclosed_msg = text "enclosed" <+> text thing_str--mkBadTyVarMsg :: Var -> SDoc-mkBadTyVarMsg tv-  = text "Non-tyvar used in TyVarTy:"-      <+> ppr tv <+> dcolon <+> ppr (varType tv)--mkBadJoinBindMsg :: Var -> SDoc-mkBadJoinBindMsg var-  = vcat [ text "Bad join point binding:" <+> ppr var-         , text "Join points can be bound only by a non-top-level let" ]--mkInvalidJoinPointMsg :: Var -> Type -> SDoc-mkInvalidJoinPointMsg var ty-  = hang (text "Join point has invalid type:")-        2 (ppr var <+> dcolon <+> ppr ty)--mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc-mkBadJoinArityMsg var ar n rhs-  = vcat [ text "Join point has too few lambdas",-           text "Join var:" <+> ppr var,-           text "Join arity:" <+> ppr ar,-           text "Number of lambdas:" <+> ppr (ar - n),-           text "Rhs = " <+> ppr rhs-           ]--invalidJoinOcc :: Var -> SDoc-invalidJoinOcc var-  = vcat [ text "Invalid occurrence of a join variable:" <+> ppr var-         , text "The binder is either not a join point, or not valid here" ]--mkBadJumpMsg :: Var -> Int -> Int -> SDoc-mkBadJumpMsg var ar nargs-  = vcat [ text "Join point invoked with wrong number of arguments",-           text "Join var:" <+> ppr var,-           text "Join arity:" <+> ppr ar,-           text "Number of arguments:" <+> int nargs ]--mkInconsistentRecMsg :: [Var] -> SDoc-mkInconsistentRecMsg bndrs-  = vcat [ text "Recursive let binders mix values and join points",-           text "Binders:" <+> hsep (map ppr_with_details bndrs) ]-  where-    ppr_with_details bndr = ppr bndr <> ppr (idDetails bndr)--mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc-mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ-  = vcat [ text "Mismatch in join point arity between binder and occurrence"-         , text "Var:" <+> ppr bndr-         , text "Arity at binding site:" <+> ppr join_arity_bndr-         , text "Arity at occurrence:  " <+> ppr join_arity_occ ]--mkBndrOccTypeMismatchMsg :: Var -> Var -> LintedType -> LintedType -> SDoc-mkBndrOccTypeMismatchMsg bndr var bndr_ty var_ty-  = vcat [ text "Mismatch in type between binder and occurrence"-         , text "Binder:" <+> ppr bndr <+> dcolon <+> ppr bndr_ty-         , text "Occurrence:" <+> ppr var <+> dcolon <+> ppr var_ty-         , text "  Before subst:" <+> ppr (idType var) ]++import GHC.Data.Bag+import GHC.Data.List.SetOps++import GHC.Utils.Monad+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Misc+import GHC.Utils.Error+import qualified GHC.Utils.Error as Err+import GHC.Utils.Logger++import GHC.Data.Pair+import GHC.Base (oneShot)+import GHC.Data.Unboxed++import Control.Monad+import Data.Foldable      ( for_, toList )+import Data.List.NonEmpty ( NonEmpty(..), groupWith, nonEmpty )+import Data.Maybe+import Data.IntMap.Strict ( IntMap )+import qualified Data.IntMap.Strict as IntMap ( lookup, keys, empty, fromList )++{-+Note [Core Lint guarantee]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Core Lint is the type-checker for Core. Using it, we get the following guarantee:++If all of:+1. Core Lint passes,+2. there are no unsafe coercions (i.e. unsafeEqualityProof),+3. all plugin-supplied coercions (i.e. PluginProv) are valid, and+4. all case-matches are complete+then running the compiled program will not seg-fault, assuming no bugs downstream+(e.g. in the code generator). This guarantee is quite powerful, in that it allows us+to decouple the safety of the resulting program from the type inference algorithm.++However, do note point (4) above. Core Lint does not check for incomplete case-matches;+see Note [Case expression invariants] in GHC.Core, invariant (4). As explained there,+an incomplete case-match might slip by Core Lint and cause trouble at runtime.++Note [GHC Formalism]+~~~~~~~~~~~~~~~~~~~~+This file implements the type-checking algorithm for System FC, the "official"+name of the Core language. Type safety of FC is heart of the claim that+executables produced by GHC do not have segmentation faults. Thus, it is+useful to be able to reason about System FC independently of reading the code.+To this purpose, there is a document core-spec.pdf built in docs/core-spec that+contains a formalism of the types and functions dealt with here. If you change+just about anything in this file or you change other types/functions throughout+the Core language (all signposted to this note), you should update that+formalism. See docs/core-spec/README for more info about how to do so.++Note [check vs lint]+~~~~~~~~~~~~~~~~~~~~+This file implements both a type checking algorithm and also general sanity+checking. For example, the "sanity checking" checks for TyConApp on the left+of an AppTy, which should never happen. These sanity checks don't really+affect any notion of type soundness. Yet, it is convenient to do the sanity+checks at the same time as the type checks. So, we use the following naming+convention:++- Functions that begin with 'lint'... are involved in type checking. These+  functions might also do some sanity checking.++- Functions that begin with 'check'... are *not* involved in type checking.+  They exist only for sanity checking.++Issues surrounding variable naming, shadowing, and such are considered *not*+to be part of type checking, as the formalism omits these details.++Summary of checks+~~~~~~~~~~~~~~~~~+Checks that a set of core bindings is well-formed.  The PprStyle and String+just control what we print in the event of an error.  The Bool value+indicates whether we have done any specialisation yet (in which case we do+some extra checks).++We check for+        (a) type errors+        (b) Out-of-scope type variables+        (c) Out-of-scope local variables+        (d) Ill-kinded types+        (e) Incorrect unsafe coercions++If we have done specialisation the we check that there are+        (a) No top-level bindings of primitive (unboxed type)++Note [Linting function types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All saturated applications of funTyCon are represented with the FunTy constructor.+See Note [Function type constructors and FunTy] in GHC.Builtin.Types.Prim++ We check this invariant in lintType.++Note [Linting type lets]+~~~~~~~~~~~~~~~~~~~~~~~~+In the desugarer, it's very very convenient to be able to say (in effect)+        let a = Type Bool in+        let x::a = True in <body>+That is, use a type let.  See Note [Core type and coercion invariant] in "GHC.Core".+One place it is used is in mkWwBodies; see Note [Join points and beta-redexes]+in GHC.Core.Opt.WorkWrap.Utils.  (Maybe there are other "clients" of this feature; I'm not sure).++* Hence when linting <body> we need to remember that a=Int, else we+  might reject a correct program.  So we carry a type substitution (in+  this example [a -> Bool]) and apply this substitution before+  comparing types. In effect, in Lint, type equality is always+  equality-modulo-le-subst.  This is in the le_subst field of+  LintEnv.  But nota bene:++  (SI1) The le_subst substitution is applied to types and coercions only++  (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 substitution does not outlive the CoreLint pass.++  (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders.++* The function+        lintInTy :: Type -> LintM (Type, Kind)+  returns a substituted type.++* When we encounter a binder (like x::a) we must apply the substitution+  to the type of the binding variable.  lintBinders does this.++* Clearly we need to clone tyvar binders as we go.++* But take care (#17590)! We must also clone CoVar binders:+    let a = TYPE (ty |> cv)+    in \cv -> blah+  blindly substituting for `a` might capture `cv`.++* Alas, when cloning a coercion variable we might choose a unique+  that happens to clash with an inner Id, thus+      \cv_66 -> let wild_X7 = blah in blah+  We decide to clone `cv_66` because it's already in scope.  Fine,+  choose a new unique.  Aha, X7 looks good.  So we check the lambda+  body with le_subst of [cv_66 :-> cv_X7]++  This is all fine, even though we use the same unique as wild_X7.+  As (SI2) says, we do /not/ return a new lambda+     (\cv_X7 -> let wild_X7 = blah in ...)+  We simply use the le_subst substitution in types/coercions only, when+  checking for equality.++* We still need to check that Id occurrences are bound by some+  enclosing binding.  We do /not/ use the InScopeSet for the le_subst+  for this purpose -- it contains only TyCoVars.  Instead we have a separate+  le_ids for the in-scope Id binders.++Sigh.  We might want to explore getting rid of type-let!++Note [Bad unsafe coercion]+~~~~~~~~~~~~~~~~~~~~~~~~~~+For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions+Linter introduces additional rules that checks improper coercion between+different types, called bad coercions. Following coercions are forbidden:++  (a) coercions between boxed and unboxed values;+  (b) coercions between unlifted values of the different sizes, here+      active size is checked, i.e. size of the actual value but not+      the space allocated for value;+  (c) coercions between floating and integral boxed values, this check+      is not yet supported for unboxed tuples, as no semantics were+      specified for that;+  (d) coercions from / to vector type+  (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be+      coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules+      (a-e) holds.++Note [Join points]+~~~~~~~~~~~~~~~~~~+We check the rules listed in Note [Invariants on join points] in GHC.Core. The+only one that causes any difficulty is the first: All occurrences must be tail+calls. To this end, along with the in-scope set, we remember in le_joins the+subset of in-scope Ids that are valid join ids. For example:++  join j x = ... in+  case e of+    A -> jump j y -- good+    B -> case (jump j z) of -- BAD+           C -> join h = jump j w in ... -- good+           D -> let x = jump j v in ... -- BAD++A join point remains valid in case branches, so when checking the A+branch, j is still valid. When we check the scrutinee of the inner+case, however, we set le_joins to empty, and catch the+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%.++Note [MCInfo for Lint]+~~~~~~~~~~~~~~~~~~~~~~+When printing a Lint message, use the MCInfo severity so that the+message is printed on stderr rather than stdout (#13342).++************************************************************************+*                                                                      *+                 Beginning and ending passes+*                                                                      *+************************************************************************+-}++-- | Configuration for boilerplate operations at the end of a+-- compilation pass producing Core.+data EndPassConfig = EndPassConfig+  { ep_dumpCoreSizes :: !Bool+  -- ^ Whether core bindings should be dumped with the size of what they+  -- are binding (i.e. the size of the RHS of the binding).++  , ep_lintPassResult :: !(Maybe LintPassResultConfig)+  -- ^ Whether we should lint the result of this pass.++  , ep_namePprCtx :: !NamePprCtx++  , ep_dumpFlag :: !(Maybe DumpFlag)++  , ep_prettyPass :: !SDoc++  , ep_passDetails :: !SDoc+  }++endPassIO :: Logger+          -> EndPassConfig+          -> CoreProgram -> [CoreRule]+          -> IO ()+-- Used by the IO-is CorePrep too+endPassIO logger cfg binds rules+  = do { dumpPassResult logger (ep_dumpCoreSizes cfg) (ep_namePprCtx cfg) mb_flag+                        (renderWithContext defaultSDocContext (ep_prettyPass cfg))+                        (ep_passDetails cfg) binds rules+       ; for_ (ep_lintPassResult cfg) $ \lp_cfg ->+           lintPassResult logger lp_cfg binds+       }+  where+    mb_flag = case ep_dumpFlag cfg of+                Just flag | logHasDumpFlag logger flag                    -> Just flag+                          | logHasDumpFlag logger Opt_D_verbose_core2core -> Just flag+                _ -> Nothing++dumpPassResult :: Logger+               -> Bool                  -- dump core sizes?+               -> NamePprCtx+               -> Maybe DumpFlag        -- Just df => show details in a file whose+                                        --            name is specified by df+               -> String                -- Header+               -> SDoc                  -- Extra info to appear after header+               -> CoreProgram -> [CoreRule]+               -> IO ()+dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr extra_info binds rules+  = do { forM_ mb_flag $ \flag -> do+           logDumpFile logger (mkDumpStyle name_ppr_ctx) flag hdr FormatCore dump_doc++         -- Report result size+         -- This has the side effect of forcing the intermediate to be evaluated+         -- if it's not already forced by a -ddump flag.+       ; Err.debugTraceMsg logger 2 size_doc+       }++  where+    size_doc = sep [text "Result size of" <+> text hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]++    dump_doc  = vcat [ nest 2 extra_info+                     , size_doc+                     , blankLine+                     , if dump_core_sizes+                        then pprCoreBindingsWithSize binds+                        else pprCoreBindings         binds+                     , ppUnless (null rules) pp_rules ]+    pp_rules = vcat [ blankLine+                    , text "------ Local rules for imported ids --------"+                    , pprRules rules ]++{-+************************************************************************+*                                                                      *+                 Top-level interfaces+*                                                                      *+************************************************************************+-}++data LintPassResultConfig = LintPassResultConfig+  { lpr_diagOpts         :: !DiagOpts+  , lpr_platform         :: !Platform+  , lpr_makeLintFlags    :: !LintFlags+  , lpr_showLintWarnings :: !Bool+  , lpr_passPpr          :: !SDoc+  , lpr_localsInScope    :: ![Var]+  }++lintPassResult :: Logger -> LintPassResultConfig+               -> CoreProgram -> IO ()+lintPassResult logger cfg binds+  = do { let warns_and_errs = lintCoreBindings'+               (LintConfig+                { l_diagOpts = lpr_diagOpts cfg+                , l_platform = lpr_platform cfg+                , l_flags    = lpr_makeLintFlags cfg+                , l_vars     = lpr_localsInScope cfg+                })+               binds+       ; Err.showPass logger $+           "Core Linted result of " +++           renderWithContext defaultSDocContext (lpr_passPpr cfg)+       ; displayLintResults logger+                            (lpr_showLintWarnings cfg) (lpr_passPpr cfg)+                            (pprCoreBindings binds) warns_and_errs+       }++displayLintResults :: Logger+                   -> Bool -- ^ If 'True', display linter warnings.+                           --   If 'False', ignore linter warnings.+                   -> SDoc -- ^ The source of the linted program+                   -> SDoc -- ^ The linted program, pretty-printed+                   -> WarnsAndErrs+                   -> IO ()+displayLintResults logger display_warnings pp_what pp_pgm (warns, errs)+  | not (isEmptyBag errs)+  = do { logMsg logger Err.MCInfo noSrcSpan  -- See Note [MCInfo for Lint]+           $ withPprStyle defaultDumpStyle+           (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs+                 , text "*** Offending Program ***"+                 , pp_pgm+                 , text "*** End of Offense ***" ])+       ; Err.ghcExit logger 1 }++  | not (isEmptyBag warns)+  , log_enable_debug (logFlags logger)+  , display_warnings+  = logMsg logger Err.MCInfo noSrcSpan  -- See Note [MCInfo for Lint]+      $ withPprStyle defaultDumpStyle+        (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))++  | otherwise = return ()++lint_banner :: String -> SDoc -> SDoc+lint_banner string pass = text "*** Core Lint"      <+> text string+                          <+> text ": in result of" <+> pass+                          <+> text "***"++-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].+lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs+--   Returns (warnings, errors)+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintCoreBindings' cfg binds+  = initL cfg $+    addLoc TopLevelBindings           $+    do { -- Check that all top-level binders are distinct+         -- We do not allow  [NonRec x=1, NonRec y=x, NonRec x=2]+         -- because of glomming; see Note [Glomming] in GHC.Core.Opt.OccurAnal+         checkL (null dups) (dupVars dups)++         -- Check for External top level binders with the same M.n name+       ; checkL (null ext_dups) (dupExtVars ext_dups)++         -- Typecheck the bindings+       ; lintRecBindings TopLevel all_pairs $ \_ ->+         return () }+  where+    all_pairs = flattenBinds binds+     -- Put all the top-level binders in scope at the start+     -- This is because rewrite rules can bring something+     -- into use 'unexpectedly'; see Note [Glomming] in "GHC.Core.Opt.OccurAnal"+    binders = map fst all_pairs++    (_, dups) = removeDups compare binders++    -- ext_dups checks for names with different uniques+    -- but the same External name M.n.  We don't+    -- allow this at top level:+    --    M.n{r3}  = ...+    --    M.n{r29} = ...+    -- because they both get the same linker symbol+    ext_dups = snd $ removeDupsOn ord_ext $+               filter isExternalName $ map Var.varName binders+    ord_ext n = (nameModule n, nameOccName n)++{-+************************************************************************+*                                                                      *+\subsection[lintUnfolding]{lintUnfolding}+*                                                                      *+************************************************************************++Note [Linting Unfoldings from Interfaces]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use this to check all top-level unfoldings that come in from interfaces+(it is very painful to catch errors otherwise).++We do not need to call lintUnfolding on unfoldings that are nested within+top-level unfoldings; they are linted when we lint the top-level unfolding;+hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore.++-}++lintUnfolding :: Bool             -- ^ True <=> is a compulsory unfolding+              -> LintConfig+              -> SrcLoc+              -> CoreExpr+              -> Maybe (Bag SDoc) -- Nothing => OK++lintUnfolding is_compulsory cfg locn expr+  | isEmptyBag errs = Nothing+  | otherwise       = Just errs+  where+    (_warns, errs) = initL cfg $+                     if is_compulsory+                       -- See Note [Checking for representation polymorphism]+                     then noFixedRuntimeRepChecks linter+                     else linter+    linter = addLoc (ImportedUnfolding locn) $+             lintCoreExpr expr++lintExpr :: LintConfig+         -> CoreExpr+         -> Maybe (Bag SDoc)  -- Nothing => OK++lintExpr cfg expr+  | isEmptyBag errs = Nothing+  | otherwise       = Just errs+  where+    (_warns, errs) = initL cfg linter+    linter = addLoc TopLevelBindings $+             lintCoreExpr expr++{-+************************************************************************+*                                                                      *+\subsection[lintCoreBinding]{lintCoreBinding}+*                                                                      *+************************************************************************++Check a core binding, returning the list of variables bound.+-}++-- Returns a UsageEnv because this function is called in lintCoreExpr for+-- Let++lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)]+                -> ([OutId] -> LintM a) -> LintM (a, [UsageEnv])+lintRecBindings top_lvl pairs thing_inside+  = lintIdBndrs top_lvl bndrs $ \ bndrs' ->+    do { ues <- zipWithM lint_pair bndrs' rhss+       ; a <- thing_inside bndrs'+       ; return (a, ues) }+  where+    (bndrs, rhss) = unzip pairs+    lint_pair bndr' rhs+      = addLoc (RhsOf bndr') $+        do { (rhs_ty, ue) <- lintRhs bndr' rhs         -- Check the rhs+           ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty+           ; return ue }++lintLetBody :: LintLocInfo -> [OutId] -> CoreExpr -> LintM (OutType, UsageEnv)+lintLetBody loc bndrs body+  = do { (body_ty, body_ue) <- addLoc loc (lintCoreExpr body)+       ; mapM_ (lintJoinBndrType body_ty) bndrs+       ; return (body_ty, body_ue) }++lintLetBind :: TopLevelFlag -> RecFlag -> OutId+              -> CoreExpr -> OutType -> LintM ()+-- Binder's type, and the RHS, have already been linted+-- This function checks other invariants+lintLetBind top_lvl rec_flag binder rhs rhs_ty+  = do { let binder_ty = idType binder+       ; ensureEqTys binder_ty rhs_ty (mkRhsMsg binder (text "RHS") rhs_ty)++       -- If the binding is for a CoVar, the RHS should be (Coercion co)+       -- See Note [Core type and coercion invariant] in GHC.Core+       ; checkL (not (isCoVar binder) || isCoArg rhs)+                (mkLetErr binder rhs)++        -- Check the let-can-float invariant+        -- See Note [Core let-can-float invariant] in GHC.Core+       ; checkL ( isJoinId binder+               || mightBeLiftedType binder_ty+               || (isNonRec rec_flag && exprOkForSpeculation rhs)+               || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed+               || exprIsTickedString rhs)+           (badBndrTyMsg binder (text "unlifted"))++        -- Check that if the binder is at the top level and has type Addr#,+        -- that it is a string literal.+        -- See Note [Core top-level string literals].+       ; checkL (not (isTopLevel top_lvl && binder_ty `eqType` addrPrimTy)+                 || exprIsTickedString rhs)+           (mkTopNonLitStrMsg binder)++       ; flags <- getLintFlags++         -- Check that a join-point binder has a valid type+         -- NB: lintIdBinder has checked that it is not top-level bound+       ; case idJoinPointHood binder of+            NotJoinPoint    -> return ()+            JoinPoint arity ->  checkL (isValidJoinPointType arity binder_ty)+                                       (mkInvalidJoinPointMsg binder binder_ty)++       ; when (lf_check_inline_loop_breakers flags+               && isStableUnfolding (realIdUnfolding binder)+               && isStrongLoopBreaker (idOccInfo binder)+               && isInlinePragma (idInlinePragma binder))+              (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder))+              -- Only non-rule loop breakers inhibit inlining++       -- We used to check that the dmdTypeDepth of a demand signature never+       -- exceeds idArity, but that is an unnecessary complication, see+       -- Note [idArity varies independently of dmdTypeDepth] in GHC.Core.Opt.DmdAnal++       -- Check that the binder's arity is within the bounds imposed by the type+       -- and the strictness signature. See Note [Arity invariants for bindings]+       -- and Note [Trimming arity]++       ; checkL (typeArity (idType binder) >= idArity binder)+           (text "idArity" <+> ppr (idArity binder) <+>+           text "exceeds typeArity" <+>+           ppr (typeArity (idType binder)) <> colon <+>+           ppr binder)++       -- See Note [idArity varies independently of dmdTypeDepth]+       --     in GHC.Core.Opt.DmdAnal+       ; case splitDmdSig (idDmdSig binder) of+           (demands, result_info) | isDeadEndDiv result_info ->+              if (demands `lengthAtLeast` idArity binder)+              then return ()+              else pprTrace "Hack alert: lintLetBind #24623"+                       (ppr (idArity binder) $$ ppr (idDmdSig binder)) $+                   return ()+--             checkL (demands `lengthAtLeast` idArity binder)+--               (text "idArity" <+> ppr (idArity binder) <+>+--               text "exceeds arity imposed by the strictness signature" <+>+--               ppr (idDmdSig binder) <> colon <+>+--               ppr binder)++           _ -> return ()++       ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)++       ; addLoc (UnfoldingOf binder) $+         lintIdUnfolding binder binder_ty (idUnfolding binder)+       ; return () }++        -- We should check the unfolding, if any, but this is tricky because+        -- the unfolding is a SimplifiableCoreExpr. Give up for now.++-- | Checks the RHS of bindings. It only differs from 'lintCoreExpr'+-- in that it doesn't reject occurrences of the function 'makeStatic' when they+-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and+-- for join points, it skips the outer lambdas that take arguments to the+-- join point.+--+-- See Note [Checking StaticPtrs].+lintRhs :: Id -> CoreExpr -> LintM (OutType, UsageEnv)+-- NB: the Id can be Linted or not -- it's only used for+--     its OccInfo and join-pointer-hood+lintRhs bndr rhs+    | JoinPoint arity <- idJoinPointHood bndr+    = lintJoinLams arity (Just bndr) rhs+    | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)+    = lintJoinLams arity Nothing rhs++-- Allow applications of the data constructor @StaticPtr@ at the top+-- but produce errors otherwise.+lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go+  where+    -- Allow occurrences of 'makeStatic' at the top-level but produce errors+    -- otherwise.+    go :: StaticPtrCheck -> LintM (OutType, UsageEnv)+    go AllowAtTopLevel+      | (binders0, rhs') <- collectTyBinders rhs+      , Just (fun, t, info, e) <- collectMakeStaticArgs rhs'+      = markAllJoinsBad $+        foldr+        -- imitate @lintCoreExpr (Lam ...)@+        lintLambda+        -- imitate @lintCoreExpr (App ...)@+        (do fun_ty_ue <- lintCoreExpr fun+            lintCoreArgs fun_ty_ue [Type t, info, e]+        )+        binders0+    go _ = markAllJoinsBad $ lintCoreExpr rhs++-- | Lint the RHS of a join point with expected join arity of @n@ (see Note+-- [Join points] in "GHC.Core").+lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (OutType, UsageEnv)+lintJoinLams join_arity enforce rhs+  = go join_arity rhs+  where+    go 0 expr            = lintCoreExpr expr+    go n (Lam var body)  = lintLambda var $ go (n-1) body+    go n expr | Just bndr <- enforce -- Join point with too few RHS lambdas+              = failWithL $ mkBadJoinArityMsg bndr join_arity n rhs+              | otherwise -- Future join point, not yet eta-expanded+              = markAllJoinsBad $ lintCoreExpr expr+                -- Body of lambda is not a tail position++lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()+lintIdUnfolding bndr bndr_ty uf+  | isStableUnfolding uf+  , Just rhs <- maybeUnfoldingTemplate uf+  = do { ty <- fst <$> (if isCompulsoryUnfolding uf+                        then noFixedRuntimeRepChecks $ lintRhs bndr rhs+            --               ^^^^^^^^^^^^^^^^^^^^^^^+            -- See Note [Checking for representation polymorphism]+                        else lintRhs bndr rhs)+       ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) }+lintIdUnfolding  _ _ _+  = return ()       -- Do not Lint unstable unfoldings, because that leads+                    -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars++{- Note [Checking for INLINE loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very suspicious if a strong loop breaker is marked INLINE.++However, the desugarer generates instance methods with INLINE pragmas+that form a mutually recursive group.  Only after a round of+simplification are they unravelled.  So we suppress the test for+the desugarer.  Here is an example:+  instance Eq T where+    t1 == t2 = blah+    t1 /= t2 = not (t1 == t2)+    {-# INLINE (/=) #-}++This will generate something like+    -- From the class decl for Eq+    data Eq a = EqDict (a->a->Bool) (a->a->Bool)+    eq_sel :: Eq a -> (a->a->Bool)+    eq_sel (EqDict eq _) = eq++    -- From the instance Eq T+    $ceq :: T -> T -> Bool+    $ceq = blah++    Rec { $dfEqT :: Eq T {-# DFunId #-}+          $dfEqT = EqDict $ceq $cnoteq++          $cnoteq :: T -> T -> Bool  {-# INLINE #-}+          $cnoteq x y = not (eq_sel $dfEqT x y) }++Notice that++* `$dfEqT` and `$cnotEq` are mutually recursive.++* We do not want `$dfEqT` to be the loop breaker: it's a DFunId, and+  we want to let it "cancel" with "eq_sel" (see Note [ClassOp/DFun+  selection] in GHC.Tc.TyCl.Instance, which it can't do if it's a loop+  breaker.++So we make `$cnoteq` into the loop breaker. That means it can't+inline, despite the INLINE pragma. That's what gives rise to the+warning, which is perfectly appropriate for, say+   Rec { {-# INLINE f #-}  f = \x -> ...f.... }+We can't inline a recursive function -- it's a loop breaker.++But now we can optimise `eq_sel $dfEqT` to `$ceq`, so we get+  Rec {+    $dfEqT :: Eq T {-# DFunId #-}+    $dfEqT = EqDict $ceq $cnoteq++    $cnoteq :: T -> T -> Bool  {-# INLINE #-}+    $cnoteq x y = not ($ceq x y) }++and now the dependencies of the Rec have gone, and we can split it up to give+    NonRec {  $dfEqT :: Eq T {-# DFunId #-}+              $dfEqT = EqDict $ceq $cnoteq }++    NonRec {  $cnoteq :: T -> T -> Bool  {-# INLINE #-}+              $cnoteq x y = not ($ceq x y) }++Now $cnoteq is not a loop breaker any more, so the INLINE pragma can+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 result of the desugarer.  See+lf_check_inline_loop_breakers in GHC.Core.Lint.+++Note [Checking for representation polymorphism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We ordinarily want to check for bad representation polymorphism. See+Note [Representation polymorphism invariants] in GHC.Core. However, we do *not*+want to do this in a compulsory unfolding. Compulsory unfoldings arise+only internally, for things like newtype wrappers, dictionaries, and+(notably) unsafeCoerce#. These might legitimately be representation-polymorphic;+indeed representation-polymorphic unfoldings are a primary reason for the+very existence of compulsory unfoldings (we can't compile code for+the original, representation-polymorphic, binding).++It is vitally important that we do representation polymorphism checks *after*+performing the unfolding, but not beforehand. This is all safe because+we will check any unfolding after it has been unfolded; checking the+unfolding beforehand is merely an optimization, and one that actively+hurts us here.++Note [Linting of runRW#]+~~~~~~~~~~~~~~~~~~~~~~~~+runRW# has some very special behavior (see Note [runRW magic] in+GHC.CoreToStg.Prep) which CoreLint must accommodate, by allowing+join points in its argument.  For example, this is fine:++    join j x = ...+    in runRW#  (\s. case v of+                       A -> j 3+                       B -> j 4)++Usually those calls to the join point 'j' would not be valid tail calls,+because they occur in a function argument.  But in the case of runRW#+they are fine, because runRW# (\s.e) behaves operationally just like e.+(runRW# is ultimately inlined in GHC.CoreToStg.Prep.)++In the case that the continuation is /not/ a lambda we simply disable this+special behaviour.  For example, this is /not/ fine:++    join j = ...+    in runRW# @r @ty (jump j)++Note [Coercions in terms]+~~~~~~~~~~~~~~~~~~~~~~~~~+The expression (Type ty) can occur only as the argument of an application,+or the RHS of a non-recursive Let.  But what about (Coercion co)?++Currently it appears in ghc-prim:GHC.Types.coercible_sel, a WiredInId whose+definition is:+   coercible_sel :: Coercible a b => (a ~R# b)+   coercible_sel d = case d of+                         MkCoercibleDict (co :: a ~# b) -> Coercion co++So this function has a (Coercion co) in the alternative of a case.++Richard says (!11908): it shouldn't appear outside of arguments, but we've been+loose about this. coercible_sel is some thin ice. Really we should be unpacking+Coercible using case, not a selector. I recall looking into this a few years+back and coming to the conclusion that the fix was worse than the disease. Don't+remember the details, but could probably recover it if we want to revisit.++So Lint current accepts (Coercion co) in arbitrary places.  There is no harm in+that: it really is a value, albeit a zero-bit value.++************************************************************************+*                                                                      *+\subsection[lintCoreExpr]{lintCoreExpr}+*                                                                      *+************************************************************************+-}++lintCoreExpr :: InExpr -> LintM (OutType, UsageEnv)+-- The returned type has the substitution from the monad+-- already applied to it:+--      lintCoreExpr e subst = exprType (subst e)+--+-- The returned "type" can be a kind, if the expression is (Type ty)++-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]++lintCoreExpr (Var var)+  = do {  var_pair@(var_ty, _) <- lintIdOcc var 0+           -- See Note [Linting representation-polymorphic builtins]+       ; checkRepPolyBuiltin (Var var) [] var_ty+           --checkDataToTagPrimOpTyCon (Var var) []+       ; return var_pair }++lintCoreExpr (Lit lit)+  = return (literalType lit, zeroUE)++lintCoreExpr (Cast expr co)+  = do { (expr_ty, ue) <- markAllJoinsBad (lintCoreExpr expr)+            -- markAllJoinsBad: see Note [Join points and casts]++       ; lintCoercion co+       ; lintRole co Representational (coercionRole co)+       ; Pair from_ty to_ty <- substCoKindM co+       ; checkValueType (typeKind to_ty) $+         text "target of cast" <+> quotes (ppr co)+       ; ensureEqTys from_ty expr_ty (mkCastErr expr co from_ty expr_ty)+       ; return (to_ty, ue) }++lintCoreExpr (Tick tickish expr)+  = do { case tickish of+           Breakpoint _ _ ids -> forM_ ids $ \id -> lintIdOcc id 0+           _                  -> return ()+       ; markAllJoinsBadIf block_joins $ lintCoreExpr expr }+  where+    block_joins = not (tickish `tickishScopesLike` SoftScope)+      -- TODO Consider whether this is the correct rule. It is consistent with+      -- the simplifier's behaviour - cost-centre-scoped ticks become part of+      -- the continuation, and thus they behave like part of an evaluation+      -- context, but soft-scoped and non-scoped ticks simply wrap the result+      -- (see Simplify.simplTick).++lintCoreExpr (Let (NonRec tv (Type ty)) body)+  | isTyVar tv+  =     -- See Note [Linting type lets]+    do  { ty' <- lintTypeAndSubst ty+        ; lintTyCoBndr tv              $ \ tv' ->+    do  { addLoc (RhsOf tv) $ lintTyKind tv' ty'+                -- Now extend the substitution so we+                -- take advantage of it in the body+        ; extendTvSubstL tv ty' $+          addLoc (BodyOfLet tv) $+          lintCoreExpr body } }++lintCoreExpr (Let (NonRec bndr rhs) body)+  | isId bndr+  = do { -- First Lint the RHS, before bringing the binder into scope+         (rhs_ty, let_ue) <- lintRhs bndr rhs++          -- See Note [Multiplicity of let binders] in Var+         -- Now lint the binder+       ; lintBinder LetBind bndr $ \bndr' ->+    do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty+       ; addAliasUE bndr' let_ue $+         lintLetBody (BodyOfLet bndr') [bndr'] body } }++  | otherwise+  = failWithL (mkLetErr bndr rhs)       -- Not quite accurate++lintCoreExpr e@(Let (Rec pairs) body)+  = do  { -- Check that the list of pairs is non-empty+          checkL (not (null pairs)) (emptyRec e)++          -- Check that there are no duplicated binders+        ; let (_, dups) = removeDups compare bndrs+        ; checkL (null dups) (dupVars dups)++          -- Check that either all the binders are joins, or none+        ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $+          mkInconsistentRecMsg bndrs++          -- See Note [Multiplicity of let binders] in Var+        ; ((body_type, body_ue), ues) <-+            lintRecBindings NotTopLevel pairs $ \ bndrs' ->+            lintLetBody (BodyOfLetRec bndrs') bndrs' body+        ; return (body_type, body_ue  `addUE` scaleUE ManyTy (foldr1WithDefault zeroUE addUE ues)) }+  where+    bndrs = map fst pairs++lintCoreExpr e@(App _ _)+  | Var fun <- fun+  , fun `hasKey` runRWKey+    -- See Note [Linting of runRW#]+    -- N.B. we may have an over-saturated application of the form:+    --   runRW (\s -> \x -> ...) y+  , ty_arg1 : ty_arg2 : cont_arg : rest <- args+  = do { let lint_rw_cont :: CoreArg -> Mult -> UsageEnv -> LintM (OutType, UsageEnv)+             lint_rw_cont expr@(Lam _ _) mult fun_ue+                = do { (arg_ty, arg_ue) <- lintJoinLams 1 (Just fun) expr+                     ; let app_ue = addUE fun_ue (scaleUE mult arg_ue)+                     ; return (arg_ty, app_ue) }++             lint_rw_cont expr mult ue+                = lintValArg expr mult ue+             -- TODO: Look through ticks?++       ; runrw_pr <- lintApp (text "runRW# expression")+                               lintTyArg lint_rw_cont+                               (idType fun) [ty_arg1,ty_arg2,cont_arg] zeroUE+       ; lintCoreArgs runrw_pr rest }++  | otherwise+  = do { fun_pair <- lintCoreFun fun (length args)+       ; app_pair@(app_ty, _) <- lintCoreArgs fun_pair args++       -- See Note [Linting representation-polymorphic builtins]+       ; checkRepPolyBuiltin fun args app_ty+       ; --checkDataToTagPrimOpTyCon fun args++       ; return app_pair}+  where+    skipTick t = case collectFunSimple e of+      (Var v) -> etaExpansionTick v t+      _ -> tickishFloatable t+    (fun, args, _source_ticks) = collectArgsTicks skipTick e+      -- We must look through source ticks to avoid #21152, for example:+      --+      -- reallyUnsafePtrEquality+      --   = \ @a ->+      --       (src<loc> reallyUnsafePtrEquality#)+      --         @Lifted @a @Lifted @a+      --+      -- To do this, we use `collectArgsTicks tickishFloatable` to match+      -- the eta expansion behaviour, as per Note [Eta expansion and source notes]+      -- in GHC.Core.Opt.Arity.+      -- Sadly this was not quite enough. So we now also accept things that CorePrep will allow.+      -- See Note [Ticks and mandatory eta expansion]++lintCoreExpr (Lam var expr)+  = markAllJoinsBad $+    lintLambda var $ lintCoreExpr expr++lintCoreExpr (Case scrut var alt_ty alts)+  = lintCaseExpr scrut var alt_ty alts++-- This case can't happen; linting types in expressions gets routed through lintTyArg+lintCoreExpr (Type ty)+  = failWithL (text "Type found as expression" <+> ppr ty)++lintCoreExpr (Coercion co)+  -- See Note [Coercions in terms]+  = do { addLoc (InCo co) $ lintCoercion co+       ; ty <- substTyM (coercionType co)+       ; return (ty, zeroUE) }++----------------------+lintIdOcc :: InId -> Int -- Number of arguments (type or value) being passed+          -> LintM (OutType, UsageEnv) -- returns type of the *variable*+lintIdOcc in_id nargs+  = addLoc (OccOf in_id) $+    do  { checkL (isNonCoVarId in_id)+                 (text "Non term variable" <+> ppr in_id)+                 -- See GHC.Core Note [Variable occurrences in Core]++        -- Check that the type of the occurrence is the same+        -- as the type of the binding site.  The inScopeIds are+        -- /un-substituted/, so this checks that the occurrence type+        -- is identical to the binder type.+        -- This makes things much easier for things like:+        --    /\a. \(x::Maybe a). /\a. ...(x::Maybe a)...+        -- The "::Maybe a" on the occurrence is referring to the /outer/ a.+        -- If we compared /substituted/ types we'd risk comparing+        -- (Maybe a) from the binding site with bogus (Maybe a1) from+        -- the occurrence site.  Comparing un-substituted types finesses+        -- this altogether+        ; out_ty <- lintVarOcc in_id++          -- Check for a nested occurrence of the StaticPtr constructor.+          -- See Note [Checking StaticPtrs].+        ; lf <- getLintFlags+        ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $+            checkL (idName in_id /= makeStaticName) $+              text "Found makeStatic nested in an expression"++        ; checkDeadIdOcc in_id++        ; case isDataConId_maybe in_id of+             Nothing -> return ()+             Just dc -> checkTypeDataConOcc "expression" dc++        ; checkJoinOcc in_id nargs+        ; usage <- varCallSiteUsage in_id++        ; return (out_ty, usage) }++++lintCoreFun :: CoreExpr+            -> Int                          -- Number of arguments (type or val) being passed+            -> LintM (OutType, UsageEnv) -- Returns type of the *function*+lintCoreFun (Var var) nargs+  = lintIdOcc var nargs++lintCoreFun (Lam var body) nargs+  -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad;+  -- See Note [Beta redexes]+  | nargs /= 0+  = lintLambda var $ lintCoreFun body (nargs - 1)++lintCoreFun expr nargs+  = markAllJoinsBadIf (nargs /= 0) $+      -- See Note [Join points are less general than the paper]+    lintCoreExpr expr+------------------+lintLambda :: Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)+lintLambda var lintBody =+    addLoc (LambdaBodyOf var) $+    lintBinder LambdaBind var $ \ var' ->+    do { (body_ty, ue) <- lintBody+       ; ue' <- checkLinearity ue var'+       ; return (mkLamType var' body_ty, ue') }+------------------+checkDeadIdOcc :: Id -> LintM ()+-- Occurrences of an Id should never be dead....+-- except when we are checking a case pattern+checkDeadIdOcc id+  | isDeadOcc (idOccInfo id)+  = do { in_case <- inCasePat+       ; checkL in_case+                (text "Occurrence of a dead Id" <+> ppr id) }+  | otherwise+  = return ()++------------------+lintJoinBndrType :: OutType -- Type of the body+                 -> OutId   -- Possibly a join Id+                -> LintM ()+-- Checks that the return type of a join Id matches the body+-- E.g. join j x = rhs in body+--      The type of 'rhs' must be the same as the type of 'body'+lintJoinBndrType body_ty bndr+  | JoinPoint arity <- idJoinPointHood bndr+  , let bndr_ty = idType bndr+  , (bndrs, res) <- splitPiTys bndr_ty+  = checkL (length bndrs >= arity+            && body_ty `eqType` mkPiTys (drop arity bndrs) res) $+    hang (text "Join point returns different type than body")+       2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr)+               , text "Join arity:" <+> ppr arity+               , text "Body type:" <+> ppr body_ty ])+  | otherwise+  = return ()++checkJoinOcc :: Id -> JoinArity -> LintM ()+-- Check that if the occurrence is a JoinId, then so is the+-- binding site, and it's a valid join Id+checkJoinOcc var n_args+  | JoinPoint join_arity_occ <- idJoinPointHood var+  = do { mb_join_arity_bndr <- lookupJoinId var+       ; case mb_join_arity_bndr of {+           NotJoinPoint -> do { join_set <- getValidJoins+                              ; addErrL (text "join set " <+> ppr join_set $$+                                invalidJoinOcc var) } ;++           JoinPoint join_arity_bndr ->++    do { checkL (join_arity_bndr == join_arity_occ) $+           -- Arity differs at binding site and occurrence+         mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ++       ; checkL (n_args == join_arity_occ) $+           -- Arity doesn't match #args+         mkBadJumpMsg var join_arity_occ n_args } } }++  | otherwise+  = return ()++checkTypeDataConOcc :: String -> DataCon -> LintM ()+-- Check that the Id is not a data constructor of a `type data` declaration+-- Invariant (I1) of Note [Type data declarations] in GHC.Rename.Module+checkTypeDataConOcc what dc+  = checkL (not (isTypeDataTyCon (dataConTyCon dc))) $+    (text "type data constructor found in a" <+> text what <> colon <+> ppr dc)++{-+-- | Check that a use of a dataToTag# primop satisfies conditions DTT2+-- and DTT3 from Note [DataToTag overview] in GHC.Tc.Instance.Class+--+-- Ignores applications not headed by dataToTag# primops.++-- Commented out because GHC.PrimopWrappers doesn't respect this condition yet.+-- See wrinkle DTW7 in Note [DataToTag overview].+checkDataToTagPrimOpTyCon+  :: CoreExpr   -- ^ the function (head of the application) we are checking+  -> [CoreArg]  -- ^ The arguments to the application+  -> LintM ()+checkDataToTagPrimOpTyCon (Var fun_id) args+  | Just op <- isPrimOpId_maybe fun_id+  , op == DataToTagSmallOp || op == DataToTagLargeOp+  = case args of+      Type _levity : Type dty : _rest+        | Just (tc, _) <- splitTyConApp_maybe dty+        , isValidDTT2TyCon tc+          -> do  platform <- getPlatform+                 let  numConstrs = tyConFamilySize tc+                      isSmallOp = op == DataToTagSmallOp+                 checkL (isSmallFamily platform numConstrs == isSmallOp) $+                   text "dataToTag# primop-size/tycon-family-size mismatch"+        | otherwise -> failWithL $ text "dataToTagLarge# used at non-ADT type:"+                                   <+> ppr dty+      _ -> failWithL $ text "dataToTagLarge# needs two type arguments but has args:"+                       <+> ppr (take 2 args)++checkDataToTagPrimOpTyCon _ _ = pure ()+-}++-- | Check representation-polymorphic invariants in an application of a+-- built-in function or newtype constructor.+--+-- See Note [Linting representation-polymorphic builtins].+checkRepPolyBuiltin :: CoreExpr   -- ^ the function (head of the application) we are checking+                    -> [CoreArg]  -- ^ the arguments to the application+                    -> OutType -- ^ the instantiated type of the overall application+                    -> LintM ()+checkRepPolyBuiltin (Var fun_id) args app_ty+  = do { do_rep_poly_checks <- lf_check_fixed_rep <$> getLintFlags+       ; when (do_rep_poly_checks && hasNoBinding fun_id) $+           if+             -- (2) representation-polymorphic unlifted newtypes+             | Just dc <- isDataConId_maybe fun_id+             , isNewDataCon dc+             -> if tcHasFixedRuntimeRep $ dataConTyCon dc+                then return ()+                else checkRepPolyNewtypeApp dc args app_ty++             -- (1) representation-polymorphic builtins+             | otherwise+             -> checkRepPolyBuiltinApp fun_id args+       }+checkRepPolyBuiltin _ _ _ = return ()++checkRepPolyNewtypeApp :: DataCon -> [CoreArg] -> OutType -> LintM ()+checkRepPolyNewtypeApp nt args app_ty+  -- If the newtype is saturated, we're OK.+  | any isValArg args+  = return ()+  -- Otherwise, check we can eta-expand.+  | otherwise+  = case getRuntimeArgTys app_ty of+      (Scaled _ first_val_arg_ty, _):_+        | not $ typeHasFixedRuntimeRep first_val_arg_ty+        -> failWithL (err_msg first_val_arg_ty)+      _ -> return ()++  where++      err_msg :: Type -> SDoc+      err_msg bad_arg_ty+        = vcat [ text "Cannot eta expand unlifted newtype constructor" <+> quotes (ppr nt) <> dot+               , text "Its argument type does not have a fixed runtime representation:"+               , nest 2 $ ppr_ty_ki bad_arg_ty ]++      ppr_ty_ki :: Type -> SDoc+      ppr_ty_ki ty = bullet <+> ppr ty <+> dcolon <+> ppr (typeKind ty)++checkRepPolyBuiltinApp :: Id -> [CoreArg] -> LintM ()+checkRepPolyBuiltinApp fun_id args = checkL (null not_concs) err_msg+  where++    conc_binder_positions :: IntMap ConcreteTvOrigin+    conc_binder_positions+      = concreteTyVarPositions fun_id+      $ idDetailsConcreteTvs+      $ idDetails fun_id++    max_pos :: Int+    max_pos =+      case nonEmpty $ IntMap.keys conc_binder_positions of+        Nothing -> 0+        Just positions -> maximum positions++    not_concs :: [(SDoc, ConcreteTvOrigin)]+    not_concs =+      mapMaybe is_bad (zip [1..max_pos] (map Just args ++ repeat Nothing))+        -- NB: 1-indexed++    is_bad :: (Int, Maybe CoreArg) -> Maybe (SDoc, ConcreteTvOrigin)+    is_bad (pos, mb_arg)+      | Just conc_reason <- IntMap.lookup pos conc_binder_positions+      , Just bad_ty <- case mb_arg of+          Just (Type ki)+            | isConcreteType ki+            -> Nothing+            | otherwise+            -- Here we handle the situation in which a "must be concrete" TyVar+            -- has been instantiated with a type that is not concrete.+            -> Just $ quotes (ppr ki) <+> text "is not concrete."+          -- We expected a type argument in this position, and got something else: panic!+          Just arg ->+            pprPanic "checkRepPolyBuiltinApp: expected a type in this position" $+              vcat [ text "fun_id:" <+> ppr fun_id <+> dcolon <+> ppr (idType fun_id)+                   , text "pos:" <+> ppr pos+                   , text "arg:" <+> ppr arg ]+          Nothing ->+            -- Here we handle the situation in which a "must be concrete" TyVar+            -- has not been instantiated at all.+            case conc_reason of+              ConcreteFRR frr_orig ->+                let ty = frr_type frr_orig+                in  Just $ ppr ty <+> dcolon <+> ppr (typeKind ty)+      = Just (bad_ty, conc_reason)+      | otherwise+      = Nothing++    err_msg :: SDoc+    err_msg+      = vcat $ map ((bullet <+>) . ppr_not_conc) not_concs++    ppr_not_conc :: (SDoc, ConcreteTvOrigin) -> SDoc+    ppr_not_conc (bad_ty, conc) =+      vcat+       [ ppr_conc_orig conc+       , nest 2 bad_ty ]++    ppr_conc_orig :: ConcreteTvOrigin -> SDoc+    ppr_conc_orig (ConcreteFRR frr_orig) =+      case frr_orig of+        FixedRuntimeRepOrigin { frr_context = ctxt } ->+          hsep [ ppr ctxt, text "does not have a fixed runtime representation:" ]++-- | Compute the 1-indexed positions in the outer forall'd quantified type variables+-- of the type in which the concrete type variables occur.+--+-- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete.+concreteTyVarPositions :: Id -> ConcreteTyVars -> IntMap ConcreteTvOrigin+concreteTyVarPositions fun_id conc_tvs+  | isNullUFM conc_tvs+  = IntMap.empty+  | otherwise+  = case splitForAllTyCoVars (idType fun_id) of+    ([], _)  -> IntMap.empty+    (tvs, _) ->+      let positions =+            IntMap.fromList+              [ (pos, conc_orig)+              | (tv, pos) <- zip tvs [1..]+              , conc_orig <- maybeToList $ lookupNameEnv conc_tvs (tyVarName tv)+              ]+         -- Assert that we have as many positions as concrete type variables,+         -- i.e. we are not missing any concreteness information.+      in assertPpr (sizeUFM conc_tvs == length positions)+           (vcat [ text "concreteTyVarPositions: missing concreteness information"+                 , text "fun_id:" <+> ppr fun_id+                 , text "tvs:" <+> ppr tvs+                 , text "Expected # of concrete tvs:" <+> ppr (sizeUFM conc_tvs)+                 , text "  Actual # of concrete tvs:" <+> ppr (length positions) ])+           positions++-- Check that the usage of var is consistent with var itself, and pop the var+-- from the usage environment (this is important because of shadowing).+checkLinearity :: UsageEnv -> OutVar -> LintM UsageEnv+checkLinearity body_ue lam_var =+  case varMultMaybe lam_var of+    Just mult -> do+      let (lhs, body_ue') = popUE body_ue lam_var+          err_msg = vcat [ text "Linearity failure in lambda:" <+> ppr lam_var+                         , ppr lhs <+> text "⊈" <+> ppr mult+                         , ppr body_ue ]+      ensureSubUsage lhs mult err_msg+      return body_ue'+    Nothing    -> return body_ue -- A type variable++{- Note [Join points and casts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You might think that this should be OK:+   join j x = rhs+   in (case e of+          A   -> alt1+          B x -> (jump j x) |> co)++You might think that, since the cast is ultimately erased, the jump to+`j` should still be OK as a join point.  But no!  See #21716. Suppose++  newtype Age = MkAge Int   -- axAge :: Age ~ Int+  f :: Int -> ...           -- f strict in it's first argument++and consider the expression++  f (join j :: Bool -> Age+          j x = (rhs1 :: Age)+     in case v of+         Just x  -> (j x |> axAge :: Int)+         Nothing -> rhs2)++Then, if the Simplifier pushes the strict call into the join points+and alternatives we'll get++   join j' x = f (rhs1 :: Age)+   in case v of+      Just x  -> j' x |> axAge+      Nothing -> f rhs2++Utterly bogus.  `f` expects an `Int` and we are giving it an `Age`.+No no no.  Casts destroy the tail-call property.  Henc markAllJoinsBad+in the (Cast expr co) case of lintCoreExpr.++Note [No alternatives lint check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Case expressions with no alternatives are odd beasts, and it would seem+like they would worth be looking at in the linter (cf #10180). We+used to check two things:++* exprIsHNF is false: it would *seem* to be terribly wrong if+  the scrutinee was already in head normal form.++* exprIsDeadEnd is true: we should be able to see why GHC believes the+  scrutinee is diverging for sure.++It was already known that the second test was not entirely reliable.+Unfortunately (#13990), the first test turned out not to be reliable+either. Getting the checks right turns out to be somewhat complicated.++For example, suppose we have (comment 8)++  data T a where+    TInt :: T Int++  absurdTBool :: T Bool -> a+  absurdTBool v = case v of++  data Foo = Foo !(T Bool)++  absurdFoo :: Foo -> a+  absurdFoo (Foo x) = absurdTBool x++GHC initially accepts the empty case because of the GADT conditions. But then+we inline absurdTBool, getting++  absurdFoo (Foo x) = case x of++x is in normal form (because the Foo constructor is strict) but the+case is empty. To avoid this problem, GHC would have to recognize+that matching on Foo x is already absurd, which is not so easy.++More generally, we don't really know all the ways that GHC can+lose track of why an expression is bottom, so we shouldn't make too+much fuss when that happens.+++Note [Beta redexes]+~~~~~~~~~~~~~~~~~~~+Consider:++  join j @x y z = ... in+  (\@x y z -> jump j @x y z) @t e1 e2++This is clearly ill-typed, since the jump is inside both an application and a+lambda, either of which is enough to disqualify it as a tail call (see Note+[Invariants on join points] in GHC.Core). However, strictly from a+lambda-calculus perspective, the term doesn't go wrong---after the two beta+reductions, the jump *is* a tail call and everything is fine.++Why would we want to allow this when we have let? One reason is that a compound+beta redex (that is, one with more than one argument) has different scoping+rules: naively reducing the above example using lets will capture any free+occurrence of y in e2. More fundamentally, type lets are tricky; many passes,+such as Float Out, tacitly assume that the incoming program's type lets have+all been dealt with by the simplifier. Thus we don't want to let-bind any types+in, say, GHC.Core.Subst.simpleOptPgm, which in some circumstances can run immediately+before Float Out.++All that said, currently GHC.Core.Subst.simpleOptPgm is the only thing using this+loophole, doing so to avoid re-traversing large functions (beta-reducing a type+lambda without introducing a type let requires a substitution). TODO: Improve+simpleOptPgm so that we can forget all this ever happened.++************************************************************************+*                                                                      *+\subsection[lintCoreArgs]{lintCoreArgs}+*                                                                      *+************************************************************************++The basic version of these functions checks that the argument is a+subtype of the required type, as one would expect.+-}++-- Takes the functions type and arguments as argument.+-- Returns the *result* of applying the function to arguments.+-- e.g. f :: Int -> Bool -> Int would return `Int` as result type.+lintCoreArgs  :: (OutType, UsageEnv) -> [InExpr] -> LintM (OutType, UsageEnv)+lintCoreArgs (fun_ty, fun_ue) args+  = lintApp (text "expression")+              lintTyArg lintValArg fun_ty args fun_ue++lintTyArg :: InExpr -> LintM OutType++-- Type argument+lintTyArg (Type arg_ty)+  = do { checkL (not (isCoercionTy arg_ty))+                (text "Unnecessary coercion-to-type injection:"+                  <+> ppr arg_ty)+       ; lintTypeAndSubst arg_ty }+lintTyArg arg+  = failWithL (hang (text "Expected type argument but found") 2 (ppr arg))++lintValArg  :: InExpr -> Mult -> UsageEnv -> LintM (OutType, UsageEnv)+lintValArg arg mult fun_ue+  = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg+           -- See Note [Representation polymorphism invariants] in GHC.Core++       ; flags <- getLintFlags+       ; when (lf_check_fixed_rep flags) $+         -- Only check that 'arg_ty' has a fixed RuntimeRep+         -- if 'lf_check_fixed_rep' is on.+         do { checkL (typeHasFixedRuntimeRep arg_ty)+                     (text "Argument does not have a fixed runtime representation"+                      <+> ppr arg <+> dcolon+                      <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))) }++       ; let app_ue = addUE fun_ue (scaleUE mult arg_ue)+       ; return (arg_ty, app_ue) }++-----------------+lintAltBinders :: UsageEnv+               -> Var         -- Case binder+               -> OutType     -- Scrutinee type+               -> OutType     -- Constructor type+               -> [(Mult, OutVar)]    -- Binders+               -> LintM UsageEnv+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintAltBinders rhs_ue _case_bndr scrut_ty con_ty []+  = do { ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty)+       ; return rhs_ue }+lintAltBinders rhs_ue case_bndr scrut_ty con_ty ((var_w, bndr):bndrs)+  | isTyVar bndr+  = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr)+       ; lintAltBinders rhs_ue case_bndr scrut_ty con_ty'  bndrs }+  | otherwise+  = do { (con_ty', _) <- lintValApp (Var bndr) con_ty (idType bndr) zeroUE zeroUE+         -- We can pass zeroUE to lintValApp because we ignore its usage+         -- calculation and compute it in the call for checkCaseLinearity below.+       ; rhs_ue' <- checkCaseLinearity rhs_ue case_bndr var_w bndr+       ; lintAltBinders rhs_ue' case_bndr scrut_ty con_ty' bndrs }++-- | Implements the case rules for linearity+checkCaseLinearity :: UsageEnv -> Var -> Mult -> Var -> LintM UsageEnv+checkCaseLinearity ue case_bndr var_w bndr = do+  ensureSubUsage lhs rhs err_msg+  lintLinearBinder (ppr bndr) (case_bndr_w `mkMultMul` var_w) (idMult bndr)+  return $ deleteUE ue bndr+  where+    lhs = bndr_usage `addUsage` (var_w `scaleUsage` case_bndr_usage)+    rhs = case_bndr_w `mkMultMul` var_w+    err_msg  = (text "Linearity failure in variable:" <+> ppr bndr+                $$ ppr lhs <+> text "⊈" <+> ppr rhs+                $$ text "Computed by:"+                <+> text "LHS:" <+> lhs_formula+                <+> text "RHS:" <+> rhs_formula)+    lhs_formula = ppr bndr_usage <+> text "+"+                                 <+> parens (ppr case_bndr_usage <+> text "*" <+> ppr var_w)+    rhs_formula = ppr case_bndr_w <+> text "*" <+> ppr var_w+    case_bndr_w = idMult case_bndr+    case_bndr_usage = lookupUE ue case_bndr+    bndr_usage = lookupUE ue bndr++++-----------------+lintTyApp :: OutType -> OutType -> LintM OutType+lintTyApp fun_ty arg_ty+  | Just (tv,body_ty) <- splitForAllTyVar_maybe fun_ty+  = do  { lintTyKind tv arg_ty+        ; in_scope <- getInScope+        -- substTy needs the set of tyvars in scope to avoid generating+        -- uniques that are already in scope.+        -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst+        ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) }++  | otherwise+  = failWithL (mkTyAppMsg fun_ty arg_ty)++-----------------++-- | @lintValApp arg fun_ty arg_ty@ lints an application of @fun arg@+-- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the+-- application.+lintValApp :: CoreExpr -> OutType -> OutType -> UsageEnv -> UsageEnv+           -> LintM (OutType, UsageEnv)+lintValApp arg fun_ty arg_ty fun_ue arg_ue+  | Just (_, w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty+  = do { ensureEqTys arg_ty' arg_ty (mkAppMsg arg_ty' arg_ty arg)+       ; let app_ue =  addUE fun_ue (scaleUE w arg_ue)+       ; return (res_ty', app_ue) }+  | otherwise+  = failWithL err2+  where+    err2 = mkNonFunAppMsg fun_ty arg_ty arg++lintTyKind :: OutTyVar -> OutType -> LintM ()+-- Both args have had substitution applied++-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintTyKind tyvar arg_ty+  = unless (arg_kind `eqType` tyvar_kind) $+    addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind))+  where+    tyvar_kind = tyVarKind tyvar+    arg_kind   = typeKind arg_ty++{-+************************************************************************+*                                                                      *+\subsection[lintCoreAlts]{lintCoreAlts}+*                                                                      *+************************************************************************+-}++lintCaseExpr :: CoreExpr -> InId -> InType -> [CoreAlt] -> LintM (OutType, UsageEnv)+lintCaseExpr scrut case_bndr alt_ty alts+  = do { let e = Case scrut case_bndr alt_ty alts   -- Just for error messages++       -- Check the scrutinee+       ; (scrut_ty', scrut_ue) <- markAllJoinsBad $ lintCoreExpr scrut+            -- See Note [Join points are less general than the paper]+            -- in GHC.Core++       ; alt_ty' <- addLoc (CaseTy scrut) $ lintValueType alt_ty++       ; checkCaseAlts e scrut scrut_ty' alts++       -- Lint the case-binder. Must do this after linting the scrutinee+       -- because the case-binder isn't in scope in the scrutineex+       ; lintBinder CaseBind case_bndr $ \case_bndr' ->+      -- Don't use lintIdBndr on case_bndr, because unboxed tuple is legitimate++    do { let case_bndr_ty' = idType case_bndr'+             scrut_mult    = idMult case_bndr'++       ; ensureEqTys case_bndr_ty' scrut_ty' (mkScrutMsg case_bndr case_bndr_ty' scrut_ty')+         -- See GHC.Core Note [Case expression invariants] item (7)++       ; -- Check the alternatives+       ; alt_ues <- mapM (lintCoreAlt case_bndr' scrut_ty' scrut_mult alt_ty') alts+       ; let case_ue = (scaleUE scrut_mult scrut_ue) `addUE` supUEs alt_ues+       ; return (alt_ty', case_ue) } }++checkCaseAlts :: InExpr -> InExpr -> OutType -> [CoreAlt] -> LintM ()+-- a) Check that the alts are non-empty+-- b1) Check that the DEFAULT comes first, if it exists+-- b2) Check that the others are in increasing order+-- c) Check that there's a default for infinite types+-- d) Check that the scrutinee is not a floating-point type+--    if there are any literal alternatives+-- e) Check if the scrutinee type has no constructors+--+-- We used to try to check whether a case expression with no+-- alternatives was legitimate, but this didn't work.+-- See Note [No alternatives lint check] for details.+--+-- NB: Algebraic cases are not necessarily exhaustive, because+--     the simplifier correctly eliminates case that can't+--     possibly match.+checkCaseAlts e scrut scrut_ty alts+  = do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)+           -- See GHC.Core Note [Case expression invariants] item (2)++       ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)+           -- See GHC.Core Note [Case expression invariants] item (3)++            -- For types Int#, Word# with an infinite (well, large!) number of+            -- possible values, there should usually be a DEFAULT case+            -- But (see Note [Empty case alternatives] in GHC.Core) it's ok to+            -- have *no* case alternatives.+            -- In effect, this is a kind of partial test. I suppose it's possible+            -- that we might *know* that 'x' was 1 or 2, in which case+            --   case x of { 1 -> e1; 2 -> e2 }+            -- would be fine.+       ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts)+                (nonExhaustiveAltsMsg e)++       -- Check that the scrutinee is not a floating-point type+       -- if there are any literal alternatives+       -- See GHC.Core Note [Case expression invariants] item (5)+       -- See Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold+       ; checkL (not $ isFloatingPrimTy scrut_ty && any is_lit_alt alts)+           (text "Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238)."+            $$ text "scrut" <+> ppr scrut)++       -- Check if scrutinee type has no constructors+       -- Just a trace message for now+       ; case tyConAppTyCon_maybe scrut_ty of+           Just tycon+                | debugIsOn+                , isAlgTyCon tycon+                , not (isAbstractTyCon tycon)+                , null (tyConDataCons tycon)+                , not (exprIsDeadEnd scrut)+                -> pprTrace "Lint warning: case scrutinee type has no constructors"+                        (ppr scrut_ty)+                          -- This can legitimately happen for type families+                        $ return ()+           _otherwise -> return ()+        }+  where+    (con_alts, maybe_deflt) = findDefault alts++        -- Check that successive alternatives have strictly increasing tags+    increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest+    increasing_tag _                         = True++    non_deflt (Alt DEFAULT _ _) = False+    non_deflt _                 = True++    is_lit_alt (Alt (LitAlt _) _  _) = True+    is_lit_alt _                     = False++    is_infinite_ty = case tyConAppTyCon_maybe scrut_ty of+                        Nothing    -> False+                        Just tycon -> isPrimTyCon tycon++lintAltExpr :: CoreExpr -> OutType -> LintM UsageEnv+lintAltExpr expr ann_ty+  = do { (actual_ty, ue) <- lintCoreExpr expr+       ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty)+       ; return ue }+         -- See GHC.Core Note [Case expression invariants] item (6)++lintCoreAlt :: OutId         -- Case binder+            -> OutType       -- Type of scrutinee+            -> Mult          -- Multiplicity of scrutinee+            -> OutType       -- Type of the alternative+            -> CoreAlt+            -> LintM UsageEnv+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintCoreAlt case_bndr _ scrut_mult alt_ty (Alt DEFAULT args rhs) =+  do { lintL (null args) (mkDefaultArgsMsg args)+     ; rhs_ue <- lintAltExpr rhs alt_ty+     ; let (case_bndr_usage, rhs_ue') = popUE rhs_ue case_bndr+           err_msg = vcat [ text "Linearity failure in the DEFAULT clause:" <+> ppr case_bndr+                          , ppr case_bndr_usage <+> text "⊈" <+> ppr scrut_mult ]+     ; ensureSubUsage case_bndr_usage scrut_mult err_msg+     ; return rhs_ue' }++lintCoreAlt case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) args rhs)+  | litIsLifted lit+  = failWithL integerScrutinisedMsg+  | otherwise+  = do { lintL (null args) (mkDefaultArgsMsg args)+       ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)+       ; rhs_ue <- lintAltExpr rhs alt_ty+       ; return (deleteUE rhs_ue case_bndr) -- No need for linearity checks+       }+  where+    lit_ty = literalType lit++lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rhs)+  | isNewTyCon (dataConTyCon con)+  = zeroUE <$ addErrL (mkNewTyDataConAltMsg scrut_ty alt)+  | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty+  = addLoc (CaseAlt alt) $  do+    { checkTypeDataConOcc "pattern" con+    ; lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con)++      -- Instantiate the universally quantified+      -- type variables of the data constructor+    ; let { con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys+          ; binderMult (Named _)   = ManyTy+          ; binderMult (Anon st _) = scaledMult st+          -- See Note [Validating multiplicities in a case]+          ; multiplicities = map binderMult $ fst $ splitPiTys con_payload_ty }++        -- And now bring the new binders into scope+    ; lintBinders CasePatBind args $ \ args' -> do+      { rhs_ue <- lintAltExpr rhs alt_ty+      ; rhs_ue' <- addLoc (CasePat alt) $+                   lintAltBinders rhs_ue case_bndr scrut_ty con_payload_ty+                                  (zipEqual multiplicities  args')+      ; return $ deleteUE rhs_ue' case_bndr+      }+   }++  | otherwise   -- Scrut-ty is wrong shape+  = zeroUE <$ addErrL (mkBadAltMsg scrut_ty alt)++{-+Note [Validating multiplicities in a case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose 'MkT :: a %m -> T m a'.+If we are validating 'case (x :: T Many a) of MkT y -> ...',+we have to substitute m := Many in the type of MkT - in particular,+y can be used Many times and that expression would still be linear in x.+We do this by looking at con_payload_ty, which is the type of the datacon+applied to the surrounding arguments.+Testcase: linear/should_compile/MultConstructor++Data constructors containing existential tyvars will then have+Named binders, which are always multiplicity Many.+Testcase: indexed-types/should_compile/GADT1+-}++lintLinearBinder :: SDoc -> Mult -> Mult -> LintM ()+lintLinearBinder doc actual_usage described_usage+  = ensureSubMult actual_usage described_usage err_msg+    where+      err_msg = (text "Multiplicity of variable does not agree with its context"+                $$ doc+                $$ ppr actual_usage+                $$ text "Annotation:" <+> ppr described_usage)++{-+************************************************************************+*                                                                      *+\subsection[lint-types]{Types}+*                                                                      *+************************************************************************+-}++-- When we lint binders, we (one at a time and in order):+--  1. Lint var types or kinds (possibly substituting)+--  2. Add the binder to the in scope set, and if its a coercion var,+--     we may extend the substitution to reflect its (possibly) new kind+lintBinders :: HasDebugCallStack => BindingSite -> [InVar] -> ([OutVar] -> LintM a) -> LintM a+lintBinders _    []         linterF = linterF []+lintBinders site (var:vars) linterF = lintBinder site var $ \var' ->+                                      lintBinders site vars $ \ vars' ->+                                      linterF (var':vars')++-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintBinder :: HasDebugCallStack => BindingSite -> InVar -> (OutVar -> LintM a) -> LintM a+lintBinder site var linterF+  | isTyCoVar var = lintTyCoBndr var linterF+  | otherwise     = lintIdBndr NotTopLevel site var linterF++lintTyCoBndr :: HasDebugCallStack => TyCoVar -> (OutTyCoVar -> LintM a) -> LintM a+lintTyCoBndr tcv thing_inside+  = do { tcv_type' <- lintTypeAndSubst (varType tcv)+       ; let tcv_kind' = typeKind tcv_type'++         -- See (FORALL1) and (FORALL2) in GHC.Core.Type+       ; if (isTyVar tcv)+         then -- Check that in (forall (a:ki). blah) we have ki:Type+              lintL (isLiftedTypeKind tcv_kind') $+              hang (text "TyVar whose kind does not have kind Type:")+                 2 (ppr tcv <+> dcolon <+> ppr tcv_type' <+> dcolon <+> ppr tcv_kind')+         else -- Check that in (forall (cv::ty). blah),+              -- then ty looks like (t1 ~# t2)+              lintL (isCoVarType tcv_type') $+              text "CoVar with non-coercion type:" <+> pprTyVar tcv++       ; addInScopeTyCoVar tcv tcv_type' thing_inside }++lintIdBndrs :: forall a. TopLevelFlag -> [InId] -> ([OutId] -> LintM a) -> LintM a+lintIdBndrs top_lvl ids thing_inside+  = go ids thing_inside+  where+    go :: [Id] -> ([Id] -> LintM a) -> LintM a+    go []       thing_inside = thing_inside []+    go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id  $ \id' ->+                               go ids                         $ \ids' ->+                               thing_inside (id' : ids')++lintIdBndr :: TopLevelFlag -> BindingSite+           -> InVar -> (OutVar -> LintM a) -> LintM a+-- Do substitution on the type of a binder and add the var with this+-- new type to the in-scope set of the second argument+-- ToDo: lint its rules+lintIdBndr top_lvl bind_site id thing_inside+  = assertPpr (isId id) (ppr id) $+    do { flags <- getLintFlags+       ; checkL (not (lf_check_global_ids flags) || isLocalId id)+                (text "Non-local Id binder" <+> ppr id)+                -- See Note [Checking for global Ids]++       -- Check that if the binder is nested, it is not marked as exported+       ; checkL (not (isExportedId id) || is_top_lvl)+           (mkNonTopExportedMsg id)++       -- Check that if the binder is nested, it does not have an external name+       ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl)+           (mkNonTopExternalNameMsg id)++          -- See Note [Representation polymorphism invariants] in GHC.Core+       ; lintL (isJoinId id || not (lf_check_fixed_rep flags)+                || typeHasFixedRuntimeRep id_ty) $+         text "Binder does not have a fixed runtime representation:" <+> ppr id <+> dcolon <+>+            parens (ppr id_ty <+> dcolon <+> ppr (typeKind id_ty))++       -- Check that a join-id is a not-top-level let-binding+       ; when (isJoinId id) $+         checkL (not is_top_lvl && is_let_bind) $+         mkBadJoinBindMsg id++       -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2);+       -- if so, it should be a CoVar, and checked by lintCoVarBndr+       ; lintL (not (isCoVarType id_ty))+               (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty)++       -- Check that the lambda binder has no value or OtherCon unfolding.+       -- See #21496+       ; lintL (not (bind_site == LambdaBind && isEvaldUnfolding (idUnfolding id)))+                (text "Lambda binder with value or OtherCon unfolding.")++       ; out_ty <- addLoc (IdTy id) (lintValueType id_ty)++       ; addInScopeId id out_ty thing_inside }+  where+    id_ty = idType id++    is_top_lvl = isTopLevel top_lvl+    is_let_bind = case bind_site of+                    LetBind -> True+                    _       -> False++{-+%************************************************************************+%*                                                                      *+             Types+%*                                                                      *+%************************************************************************+-}++{- Note [Linting types and coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Notice that+   lintType     :: InType     -> LintM ()+   lintCoercion :: InCoercion -> LintM ()+Neither returns anything.++If you need the kind of the type, then do `typeKind` and then apply+the ambient substitution using `substTyM`.  Note that the substitution+empty unless there is shadowing or type-lets; and if the substitution is+empty, the `substTyM` is a no-op.++It is better to take the kind and then substitute, rather than substitute+and then take the kind, becaues the kind is usually smaller.++Note: you might wonder if we should apply the same logic to expressions.+Why do we have+  lintExpr :: InExpr -> LintM OutType+Partly inertia; but also taking the type of an expresison involve looking+down a deep chain of let's, whereas that is not true of taking the kind+of a type.  It'd be worth an experiment though.++Historical note: in the olden days we had+   lintType :: InType -> LintM OutType+but that burned a huge amount of allocation building an OutType that was+often discarded, or used only to get its kind.++I also experimented with+   lintType :: InType -> LintM OutKind+but that too was slower.  It is also much simpler to return ()!  If we+return the kind we have to duplicate the logic in `typeKind`; and it is+much worse for coercions.+-}++lintValueType :: Type -> LintM OutType+-- Types only, not kinds+-- Check the type, and apply the substitution to it+-- See Note [Linting type lets]+lintValueType ty+  = addLoc (InType ty) $+    do  { ty' <- lintTypeAndSubst ty+        ; let sk = typeKind ty'+        ; lintL (isTYPEorCONSTRAINT sk) $+          hang (text "Ill-kinded type:" <+> ppr ty)+             2 (text "has kind:" <+> ppr sk)+        ; return ty' }++checkTyCon :: TyCon -> LintM ()+checkTyCon tc+  = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc)++-------------------+lintTypeAndSubst :: InType -> LintM OutType+lintTypeAndSubst ty = do { lintType ty; substTyM ty }+           -- In GHCi we may lint an expression with a free+           -- type variable.  Then it won't be in the+           -- substitution, but it should be in scope++lintType :: InType -> LintM ()+-- See Note [Linting types and coercions]+--+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintType (TyVarTy tv)+  | not (isTyVar tv)+  = failWithL (mkBadTyVarMsg tv)++  | otherwise+  = do { _ <- lintVarOcc tv+       ; return () }++lintType ty@(AppTy t1 t2)+  | TyConApp {} <- t1+  = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty+  | otherwise+  = do { let (fun_ty, arg_tys) = collect t1 [t2]+       ; lintType fun_ty+       ; fun_kind <- substTyM (typeKind fun_ty)+       ; lint_ty_app ty fun_kind arg_tys }+  where+    collect (AppTy f a) as = collect f (a:as)+    collect fun         as = (fun, as)++lintType ty@(TyConApp tc tys)+  | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc+  = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags+       ; lintTySynFamApp report_unsat ty tc tys }++  | Just {} <- tyConAppFunTy_maybe tc tys+    -- We should never see a saturated application of funTyCon; such+    -- applications should be represented with the FunTy constructor.+    -- See Note [Linting function types]+  = failWithL (hang (text "Saturated application of" <+> quotes (ppr tc)) 2 (ppr ty))++  | otherwise  -- Data types, data families, primitive types+  = do { checkTyCon tc+       ; lint_ty_app ty (tyConKind tc) tys }++-- arrows can related *unlifted* kinds, so this has to be separate from+-- a dependent forall.+lintType ty@(FunTy af tw t1 t2)+  = do { lintType t1+       ; lintType t2+       ; lintType tw+       ; lintArrow (text "type or kind" <+> quotes (ppr ty)) af t1 t2 tw }++lintType ty@(ForAllTy {})+  = go [] ty+  where+    go :: [OutTyCoVar] -> InType -> LintM ()+    -- Loop, collecting the forall-binders+    go tcvs ty@(ForAllTy (Bndr tcv _) body_ty)+      | not (isTyCoVar tcv)+      = failWithL (text "Non-TyVar or Non-CoVar bound in type:" <+> ppr ty)++      | otherwise+      = lintTyCoBndr tcv $ \tcv' ->+        do { -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]+             -- Suspicious because it works on InTyCoVar; c.f. ForAllCo+             when (isCoVar tcv) $+             lintL (anyFreeVarsOfType (== tcv) body_ty) $+             text "Covar does not occur in the body:" <+> (ppr tcv $$ ppr body_ty)++           ; go (tcv' : tcvs) body_ty }++    go tcvs body_ty+      = do { lintType body_ty+           ; lintForAllBody tcvs body_ty }++lintType (CastTy ty co)+  = do { lintType ty+       ; ty_kind <- substTyM (typeKind ty)+       ; co_lk <- lintStarCoercion co+       ; ensureEqTys ty_kind co_lk (mkCastTyErr ty co ty_kind co_lk) }++lintType (LitTy l)       = lintTyLit l+lintType (CoercionTy co) = lintCoercion co++-----------------+lintForAllBody :: [OutTyCoVar] -> InType -> LintM ()+-- Do the checks for the body of a forall-type+lintForAllBody tcvs body_ty+  = do { -- For type variables, check for skolem escape+         -- See Note [Phantom type variables in kinds] in GHC.Core.Type+         -- The kind of (forall cv. th) is liftedTypeKind, so no+         -- need to check for skolem-escape in the CoVar case+         body_kind <- substTyM (typeKind body_ty)+       ; case occCheckExpand tcvs body_kind of+           Just {} -> return ()+           Nothing -> failWithL $+                      hang (text "Variable escape in forall:")+                         2 (vcat [ text "tycovars (reversed):" <+> ppr tcvs+                                 , text "type:" <+> ppr body_ty+                                 , text "kind:" <+> ppr body_kind ])+       ; checkValueType body_kind (text "the body of forall:" <+> ppr body_ty) }++-----------------+lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM ()+-- The TyCon is a type synonym or a type family (not a data family)+-- See Note [Linting type synonym applications]+-- c.f. GHC.Tc.Validity.check_syn_tc_app+lintTySynFamApp report_unsat ty tc tys+  | report_unsat   -- Report unsaturated only if report_unsat is on+  , tys `lengthLessThan` tyConArity tc+  = failWithL (hang (text "Un-saturated type application") 2 (ppr ty))++  -- Deal with type synonyms+  | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc tys+  , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys'+  = do { when report_unsat $ do { _ <- lintType expanded_ty+                                ; return () }++       ; -- Kind-check the argument types, but without reporting+         -- un-saturated type families/synonyms+       ; setReportUnsat False $+         lint_ty_app ty (tyConKind tc) tys }++  -- Otherwise this must be a type family+  | otherwise+  = lint_ty_app ty (tyConKind tc) tys++-----------------+-- Confirms that a kind is really TYPE r or Constraint+checkValueType :: OutKind -> SDoc -> LintM ()+checkValueType kind doc+  = lintL (isTYPEorCONSTRAINT kind)+          (text "Non-Type-like kind when Type-like expected:" <+> ppr kind $$+           text "when checking" <+> doc)++-----------------+lintArrow :: SDoc -> FunTyFlag -> InType -> InType -> InType -> LintM ()+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintArrow what af t1 t2 tw  -- Eg lintArrow "type or kind `blah'" k1 k2 kw+                            -- or lintArrow "coercion `blah'" k1 k2 kw+  = do { k1 <- substTyM (typeKind t1)+       ; k2 <- substTyM (typeKind t2)+       ; kw <- substTyM (typeKind tw)+       ; unless (isTYPEorCONSTRAINT k1) (report (text "argument")     t1 k1)+       ; unless (isTYPEorCONSTRAINT k2) (report (text "result")       t2 k2)+       ; unless (isMultiplicityTy kw)   (report (text "multiplicity") tw kw)++       ; let real_af = chooseFunTyFlag t1 t2+       ; unless (real_af == af) $ addErrL $+         hang (text "Bad FunTyFlag")+            2 (vcat [ text "FunTyFlag =" <+> ppr af+                    , text "Computed FunTyFlag =" <+> ppr real_af+                    , text "in" <+> what ]) }+  where+    report ar t k = addErrL (hang (text "Ill-kinded" <+> ar)+                                2 (vcat [ ppr t <+> dcolon <+> ppr k+                                        , text "in" <+> what ]))++-----------------+lintTyLit :: TyLit -> LintM ()+lintTyLit (NumTyLit n)+  | n >= 0    = return ()+  | otherwise = failWithL msg+    where msg = text "Negative type literal:" <+> integer n+lintTyLit (StrTyLit _) = return ()+lintTyLit (CharTyLit _) = return ()++-----------------+lint_ty_app :: InType -> OutKind -> [InType] -> LintM ()+lint_ty_app ty = lint_tyco_app (text "type" <+> quotes (ppr ty))++lint_co_app :: HasDebugCallStack => Coercion -> OutKind -> [InType] -> LintM ()+lint_co_app co = lint_tyco_app (text "coercion" <+> quotes (ppr co))++lint_tyco_app :: SDoc -> OutKind -> [InType] -> LintM ()+lint_tyco_app msg fun_kind arg_tys+    -- See Note [Avoiding compiler perf traps when constructing error messages.]+  = do { _ <- lintApp msg (\ty     -> do { lintType ty; substTyM ty })+                            (\ty _ _ -> do { lintType ty; ki <- substTyM (typeKind ty); return (ki,()) })+                            fun_kind arg_tys ()+       ; return () }++----------------+lintApp :: forall in_a acc. Outputable in_a =>+             SDoc+          -> (in_a -> LintM OutType)                        -- Lint the thing and return its value+          -> (in_a -> Mult -> acc -> LintM (OutKind, acc))  -- Lint the thing and return its type+          -> OutType+          -> [in_a]                               -- The arguments, always "In" things+          -> acc                                  -- Used (only) for UsageEnv in /term/ applications+          -> LintM (OutType,acc)+-- lintApp is a performance-critical function, which deals with multiple+-- applications such as  (/\a./\b./\c. expr) @ta @tb @tc+-- When returning the type of this expression we want to avoid substituting a:=ta,+-- and /then/ substituting b:=tb, etc.  That's quadratic, and can be a huge+-- perf hole.  So we gather all the arguments [in_a], and then gather the+-- substitution incrementally in the `go` loop.+--+-- lintApp is used:+--    * for term applications (lintCoreArgs)+--    * for type applications (lint_ty_app)+--    * for coercion application (lint_co_app)+-- To deal with these cases `lintApp` has two higher order arguments;+-- but we specialise it for each call site (by inlining)+{-# INLINE lintApp #-}    -- INLINE: very few call sites;+                          -- not recursive; specialised at its call sites++lintApp msg lint_forall_arg lint_arrow_arg !orig_fun_ty all_args acc+    = do { !in_scope <- getInScope+         -- We need the in_scope set to satisfy the invariant in+         -- Note [The substitution invariant] in GHC.Core.TyCo.Subst+         -- Forcing the in scope set eagerly here reduces allocations by up to 4%.++         ; let init_subst = mkEmptySubst in_scope++               go :: Subst -> OutType -> acc -> [in_a] -> LintM (OutType, acc)+                     -- The Subst applies (only) to the fun_ty+                     -- c.f. GHC.Core.Type.piResultTys, which has a similar loop++               go subst fun_ty acc []+                 = return (substTy subst fun_ty, acc)++               go subst (ForAllTy (Bndr tv _vis) body_ty) acc (arg:args)+                 = do { arg' <- lint_forall_arg arg+                      ; let tv_kind = substTy subst (varType tv)+                            karg'   = typeKind arg'+                            subst'  = extendTCvSubst subst tv arg'+                      ; ensureEqTys karg' tv_kind $+                        lint_app_fail_msg msg orig_fun_ty all_args+                            (hang (text "Forall:" <+> (ppr tv $$ ppr tv_kind))+                                2 (ppr arg' <+> dcolon <+> ppr karg'))+                      ; go subst' body_ty acc args }++               go subst fun_ty@(FunTy _ mult exp_arg_ty res_ty) acc (arg:args)+                 = do { (arg_ty, acc') <- lint_arrow_arg arg (substTy subst mult) acc+                      ; ensureEqTys (substTy subst exp_arg_ty) arg_ty $+                        lint_app_fail_msg msg orig_fun_ty all_args+                            (hang (text "Fun:" <+> ppr fun_ty)+                                2 (vcat [ text "exp_arg_ty:" <+> ppr exp_arg_ty+                                        , text "arg:" <+> ppr arg <+> dcolon <+> ppr arg_ty ]))+                      ; go subst res_ty acc' args }++               go subst fun_ty acc args+                 | Just fun_ty' <- coreView fun_ty+                 = go subst fun_ty' acc args++                 | not (isEmptyTCvSubst subst)  -- See Note [Care with kind instantiation]+                 = go init_subst (substTy subst fun_ty) acc args++                 | otherwise+                 = failWithL (lint_app_fail_msg msg orig_fun_ty all_args+                                  (text "Not a fun:" <+> (ppr fun_ty $$ ppr args)))++         ; go init_subst orig_fun_ty acc all_args }++-- 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 a2) => SDoc -> OutType -> a2 -> SDoc -> SDoc+lint_app_fail_msg msg kfn arg_tys extra+  = vcat [ hang (text "Application error in") 2 msg+         , nest 2 (text "Function type =" <+> ppr kfn)+         , nest 2 (text "Args =" <+> ppr arg_tys)+         , extra ]++{- *********************************************************************+*                                                                      *+        Linting rules+*                                                                      *+********************************************************************* -}++lintCoreRule :: OutVar -> OutType -> CoreRule -> LintM ()+lintCoreRule _ _ (BuiltinRule {})+  = return ()  -- Don't bother++lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs+                                   , ru_args = args, ru_rhs = rhs })+  = lintBinders LambdaBind bndrs $ \ _ ->+    do { (lhs_ty, _) <- lintCoreArgs (fun_ty, zeroUE) args+       ; (rhs_ty, _) <- case idJoinPointHood fun of+                     JoinPoint join_arity+                       -> do { checkL (args `lengthIs` join_arity) $+                                mkBadJoinPointRuleMsg fun join_arity rule+                               -- See Note [Rules for join points]+                             ; lintCoreExpr rhs }+                     _ -> markAllJoinsBad $ lintCoreExpr rhs+       ; ensureEqTys lhs_ty rhs_ty $+         (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty+                            , text "rhs type:" <+> ppr rhs_ty+                            , text "fun_ty:" <+> ppr fun_ty ])+       ; let bad_bndrs = filter is_bad_bndr bndrs++       ; checkL (null bad_bndrs)+                (rule_doc <+> text "unbound" <+> ppr bad_bndrs)+            -- See Note [Linting rules]+    }+  where+    rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon++    lhs_fvs = exprsFreeVars args+    rhs_fvs = exprFreeVars rhs++    is_bad_bndr :: Var -> Bool+    -- See Note [Unbound RULE binders] in GHC.Core.Rules+    is_bad_bndr bndr = not (bndr `elemVarSet` lhs_fvs)+                    && bndr `elemVarSet` rhs_fvs+                    && isNothing (isReflCoVar_maybe bndr)+++{- Note [Linting rules]+~~~~~~~~~~~~~~~~~~~~~~~+It's very bad if simplifying a rule means that one of the template+variables (ru_bndrs) that /is/ mentioned on the RHS becomes+not-mentioned in the LHS (ru_args).  How can that happen?  Well, in #10602,+SpecConstr stupidly constructed a rule like++  forall x,c1,c2.+     f (x |> c1 |> c2) = ....++But simplExpr collapses those coercions into one.  (Indeed in #10602,+it collapsed to the identity and was removed altogether.)++We don't have a great story for what to do here, but at least+this check will nail it.++NB (#11643): it's possible that a variable listed in the+binders becomes not-mentioned on both LHS and RHS.  Here's a silly+example:+   RULE forall x y. f (g x y) = g (x+1) (y-1)+And suppose worker/wrapper decides that 'x' is Absent.  Then+we'll end up with+   RULE forall x y. f ($gw y) = $gw (x+1)+This seems sufficiently obscure that there isn't enough payoff to+try to trim the forall'd binder list.++Note [Rules for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A join point cannot be partially applied. However, the left-hand side of a rule+for a join point is effectively a *pattern*, not a piece of code, so there's an+argument to be made for allowing a situation like this:++  join $sj :: Int -> Int -> String+       $sj n m = ...+       j :: forall a. Eq a => a -> a -> String+       {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-}+       j @a $dEq x y = ...++Applying this rule can't turn a well-typed program into an ill-typed one, so+conceivably we could allow it. But we can always eta-expand such an+"undersaturated" rule (see 'GHC.Core.Opt.Arity.etaExpandToJoinPointRule'), and in fact+the simplifier would have to in order to deal with the RHS. So we take a+conservative view and don't allow undersaturated rules for join points. See+Note [Join points and unfoldings/rules] in "GHC.Core.Opt.OccurAnal" for further discussion.+-}++{-+************************************************************************+*                                                                      *+         Linting coercions+*                                                                      *+************************************************************************+-}++{- Note [Asymptotic efficiency]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When linting coercions (and types actually) we return a linted+(substituted) coercion.  Then we often have to take the coercionKind of+that returned coercion. If we get long chains, that can be asymptotically+inefficient, notably in+* TransCo+* InstCo+* SelCo (cf #9233)+* LRCo++But the code is simple.  And this is only Lint.  Let's wait to see if+the bad perf bites us in practice.++A solution would be to return the kind and role of the coercion,+as well as the linted coercion.  Or perhaps even *only* the kind and role,+which is what used to happen.   But that proved tricky and error prone+(#17923), so now we return the coercion.+-}+++-- lintStarCoercion lints a coercion, confirming that its lh kind and+-- its rh kind are both *; also ensures that the role is Nominal+-- Returns the lh kind+lintStarCoercion :: InCoercion -> LintM OutType+lintStarCoercion g+  = do { lintCoercion g+       ; Pair t1 t2 <- substCoKindM g+       ; checkValueType (typeKind t1) (text "the kind of the left type in" <+> ppr g)+       ; checkValueType (typeKind t2) (text "the kind of the right type in" <+> ppr g)+       ; lintRole g Nominal (coercionRole g)+       ; return t1 }++substCoKindM :: InCoercion -> LintM (Pair OutType)+substCoKindM co+  = do { let !(Pair lk rk) = coercionKind co+       ; lk' <- substTyM lk+       ; rk' <- substTyM rk+       ; return (Pair lk' rk') }++lintCoercion :: HasDebugCallStack => InCoercion -> LintM ()+-- See Note [Linting types and coercions]+--+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]++lintCoercion (CoVarCo cv)+  | not (isCoVar cv)+  = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv)+                  2 (text "With offending type:" <+> ppr (varType cv)))++  | otherwise  -- C.f. lintType (TyVarTy tv), which has better docs+  = do { _ <- lintVarOcc cv; return () }++lintCoercion (Refl ty)          = lintType ty+lintCoercion (GRefl _r ty MRefl) = lintType ty++lintCoercion (GRefl _r ty (MCo co))+  = do { lintType ty+       ; lintCoercion co+       ; tk <- substTyM (typeKind ty)+       ; tl <- substTyM (coercionLKind co)+       ; ensureEqTys tk tl $+         hang (text "GRefl coercion kind mis-match:" <+> ppr co)+            2 (vcat [ppr ty, ppr tk, ppr tl])+       ; lintRole co Nominal (coercionRole co) }++lintCoercion co@(TyConAppCo r tc cos)+  | Just {} <- tyConAppFunCo_maybe r tc cos+  = failWithL (hang (text "Saturated application of" <+> quotes (ppr tc))+                  2 (ppr co))+    -- All saturated TyConAppCos should be FunCos++  | Just {} <- synTyConDefn_maybe tc+  = failWithL (text "Synonym in TyConAppCo:" <+> ppr co)++  | otherwise+  = do { checkTyCon tc+       ; mapM_ lintCoercion cos+       ; let tc_kind = tyConKind tc+       ; lint_co_app co tc_kind (map coercionLKind cos)+       ; lint_co_app co tc_kind (map coercionRKind cos)+       ; zipWithM_ (lintRole co) (tyConRoleListX r tc) (map coercionRole cos) }+++lintCoercion co@(AppCo co1 co2)+  | TyConAppCo {} <- co1+  = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co)+  | Just (TyConApp {}, _) <- isReflCo_maybe co1+  = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co)+  | otherwise+  = do { lintCoercion co1+       ; lintCoercion co2+       ; let !(Pair lt1 rt1) = coercionKind co1+       ; lk1 <- substTyM (typeKind lt1)+       ; rk1 <- substTyM (typeKind rt1)+       ; lint_co_app co lk1 [coercionLKind co2]+       ; lint_co_app co rk1 [coercionRKind co2]++       ; let r2 = coercionRole co2+       ; if coercionRole co1 == Phantom+         then lintL (r2 == Phantom || r2 == Nominal)+                     (text "Second argument in AppCo cannot be R:" $$+                      ppr co)+         else lintRole co Nominal r2 }++----------+lintCoercion co@(ForAllCo {})+-- See Note [ForAllCo] in GHC.Core.TyCo.Rep for the typing rule for ForAllCo+  = do { _ <- go [] co; return () }+  where+    go :: [OutTyCoVar]   -- Binders in reverse order+       -> InCoercion -> LintM Role+    go tcvs co@(ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR+                         , fco_kind = kind_co, fco_body = body_co })+      | not (isTyCoVar tcv)+      = failWithL (text "Non tyco binder in ForAllCo:" <+> ppr co)++      | otherwise+      = do { lk <- lintStarCoercion kind_co+           ; lintTyCoBndr tcv $ \tcv' ->+        do { ensureEqTys (varType tcv') lk $+             text "Kind mis-match in ForallCo" <+> ppr co++           -- I'm not very sure about this part, because it traverses body_co+           -- but at least it's on a cold path (a ForallCo for a CoVar)+           -- Also it works on InTyCoVar and InCoercion, which is suspect+           ; when (isCoVar tcv) $+             do { lintL (visL == coreTyLamForAllTyFlag && visR == coreTyLamForAllTyFlag) $+                  text "Invalid visibility flags in CoVar ForAllCo" <+> ppr co+                  -- See (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep+                ; lintL (almostDevoidCoVarOfCo tcv body_co) $+                  text "Covar can only appear in Refl and GRefl: " <+> ppr co }+                  -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep++           ; role <- go (tcv':tcvs) body_co++           ; when (role == Nominal) $+             lintL (visL `eqForAllVis` visR) $+             text "Nominal ForAllCo has mismatched visibilities: " <+> ppr co++           ; return role } }++    go tcvs body_co+      = do { lintCoercion body_co++           -- Need to check that+           --    (forall (tcv:k1). lty) and+           --    (forall (tcv:k2). rty[(tcv:k2) |> sym kind_co/tcv])+           -- are both well formed, including the skolem escape check.+           -- Easiest way is to call lintForAllBody for each+           ; let Pair lty rty = coercionKind body_co+           ; lintForAllBody tcvs lty+           ; lintForAllBody tcvs rty++           ; return (coercionRole body_co) }+++lintCoercion (FunCo { fco_role = r, fco_afl = afl, fco_afr = afr+                    , fco_mult = cow, fco_arg = co1, fco_res = co2 })+  = do { lintCoercion co1+       ; lintCoercion co2+       ; lintCoercion cow+       ; let Pair lt1 rt1 = coercionKind co1+             Pair lt2 rt2 = coercionKind co2+             Pair ltw rtw = coercionKind cow+       ; lintArrow (bad_co_msg "arrowl") afl lt1 lt2 ltw+       ; lintArrow (bad_co_msg "arrowr") afr rt1 rt2 rtw+       ; lintRole co1 r (coercionRole co1)+       ; lintRole co2 r (coercionRole co2)+       ; let expected_mult_role = case r of+                                    Phantom -> Phantom+                                    _ -> Nominal+       ; lintRole cow expected_mult_role (coercionRole cow) }+  where+    bad_co_msg s = hang (text "Bad coercion" <+> parens (text s))+                      2 (vcat [ text "afl:" <+> ppr afl+                              , text "afr:" <+> ppr afr+                              , text "arg_co:" <+> ppr co1+                              , text "res_co:" <+> ppr co2 ])++-- See Note [Bad unsafe coercion]+lintCoercion co@(UnivCo { uco_role = r, uco_prov = prov+                        , uco_lty = ty1, uco_rty = ty2, uco_deps = deps })+  = do { -- Check the role.  PhantomProv must have Phantom role, otherwise any role is fine+         case prov of+            PhantomProv -> lintRole co Phantom r+            _           -> return ()++       -- Check the to and from types+       ; lintType ty1+       ; lintType ty2+       ; tk1 <- substTyM (typeKind ty1)+       ; tk2 <- substTyM (typeKind ty2)++       ; when (r /= Phantom && isTYPEorCONSTRAINT tk1 && isTYPEorCONSTRAINT tk2)+              (checkTypes ty1 ty2)++       -- Check the coercions on which this UnivCo depends+       ; mapM_ lintCoercion deps }+   where+     report s = hang (text $ "Unsafe coercion: " ++ s)+                     2 (vcat [ text "From:" <+> ppr ty1+                             , text "  To:" <+> ppr ty2])+     isUnBoxed :: PrimRep -> Bool+     isUnBoxed = not . isGcPtrRep++       -- see #9122 for discussion of these checks+     checkTypes t1 t2+       = do { checkWarnL fixed_rep_1+                         (report "left-hand type does not have a fixed runtime representation")+            ; checkWarnL fixed_rep_2+                         (report "right-hand type does not have a fixed runtime representation")+            ; when (fixed_rep_1 && fixed_rep_2) $+              do { checkWarnL (reps1 `equalLength` reps2)+                              (report "between values with different # of reps")+                 ; zipWithM_ validateCoercion reps1 reps2 }}+       where+         fixed_rep_1 = typeHasFixedRuntimeRep t1+         fixed_rep_2 = typeHasFixedRuntimeRep t2++         -- don't look at these unless lev_poly1/2 are False+         -- Otherwise, we get #13458+         reps1 = typePrimRep t1+         reps2 = typePrimRep t2++     validateCoercion :: PrimRep -> PrimRep -> LintM ()+     validateCoercion rep1 rep2+       = do { platform <- getPlatform+            ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2)+                         (report "between unboxed and boxed value")+            ; checkWarnL (TyCon.primRepSizeB platform rep1+                           == TyCon.primRepSizeB platform rep2)+                         (report "between unboxed values of different size")+            ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1)+                                   (TyCon.primRepIsFloat rep2)+            ; case fl of+                Nothing    -> addWarnL (report "between vector types")+                Just False -> addWarnL (report "between float and integral values")+                _          -> return ()+            }++lintCoercion (SymCo co) = lintCoercion co++lintCoercion co@(TransCo co1 co2)+  = do { lintCoercion co1+       ; lintCoercion co2+       ; rk1 <- substTyM (coercionRKind co1)+       ; lk2 <- substTyM (coercionLKind co2)+       ; ensureEqTys rk1 lk2+               (hang (text "Trans coercion mis-match:" <+> ppr co)+                   2 (vcat [ppr (coercionKind co1), ppr (coercionKind co2)]))+       ; lintRole co (coercionRole co1) (coercionRole co2) }++lintCoercion the_co@(SelCo cs co)+  = do { lintCoercion co+       ; Pair s t <- substCoKindM co++       ; if -- forall (both TyVar and CoVar)+            | Just _ <- splitForAllTyCoVar_maybe s+            , Just _ <- splitForAllTyCoVar_maybe t+            , SelForAll <- cs+            ,   (isForAllTy_ty s && isForAllTy_ty t)+             || (isForAllTy_co s && isForAllTy_co t)+            -> return ()++            -- function+            | isFunTy s+            , isFunTy t+            , SelFun {} <- cs+            -> return ()++            -- TyCon+            | Just (tc_s, tys_s) <- splitTyConApp_maybe s+            , Just (tc_t, tys_t) <- splitTyConApp_maybe t+            , tc_s == tc_t+            , SelTyCon n r0 <- cs+            , let co_role = coercionRole co+            , isInjectiveTyCon tc_s co_role+                -- see Note [SelCo and newtypes] in GHC.Core.TyCo.Rep+            , tys_s `equalLength` tys_t+            , tys_s `lengthExceeds` n+            -> do { lintRole the_co (tyConRole co_role tc_s n) r0+                  ; return () }++            | otherwise+            -> failWithL (hang (text "Bad SelCo:")+                             2 (ppr the_co $$ ppr s $$ ppr t)) }++lintCoercion the_co@(LRCo _lr co)+  = do { lintCoercion co+       ; Pair s t <- substCoKindM co+       ; lintRole co Nominal (coercionRole co)+       ; case (splitAppTy_maybe s, splitAppTy_maybe t) of+           (Just {}, Just {}) -> return ()+           _ -> failWithL (hang (text "Bad LRCo:")+                              2 (ppr the_co $$ ppr s $$ ppr t)) }+++lintCoercion orig_co@(InstCo co arg)+  = go co [arg]+  where+    go (InstCo co arg) args = do { lintCoercion arg; go co (arg:args) }+    go co              args = do { lintCoercion co+                                 ; let Pair lty rty = coercionKind co+                                 ; lty' <- substTyM lty+                                 ; rty' <- substTyM rty+                                 ; in_scope <- getInScope+                                 ; let subst = mkEmptySubst in_scope+                                 ; go_args (subst, lty') (subst,rty') args }++    -------------+    go_args :: (Subst, OutType) -> (Subst,OutType) -> [InCoercion]+           -> LintM ()+    go_args _ _ []+      = return ()+    go_args lty rty (arg:args)+      = do { (lty1, rty1)  <- go_arg lty rty arg+           ; go_args lty1 rty1 args }++    -------------+    go_arg :: (Subst, OutType) -> (Subst,OutType) -> InCoercion+           -> LintM ((Subst,OutType), (Subst,OutType))+    go_arg (lsubst,lty) (rsubst,rty) arg+      = do { lintRole arg Nominal (coercionRole arg)+           ; Pair arg_lty arg_rty <- substCoKindM arg++           ; case (splitForAllTyCoVar_maybe lty, splitForAllTyCoVar_maybe rty) of+              -- forall over tvar+                (Just (ltv,lty1), Just (rtv,rty1))+                  | typeKind arg_lty `eqType` substTy lsubst (tyVarKind ltv)+                  , typeKind arg_rty `eqType` substTy rsubst (tyVarKind rtv)+                  -> return ( (extendTCvSubst lsubst ltv arg_lty, lty1)+                            , (extendTCvSubst rsubst rtv arg_rty, rty1) )+                  | otherwise+                  -> failWithL (hang (text "Kind mis-match in inst coercion")+                                   2 (vcat [ text "arg"  <+> ppr arg+                                           , text "lty"  <+> ppr lty <+> dcolon <+> ppr (typeKind lty)+                                           , text "rty"  <+> ppr rty <+> dcolon <+> ppr (typeKind rty)+                                           , text "arg_lty" <+> ppr arg_lty <+> dcolon <+> ppr (typeKind arg_lty)+                                           , text "arg_rty" <+> ppr arg_rty <+> dcolon <+> ppr (typeKind arg_rty)+                                           , text "ltv" <+> ppr ltv <+> dcolon <+> ppr (tyVarKind ltv)+                                           , text "rtv" <+> ppr rtv <+> dcolon <+> ppr (tyVarKind rtv) ]))++                _ -> failWithL (text "Bad argument of inst" <+> ppr orig_co) }++lintCoercion this_co@(AxiomCo ax cos)+  = do { mapM_ lintCoercion cos+       ; lint_roles 0 (coAxiomRuleArgRoles ax) cos+       ; prs <- mapM substCoKindM cos+       ; lint_ax ax prs }++  where+    lint_ax :: CoAxiomRule -> [Pair OutType] -> LintM ()+    lint_ax (BuiltInFamRew  bif) prs+      = checkL (isJust (bifrw_proves bif prs))  bad_bif+    lint_ax (BuiltInFamInj bif) prs+      = checkL (case prs of+                  [pr] -> isJust (bifinj_proves bif pr)+                  _    -> False)+               bad_bif+    lint_ax (UnbranchedAxiom ax) prs+      = lintBranch this_co (coAxiomTyCon ax) (coAxiomSingleBranch ax) prs+    lint_ax (BranchedAxiom ax ind) prs+      = do { checkL (0 <= ind && ind < numBranches (coAxiomBranches ax))+                    (bad_ax this_co (text "index out of range"))+           ; lintBranch this_co (coAxiomTyCon ax) (coAxiomNthBranch ax ind) prs }++    bad_bif = bad_ax this_co (text "Proves returns Nothing")++    err :: forall a. String -> [SDoc] -> LintM a+    err m xs  = failWithL $+                hang (text m) 2 $ vcat (text "Rule:" <+> ppr ax : xs)++    lint_roles n (e : es) (co:cos)+      | e == coercionRole co+      = lint_roles (n+1) es cos+      | otherwise = err "Argument roles mismatch"+                        [ text "In argument:" <+> int (n+1)+                        , text "Expected:" <+> ppr e+                        , text "Found:" <+> ppr (coercionRole co) ]+    lint_roles _ [] []  = return ()+    lint_roles n [] rs  = err "Too many coercion arguments"+                            [ text "Expected:" <+> int n+                            , text "Provided:" <+> int (n + length rs) ]++    lint_roles n es []  = err "Not enough coercion arguments"+                            [ text "Expected:" <+> int (n + length es)+                            , text "Provided:" <+> int n ]++lintCoercion (KindCo co) = lintCoercion co++lintCoercion (SubCo co)+  = do { lintCoercion co+       ; lintRole co Nominal (coercionRole co) }++lintCoercion (HoleCo h)+  = failWithL (text "Unfilled coercion hole:" <+> ppr h)++{-+Note [Conflict checking for axiom applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following type family and axiom:++type family Equal (a :: k) (b :: k) :: Bool+type instance where+  Equal a a = True+  Equal a b = False+--+Equal :: forall k::*. k -> k -> Bool+axEqual :: { forall k::*. forall a::k. Equal k a a ~ True+           ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False }++The coercion (axEqual[1] <*> <Int> <Int) is ill-typed, and Lint should reject it.+(Recall that the index is 0-based, so this is the second branch of the axiom.)+The problem is that, on the surface, it seems that++  (axEqual[1] <*> <Int> <Int>) :: (Equal * Int Int ~ False)++and that all is OK. But, all is not OK: we want to use the first branch of the+axiom in this case, not the second. The problem is that the parameters of the+first branch can unify with the supplied coercions, thus meaning that the first+branch should be taken. See also Note [Apartness] in "GHC.Core.FamInstEnv".++For more details, see the section "Branched axiom conflict checking" in+docs/core-spec, which defines the corresponding no_conflict function used by the+Co_AxiomInstCo rule in the section "Coercion typing".+-}++-- | Check to make sure that an axiom application is internally consistent.+-- Returns the conflicting branch, if it exists+-- Note [Conflict checking for axiom applications]+lintBranch :: Coercion -> TyCon-> CoAxBranch -> [Pair Type] -> LintM ()+-- defined here to avoid dependencies in GHC.Core.Coercion+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+lintBranch this_co fam_tc branch arg_kinds+  | CoAxBranch { cab_tvs = ktvs, cab_cvs = cvs } <- branch+  = do { checkL (arg_kinds `equalLength` (ktvs ++ cvs)) $+                (bad_ax this_co (text "lengths"))++       ; subst <- getSubst+       ; let empty_subst = zapSubst subst+       ; _ <- foldlM check_ki (empty_subst, empty_subst)+                              (zip (ktvs ++ cvs) arg_kinds)++       ; case check_no_conflict target incomps of+            Nothing -> return ()+            Just bad_branch -> failWithL $ bad_ax this_co $+                               text "inconsistent with" <+>+                                 pprCoAxBranch fam_tc bad_branch }+  where+    check_ki (subst_l, subst_r) (ktv, Pair s' t')+      = do { let sk' = typeKind s'+                 tk' = typeKind t'+           ; let ktv_kind_l = substTy subst_l (tyVarKind ktv)+                 ktv_kind_r = substTy subst_r (tyVarKind ktv)+           ; checkL (sk' `eqType` ktv_kind_l)+                    (bad_ax this_co (text "check_ki1" <+> vcat [ ppr this_co, ppr sk', ppr ktv, ppr ktv_kind_l ] ))+           ; checkL (tk' `eqType` ktv_kind_r)+                    (bad_ax this_co (text "check_ki2" <+> vcat [ ppr this_co, ppr tk', ppr ktv, ppr ktv_kind_r ] ))+           ; return (extendTCvSubst subst_l ktv s',+                     extendTCvSubst subst_r ktv t') }++    tvs          = coAxBranchTyVars branch+    cvs          = coAxBranchCoVars branch+    incomps      = coAxBranchIncomps branch+    (tys, cotys) = splitAtList tvs (map pFst arg_kinds)+    co_args      = map stripCoercionTy cotys+    subst        = zipTvSubst tvs tys `composeTCvSubst`+                   zipCvSubst cvs co_args+    target   = Type.substTys subst (coAxBranchLHS branch)++    check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch+    check_no_conflict _    [] = Nothing+    check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest)+         -- See Note [Apartness] in GHC.Core.FamInstEnv+      | SurelyApart <- tcUnifyTysFG alwaysBindFam alwaysBindTv flat lhs_incomp+      = check_no_conflict flat rest+      | otherwise+      = Just b++bad_ax :: Coercion -> SDoc -> SDoc+bad_ax this_co what+    = hang (text "Bad axiom application" <+> parens what) 2 (ppr this_co)+++{-+************************************************************************+*                                                                      *+              Axioms+*                                                                      *+************************************************************************+-}++lintAxioms :: Logger+           -> LintConfig+           -> SDoc -- ^ The source of the linted axioms+           -> [CoAxiom Branched]+           -> IO ()+lintAxioms logger cfg what axioms =+  displayLintResults logger True what (vcat $ map pprCoAxiom axioms) $+  initL cfg $+  do { mapM_ lint_axiom axioms+     ; let axiom_groups = groupWith coAxiomTyCon axioms+     ; mapM_ lint_axiom_group axiom_groups }++lint_axiom :: CoAxiom Branched -> LintM ()+lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches+                       , co_ax_role = ax_role })+  = addLoc (InAxiom ax) $+    do { mapM_ (lint_branch tc) branch_list+       ; extra_checks }+  where+    branch_list = fromBranches branches++    extra_checks+      | isNewTyCon tc+      = do { CoAxBranch { cab_tvs     = ax_tvs+                        , cab_eta_tvs = eta_tvs+                        , cab_cvs     = cvs+                        , cab_roles   = roles+                        , cab_lhs     = lhs_tys }+              <- case branch_list of+               [branch] -> return branch+               _        -> failWithL (text "multi-branch axiom with newtype")++           -- The LHS of the axiom is (N lhs_tys)+           -- We expect it to be      (N ax_tvs)+           ; lintL (mkTyVarTys ax_tvs `eqTypes` lhs_tys)+                   (text "Newtype axiom LHS does not match newtype definition")+           ; lintL (null cvs)+                   (text "Newtype axiom binds coercion variables")+           ; lintL (null eta_tvs)  -- See Note [Eta reduction for data families]+                                   -- which is not about newtype axioms+                   (text "Newtype axiom has eta-tvs")+           ; lintL (ax_role == Representational)+                   (text "Newtype axiom role not representational")+           ; lintL (roles `equalLength` ax_tvs)+                   (text "Newtype axiom roles list is the wrong length." $$+                    text "roles:" <+> sep (map ppr roles))+           ; lintL (roles == takeList roles (tyConRoles tc))+                   (vcat [ text "Newtype axiom roles do not match newtype tycon's."+                         , text "axiom roles:" <+> sep (map ppr roles)+                         , text "tycon roles:" <+> sep (map ppr (tyConRoles tc)) ])+           }++      | isFamilyTyCon tc+      = do { if | isTypeFamilyTyCon tc+                  -> lintL (ax_role == Nominal)+                           (text "type family axiom is not nominal")++                | isDataFamilyTyCon tc+                  -> lintL (ax_role == Representational)+                           (text "data family axiom is not representational")++                | otherwise+                  -> addErrL (text "A family TyCon is neither a type family nor a data family:" <+> ppr tc)++           ; mapM_ (lint_family_branch tc) branch_list }++      | otherwise+      = addErrL (text "Axiom tycon is neither a newtype nor a family.")++lint_branch :: TyCon -> CoAxBranch -> LintM ()+lint_branch ax_tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                              , cab_lhs = lhs_args, cab_rhs = rhs })+  = lintBinders LambdaBind (tvs ++ cvs) $ \_ ->+    do { let lhs = mkTyConApp ax_tc lhs_args+       ; lintType lhs+       ; lintType rhs+       ; lhs_kind <- substTyM (typeKind lhs)+       ; rhs_kind <- substTyM (typeKind rhs)+       ; lintL (not (lhs_kind `typesAreApart` rhs_kind)) $+         hang (text "Inhomogeneous axiom")+            2 (text "lhs:" <+> ppr lhs <+> dcolon <+> ppr lhs_kind $$+               text "rhs:" <+> ppr rhs <+> dcolon <+> ppr rhs_kind) }+         -- Type and Constraint are not Apart, so this test allows+         -- the newtype axiom for a single-method class.  Indeed the+         -- whole reason Type and Constraint are not Apart is to allow+         -- such axioms!++-- these checks do not apply to newtype axioms+lint_family_branch :: TyCon -> CoAxBranch -> LintM ()+lint_family_branch fam_tc br@(CoAxBranch { cab_tvs     = tvs+                                         , cab_eta_tvs = eta_tvs+                                         , cab_cvs     = cvs+                                         , cab_roles   = roles+                                         , cab_lhs     = lhs+                                         , cab_incomps = incomps })+  = do { lintL (isDataFamilyTyCon fam_tc || null eta_tvs)+               (text "Type family axiom has eta-tvs")+       ; lintL (all (`elemVarSet` tyCoVarsOfTypes lhs) tvs)+               (text "Quantified variable in family axiom unused in LHS")+       ; lintL (all isTyFamFree lhs)+               (text "Type family application on LHS of family axiom")+       ; lintL (all (== Nominal) roles)+               (text "Non-nominal role in family axiom" $$+                text "roles:" <+> sep (map ppr roles))+       ; lintL (null cvs)+               (text "Coercion variables bound in family axiom")+       ; forM_ incomps $ \ br' ->+           lintL (not (compatibleBranches br br')) $+           hang (text "Incorrect incompatible branches:")+              2 (vcat [text "Branch:"       <+> ppr br,+                       text "Bogus incomp:" <+> ppr br']) }++lint_axiom_group :: NonEmpty (CoAxiom Branched) -> LintM ()+lint_axiom_group (_  :| []) = return ()+lint_axiom_group (ax :| axs)+  = do { lintL (isOpenFamilyTyCon tc)+               (text "Non-open-family with multiple axioms")+       ; let all_pairs = [ (ax1, ax2) | ax1 <- all_axs+                                      , ax2 <- all_axs ]+       ; mapM_ (lint_axiom_pair tc) all_pairs }+  where+    all_axs = ax : axs+    tc      = coAxiomTyCon ax++lint_axiom_pair :: TyCon -> (CoAxiom Branched, CoAxiom Branched) -> LintM ()+lint_axiom_pair tc (ax1, ax2)+  | Just br1@(CoAxBranch { cab_tvs = tvs1+                         , cab_lhs = lhs1+                         , cab_rhs = rhs1 }) <- coAxiomSingleBranch_maybe ax1+  , Just br2@(CoAxBranch { cab_tvs = tvs2+                         , cab_lhs = lhs2+                         , cab_rhs = rhs2 }) <- coAxiomSingleBranch_maybe ax2+  = lintL (compatibleBranches br1 br2) $+    vcat [ hsep [ text "Axioms", ppr ax1, text "and", ppr ax2+                , text "are incompatible" ]+         , text "tvs1 =" <+> pprTyVars tvs1+         , text "lhs1 =" <+> ppr (mkTyConApp tc lhs1)+         , text "rhs1 =" <+> ppr rhs1+         , text "tvs2 =" <+> pprTyVars tvs2+         , text "lhs2 =" <+> ppr (mkTyConApp tc lhs2)+         , text "rhs2 =" <+> ppr rhs2 ]++  | otherwise+  = addErrL (text "Open type family axiom has more than one branch: either" <+>+             ppr ax1 <+> text "or" <+> ppr ax2)++{-+************************************************************************+*                                                                      *+\subsection[lint-monad]{The Lint monad}+*                                                                      *+************************************************************************+-}++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism]+data LintEnv+  = LE { le_flags :: LintFlags       -- Linting the result of this pass+       , le_loc   :: [LintLocInfo]   -- Locations++       , le_subst :: Subst+                  -- Current substitution, for TyCoVars only.+                  -- Non-CoVar Ids don't appear in here, not even in the InScopeSet+                  -- Used for (a) cloning to avoid shadowing of TyCoVars,+                  --              so that eqType works ok+                  --          (b) substituting for let-bound tyvars, when we have+                  --              (let @a = Int -> Int in ...)++       , le_in_vars :: VarEnv (InVar, OutType)+                    -- Maps an InVar (i.e. its unique) to its binding InVar+                    --    and to its OutType+                    -- /All/ in-scope variables are here (term variables,+                    --    type variables, and coercion variables)+                    -- Used at an occurrence of the InVar++       , le_joins :: IdSet     -- Join points in scope that are valid+                               -- A subset of the InScopeSet in le_subst+                               -- See Note [Join points]++       , le_ue_aliases :: NameEnv UsageEnv+             -- See Note [Linting linearity]+             -- Assigns usage environments to the alias-like binders,+             -- as found in non-recursive lets.+             -- Domain is OutIds++       , le_platform   :: Platform         -- ^ Target platform+       , le_diagOpts   :: DiagOpts         -- ^ Target platform+       }++data LintFlags+  = LF { lf_check_global_ids           :: Bool -- See Note [Checking for global Ids]+       , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers]+       , lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs]+       , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications]+       , lf_check_linearity :: Bool -- ^ See Note [Linting linearity]+       , lf_check_fixed_rep :: Bool -- See Note [Checking for representation polymorphism]+    }++-- See Note [Checking StaticPtrs]+data StaticPtrCheck+    = AllowAnywhere+        -- ^ Allow 'makeStatic' to occur anywhere.+    | AllowAtTopLevel+        -- ^ Allow 'makeStatic' calls at the top-level only.+    | RejectEverywhere+        -- ^ Reject any 'makeStatic' occurrence.+  deriving Eq++newtype LintM a =+   LintM' { unLintM ::+            LintEnv ->+            WarnsAndErrs ->           -- Warning and error messages so far+            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%.+--+-- Warning: if you don't inline the matcher for JustUB etc, Lint becomes+-- /tremendously/ inefficient, and compiling GHC.Tc.Errors.Types (which+-- contains gigantic types) is very very slow indeed. Conclusion: make+-- sure unfoldings are expose in GHC.Data.Unboxed, and that you compile+-- Lint.hs with optimistation on.+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+top-level ones. See Note [Exported LocalIds] and #9857.++Note [Checking StaticPtrs]+~~~~~~~~~~~~~~~~~~~~~~~~~~+See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview.++Every occurrence of the function 'makeStatic' should be moved to the+top level by the FloatOut pass.  It's vital that we don't have nested+'makeStatic' occurrences after CorePrep, because we populate the Static+Pointer Table from the top-level bindings. See SimplCore Note [Grand+plan for static forms].++The linter checks that no occurrence is left behind, nested within an+expression. The check is enabled only after the FloatOut, CorePrep,+and CoreTidy passes and only if the module uses the StaticPointers+language extension. Checking more often doesn't help since the condition+doesn't hold until after the first FloatOut pass.++Note [Type substitution]+~~~~~~~~~~~~~~~~~~~~~~~~+Why do we need a type substitution?  Consider+        /\(a:*). \(x:a). /\(a:*). id a x+This is ill typed, because (renaming variables) it is really+        /\(a:*). \(x:a). /\(b:*). id b x+Hence, when checking an application, we can't naively compare x's type+(at its binding site) with its expected type (at a use site).  So we+rename type binders as we go, maintaining a substitution.++The same substitution also supports let-type, current expressed as+        (/\(a:*). body) ty+Here we substitute 'ty' for 'a' in 'body', on the fly.++Note [Linting type synonym applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When linting a type-synonym, or type-family, application+  S ty1 .. tyn+we behave as follows (#15057, #T15664):++* If lf_report_unsat_syns = True, and S has arity < n,+  complain about an unsaturated type synonym or type family++* Switch off lf_report_unsat_syns, and lint ty1 .. tyn.++  Reason: catch out of scope variables or other ill-kinded gubbins,+  even if S discards that argument entirely. E.g. (#15012):+     type FakeOut a = Int+     type family TF a+     type instance TF Int = FakeOut a+  Here 'a' is out of scope; but if we expand FakeOut, we conceal+  that out-of-scope error.++  Reason for switching off lf_report_unsat_syns: with+  LiberalTypeSynonyms, GHC allows unsaturated synonyms provided they+  are saturated when the type is expanded. Example+     type T f = f Int+     type S a = a -> a+     type Z = T S+  In Z's RHS, S appears unsaturated, but it is saturated when T is expanded.++* If lf_report_unsat_syns is on, expand the synonym application and+  lint the result.  Reason: want to check that synonyms are saturated+  when the type is expanded.++Note [Linting linearity]+~~~~~~~~~~~~~~~~~~~~~~~~+Lint ignores linearity unless `-dlinear-core-lint` is set.  For why, see below.++* When do we /check linearity/ in Lint?  That is, when is `-dlinear-core-lint`+  lint set?  Answer: we check linearity in the output of the desugarer, shortly+  after type checking.++* When so we /not/ check linearity in Lint?  On all passes after desugaring.  Why?+  Because optimisation passes are not (yet) guaranteed to maintain linearity.+  They should do so semantically (GHC is careful not to duplicate computation)+  but it is much harder to ensure that the statically-checkable constraints of+  Linear Core are maintained. See examples below.++The current Linear Core is described in the wiki at:+https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation.++Concretely, "ignore linearity in Lint" specifically means two things:+* In `ensureEqTypes`, use `eqTypeIgnoringMultiplicity`+* In `ensureSubMult`, do nothing++Here are some examples of how the optimiser can break linearity checking.  Other+examples are documented in the linear-type implementation wiki page+[https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation#core-to-core-passes]++* EXAMPLE 1: the binder swap transformation+    Consider++      data T = MkT {-# UNPACK #-} !Int++    The wrapper for MkT is++      $wMkT :: Int %1 -> T+      $wMkT n = case %1 n of+        I# n' -> MkT n'++    This introduces, in particular, a `case %1` (this is not actual Haskell or+    Core syntax), where the `%1` means that the `case` expression consumes its+    scrutinee linearly.++    Now, `case %1` interacts with the binder swap optimisation in a non-trivial+    way. Take a slightly modified version of the code for $wMkT:++      case %1 x of z {+        I# n' -> (x, n')+      }++    Binder-swap changes this to++      case %1 x of z {+        I# n' -> let x = z in (x, n')+      }++    This is rejected by `-dlinear-core-lint` because 1/ n' must be used linearly+    2/ `-dlinear-core-lint` recognises a use of `z` as a use of `n'`. So it sees+    two uses of n' where there should be a single one.++* EXAMPLE 2: letrec+    Some optimisations can create a letrec which uses a variable+    linearly, e.g.++      letrec f True = f False+             f False = x+      in f True++    uses 'x' linearly, but this is not seen by the linter, which considers,+    conservatively, that a letrec always has multiplicity Many (in particular+    that every captured free variable must have multiplicity Many). This issue+    is discussed in ticket #18694.++* EXAMPLE 3: rewrite rules+    Ignoring linearity means in particular that `a -> b` and `a %1 -> b` must be+    treated the same by rewrite rules (see also Note [Rewrite rules ignore+    multiplicities in FunTy] in GHC.Core.Unify). Consider++      m :: Bool -> A+      m' :: (Bool -> Bool) -> A+      {- RULES "ex" forall f. m (f True) = m' f -}++      f :: Bool %1 -> A+      x = m (f True)++    The rule "ex" must match . So the linter must accept `m' f`.++* EXAMPLE 4: eta-reduction+   Eta-expansion can change linear functions into unrestricted functions++     f :: A %1 -> B++     g :: A %Many -> B+     g = \x -> f x++   Eta-reduction undoes this and produces:++     g :: A %Many -> B+     g = f++Historical note: In the original linear-types implementation, we had tried to+make every optimisation pass produce code that passes `-dlinear-core-lint`. It+had proved very difficult. We kept finding corner case after corner+case. Furthermore, to attempt to achieve that goal we ended up restricting+transformations when `-dlinear-core-lint` couldn't typecheck the result.++In the future, we may be able to lint the linearity of the output of+Core-to-Core passes (#19165). But this shouldn't be done at the expense of+producing efficient code. Therefore we lay the following principle.++PRINCIPLE: The type system bends to the optimisation, not the other way around.++There is a useful discussion at https://gitlab.haskell.org/ghc/ghc/-/issues/22123++Note [Linting representation-polymorphic builtins]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As described in Note [Representation-polymorphism checking built-ins], on+top of the two main representation-polymorphism invariants described in the+Note [Representation polymorphism invariants], we must perform additional+representation-polymorphism checks on builtin functions which don't have a+binding, for example to ensure that we don't run afoul of the+representation-polymorphism invariants when eta-expanding.++There are two situations:++  1. Builtins which have skolem type variables which must be instantiated to+     concrete types, such as the RuntimeRep type argument r to the catch# primop.++  2. Representation-polymorphic unlifted newtypes, which must always be instantiated+     at a fixed runtime representation.++For 1, consider for example 'coerce':++  coerce :: forall {r} (a :: TYPE r) (b :: TYPE r). Coercible a b => a -> b++We store in the IdDetails of the coerce Id that the first binder, r, must always+be instantiated to a concrete type. We thus check this in Core Lint: whenever we+see an application of the form++  coerce @{rep1} ...++we ensure that 'rep1' is concrete. This is done in the function "checkRepPolyBuiltinApp".+Moreover, not instantiating these type variables at all is also an error, as+we would again not be able to perform eta-expansion. (This is a bit more theoretical,+as in user programs the typechecker will insert these type applications when+instantiating, but it can still arise when constructing Core expressions).++For 2, whenever we have an unlifted newtype such as++  type RR :: Type -> RuntimeRep+  type family RR a++  type F :: forall (a :: Type) -> TYPE (RR a)+  type family F a++  type N :: forall (a :: Type) -> TYPE (RR a)+  newtype N a = MkN (F a)++and an unsaturated occurrence++  MkN @ty -- NB: no value argument!++we check that the (instantiated) argument type has a fixed runtime representation.+This is done in the function "checkRepPolyNewtypeApp".+-}++instance Applicative LintM where+      pure x = LintM $ \ _ errs -> LResult (JustUB x) errs+                                   --(Just x, errs)+      (<*>) = ap++instance Monad LintM where+  m >>= k  = LintM (\ env errs ->+                       let res = unLintM m env errs in+                         case res of+                           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 -> (LResult (JustUB $ le_platform e) errs))++data LintLocInfo+  = RhsOf Id            -- The variable bound+  | OccOf Id            -- Occurrence of id+  | LambdaBodyOf Id     -- The lambda-binder+  | RuleOf Id           -- Rules attached to a binder+  | UnfoldingOf Id      -- Unfolding of a binder+  | BodyOfLet Id        -- The let-bound variable+  | BodyOfLetRec [Id]   -- The binders of the let+  | CaseAlt CoreAlt     -- Case alternative+  | CasePat CoreAlt     -- The *pattern* of the case alternative+  | CaseTy CoreExpr     -- The type field of a case expression+                        -- with this scrutinee+  | IdTy Id             -- The type field of an Id binder+  | AnExpr CoreExpr     -- Some expression+  | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)+  | TopLevelBindings+  | InType Type         -- Inside a type+  | InCo   Coercion     -- Inside a coercion+  | InAxiom (CoAxiom Branched)   -- Inside a CoAxiom++data LintConfig = LintConfig+  { l_diagOpts   :: !DiagOpts         -- ^ Diagnostics opts+  , l_platform   :: !Platform         -- ^ Target platform+  , l_flags      :: !LintFlags        -- ^ Linting the result of this pass+  , l_vars       :: ![Var]            -- ^ 'Id's that should be treated as being in scope+  }++initL :: LintConfig+      -> LintM a            -- ^ Action to run+      -> WarnsAndErrs+initL cfg m+  = case unLintM m env (emptyBag, emptyBag) of+      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+    vars = l_vars cfg+    env = LE { le_flags   = l_flags cfg+             , le_subst   = mkEmptySubst (mkInScopeSetList vars)+             , le_in_vars = mkVarEnv [ (v,(v, varType v)) | v <- vars ]+             , le_joins   = emptyVarSet+             , le_loc     = []+             , le_ue_aliases = emptyNameEnv+             , le_platform = l_platform cfg+             , le_diagOpts = l_diagOpts cfg+             }++setReportUnsat :: Bool -> LintM a -> LintM a+-- Switch off lf_report_unsat_syns+setReportUnsat ru thing_inside+  = LintM $ \ env errs ->+    let env' = env { le_flags = (le_flags env) { lf_report_unsat_syns = ru } }+    in unLintM thing_inside env' errs++-- See Note [Checking for representation polymorphism]+noFixedRuntimeRepChecks :: LintM a -> LintM a+noFixedRuntimeRepChecks thing_inside+  = LintM $ \env errs ->+    let env' = env { le_flags = (le_flags env) { lf_check_fixed_rep = False } }+    in unLintM thing_inside env' errs++getLintFlags :: LintM LintFlags+getLintFlags = LintM $ \ env errs -> fromBoxedLResult (Just (le_flags env), errs)++checkL :: Bool -> SDoc -> LintM ()+checkL True  _   = return ()+checkL False msg = failWithL msg++-- like checkL, but relevant to type checking+lintL :: Bool -> SDoc -> LintM ()+lintL = checkL++checkWarnL :: Bool -> SDoc -> LintM ()+checkWarnL True   _  = return ()+checkWarnL False msg = addWarnL msg++failWithL :: SDoc -> LintM a+failWithL msg = LintM $ \ env (warns,errs) ->+                fromBoxedLResult (Nothing, (warns, addMsg True env errs msg))++addErrL :: SDoc -> LintM ()+addErrL msg = LintM $ \ env (warns,errs) ->+              fromBoxedLResult (Just (), (warns, addMsg True env errs msg))++addWarnL :: SDoc -> LintM ()+addWarnL msg = LintM $ \ env (warns,errs) ->+              fromBoxedLResult (Just (), (addMsg True env warns msg, errs))++addMsg :: Bool -> LintEnv ->  Bag SDoc -> SDoc -> Bag SDoc+addMsg show_context env msgs msg+  = assertPpr (notNull loc_msgs) msg $+    msgs `snocBag` mk_msg msg+  where+   loc_msgs :: [(SrcLoc, SDoc)]  -- Innermost first+   loc_msgs = map dumpLoc (le_loc env)++   cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs+                  , text "Substitution:" <+> ppr (le_subst env) ]++   context | show_context  = cxt_doc+           | otherwise     = whenPprDebug cxt_doc+     -- Print voluminous info for Lint errors+     -- but not for warnings++   msg_span = case [ span | (loc,_) <- loc_msgs+                          , let span = srcLocSpan loc+                          , isGoodSrcSpan span ] of+               []    -> noSrcSpan+               (s:_) -> s+   !diag_opts = le_diagOpts env+   mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) msg_span+                             (msg $$ context)++addLoc :: LintLocInfo -> LintM a -> LintM a+addLoc extra_loc m+  = LintM $ \ env errs ->+    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 -> fromBoxedLResult (Just (is_case_pat env), errs)+  where+    is_case_pat (LE { le_loc = CasePat {} : _ }) = True+    is_case_pat _other                           = False++addInScopeId :: InId -> OutType -> (OutId -> LintM a) -> LintM a+-- Unlike addInScopeTyCoVar, this function does no cloning; Ids never get cloned+addInScopeId in_id out_ty thing_inside+  = LintM $ \ env errs ->+    let !(out_id, env') = add env+    in unLintM (thing_inside out_id) env' errs++  where+    add env@(LE { le_in_vars = id_vars, le_joins = join_set+                , le_ue_aliases = aliases, le_subst = subst })+      = (out_id, env1)+      where+        env1 = env { le_in_vars = in_vars', le_joins = join_set', le_ue_aliases = aliases' }++        in_vars' = extendVarEnv id_vars in_id (in_id, out_ty)+        aliases' = delFromNameEnv aliases (idName in_id)+           -- aliases': when shadowing an alias, we need to make sure the+           -- Id is no longer classified as such. E.g.+           --   let x = <e1> in case x of x { _DEFAULT -> <e2> }+           -- Occurrences of 'x' in e2 shouldn't count as occurrences of e1.++        -- A very tiny optimisation, not sure if it's really worth it+        -- Short-cut when the substitution is a no-op+        out_id | isEmptyTCvSubst subst = in_id+               | otherwise             = setIdType in_id out_ty++        join_set'+          | isJoinId out_id = extendVarSet join_set in_id -- Overwrite with new arity+          | otherwise       = delVarSet    join_set in_id -- Remove any existing binding++addInScopeTyCoVar :: InTyCoVar -> OutType -> (OutTyCoVar -> LintM a) -> LintM a+-- This function clones to avoid shadowing of TyCoVars+addInScopeTyCoVar tcv tcv_type thing_inside+  = LintM $ \ env@(LE { le_in_vars = in_vars, le_subst = subst }) errs ->+    let (tcv', subst') = subst_bndr subst+        env' = env { le_in_vars = extendVarEnv in_vars tcv (tcv, tcv_type)+                   , le_subst = subst' }+    in unLintM (thing_inside tcv') env' errs+  where+    subst_bndr subst+      | isEmptyTCvSubst subst                -- No change in kind+      , not (tcv `elemInScopeSet` in_scope)  -- Not already in scope+      = -- Do not extend the substitution, just the in-scope set+        (if (varType tcv `eqType` tcv_type) then (\x->x) else+          pprTrace "addInScopeTyCoVar" (+            vcat [ text "tcv" <+> ppr tcv <+> dcolon <+> ppr (varType tcv)+                 , text "tcv_type" <+> ppr tcv_type ])) $+        (tcv, subst `extendSubstInScope` tcv)++      -- Clone, and extend the substitution+      | let tcv' = uniqAway in_scope (setVarType tcv tcv_type)+      = (tcv', extendTCvSubstWithClone subst tcv tcv')+      where+        in_scope = substInScopeSet subst++getInVarEnv :: LintM (VarEnv (InId, OutType))+getInVarEnv = LintM (\env errs -> fromBoxedLResult (Just (le_in_vars env), errs))++extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a+extendTvSubstL tv ty m+  = LintM $ \ env errs ->+    unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs++markAllJoinsBad :: LintM a -> LintM a+markAllJoinsBad m+  = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs++markAllJoinsBadIf :: Bool -> LintM a -> LintM a+markAllJoinsBadIf True  m = markAllJoinsBad m+markAllJoinsBadIf False m = m++getValidJoins :: LintM IdSet+getValidJoins = LintM (\ env errs -> fromBoxedLResult (Just (le_joins env), errs))++getSubst :: LintM Subst+getSubst = LintM (\ env errs -> fromBoxedLResult (Just (le_subst env), errs))++substTyM :: InType -> LintM OutType+-- Apply the substitution to the type+-- The substitution is often empty, in which case it is a no-op+substTyM ty+  = do { subst <- getSubst+       ; return (substTy subst ty) }++getUEAliases :: LintM (NameEnv UsageEnv)+getUEAliases = LintM (\ env errs -> fromBoxedLResult (Just (le_ue_aliases env), errs))++getInScope :: LintM InScopeSet+getInScope = LintM (\ env errs -> fromBoxedLResult (Just (substInScopeSet $ le_subst env), errs))++lintVarOcc :: InVar -> LintM OutType+-- Used at an occurrence of a variable: term variables, type variables, and coercion variables+-- Checks two things:+-- a) that it is in scope+-- b) that the InType at the ocurrences matches the InType at the binding site+lintVarOcc v_occ+  = do { in_var_env <- getInVarEnv+       ; case lookupVarEnv in_var_env v_occ of+           Nothing | isGlobalId v_occ -> return (idType v_occ)+                   | otherwise        -> failWithL (text pp_what <+> quotes (ppr v_occ)+                                                    <+> text "is out of scope")+           Just (v_bndr, out_ty) -> do { check_bad_global v_bndr+                                       ; ensureEqTys occ_ty bndr_ty $  -- Compares InTypes+                                         mkBndrOccTypeMismatchMsg v_occ bndr_ty occ_ty+                                       ; return out_ty }+             where+               occ_ty  = varType v_occ+               bndr_ty = varType v_bndr }+  where+    pp_what | isTyVar v_occ = "The type variable"+            | isCoVar v_occ = "The coercion variable"+            | otherwise     = "The value variable"++       -- 'check_bad_global' checks for the case where an /occurrence/ is+       -- a GlobalId, but there is an enclosing binding fora a LocalId.+       -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr,+       --     but GHCi adds GlobalIds from the interactive context.  These+       --     are fine; hence the test (isLocalId id == isLocalId v)+       -- NB: when compiling Control.Exception.Base, things like absentError+       --     are defined locally, but appear in expressions as (global)+       --     wired-in Ids after worker/wrapper+       --     So we simply disable the test in this case+    check_bad_global v_bndr+      | isGlobalId v_occ+      , isLocalId v_bndr+      , not (isWiredIn v_occ)+      = failWithL $ hang (text "Occurrence is GlobalId, but binding is LocalId")+                       2 (vcat [ hang (text "occurrence:") 2 $ pprBndr LetBind v_occ+                               , hang (text "binder    :") 2 $ pprBndr LetBind v_bndr ])+      | otherwise+      = return ()++lookupJoinId :: Id -> LintM JoinPointHood+-- Look up an Id which should be a join point, valid here+-- If so, return its arity, if not return Nothing+lookupJoinId id+  = do { join_set <- getValidJoins+       ; case lookupVarSet join_set id of+            Just id' -> return (idJoinPointHood id')+            Nothing  -> return NotJoinPoint }++addAliasUE :: OutId -> UsageEnv -> LintM a -> LintM a+addAliasUE id ue thing_inside = LintM $ \ env errs ->+  let new_ue_aliases =+        extendNameEnv (le_ue_aliases env) (getName id) ue+  in+    unLintM thing_inside (env { le_ue_aliases = new_ue_aliases }) errs++varCallSiteUsage :: OutId -> LintM UsageEnv+varCallSiteUsage id =+  do m <- getUEAliases+     return $ case lookupNameEnv m (getName id) of+         Nothing    -> singleUsageUE id+         Just id_ue -> id_ue++ensureEqTys :: OutType -> OutType -> SDoc -> LintM ()+-- check ty2 is subtype of ty1 (ie, has same structure but usage+-- annotations need only be consistent, not equal)+-- Assumes ty1,ty2 are have already had the substitution applied+{-# INLINE ensureEqTys #-} -- See Note [INLINE ensureEqTys]+ensureEqTys ty1 ty2 msg+  = do { flags <- getLintFlags+       ; lintL (eq_type flags ty1 ty2) msg }++eq_type :: LintFlags -> Type -> Type -> Bool+-- When `-dlinear-core-lint` is off, then consider `a -> b` and `a %1 -> b` to+-- be equal. See Note [Linting linearity].+eq_type flags ty1 ty2 | lf_check_linearity flags = eqType                     ty1 ty2+                      | otherwise                = eqTypeIgnoringMultiplicity ty1 ty2++{- Note [INLINE ensureEqTys]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To make Lint fast, we want to avoid allocating a thunk for <msg> in+      ensureEqTypes ty1 ty2 <msg>+because the test almost always succeeds, and <msg> isn't needed.+So we INLINE `ensureEqTys`.  This actually make a difference of+1-2% when compiling programs with -dcore-lint.+-}++ensureSubUsage :: Usage -> Mult -> SDoc -> LintM ()+ensureSubUsage Bottom     _              _ = return ()+ensureSubUsage Zero       described_mult err_msg = ensureSubMult ManyTy described_mult err_msg+ensureSubUsage (MUsage m) described_mult err_msg = ensureSubMult m described_mult err_msg++ensureSubMult :: Mult -> Mult -> SDoc -> LintM ()+ensureSubMult actual_mult described_mult err_msg = do+    flags <- getLintFlags+    when (lf_check_linearity flags) $+      unless (deepSubMult actual_mult described_mult) $+        addErrL err_msg+  where+    -- Check for submultiplicity using the following rules:+    -- 1. x*y <= z when x <= z and y <= z.+    --    This rule follows from the fact that x*y = sup{x,y} for any+    --    multiplicities x,y.+    -- 2. x <= y*z when x <= y or x <= z.+    --    This rule is not complete: when x = y*z, we cannot+    --    change y*z <= y*z to y*z <= y or y*z <= z.+    --    However, we eliminate products on the LHS in step 1.+    -- 3. One <= x and x <= Many for any x, as checked by 'submult'.+    -- 4. x <= x.+    -- Otherwise, we fail.+    deepSubMult :: Mult -> Mult -> Bool+    deepSubMult m n+      | Just (m1, m2) <- isMultMul m = deepSubMult m1 n  && deepSubMult m2 n+      | Just (n1, n2) <- isMultMul n = deepSubMult m  n1 || deepSubMult m  n2+      | Submult <- m `submult` n = True+      | otherwise = m `eqType` n++lintRole :: Outputable thing+          => thing     -- where the role appeared+          -> Role      -- expected+          -> Role      -- actual+          -> LintM ()+lintRole co r1 r2+  = lintL (r1 == r2)+          (text "Role incompatibility: expected" <+> ppr r1 <> comma <+>+           text "got" <+> ppr r2 $$+           text "in" <+> ppr co)++{-+************************************************************************+*                                                                      *+\subsection{Error messages}+*                                                                      *+************************************************************************+-}++dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)++dumpLoc (RhsOf v)+  = (getSrcLoc v, text "In the RHS of" <+> pp_binders [v])++dumpLoc (OccOf v)+  = (getSrcLoc v, text "In an occurrence of" <+> pp_binder v)++dumpLoc (LambdaBodyOf b)+  = (getSrcLoc b, text "In the body of lambda with binder" <+> pp_binder b)++dumpLoc (RuleOf b)+  = (getSrcLoc b, text "In a rule attached to" <+> pp_binder b)++dumpLoc (UnfoldingOf b)+  = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b)++dumpLoc (BodyOfLet b)+  = (noSrcLoc, text "In the body of a let with binder" <+> pp_binder b)++dumpLoc (BodyOfLetRec [])+  = (noSrcLoc, text "In body of a letrec with no binders")++dumpLoc (BodyOfLetRec bs@(b:_))+  = ( getSrcLoc b, text "In the body of a letrec with binders" <+> pp_binders bs)++dumpLoc (AnExpr e)+  = (noSrcLoc, text "In the expression:" <+> ppr e)++dumpLoc (CaseAlt (Alt con args _))+  = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))++dumpLoc (CasePat (Alt con args _))+  = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))++dumpLoc (CaseTy scrut)+  = (noSrcLoc, hang (text "In the result-type of a case with scrutinee:")+                  2 (ppr scrut))++dumpLoc (IdTy b)+  = (getSrcLoc b, text "In the type of a binder:" <+> ppr b)++dumpLoc (ImportedUnfolding locn)+  = (locn, text "In an imported unfolding")+dumpLoc TopLevelBindings+  = (noSrcLoc, Outputable.empty)+dumpLoc (InType ty)+  = (noSrcLoc, text "In the type" <+> quotes (ppr ty))+dumpLoc (InCo co)+  = (noSrcLoc, text "In the coercion" <+> quotes (ppr co))+dumpLoc (InAxiom ax)+  = (getSrcLoc ax, hang (text "In the coercion axiom")+                      2 (pprCoAxiom ax))++pp_binders :: [Var] -> SDoc+pp_binders bs = sep (punctuate comma (map pp_binder bs))++pp_binder :: Var -> SDoc+pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]+            | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)]++------------------------------------------------------+--      Messages for case expressions++mkDefaultArgsMsg :: [Var] -> SDoc+mkDefaultArgsMsg args+  = hang (text "DEFAULT case with binders")+         4 (ppr args)++mkCaseAltMsg :: CoreExpr -> Type -> Type -> SDoc+mkCaseAltMsg e ty1 ty2+  = hang (text "Type of case alternatives not the same as the annotation on case:")+         4 (vcat [ text "Actual type:" <+> ppr ty1,+                   text "Annotation on case:" <+> ppr ty2,+                   text "Alt Rhs:" <+> ppr e ])++mkScrutMsg :: Id -> Type -> Type -> SDoc+mkScrutMsg var var_ty scrut_ty+  = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,+          text "Result binder type:" <+> ppr var_ty,--(idType var),+          text "Scrutinee type:" <+> ppr scrut_ty]++mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> SDoc+mkNonDefltMsg e+  = hang (text "Case expression with DEFAULT not at the beginning") 4 (ppr e)+mkNonIncreasingAltsMsg e+  = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)++nonExhaustiveAltsMsg :: CoreExpr -> SDoc+nonExhaustiveAltsMsg e+  = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)++mkBadConMsg :: TyCon -> DataCon -> SDoc+mkBadConMsg tycon datacon+  = vcat [+        text "In a case alternative, data constructor isn't in scrutinee type:",+        text "Scrutinee type constructor:" <+> ppr tycon,+        text "Data con:" <+> ppr datacon+    ]++mkBadPatMsg :: Type -> Type -> SDoc+mkBadPatMsg con_result_ty scrut_ty+  = vcat [+        text "In a case alternative, pattern result type doesn't match scrutinee type:",+        text "Pattern result type:" <+> ppr con_result_ty,+        text "Scrutinee type:" <+> ppr scrut_ty+    ]++integerScrutinisedMsg :: SDoc+integerScrutinisedMsg+  = text "In a LitAlt, the literal is lifted (probably Integer)"++mkBadAltMsg :: Type -> CoreAlt -> SDoc+mkBadAltMsg scrut_ty alt+  = vcat [ text "Data alternative when scrutinee is not a tycon application",+           text "Scrutinee type:" <+> ppr scrut_ty,+           text "Alternative:" <+> pprCoreAlt alt ]++mkNewTyDataConAltMsg :: Type -> CoreAlt -> SDoc+mkNewTyDataConAltMsg scrut_ty alt+  = vcat [ text "Data alternative for newtype datacon",+           text "Scrutinee type:" <+> ppr scrut_ty,+           text "Alternative:" <+> pprCoreAlt alt ]+++------------------------------------------------------+--      Other error messages++mkAppMsg :: Type -> Type -> CoreExpr -> SDoc+mkAppMsg expected_arg_ty actual_arg_ty arg+  = vcat [text "Argument value doesn't match argument type:",+              hang (text "Expected arg type:") 4 (ppr expected_arg_ty),+              hang (text "Actual arg type:") 4 (ppr actual_arg_ty),+              hang (text "Arg:") 4 (ppr arg)]++mkNonFunAppMsg :: Type -> Type -> CoreExpr -> SDoc+mkNonFunAppMsg fun_ty arg_ty arg+  = vcat [text "Non-function type in function position",+              hang (text "Fun type:") 4 (ppr fun_ty),+              hang (text "Arg type:") 4 (ppr arg_ty),+              hang (text "Arg:") 4 (ppr arg)]++mkLetErr :: TyVar -> CoreExpr -> SDoc+mkLetErr bndr rhs+  = vcat [text "Bad `let' binding:",+          hang (text "Variable:")+                 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)),+          hang (text "Rhs:")+                 4 (ppr rhs)]++mkTyAppMsg :: OutType -> Type -> SDoc+mkTyAppMsg ty arg_ty+  = vcat [text "Illegal type application:",+              hang (text "Function type:")+                 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),+              hang (text "Type argument:")+                 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]++emptyRec :: CoreExpr -> SDoc+emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e)++mkRhsMsg :: Id -> SDoc -> Type -> SDoc+mkRhsMsg binder what ty+  = vcat+    [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon,+            ppr binder],+     hsep [text "Binder's type:", ppr (idType binder)],+     hsep [text "Rhs type:", ppr ty]]++badBndrTyMsg :: Id -> SDoc -> SDoc+badBndrTyMsg binder what+  = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder+         , text "Binder's type:" <+> ppr (idType binder) ]++mkNonTopExportedMsg :: Id -> SDoc+mkNonTopExportedMsg binder+  = hsep [text "Non-top-level binder is marked as exported:", ppr binder]++mkNonTopExternalNameMsg :: Id -> SDoc+mkNonTopExternalNameMsg binder+  = hsep [text "Non-top-level binder has an external name:", ppr binder]++mkTopNonLitStrMsg :: Id -> SDoc+mkTopNonLitStrMsg binder+  = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder]++mkKindErrMsg :: TyVar -> Type -> SDoc+mkKindErrMsg tyvar arg_ty+  = vcat [text "Kinds don't match in type application:",+          hang (text "Type variable:")+                 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),+          hang (text "Arg type:")+                 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]++mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> SDoc+mkCastErr expr = mk_cast_err "expression" "type" (ppr expr)++mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> SDoc+mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty)++mk_cast_err :: String -- ^ What sort of casted thing this is+                      --   (\"expression\" or \"type\").+            -> String -- ^ What sort of coercion is being used+                      --   (\"type\" or \"kind\").+            -> SDoc   -- ^ The thing being casted.+            -> Coercion -> Type -> Type -> SDoc+mk_cast_err thing_str co_str pp_thing co from_ty thing_ty+  = vcat [from_msg <+> text "of Cast differs from" <+> co_msg+            <+> text "of" <+> enclosed_msg,+          from_msg <> colon <+> ppr from_ty,+          text (capitalise co_str) <+> text "of" <+> enclosed_msg <> colon+            <+> ppr thing_ty,+          text "Actual" <+> enclosed_msg <> colon <+> pp_thing,+          text "Coercion used in cast:" <+> ppr co+         ]+  where+    co_msg, from_msg, enclosed_msg :: SDoc+    co_msg       = text co_str+    from_msg     = text "From-" <> co_msg+    enclosed_msg = text "enclosed" <+> text thing_str++mkBadTyVarMsg :: Var -> SDoc+mkBadTyVarMsg tv+  = text "Non-tyvar used in TyVarTy:"+      <+> ppr tv <+> dcolon <+> ppr (varType tv)++mkBadJoinBindMsg :: Var -> SDoc+mkBadJoinBindMsg var+  = vcat [ text "Bad join point binding:" <+> ppr var+         , text "Join points can be bound only by a non-top-level let" ]++mkInvalidJoinPointMsg :: Var -> Type -> SDoc+mkInvalidJoinPointMsg var ty+  = hang (text "Join point has invalid type:")+        2 (ppr var <+> dcolon <+> ppr ty)++mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc+mkBadJoinArityMsg var ar n rhs+  = vcat [ text "Join point has too few lambdas",+           text "Join var:" <+> ppr var,+           text "Join arity:" <+> ppr ar,+           text "Number of lambdas:" <+> ppr (ar - n),+           text "Rhs = " <+> ppr rhs+           ]++invalidJoinOcc :: Var -> SDoc+invalidJoinOcc var+  = vcat [ text "Invalid occurrence of a join variable:" <+> ppr var+         , text "The binder is either not a join point, or not valid here" ]++mkBadJumpMsg :: Var -> Int -> Int -> SDoc+mkBadJumpMsg var ar nargs+  = vcat [ text "Join point invoked with wrong number of arguments",+           text "Join var:" <+> ppr var,+           text "Join arity:" <+> ppr ar,+           text "Number of arguments:" <+> int nargs ]++mkInconsistentRecMsg :: [Var] -> SDoc+mkInconsistentRecMsg bndrs+  = vcat [ text "Recursive let binders mix values and join points",+           text "Binders:" <+> hsep (map ppr_with_details bndrs) ]+  where+    ppr_with_details bndr = ppr bndr <> ppr (idDetails bndr)++mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc+mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ+  = vcat [ text "Mismatch in join point arity between binder and occurrence"+         , text "Var:" <+> ppr bndr+         , text "Arity at binding site:" <+> ppr join_arity_bndr+         , text "Arity at occurrence:  " <+> ppr join_arity_occ ]++mkBndrOccTypeMismatchMsg :: InVar -> InType -> InType -> SDoc+mkBndrOccTypeMismatchMsg var bndr_ty occ_ty+  = vcat [ text "Mismatch in type between binder and occurrence"+         , text "Binder:    " <+> ppr var <+> dcolon <+> ppr bndr_ty+         , text "Occurrence:" <+> ppr var <+> dcolon <+> ppr occ_ty ]  mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc mkBadJoinPointRuleMsg bndr join_arity rule
compiler/GHC/Core/Make.hs view
@@ -1,11 +1,10 @@-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- -- | Handy functions for creating much Core syntax module GHC.Core.Make (         -- * Constructing normal syntax         mkCoreLet, mkCoreLets,-        mkCoreApp, mkCoreApps, mkCoreConApps,-        mkCoreLams, mkWildCase, mkIfThenElse,+        mkCoreApp, mkCoreApps, mkCoreConApps, mkCoreConWrapApps,+        mkCoreLams, mkCoreTyLams,+        mkWildCase, mkIfThenElse,         mkWildValBinder,         mkSingleAltCase,         sortQuantVars, castBottomExpr,@@ -65,12 +64,12 @@ import GHC.Types.Unique.Supply  import GHC.Core-import GHC.Core.Utils ( exprType, mkSingleAltCase, bindNonRec )+import GHC.Core.Utils ( exprType, mkSingleAltCase, bindNonRec, mkCast ) import GHC.Core.Type-import GHC.Core.Predicate    ( isCoVarType )+import GHC.Core.Predicate    ( scopedSort, isEqPred ) import GHC.Core.TyCo.Compare ( eqType )-import GHC.Core.Coercion     ( isCoVar )-import GHC.Core.DataCon      ( DataCon, dataConWorkId )+import GHC.Core.Coercion     ( isCoVar, mkRepReflCo, mkForAllVisCos )+import GHC.Core.DataCon      ( DataCon, dataConWorkId, dataConWrapId ) import GHC.Core.Multiplicity  import GHC.Builtin.Types@@ -83,8 +82,10 @@  import GHC.Settings.Constants( mAX_TUPLE_SIZE ) import GHC.Data.FastString+import GHC.Data.Maybe ( expectJust )  import Data.List        ( partition )+import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Char        ( ord )  infixl 4 `mkCoreApp`, `mkCoreApps`@@ -122,6 +123,14 @@ mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr mkCoreLams = mkLams +-- | Create a type lambda (/\a b c. e) and apply a cast to fix up visibilities+-- if needed. See Note [Required foralls in Core]+mkCoreTyLams :: [TyVarBinder] -> CoreExpr -> CoreExpr+mkCoreTyLams binders body = mkCast lam co+  where+    lam = mkCoreLams (binderVars binders) body+    co  = mkForAllVisCos binders (mkRepReflCo (exprType body))+ -- | Bind a list of binding groups over an expression. The leftmost binding -- group becomes the outermost group in the resulting expression mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr@@ -133,6 +142,13 @@ mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args +-- | A variant of 'mkCoreConApps' constructs an expression which represents the+-- application of a number of expressions to that of a data constructor+-- expression using the wrapper, not the worker, of the data constructor. The+-- leftmost expression in the list is applied first+mkCoreConWrapApps :: DataCon -> [CoreExpr] -> CoreExpr+mkCoreConWrapApps con args = mkCoreApps (Var (dataConWrapId con)) args+ -- | Construct an expression which represents the application of a number of -- expressions to another. The leftmost expression in the list is applied first mkCoreApps :: CoreExpr -- ^ function@@ -224,12 +240,12 @@ mkLitRubbish ty   | not (noFreeVarsOfType rep)   = Nothing   -- Satisfy INVARIANT 1-  | isCoVarType ty+  | isEqPred ty   = Nothing   -- Satisfy INVARIANT 2   | otherwise   = Just (Lit (LitRubbish torc rep) `mkTyApps` [ty])   where-    Just (torc, rep) = sORTKind_maybe (typeKind ty)+    (torc, rep) = expectJust $ sORTKind_maybe (typeKind ty)  {- ************************************************************************@@ -609,8 +625,13 @@         where           tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s]           tpl_vs  = mkTemplateLocals tpl_tys-          [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkBigTupleSelector" tpl_vs vars_s,-                                         the_var `elem` gp ]+          (tpl_v, group) = case+            [ (tpl,gp)+            | (tpl,gp) <- zipEqual tpl_vs vars_s+            , the_var `elem` gp+            ] of+              [x] -> x+              _ -> panic "mkBigTupleSelector" -- ^ 'mkBigTupleSelectorSolo' is like 'mkBigTupleSelector' -- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) mkBigTupleSelectorSolo vars the_var scrut_var scrut@@ -1277,7 +1298,7 @@ mkRuntimeErrorTy torc = mkSpecForAllTys [runtimeRep1TyVar, tyvar] $                         mkFunctionType ManyTy addrPrimTy (mkTyVarTy tyvar)   where-    (tyvar:_) = mkTemplateTyVars [kind]+    tyvar:|_ = expectNonEmpty $ mkTemplateTyVars [kind]     kind = case torc of               TypeLike       -> mkTYPEapp       runtimeRep1Ty               ConstraintLike -> mkCONSTRAINTapp runtimeRep1Ty
compiler/GHC/Core/Map/Expr.hs view
@@ -122,6 +122,7 @@     alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m)     foldTM k (CoreMap m) = foldTM k m     filterTM f (CoreMap m) = CoreMap (filterTM f m)+    mapMaybeTM f (CoreMap m) = CoreMap (mapMaybeTM f m)  -- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@.  The extended -- key makes it suitable for recursive traversal, since it can track binders,@@ -197,11 +198,10 @@  eqDeBruijnTickish :: DeBruijn CoreTickish -> DeBruijn CoreTickish -> Bool eqDeBruijnTickish (D env1 t1) (D env2 t2) = go t1 t2 where-    go (Breakpoint lext lid lids lmod) (Breakpoint rext rid rids rmod)+    go (Breakpoint lext lid lids) (Breakpoint rext rid rids)         =  lid == rid         && D env1 lids == D env2 rids         && lext == rext-        && lmod == rmod     go l r = l == r  -- Compares for equality, modulo alpha@@ -271,6 +271,7 @@    alterTM  = xtE    foldTM   = fdE    filterTM = ftE+   mapMaybeTM = mpE  -------------------------- ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a@@ -287,6 +288,20 @@        , cm_letr = fmap (fmap (filterTM f)) cletr, cm_case = fmap (filterTM f) ccase        , cm_ecase = fmap (filterTM f) cecase, cm_tick = fmap (filterTM f) ctick } +mpE :: (a -> Maybe b) -> CoreMapX a -> CoreMapX b+mpE f (CM { cm_var = cvar, cm_lit = clit+          , cm_co = cco, cm_type = ctype+          , cm_cast = ccast , cm_app = capp+          , cm_lam = clam, cm_letn = cletn+          , cm_letr = cletr, cm_case = ccase+          , cm_ecase = cecase, cm_tick = ctick })+  = CM { cm_var = mapMaybeTM f cvar, cm_lit = mapMaybeTM f clit+       , cm_co = mapMaybeTM f cco, cm_type = mapMaybeTM f ctype+       , cm_cast = fmap (mapMaybeTM f) ccast, cm_app = fmap (mapMaybeTM f) capp+       , cm_lam = fmap (mapMaybeTM f) clam, cm_letn = fmap (fmap (mapMaybeTM f)) cletn+       , cm_letr = fmap (fmap (mapMaybeTM f)) cletr, cm_case = fmap (mapMaybeTM f) ccase+       , cm_ecase = fmap (mapMaybeTM f) cecase, cm_tick = fmap (mapMaybeTM f) ctick }+ -------------------------- lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a lookupCoreMap cm e = lookupTM e cm@@ -409,6 +424,7 @@    alterTM  = xtA emptyCME    foldTM   = fdA    filterTM = ftA+   mapMaybeTM = mpA  instance Eq (DeBruijn CoreAlt) where   D env1 a1 == D env2 a2 = go a1 a2 where@@ -446,3 +462,9 @@ fdA k m = foldTM k (am_deflt m)         . foldTM (foldTM k) (am_data m)         . foldTM (foldTM k) (am_lit m)++mpA :: (a -> Maybe b) -> AltMap a -> AltMap b+mpA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })+  = AM { am_deflt = mapMaybeTM f adeflt+       , am_data = fmap (mapMaybeTM f) adata+       , am_lit = fmap (mapMaybeTM f) alit }
compiler/GHC/Core/Map/Type.hs view
@@ -96,6 +96,7 @@    alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m)    foldTM k    (CoercionMap m) = foldTM k m    filterTM f  (CoercionMap m) = CoercionMap (filterTM f m)+   mapMaybeTM f (CoercionMap m) = CoercionMap (mapMaybeTM f m)  type CoercionMapG = GenMap CoercionMapX newtype CoercionMapX a = CoercionMapX (TypeMapX a)@@ -112,6 +113,7 @@   alterTM  = xtC   foldTM f (CoercionMapX core_tm) = foldTM f core_tm   filterTM f (CoercionMapX core_tm) = CoercionMapX (filterTM f core_tm)+  mapMaybeTM f (CoercionMapX core_tm) = CoercionMapX (mapMaybeTM f core_tm)  instance Eq (DeBruijn Coercion) where   D env1 co1 == D env2 co2@@ -189,6 +191,7 @@    alterTM  = xtT    foldTM   = fdT    filterTM = filterT+   mapMaybeTM = mpT  instance Eq (DeBruijn Type) where   (==) = eqDeBruijnType@@ -380,6 +383,7 @@    alterTM  = xtTyLit    foldTM   = foldTyLit    filterTM = filterTyLit+   mapMaybeTM = mpTyLit  emptyTyLitMap :: TyLitMap a emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM, tlm_char = Map.empty }@@ -407,6 +411,10 @@ filterTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc })   = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts, tlm_char = Map.filter f tc } +mpTyLit :: (a -> Maybe b) -> TyLitMap a -> TyLitMap b+mpTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc })+  = TLM { tlm_number = Map.mapMaybe f tn, tlm_string = mapMaybeUFM f ts, tlm_char = Map.mapMaybe f tc }+ ------------------------------------------------- -- | @TypeMap a@ is a map from 'Type' to @a@.  If you are a client, this -- is the type you want. The keys in this map may have different kinds.@@ -435,6 +443,7 @@     alterTM k f m = xtTT (deBruijnize k) f m     foldTM k (TypeMap m) = foldTM (foldTM k) m     filterTM f (TypeMap m) = TypeMap (fmap (filterTM f) m)+    mapMaybeTM f (TypeMap m) = TypeMap (fmap (mapMaybeTM f) m)  foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b foldTypeMap k z m = foldTM k m z@@ -479,6 +488,7 @@   alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m)   foldTM f (LooseTypeMap m) = foldTM f m   filterTM f (LooseTypeMap m) = LooseTypeMap (filterTM f m)+  mapMaybeTM f (LooseTypeMap m) = LooseTypeMap (mapMaybeTM f m)  {- ************************************************************************@@ -558,10 +568,13 @@    alterTM  = xtBndr emptyCME    foldTM   = fdBndrMap    filterTM = ftBndrMap+   mapMaybeTM = mpBndrMap  fdBndrMap :: (a -> b -> b) -> BndrMap a -> b -> b fdBndrMap f (BndrMap tm) = foldTM (foldTM f) tm +mpBndrMap :: (a -> Maybe b) -> BndrMap a -> BndrMap b+mpBndrMap f (BndrMap tm) = BndrMap (fmap (mapMaybeTM f) tm)  -- We need to use 'BndrMap' for 'Coercion', 'CoreExpr' AND 'Type', since all -- of these data types have binding forms.@@ -594,6 +607,7 @@    alterTM  = xtVar emptyCME    foldTM   = fdVar    filterTM = ftVar+   mapMaybeTM = mpVar  lkVar :: CmEnv -> Var -> VarMap a -> Maybe a lkVar env v@@ -619,9 +633,24 @@ ftVar f (VM { vm_bvar = bv, vm_fvar = fv })   = VM { vm_bvar = filterTM f bv, vm_fvar = filterTM f fv } +mpVar :: (a -> Maybe b) -> VarMap a -> VarMap b+mpVar f (VM { vm_bvar = bv, vm_fvar = fv })+  = VM { vm_bvar = mapMaybeTM f bv, vm_fvar = mapMaybeTM f fv }+ ------------------------------------------------- lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a lkDNamed n env = lookupDNameEnv env (getName n)  xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a xtDNamed tc f m = alterDNameEnv f m (getName tc)++mpT :: (a -> Maybe b) -> TypeMapX a -> TypeMapX b+mpT f (TM { tm_var  = tvar, tm_app = tapp, tm_tycon = ttycon+          , tm_forall = tforall, tm_tylit = tlit+          , tm_coerce = tcoerce })+  = TM { tm_var    = mapMaybeTM f tvar+       , tm_app    = fmap (mapMaybeTM f) tapp+       , tm_tycon  = mapMaybeTM f ttycon+       , tm_forall = fmap (mapMaybeTM f) tforall+       , tm_tylit  = mapMaybeTM f tlit+       , tm_coerce = tcoerce >>= f }
compiler/GHC/Core/Opt/Arity.hs view
@@ -7,6 +7,7 @@ -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}  -- | Arity and eta expansion module GHC.Core.Opt.Arity@@ -52,9 +53,9 @@ import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.DataCon-import GHC.Core.TyCon     ( tyConArity )+import GHC.Core.TyCon     ( TyCon, tyConArity, isInjectiveTyCon ) import GHC.Core.TyCon.RecWalk     ( initRecTc, checkRecTc )-import GHC.Core.Predicate ( isDictTy, isEvVar, isCallStackPredTy, isCallStackTy )+import GHC.Core.Predicate ( isDictTy, isEvId, isCallStackPredTy, isCallStackTy ) import GHC.Core.Multiplicity  -- We have two sorts of substitution:@@ -87,6 +88,8 @@ import GHC.Utils.Panic import GHC.Utils.Misc +import Data.List.NonEmpty ( nonEmpty )+import qualified Data.List.NonEmpty as NE import Data.Maybe( isJust )  {-@@ -1533,7 +1536,7 @@         -- See Note [Eta expanding through dictionaries]         -- See Note [Eta expanding through CallStacks] -    cheap_fun e = exprIsCheapX (myIsCheapApp sigs) e+    cheap_fun e = exprIsCheapX (myIsCheapApp sigs) False e  -- | A version of 'isCheapApp' that considers results from arity analysis. -- See Note [Arity analysis] for what's in the signature environment and why@@ -1599,23 +1602,22 @@         --      f x y = case x of { (a,b) -> e }         -- The difference is observable using 'seq'         ---arityType env (Case scrut bndr _ alts)-  | exprIsDeadEnd scrut || null alts-  = botArityType    -- Do not eta expand. See (1) in Note [Dealing with bottom]--  | not (pedanticBottoms env)  -- See (2) in Note [Dealing with bottom]-  , myExprIsCheap env scrut (Just (idType bndr))-  = alts_type+arityType env (Case scrut bndr _ altList)+  | not $ exprIsDeadEnd scrut, Just alts <- nonEmpty altList+  = let env' = delInScope env bndr+        arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs+        alts_type = foldr1 (andArityType env) (NE.map arity_type_alt alts)+    in if+      | not (pedanticBottoms env)  -- See (2) in Note [Dealing with bottom]+      , myExprIsCheap env scrut (Just (idType bndr))+       -> alts_type -  | exprOkForSpeculation scrut-  = alts_type+      | exprOkForSpeculation scrut+       -> alts_type -  | otherwise            -- In the remaining cases we may not push-  = addWork alts_type    -- evaluation of the scrutinee in-  where-    env' = delInScope env bndr-    arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs-    alts_type = foldr1 (andArityType env) (map arity_type_alt alts)+      | otherwise            -- In the remaining cases we may not push+       -> addWork alts_type -- evaluation of the scrutinee in+  | otherwise = botArityType    -- Do not eta expand. See (1) in Note [Dealing with bottom]  arityType env (Let (NonRec b rhs) e)   = -- See Note [arityType for non-recursive let-bindings]@@ -2258,7 +2260,7 @@ -- If                    e :: ty -- then   etaInfoApp e eis :: etaInfoApp ty eis etaInfoAppTy ty (EI bs mco)-  = applyTypeToArgs (text "etaInfoAppTy") ty1 (map varToCoreExpr bs)+  = applyTypeToArgs ty1 (map varToCoreExpr bs)   where     ty1 = case mco of              MRefl  -> ty@@ -2304,7 +2306,7 @@      go _ [] subst _        ----------- Done!  No more expansion needed-       = (getSubstInScope subst, EI [] MRefl)+       = (substInScopeSet subst, EI [] MRefl)      go n oss@(one_shot:oss1) subst ty        ----------- Forall types  (forall a. ty)@@ -2351,7 +2353,7 @@                          -- but its type isn't a function, or a binder                          -- does not have a fixed runtime representation        = warnPprTrace True "mkEtaWW" ((ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr)-         (getSubstInScope subst, EI [] MRefl)+         (substInScopeSet subst, EI [] MRefl)         -- This *can* legitimately happen:         -- e.g.  coerce Int (\x. x) Essentially the programmer is         -- playing fast and loose with types (Happy does this a lot).@@ -2789,7 +2791,7 @@          arity = idArity fun      ----------------    ok_lam v = isTyVar v || isEvVar v+    ok_lam v = isTyVar v || isEvId v     -- See Note [Eta reduction makes sense], point (2)      ---------------@@ -3020,14 +3022,14 @@     | otherwise     = Nothing -pushCoDataCon :: DataCon -> [CoreExpr] -> MCoercion+pushCoDataCon :: DataCon -> [CoreExpr] -> MCoercionR               -> Maybe (DataCon                        , [Type]      -- Universal type args                        , [CoreExpr]) -- All other args incl existentials -- Implement the KPush reduction rule as described in "Down with kinds" -- The transformation applies iff we have --      (C e1 ... en) `cast` co--- where co :: (T t1 .. tn) ~ to_ty+-- where co :: (T t1 .. tn) ~ (T s1 .. sn) -- The left-hand one must be a T, because exprIsConApp returned True -- but the right-hand one might not be.  (Though it usually will.) pushCoDataCon dc dc_args MRefl    = Just $! (push_dc_refl dc dc_args)@@ -3039,7 +3041,7 @@   where     !(univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args -push_dc_gen :: DataCon -> [CoreExpr] -> Coercion -> Pair Type+push_dc_gen :: DataCon -> [CoreExpr] -> CoercionR -> Pair Type             -> Maybe (DataCon, [Type], [CoreExpr]) push_dc_gen dc dc_args co (Pair from_ty to_ty)   | from_ty `eqType` to_ty  -- try cheap test first@@ -3052,44 +3054,54 @@         -- where S is a type function.  In fact, exprIsConApp         -- will probably not be called in such circumstances,         -- but there's nothing wrong with it+  = Just (push_data_con to_tc to_tc_arg_tys dc dc_args co Representational) -  = let-        tc_arity       = tyConArity to_tc-        dc_univ_tyvars = dataConUnivTyVars dc-        dc_ex_tcvars   = dataConExTyCoVars dc-        arg_tys        = dataConRepArgTys dc+  | otherwise+  = Nothing -        non_univ_args  = dropList dc_univ_tyvars dc_args-        (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args -        -- Make the "Psi" from the paper-        omegas = decomposeCo tc_arity co (tyConRolesRepresentational to_tc)-        (psi_subst, to_ex_arg_tys)-          = liftCoSubstWithEx Representational-                              dc_univ_tyvars-                              omegas-                              dc_ex_tcvars-                              (map exprToType ex_args)+push_data_con :: TyCon -> [Type] -> DataCon -> [CoreExpr]+              -> CoercionR -> Role                  -- Coercion and its role+              -> (DataCon, [Type], [CoreExpr])+push_data_con to_tc to_tc_arg_tys dc dc_args co role+  = assertPpr (eqType from_ty dc_app_ty)     dump_doc $+    assertPpr (equalLength val_args arg_tys) dump_doc $+    assertPpr (role == coercionRole co)      dump_doc $+    assertPpr (isInjectiveTyCon to_tc role)  dump_doc $+    -- isInjectiveTyCon: see (UCM9) in Note [Unary class magic]+    --                   in GHC.Core.TyCon+    (dc, to_tc_arg_tys, to_ex_args ++ new_val_args)+  where+    Pair from_ty to_ty = coercionKind co+    tc_arity       = tyConArity to_tc+    dc_univ_tyvars = dataConUnivTyVars dc+    dc_ex_tcvars   = dataConExTyCoVars dc+    arg_tys        = dataConRepArgTys dc -          -- Cast the value arguments (which include dictionaries)-        new_val_args = zipWith cast_arg (map scaledThing arg_tys) val_args-        cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty)+    dc_app_ty = mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) -        to_ex_args = map Type to_ex_arg_tys+    non_univ_args  = dropList dc_univ_tyvars dc_args+    (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args -        dump_doc = vcat [ppr dc,      ppr dc_univ_tyvars, ppr dc_ex_tcvars,-                         ppr arg_tys, ppr dc_args,-                         ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc-                         , ppr $ mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) ]-    in-    assertPpr (eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args))) dump_doc $-    assertPpr (equalLength val_args arg_tys) dump_doc $-    Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args)+    -- Make the "Psi" from the paper+    omegas = decomposeCo tc_arity co (tyConRolesX role to_tc)+    (psi_subst, to_ex_arg_tys)+      = liftCoSubstWithEx dc_univ_tyvars+                          omegas+                          dc_ex_tcvars+                          (map exprToType ex_args) -  | otherwise-  = Nothing+      -- Cast the value arguments (which include dictionaries)+    new_val_args = zipWith cast_arg (map scaledThing arg_tys) val_args+    cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty) +    to_ex_args = map Type to_ex_arg_tys +    dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars+                    , ppr arg_tys, ppr dc_args+                    , ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc+                    , ppr $ mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) ]+ collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr) -- Collect lambda binders, pushing coercions inside if possible -- E.g.   (\x.e) |> g         g :: <Int> -> blah@@ -3145,15 +3157,12 @@        | otherwise = (reverse bs, mkCast (Lam b e) co) -{---Note [collectBindersPushingCo]+{- Note [collectBindersPushingCo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We just look for coercions of form    <type> % w -> blah (and similarly for foralls) to keep this function simple.  We could do more elaborate stuff, but it'd involve substitution etc.- -}  {- *********************************************************************@@ -3246,7 +3255,7 @@       = (subst', eta_id')       where         Scaled mult' ty' = Type.substScaledTyUnchecked subst ty-        eta_id' = uniqAway (getSubstInScope subst) $+        eta_id' = uniqAway (substInScopeSet subst) $                   mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) mult' ty'                   -- "OrCoVar" since this can be used to eta-expand                   -- coercion abstractions
compiler/GHC/Core/Opt/CallerCC/Types.hs view
@@ -19,6 +19,7 @@ import GHC.Utils.Panic import qualified GHC.Utils.Binary as B import Data.Char+import Control.DeepSeq  import Language.Haskell.Syntax.Module.Name @@ -33,6 +34,11 @@   ppr (PWildcard rest) = char '*' <> ppr rest   ppr PEnd = Outputable.empty +instance NFData NamePattern where+  rnf (PChar c n) = rnf c `seq` rnf n+  rnf (PWildcard np) = rnf np+  rnf PEnd = ()+ instance B.Binary NamePattern where   get bh = do     tag <- B.get bh@@ -75,6 +81,9 @@     = CallerCcFilter { ccfModuleName  :: Maybe ModuleName                      , ccfFuncName    :: NamePattern                      }++instance NFData CallerCcFilter where+  rnf (CallerCcFilter mn n) = rnf mn `seq` rnf n  instance Outputable CallerCcFilter where   ppr ccf =
compiler/GHC/Core/Opt/ConstantFold.hs view
@@ -20,7 +20,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}  -- | Constant Folder module GHC.Core.Opt.ConstantFold@@ -55,7 +55,7 @@ import GHC.Core.Type import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.TyCon-   ( TyCon, tyConDataCons_maybe, tyConDataCons, tyConFamilySize+   ( TyCon, tyConDataCons_maybe, tyConDataCons, tyConSingleDataCon, tyConFamilySize    , isEnumerationTyCon, isValidDTT2TyCon, isNewTyCon ) import GHC.Core.Map.Expr ( eqCoreExpr ) @@ -69,7 +69,6 @@ import GHC.Cmm.Type ( Width(..) )  import GHC.Data.FastString-import GHC.Data.Maybe      ( orElse )  import GHC.Utils.Outputable import GHC.Utils.Misc@@ -1997,6 +1996,14 @@ generate calls in derived instances of Enum.  So we compromise: a rewrite rule rewrites a bad instance of tagToEnum# to an error call, and emits a warning.++We also do something similar if we can see that the argument of tagToEnum is out+of bounds, e.g. `tagToEnum# 99# :: Bool`.+Replacing this with an error expression is better for two reasons:+* It allow us to eliminate more dead code in cases like `case tagToEnum# 99# :: Bool of ...`+* Should we actually end up executing the relevant code at runtime the user will+  see a meaningful error message, instead of a segfault or incorrect result.+See #25976. -}  tagToEnumRule :: RuleM CoreExpr@@ -2008,9 +2015,13 @@     Just (tycon, tc_args) | isEnumerationTyCon tycon -> do       let tag = fromInteger i           correct_tag dc = (dataConTagZ dc) == tag-      (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])-      massert (null rest)-      return $ mkTyApps (Var (dataConWorkId dc)) tc_args+      Just dataCons <- pure $ tyConDataCons_maybe tycon+      case filter correct_tag dataCons of+        (dc:rest) -> do+          massert (null rest)+          pure $ mkTyApps (Var (dataConWorkId dc)) tc_args+        -- Literal is out of range, e.g. tagToEnum @Bool #4+        [] -> pure $ mkImpossibleExpr ty "tagToEnum: Argument out of range"      -- See Note [tagToEnum#]     _ -> warnPprTrace True "tagToEnum# on non-enumeration type" (ppr ty) $@@ -2059,7 +2070,7 @@        ; fn <- getFunction        ; let (_, ue) = splitForAllTyCoVars (idType fn)              tc      = tyConAppTyCon ue  -- tycon:    UnsafeEquality-             (dc:_)  = tyConDataCons tc  -- data con: UnsafeRefl+             dc      = tyConSingleDataCon tc  -- data con: UnsafeRefl              -- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r).              --               UnsafeEquality r a a        ; return (mkTyApps (Var (dataConWrapId dc)) [rep, t1]) }@@ -2635,6 +2646,13 @@ -------------------------------------------------------- -- Note [Constant folding through nested expressions] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- GHC has some support for constant folding through nested expressions (i.e.+-- when constants are not only arguments of the considered App node but to one+-- of its own argument (an App node too), see examples below).+--+-- For performance reason, this optimization is only enabled with -O1 and above.+-- As with all optimizations, it can also be independently enabled with its own+-- command-line flag too: -fnum-constant-folding (grep Opt_NumConstantFolding). -- -- We use rewrites rules to perform constant folding. It means that we don't -- have a global view of the expression we are trying to optimise. As a
compiler/GHC/Core/Opt/OccurAnal.hs view
@@ -37,7 +37,6 @@                           mkCastMCo, mkTicks ) import GHC.Core.Opt.Arity   ( joinRhsArity, isOneShotBndr ) import GHC.Core.Coercion-import GHC.Core.Predicate   ( isDictId ) import GHC.Core.Type import GHC.Core.TyCo.FVs    ( tyCoVarsOfMCo ) @@ -65,6 +64,7 @@ import GHC.Unit.Module( Module )  import Data.List (mapAccumL)+import Data.List.NonEmpty (NonEmpty (..))  {- ************************************************************************@@ -1026,14 +1026,14 @@ ----------------- occAnalNonRecRhs :: OccEnv -> TopLevelFlag -> ImpRuleEdges                 -> JoinPointHood -> Id -> CoreExpr-                 -> ([UsageDetails], Id, CoreExpr)+                 -> (NonEmpty UsageDetails, Id, CoreExpr) occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs   | null rules, null imp_rule_infos   =  -- Fast path for common case of no rules. This is only worth      -- 0.1% perf on average, but it's also only a line or two of code-    ( [adj_rhs_uds, adj_unf_uds],              final_bndr_no_rules,   final_rhs )+    ( adj_rhs_uds :| adj_unf_uds : [], final_bndr_no_rules, final_rhs )   | otherwise-  = (adj_rhs_uds : adj_unf_uds : adj_rule_uds, final_bndr_with_rules, final_rhs )+  = ( adj_rhs_uds :| adj_unf_uds : adj_rule_uds, final_bndr_with_rules, final_rhs )   where     --------- Right hand side ---------     -- For join points, set occ_encl to OccVanilla, via setTailCtxt.  If we have@@ -1804,7 +1804,7 @@ --   d) adjust each RHS's usage details according to --      the binder's (new) shotness and join-point-hood mkLoopBreakerNodes !env lvl body_uds details_s-  = WUD final_uds (zipWithEqual "mkLoopBreakerNodes" mk_lb_node details_s bndrs')+  = WUD final_uds (zipWithEqual mk_lb_node details_s bndrs')   where     WUD final_uds bndrs' = tagRecBinders lvl body_uds details_s @@ -2500,7 +2500,7 @@       -- For a non-soft tick scope, we can inline lambdas only, so we       -- abandon tail calls, and do markAllInsideLam too: usage_lam -      |  Breakpoint _ _ ids _ <- tickish+      | Breakpoint _ _ ids <- tickish       = -- Never substitute for any of the Ids in a Breakpoint         addManyOccs usage_lam (mkVarSet ids) @@ -3327,8 +3327,8 @@ (BS5) We have to apply the occ_bs_env substitution uniformly,       including to (local) rules and unfoldings. -(BS6) We must be very careful with dictionaries.-      See Note [Care with binder-swap on dictionaries]+(BS6) For interest (only),+      see Historical Note [Care with binder-swap on dictionaries]  Note [Case of cast] ~~~~~~~~~~~~~~~~~~~@@ -3338,9 +3338,13 @@ equation (2) in Note [Binder swap].  When we get to the inner case, we inline x, cancel the casts, and away we go. -Note [Care with binder-swap on dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This Note explains why we need isDictId in scrutOkForBinderSwap.+Historical Note [Care with binder-swap on dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note is now out-dated; it has been rendered irrelevant by+Note [Unary class magic] in GHC.Core.TyCon.  I'm leaving it here in+case we are every tempted to return to newtype classes.++This (historical) Note explains why we need isDictId in scrutOkForBinderSwap. Consider this tricky example (#21229, #21470):    class Sing (b :: Bool) where sing :: Bool@@ -3386,6 +3390,16 @@  Hence the subtle isDictId in scrutOkForBinderSwap. +Why this Note is now outdated.  Using Note [Unary class magic] in GHC.Core.TyCon+the program above becomes+  h = \ @(a :: Bool) ($dSing :: Sing a)+      case sing @a $dSing of (wild::Bool)+        True  -> f @'True $dSing+        False -> f @a     $dSing+so the issue of binder-swapping doesn't arise.++End of Historical Note.+ Note [Zap case binders in proxy bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ From the original@@ -3429,21 +3443,17 @@ -- If (scrutOkForBinderSwap e = DoBinderSwap v mco, then --    v = e |> mco -- See Note [Case of cast]--- See Note [Care with binder-swap on dictionaries]+-- See Historical Note [Care with binder-swap on dictionaries] -- -- We use this same function in SpecConstr, and Simplify.Iteration, -- when something binder-swap-like is happening-scrutOkForBinderSwap (Var v)    = DoBinderSwap v MRefl-scrutOkForBinderSwap (Cast (Var v) co)-  | not (isDictId v)             = DoBinderSwap v (MCo (mkSymCo co))-        -- Cast: see Note [Case of cast]-        -- isDictId: see Note [Care with binder-swap on dictionaries]-        -- The isDictId rejects a Constraint/Constraint binder-swap, perhaps-        -- over-conservatively. But I have never seen one, so I'm leaving-        -- the code as simple as possible. Losing the binder-swap in a-        -- rare case probably has very low impact.-scrutOkForBinderSwap (Tick _ e) = scrutOkForBinderSwap e  -- Drop ticks-scrutOkForBinderSwap _          = NoBinderSwap+scrutOkForBinderSwap e+  = case e of+      Tick _ e        -> scrutOkForBinderSwap e  -- Drop ticks+      Var v           -> DoBinderSwap v MRefl+      Cast (Var v) co -> DoBinderSwap v (MCo (mkSymCo co))+                         -- Cast: see Note [Case of cast]+      _               -> NoBinderSwap  lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id) -- See Note [The binder-swap substitution]
compiler/GHC/Core/Opt/Simplify/Env.hs view
@@ -8,14 +8,13 @@  module GHC.Core.Opt.Simplify.Env (         -- * The simplifier mode-        SimplMode(..), updMode,-        smPedanticBottoms, smPlatform,+        SimplMode(..), updMode, smPlatform,          -- * Environments         SimplEnv(..), pprSimplEnv,   -- Temp not abstract         seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle,         seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames,-        seOptCoercionOpts, sePedanticBottoms, sePhase, sePlatform, sePreInline,+        seOptCoercionOpts, sePhase, sePlatform, sePreInline,         seRuleOpts, seRules, seUnfoldingOpts,         mkSimplEnv, extendIdSubst, extendCvIdSubst,         extendTvSubst, extendCvSubst,@@ -25,13 +24,15 @@         getSimplRules, enterRecGroupRHSs,         reSimplifying, +        SimplEnvIS,  checkSimplEnvIS, pprBadSimplEnvIS,+         -- * Substitution results         SimplSR(..), mkContEx, substId, lookupRecBndr,          -- * Simplifying 'Id' binders         simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,         simplBinder, simplBinders,-        substTy, substTyVar, getSubst,+        substTy, substTyVar, getFullSubst, getTCvSubst,         substCo, substCoVar,          -- * Floats@@ -59,8 +60,9 @@ import GHC.Core.Rules.Config ( RuleOpts(..) ) import GHC.Core import GHC.Core.Utils+import GHC.Core.Subst( substExprSC ) import GHC.Core.Unfold-import GHC.Core.TyCo.Subst (emptyIdSubstEnv)+import GHC.Core.TyCo.Subst (emptyIdSubstEnv, mkSubst) import GHC.Core.Multiplicity( Scaled(..), mkMultMul ) import GHC.Core.Make            ( mkWildValBinder, mkCoreLet ) import GHC.Core.Type hiding     ( substTy, substTyVar, substTyVarBndr, substCo@@ -202,6 +204,19 @@                                -- See Note [Inline depth]     } +type SimplEnvIS = SimplEnv+     -- Invariant: the substitution is empty+     -- We want this SimplEnv for its InScopeSet and flags++checkSimplEnvIS :: SimplEnvIS -> Bool+-- Check the invariant for SimplEnvIS+checkSimplEnvIS (SimplEnv { seIdSubst = id_env, seTvSubst = tv_env, seCvSubst = cv_env })+  = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env++pprBadSimplEnvIS :: SimplEnvIS -> SDoc+-- Print a SimplEnv that fails checkSimplEnvIS+pprBadSimplEnvIS env = ppr (getFullSubst (seInScope env) env)+ seArityOpts :: SimplEnv -> ArityOpts seArityOpts env = sm_arity_opts (seMode env) @@ -235,9 +250,6 @@ seOptCoercionOpts :: SimplEnv -> OptCoercionOpts seOptCoercionOpts env = sm_co_opt_opts (seMode env) -sePedanticBottoms :: SimplEnv -> Bool-sePedanticBottoms env = smPedanticBottoms (seMode env)- sePhase :: SimplEnv -> CompilerPhase sePhase env = sm_phase (seMode env) @@ -292,9 +304,6 @@          where            pp_flag f s = ppUnless f (text "no") <+> s -smPedanticBottoms :: SimplMode -> Bool-smPedanticBottoms opts = ao_ped_bot (sm_arity_opts opts)- smPlatform :: SimplMode -> Platform smPlatform opts = roPlatform (sm_rule_opts opts) @@ -1265,33 +1274,47 @@ ************************************************************************ -} -getSubst :: SimplEnv -> Subst-getSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env })-  = mkTCvSubst in_scope tv_env cv_env+getTCvSubst :: SimplEnv -> Subst+getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env })+  = mkSubst in_scope emptyVarEnv tv_env cv_env +getFullSubst :: InScopeSet -> SimplEnv -> Subst+getFullSubst in_scope (SimplEnv { seIdSubst = id_env, seTvSubst = tv_env, seCvSubst = cv_env })+  = mk_full_subst in_scope tv_env cv_env id_env++mk_full_subst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> Subst+mk_full_subst in_scope tv_env cv_env id_env+  = mkSubst in_scope (mapVarEnv to_expr id_env) tv_env cv_env+  where+    to_expr :: SimplSR -> CoreExpr+    -- A tiresome impedence-matcher+    to_expr (DoneEx e _)           = e+    to_expr (DoneId v)             = Var v+    to_expr (ContEx tvs cvs ids e) = GHC.Core.Subst.substExprSC (mk_full_subst in_scope tvs cvs ids) e+ substTy :: HasDebugCallStack => SimplEnv -> Type -> Type-substTy env ty = Type.substTy (getSubst env) ty+substTy env ty = Type.substTy (getTCvSubst env) ty  substTyVar :: SimplEnv -> TyVar -> Type-substTyVar env tv = Type.substTyVar (getSubst env) tv+substTyVar env tv = Type.substTyVar (getTCvSubst env) tv  substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) substTyVarBndr env tv-  = case Type.substTyVarBndr (getSubst env) tv of+  = case Type.substTyVarBndr (getTCvSubst env) tv of         (Subst in_scope' _ tv_env' cv_env', tv')            -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv')  substCoVar :: SimplEnv -> CoVar -> Coercion-substCoVar env tv = Coercion.substCoVar (getSubst env) tv+substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv  substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar) substCoVarBndr env cv-  = case Coercion.substCoVarBndr (getSubst env) cv of+  = case Coercion.substCoVarBndr (getTCvSubst env) cv of         (Subst in_scope' _ tv_env' cv_env', cv')            -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')  substCo :: SimplEnv -> Coercion -> Coercion-substCo env co = Coercion.substCo (getSubst env) co+substCo env co = Coercion.substCo (getTCvSubst env) co  ------------------ substIdType :: SimplEnv -> Id -> Id@@ -1307,4 +1330,4 @@     no_free_vars = noFreeVarsOfType old_ty && noFreeVarsOfType old_w     subst = Subst in_scope emptyIdSubstEnv tv_env cv_env     old_ty = idType id-    old_w  = varMult id+    old_w  = idMult id
compiler/GHC/Core/Opt/Simplify/Iteration.hs view
@@ -8,7 +8,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiWayIf #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) where  import GHC.Prelude@@ -31,9 +30,6 @@ import GHC.Core.Coercion.Opt    ( optCoercion ) import GHC.Core.FamInstEnv      ( FamInstEnv, topNormaliseType_maybe ) import GHC.Core.DataCon-   ( DataCon, dataConWorkId, dataConRepStrictness-   , dataConRepArgTys, isUnboxedTupleDataCon-   , StrictnessMark (..), dataConWrapId_maybe ) import GHC.Core.Opt.Stats ( Tick(..) ) import GHC.Core.Ppr     ( pprCoreExpr ) import GHC.Core.Unfold@@ -72,6 +68,7 @@ import GHC.Utils.Misc  import Control.Monad+import Data.List.NonEmpty (NonEmpty (..))  {- The guts of the simplifier is in this module, but the driver loop for@@ -284,7 +281,7 @@   | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt)                                           old_bndr rhs env   = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}-    simplTrace "SimplBindr:inline-uncond" (ppr old_bndr) $+    simplTrace "SimplBindr:inline-uncond1" (ppr old_bndr) $     do { tick (PreInlineUnconditionally old_bndr)        ; return ( emptyFloats env, env' ) } @@ -802,8 +799,8 @@ makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd })   = do { (floats, e') <- makeTrivial env NotTopLevel dmd (fsLit "arg") e        ; return (floats, arg { as_arg = e' }) }-makeTrivialArg _ arg-  = return (emptyLetFloats, arg)  -- CastBy, TyArg+makeTrivialArg _ arg@(TyArg {})+  = return (emptyLetFloats, arg)  makeTrivial :: HasDebugCallStack             => SimplEnv -> TopLevelFlag -> Demand@@ -1162,14 +1159,14 @@            -> SimplM (SimplFloats, OutExpr)  simplExprF !env e !cont -- See Note [Bangs in the Simplifier]-  = {- pprTrace "simplExprF" (vcat-      [ ppr e-      , text "cont =" <+> ppr cont-      , text "inscope =" <+> ppr (seInScope env)-      , text "tvsubst =" <+> ppr (seTvSubst env)-      , text "idsubst =" <+> ppr (seIdSubst env)-      , text "cvsubst =" <+> ppr (seCvSubst env)-      ]) $ -}+  = -- pprTrace "simplExprF" (vcat+    --  [ ppr e+    --  , text "cont =" <+> ppr cont+    --  , text "inscope =" <+> ppr (seInScope env)+    --  , text "tvsubst =" <+> ppr (seTvSubst env)+    --  , text "idsubst =" <+> ppr (seIdSubst env)+    --  , text "cvsubst =" <+> ppr (seCvSubst env)+    --  ]) $     simplExprF1 env e cont  simplExprF1 :: HasDebugCallStack@@ -1182,7 +1179,7 @@     -- The (Type ty) case is handled separately by simplExpr     -- and by the other callers of simplExprF -simplExprF1 env (Var v)        cont = {-#SCC "simplIdF" #-} simplIdF env v cont+simplExprF1 env (Var v)        cont = {-#SCC "simplInId" #-} simplInId env v cont simplExprF1 env (Lit lit)      cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont simplExprF1 env (Tick t expr)  cont = {-#SCC "simplTick" #-} simplTick env t expr cont simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont@@ -1255,7 +1252,8 @@   | Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env     -- Because of the let-can-float invariant, it's ok to     -- inline freely, or to drop the binding if it is dead.-  = do { tick (PreInlineUnconditionally bndr)+  = do { simplTrace "SimplBindr:inline-uncond2" (ppr bndr) $+         tick (PreInlineUnconditionally bndr)        ; simplExprF env' body cont }    -- Now check for a join point.  It's better to do the preInlineUnconditionally@@ -1360,7 +1358,7 @@              -- See Note [Inline depth] in GHC.Core.Opt.Simplify.Env        ; seqCo opt_co `seq` return opt_co }   where-    subst = getSubst env+    subst = getTCvSubst env     opts  = seOptCoercionOpts env  -----------------------------------@@ -1463,8 +1461,8 @@     simplTickish env tickish-    | Breakpoint ext n ids modl <- tickish-          = Breakpoint ext n (mapMaybe (getDoneId . substId env) ids) modl+    | Breakpoint ext bid ids <- tickish+          = Breakpoint ext bid (mapMaybe (getDoneId . substId env) ids)     | otherwise = tickish    -- Push type application and coercion inside a tick@@ -1522,14 +1520,18 @@ -}  rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)--- At this point the substitution in the SimplEnv should be irrelevant;--- only the in-scope set matters-rebuild env expr cont-  = case cont of+rebuild env expr cont = rebuild_go (zapSubstEnv env) expr cont++rebuild_go :: SimplEnvIS -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)+-- SimplEnvIS: at this point the substitution in the SimplEnv is irrelevant;+-- only the in-scope set matters, plus the flags.+rebuild_go env expr cont+  = assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env) $+    case cont of       Stop {}          -> return (emptyFloats env, expr)-      TickIt t cont    -> rebuild env (mkTick t expr) cont+      TickIt t cont    -> rebuild_go env (mkTick t expr) cont       CastIt { sc_co = co, sc_opt = opt, sc_cont = cont }-        -> rebuild env (mkCast expr co') cont+        -> rebuild_go env (mkCast expr co') cont            -- NB: mkCast implements the (Coercion co |> g) optimisation         where           co' = optOutCoercion env co opt@@ -1538,20 +1540,20 @@         -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont        StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }-        -> rebuildCall env (addValArgTo fun expr fun_ty ) cont+        -> rebuildCall env (addValArgTo fun expr fun_ty) cont        StrictBind { sc_bndr = b, sc_body = body, sc_env = se                  , sc_cont = cont, sc_from = from_what }         -> completeBindX (se `setInScopeFromE` env) from_what b expr body cont        ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}-        -> rebuild env (App expr (Type ty)) cont+        -> rebuild_go env (App expr (Type ty)) cont        ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag                  , sc_cont = cont, sc_hole_ty = fun_ty }         -- See Note [Avoid redundant simplification]         -> do { (_, _, arg') <- simplLazyArg env dup_flag fun_ty Nothing se arg-              ; rebuild env (App expr arg') cont }+              ; rebuild_go env (App expr arg') cont }  completeBindX :: SimplEnv               -> FromWhat@@ -1661,7 +1663,7 @@ -}  -optOutCoercion :: SimplEnv -> OutCoercion -> Bool -> OutCoercion+optOutCoercion :: SimplEnvIS -> OutCoercion -> Bool -> OutCoercion -- See Note [Avoid re-simplifying coercions] optOutCoercion env co already_optimised   | already_optimised = co  -- See Note [Avoid re-simplifying coercions]@@ -1711,7 +1713,7 @@                                           , sc_dup = dup, sc_cont = tail                                           , sc_hole_ty = fun_ty })           | not opt  -- pushCoValArg duplicates the coercion, so optimise first-          = addCoerce (optOutCoercion env co opt) True cont+          = addCoerce (optOutCoercion (zapSubstEnv env) co opt) True cont            | Just (m_co1, m_co2) <- pushCoValArg co           , fixed_rep m_co1@@ -1749,7 +1751,8 @@           -- See Note [Representation polymorphism invariants] in GHC.Core           -- test: typecheck/should_run/EtaExpandLevPoly -simplLazyArg :: SimplEnv -> DupFlag+simplLazyArg :: SimplEnvIS              -- ^ Used only for its InScopeSet+             -> DupFlag              -> OutType                 -- ^ Type of the function applied to this arg              -> Maybe ArgInfo           -- ^ Just <=> This arg `ai` occurs in an app                                         --   `f a1 ... an` where we have ArgInfo on@@ -1829,18 +1832,22 @@              --      It's wrong to err in either direction              --      But fun_ty is an OutType, so is fully substituted -       ; if | isSimplified dup  -- Don't re-simplify if we've simplified it once-                                -- Including don't preInlineUnconditionally-                                -- See Note [Avoiding simplifying repeatedly]-            -> completeBindX env from_what bndr arg body cont--            | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se+       ; if | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se             , not (needsCaseBindingL arg_levity arg)               -- Ok to test arg::InExpr in needsCaseBinding because               -- exprOkForSpeculation is stable under simplification-            -> do { tick (PreInlineUnconditionally bndr)+            , not ( isSimplified dup &&  -- See (SR2) in Note [Avoiding simplifying repeatedly]+                    not (exprIsTrivial arg) &&+                    not (isDeadOcc (idOccInfo bndr)) )+            -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr) $+                    tick (PreInlineUnconditionally bndr)                   ; simplLam env' body cont } +            | isSimplified dup  -- Don't re-simplify if we've simplified it once+                                -- Including don't preInlineUnconditionally+                                -- See Note [Avoiding simplifying repeatedly]+            -> completeBindX env from_what bndr arg body cont+             | otherwise             -> simplNonRecE env from_what bndr (arg, arg_se) body cont } @@ -1997,15 +2004,22 @@ * We go to some efforts to avoid unnecessarily simplifying ApplyToVal,   in at least two places     - In simplCast/addCoerce, where we check for isReflCo-    - In rebuildCall we avoid simplifying arguments before we have to-      (see Note [Trying rewrite rules])+    - We sometimes try rewrite RULES befoe simplifying arguments;+      see Note [tryRules: plan (BEFORE)] -All that said /postInlineUnconditionally/ (called in `completeBind`) does-fire in the above (f BIG) situation.  See Note [Post-inline for single-use-things] in Simplify.Utils.  This certainly risks repeated simplification, but-in practice seems to be a small win.+Wrinkles: +(SR1) All that said /postInlineUnconditionally/ (called in `completeBind`) does+    fire in the above (f BIG) situation.  See Note [Post-inline for single-use+    things] in Simplify.Utils.  This certainly risks repeated simplification,+    but in practice seems to be a small win. +(SR2) When considering preInlineUnconditionally in `simpl_lam`, if the+   expression is trivial, or it is dead (the binder doesn't occur), then there+   is no danger of simplifying repeatedly. But there is a benefit: it can save+   a simplifier iteration.  So we check for that.++ ************************************************************************ *                                                                      *                      Join points@@ -2204,25 +2218,29 @@ We'll clone the inner \x, adding x->x' in the id_subst Then when we inline y, we must *not* replace x by x' in the inlined copy!! -Note [Fast path for data constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For applications of a data constructor worker, the full glory of+Note [Fast path for lazy data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For applications of a /lazy/ data constructor worker, the full glory of rebuildCall is a waste of effort; * They never inline, obviously * They have no rewrite rules-* They are not strict (see Note [Data-con worker strictness]-  in GHC.Core.DataCon)+* Lazy constructors don't need the `StrictArg` treatment. So it's fine to zoom straight to `rebuild` which just rebuilds the call in a very straightforward way. +For a data constructor worker that is strict (see Note [Strict fields in Core])+we take the slow path, so that we'll transform+  K (case x of (a,b) -> a)  -->   case x of (a,b) -> K a+via the StrictArg case of rebuildCall+ Some programs have a /lot/ of data constructors in the source program (compiler/perf/T9961 is an example), so this fast path can be very valuable. -} -simplVar :: SimplEnv -> InVar -> SimplM OutExpr+simplInVar :: SimplEnv -> InVar -> SimplM OutExpr -- Look up an InVar in the environment-simplVar env var+simplInVar env var   -- Why $! ? See Note [Bangs in the Simplifier]   | isTyVar var = return $! Type $! (substTyVar env var)   | isCoVar var = return $! Coercion $! (substCoVar env var)@@ -2233,10 +2251,11 @@         DoneId var1          -> return (Var var1)         DoneEx e _           -> return e -simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)-simplIdF env var cont-  | isDataConWorkId var         -- See Note [Fast path for data constructors]-  = rebuild env (Var var) cont+simplInId :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)+simplInId env var cont+  | Just dc <- isDataConWorkId_maybe var+  , isLazyDataConRep dc                    -- See Note [Fast path for lazy data constructors]+  = rebuild zapped_env (Var var) cont   | otherwise   = case substId env var of       ContEx tvs cvs ids e -> simplExprF env' e cont@@ -2245,113 +2264,39 @@         where           env' = setSubstEnv env tvs cvs ids -      DoneId var1 ->-        do { rule_base <- getSimplRules-           ; let cont' = trimJoinCont var1 (idJoinPointHood var1) cont-                 info  = mkArgInfo env rule_base var1 cont'-           ; rebuildCall env info cont' }+      DoneId out_id -> simplOutId zapped_env out_id cont'+        where+          cont' = trimJoinCont out_id (idJoinPointHood out_id) cont -      DoneEx e mb_join -> simplExprF env' e cont'+      DoneEx e mb_join -> simplExprF zapped_env e cont'         where           cont' = trimJoinCont var mb_join cont-          env'  = zapSubstEnv env  -- See Note [zapSubstEnv]--------------------------------------------------------------      Dealing with a call site--rebuildCall :: SimplEnv -> ArgInfo -> SimplCont-            -> SimplM (SimplFloats, OutExpr)------------ Bottoming applications ---------------rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont-  -- When we run out of strictness args, it means-  -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo-  -- Then we want to discard the entire strict continuation.  E.g.-  --    * case (error "hello") of { ... }-  --    * (error "Hello") arg-  --    * f (error "Hello") where f is strict-  --    etc-  -- Then, especially in the first of these cases, we'd like to discard-  -- the continuation, leaving just the bottoming expression.  But the-  -- type might not be right, so we may have to add a coerce.-  | not (contIsTrivial cont)     -- Only do this if there is a non-trivial-                                 -- continuation to discard, else we do it-                                 -- again and again!-  = seqType cont_ty `seq`        -- See Note [Avoiding space leaks in OutType]-    return (emptyFloats env, castBottomExpr res cont_ty)   where-    res     = argInfoExpr fun rev_args-    cont_ty = contResultType cont------------ Try inlining, if ai_rewrite = TryInlining ----------- In the TryInlining case we try inlining immediately, before simplifying--- any (more) arguments. Why?  See Note [Rewrite rules and inlining].------ If there are rewrite rules we'll skip this case until we have--- simplified enough args to satisfy nr_wanted==0 in the TryRules case below--- Then we'll try the rules, and if that fails, we'll do TryInlining-rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args-                              , ai_rewrite = TryInlining }) cont-  = do { logger <- getLogger-       ; let full_cont = pushSimplifiedRevArgs env rev_args cont-       ; mb_inline <- tryInlining env logger fun full_cont-       ; case mb_inline of-            Just expr -> do { checkedTick (UnfoldingDone fun)-                            ; let env1 = zapSubstEnv env-                            ; simplExprF env1 expr full_cont }-            Nothing -> rebuildCall env (info { ai_rewrite = TryNothing }) cont-       }------------ Try rewrite RULES, if ai_rewrite = TryRules ----------------- See Note [Rewrite rules and inlining]--- See also Note [Trying rewrite rules]-rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args-                              , ai_rewrite = TryRules nr_wanted rules }) cont-  | nr_wanted == 0 || no_more_args-  = -- We've accumulated a simplified call in <fun,rev_args>-    -- so try rewrite rules; see Note [RULES apply to simplified arguments]-    -- See also Note [Rules for recursive functions]-    do { mb_match <- tryRules env rules fun (reverse rev_args) cont-       ; case mb_match of-             Just (env', rhs, cont') -> simplExprF env' rhs cont'-             Nothing -> rebuildCall env (info { ai_rewrite = TryInlining }) cont }-  where-    -- If we have run out of arguments, just try the rules; there might-    -- be some with lower arity.  Casts get in the way -- they aren't-    -- allowed on rule LHSs-    no_more_args = case cont of-                      ApplyToTy  {} -> False-                      ApplyToVal {} -> False-                      _             -> True------------ Simplify type applications and casts ---------------rebuildCall env info (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont })-  = rebuildCall env (addCastTo info co') cont-  where-    co' = optOutCoercion env co opt+    zapped_env =  zapSubstEnv env  -- See Note [zapSubstEnv] -rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont })-  = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont+---------------------------------------------------------+simplOutId :: SimplEnvIS -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) ----------- The runRW# rule. Do this after absorbing all arguments ------+---------- The runRW# rule ------ -- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep. -- -- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o--- K[ runRW# rr ty body ]   -->   runRW rr' ty' (\s. K[ body s ])-rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })-            (ApplyToVal { sc_arg = arg, sc_env = arg_se-                        , sc_cont = cont, sc_hole_ty = fun_ty })-  | fun_id `hasKey` runRWKey-  , [ TyArg { as_arg_ty = hole_ty }, TyArg {} ] <- rev_args+-- K[ runRW# @rr @hole_ty body ]   -->   runRW @rr' @ty' (\s. K[ body s ])+simplOutId env fun cont+  | fun `hasKey` runRWKey+  , ApplyToTy  { sc_cont = cont1 } <- cont+  , ApplyToTy  { sc_cont = cont2, sc_arg_ty = hole_ty } <- cont1+  , ApplyToVal { sc_cont = cont3, sc_arg = arg+               , sc_env = arg_se, sc_hole_ty = fun_ty } <- cont2   -- Do this even if (contIsStop cont), or if seCaseCase is off.   -- See Note [No eta-expansion in runRW#]   = do { let arg_env = arg_se `setInScopeFromE` env -             overall_res_ty  = contResultType cont+             overall_res_ty = contResultType cont3              -- hole_ty is the type of the current runRW# application              (outer_cont, new_runrw_res_ty, inner_cont)-                | seCaseCase env = (mkBoringStop overall_res_ty, overall_res_ty, cont)-                | otherwise      = (cont, hole_ty, mkBoringStop hole_ty)+                | seCaseCase env = (mkBoringStop overall_res_ty, overall_res_ty, cont3)+                | otherwise      = (cont3, hole_ty, mkBoringStop hole_ty)                 -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify                 --    Note [Case-of-case and full laziness] @@ -2378,9 +2323,76 @@                    ; return (Lam s' body') }         ; let rr'   = getRuntimeRep new_runrw_res_ty-             call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg']+             call' = mkApps (Var fun) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg']        ; rebuild env call' outer_cont } +-- Normal case for (f e1 .. en)+simplOutId env fun cont+  = -- Try rewrite rules: Plan (BEFORE) in Note [When to apply rewrite rules]+    do { rule_base <- getSimplRules+       ; let rules_for_me = getRules rule_base fun+             out_args     = contOutArgs env cont :: [OutExpr]+       ; mb_match <- if not (null rules_for_me) &&+                        (isClassOpId fun || activeUnfolding (seMode env) fun)+                     then tryRules env rules_for_me fun out_args+                     else return Nothing+       ; case mb_match of {+             Just (rule_arity, rhs) -> simplExprF env rhs $+                                       dropContArgs rule_arity cont ;+             Nothing ->++    -- Try inlining+    do { logger <- getLogger+       ; mb_inline <- tryInlining env logger fun cont+       ; case mb_inline of{+            Just expr -> do { checkedTick (UnfoldingDone fun)+                            ; simplExprF env expr cont } ;+            Nothing ->++    -- Neither worked, so just rebuild+    do { let arg_info = mkArgInfo env fun rules_for_me cont+       ; rebuildCall env arg_info cont+    } } } } }++---------------------------------------------------------+--      Dealing with a call site++rebuildCall :: SimplEnvIS -> ArgInfo -> SimplCont+            -> SimplM (SimplFloats, OutExpr)+-- SimplEnvIS: at this point the substitution in the SimplEnv is irrelevant;+-- it is usually empty, and regardless should be ignored.+-- Only the in-scope set matters, plus the seMode flags++-- Check the invariant+rebuildCall env arg_info _cont+  | assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env $$ ppr arg_info) False+  = pprPanic "rebuildCall" empty++---------- Bottoming applications --------------+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont+  -- When we run out of strictness args, it means+  -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo+  -- Then we want to discard the entire strict continuation.  E.g.+  --    * case (error "hello") of { ... }+  --    * (error "Hello") arg+  --    * f (error "Hello") where f is strict+  --    etc+  -- Then, especially in the first of these cases, we'd like to discard+  -- the continuation, leaving just the bottoming expression.  But the+  -- type might not be right, so we may have to add a coerce.+  | not (contIsTrivial cont)     -- Only do this if there is a non-trivial+                                 -- continuation to discard, else we do it+                                 -- again and again!+  = seqType cont_ty `seq`        -- See Note [Avoiding space leaks in OutType]+    return (emptyFloats env, castBottomExpr res cont_ty)+  where+    res     = argInfoExpr fun rev_args+    cont_ty = contResultType cont++---------- Simplify type applications --------------+rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont })+  = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont+ ---------- Simplify value arguments -------------------- rebuildCall env fun_info             (ApplyToVal { sc_arg = arg, sc_env = arg_se@@ -2411,8 +2423,16 @@         ; rebuildCall env (addValArgTo fun_info  arg' fun_ty) cont }  ---------- No further useful info, revert to generic rebuild -------------rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont+  | null rules   = rebuild env (argInfoExpr fun rev_args) cont+  | otherwise  -- Try rules again: Plan (AFTER) in Note [When to apply rewrite rules]+  = do { let args = reverse rev_args+       ; mb_match <- tryRules env rules fun (map argSpecArg args)+       ; case mb_match of+           Just (rule_arity, rhs) -> simplExprF env rhs $+                                     pushSimplifiedArgs env (drop rule_arity args) cont+           Nothing -> rebuild env (argInfoExpr fun rev_args) cont }  ----------------------------------- tryInlining :: SimplEnv -> Logger -> OutId -> SimplCont -> SimplM (Maybe OutExpr)@@ -2446,83 +2466,102 @@                               text "Cont:  " <+> ppr cont])]  -{- Note [Trying rewrite rules]+{- Note [When to apply rewrite rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should we apply rewrite rules before simplifying the arguments, or after?+Each is highly desirable in some cases, and in fact we do both!++  - Plan (BEFORE) selectively, in `simplOutId`+    See Note [tryRules: plan (BEFORE)]++  - Plan (AFTER) always, in the finishing-up case of `rebuildCall`+    See Note [tryRules: plan (AFTER)]++Historical note.  Pre-2025, GHC only did tryRules once, when it had simplified+enough arguments to saturate all the RULEs it had in hand.  But alas, if a new+unrelated RULE showed up (but did not fire), it could nevertheless change the+simplifier's behaviour a bit; and that messed up deterministic compilation+(#25170).  (This was particularly nasty if the rule wasn't even transitively+below the module being compiled.)  Current solution: ensure that adding a new,+unrelated rule that never fires does not change the simplifier behaviour.  End+of historical note.++Note [tryRules: plan (BEFORE)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet-simplified.  We want to simplify enough arguments to allow the rules-to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone-is sufficient.  Example: class ops-   (+) dNumInt e2 e3-If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the-latter's strictness when simplifying e2, e3.  Moreover, suppose we have-  RULE  f Int = \x. x True+It is sometimes desirable to apply RULES before simplifying the function+arguments.  We do so in `simplOutId`. -Then given (f Int e1) we rewrite to-   (\x. x True) e1-without simplifying e1.  Now we can inline x into its unique call site,-and absorb the True into it all in the same pass.  If we simplified-e1 first, we couldn't do that; see Note [Avoiding simplifying repeatedly].+We do so /selectively/ (see (BF2)), in two particular cases: -So we try to apply rules if either-  (a) no_more_args: we've run out of argument that the rules can "see"-  (b) nr_wanted: none of the rules wants any more arguments+* Class ops+     (+) dNumInt e2 e3+  If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the+  latter's strictness when simplifying e2, e3.  Moreover, if+      (+) dNumInt e2 e3   -->    (\x y -> ....) e2 e3+  Frequently `x` is used just once in the body of the (\x y -> ...).+  If `e2` is un-simplified we can preInlineUnconditinally and that saves+  simplifying `e2` twice. See Note [Avoiding simplifying repeatedly]. +* Specialisation RULES.  In general we try to arrange that inlining is disabled+  (via a pragma) if a rewrite rule should apply, so that the rule has a decent+  chance to fire before we inline the function. -Note [RULES apply to simplified arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's very desirable to try RULES once the arguments have been simplified, because-doing so ensures that rule cascades work in one pass.  Consider-   {-# RULES g (h x) = k x-             f (k x) = x #-}-   ...f (g (h x))...-Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If-we match f's rules against the un-simplified RHS, it won't match.  This-makes a particularly big difference when superclass selectors are involved:-        op ($p1 ($p2 (df d)))-We want all this to unravel in one sweep.+  But it turns out that (especially when type-class specialisation or+  SpecConstr is involved) it is very helpful for the the rewrite rule to+  "win" over inlining when both are active at once: see #21851, #22097. -Note [Rewrite rules and inlining]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In general we try to arrange that inlining is disabled (via a pragma) if-a rewrite rule should apply, so that the rule has a decent chance to fire-before we inline the function.+  So if the Id has an unfolding, we want to try RULES before we try inlining. -But it turns out that (especially when type-class specialisation or-SpecConstr is involved) it is very helpful for the the rewrite rule to-"win" over inlining when both are active at once: see #21851, #22097.+Wrinkles: -The simplifier arranges to do this, as follows. In effect, the ai_rewrite-field of the ArgInfo record is the state of a little state-machine:+(BF1) Each un-simplified argument has its own static environment, stored+  in its `ApplyToVal` nodes.   So we can't just match on the un-simplified+  arguments: we  have to apply that static environment as a substitution+  first!  This is done lazily in `GHC.Core.Opt.Simplify.Utils.contOutArgs`,+  so it'll be done just enough to allow the rule to match, or not. -* mkArgInfo sets the ai_rewrite field to TryRules if there are any rewrite-  rules avaialable for that function.+(BF2) The "selectively" in Plan (BEFORE) is a bit ad-hoc: -* rebuildCall simplifies arguments until enough are simplified to match the-  rule with greatest arity.  See Note [RULES apply to simplified arguments]-  and the first field of `TryRules`.+  * We want Plan (BEFORE) for class ops (see above in this Note) -  But no more! As soon as we have simplified enough arguments to satisfy the-  maximum-arity rules, we try the rules; see Note [Trying rewrite rules].+  * But we do NOT want Plan (BEFORE) for primops, because the constant-folding+    rules are quite complicated and expensive, and we don't want to try them+    twice.  Moreover the benefts of Plan (BEFORE), described in the Note, don't+    apply to primops. -* Once we have tried rules (or immediately if there are no rules) set-  ai_rewrite to TryInlining, and the Simplifier will try to inline the-  function.  We want to try this immediately (before simplifying any (more)-  arguments). Why? Consider-      f BIG      where   f = \x{OneOcc}. ...x...-  If we inline `f` before simplifying `BIG` well use preInlineUnconditionally,-  and we'll simplify BIG once, at x's occurrence, rather than twice.+Note [tryRules: plan (AFTER)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very desirable to try RULES once the arguments have been simplified,+because doing so ensures that rule cascades work in one pass. We do this+in the finishing-up case of `rebuildCall`. -* GHC.Core.Opt.Simplify.Utils. mkRewriteCall: if there are no rules, and no-  unfolding, we can skip both TryRules and TryInlining, which saves work.+Consider+   {-# RULES g (h x) = k x+             f (k x) = x #-}+   ...f (g (h x))...+Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If+we match f's rules against the un-simplified RHS, it won't match.  This+makes a particularly big difference for +* Superclass selectors+        op ($p1 ($p2 (df d)))+  We want all this to unravel in one sweep++* Constant folding+        +# 3# (+# 4# 5#)+  We want this to happen in one pass+ Note [Avoid redundant simplification] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Because RULES apply to simplified arguments, there's a danger of repeatedly-simplifying already-simplified arguments.  An important example is that of-        (>>=) d e1 e2-Here e1, e2 are simplified before the rule is applied, but don't really-participate in the rule firing. So we mark them as Simplified to avoid-re-simplifying them.+Because RULES often apply to simplified arguments (see Note [Plan (AFTER)]),+there's a danger of simplifying already-simplified arguments.  For example,+suppose we have+   RULE f (x,y) = $sf x  y+and the expression+   f (p,q) e1 e2+With Plan (AFTER) by the time the rule fires, we will have already simplified e1, e2,+and we want to avoid doing so a second time.  So ApplyToVal records if the argument+is already Simplified.  Note [Shadowing in the Simplifier] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2572,33 +2611,19 @@ -}  tryRules :: SimplEnv -> [CoreRule]-         -> Id-         -> [ArgSpec]   -- In /normal, forward/ order-         -> SimplCont-         -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))--tryRules env rules fn args call_cont-  | null rules-  = return Nothing+         -> OutId -> [OutExpr]+         -> SimplM (Maybe (FullArgCount, CoreExpr)) -  | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env)-                                        (activeRule (seMode env)) fn-                                        (argInfoAppArgs args) rules+tryRules env rules fn args+  | Just (rule, rule_rhs) <- lookupRule ropts in_scope_env+                                        act_fun fn args rules   -- Fire a rule for the function   = do { logger <- getLogger        ; checkedTick (RuleFired (ruleName rule))-       ; let cont' = pushSimplifiedArgs zapped_env-                                        (drop (ruleArity rule) args)-                                        call_cont-                     -- (ruleArity rule) says how-                     -- many args the rule consumed--             occ_anald_rhs = occurAnalyseExpr rule_rhs+       ; let occ_anald_rhs = occurAnalyseExpr rule_rhs                  -- See Note [Occurrence-analyse after rule firing]        ; dump logger rule rule_rhs-       ; return (Just (zapped_env, occ_anald_rhs, cont')) }-            -- The occ_anald_rhs and cont' are all Out things-            -- hence zapping the environment+       ; return (Just (ruleArity rule, occ_anald_rhs)) }    | otherwise  -- No rule fires   = do { logger <- getLogger@@ -2606,8 +2631,9 @@        ; return Nothing }    where-    ropts      = seRuleOpts env-    zapped_env = zapSubstEnv env  -- See Note [zapSubstEnv]+    ropts        = seRuleOpts env :: RuleOpts+    in_scope_env = getUnfoldingInRuleMatch env :: InScopeEnv+    act_fun      = activeRule (seMode env) :: Activation -> Bool      printRuleModule rule       = parens (maybe (text "BUILTIN")@@ -2619,10 +2645,9 @@       = log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat           [ text "Rule:" <+> ftext (ruleName rule)           , text "Module:" <+>  printRuleModule rule+          , text "Full arity:" <+>  ppr (ruleArity rule)           , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))-          , text "After: " <+> hang (pprCoreExpr rule_rhs) 2-                               (sep $ map ppr $ drop (ruleArity rule) args)-          , text "Cont:  " <+> ppr call_cont ]+          , text "After: " <+> pprCoreExpr rule_rhs ]        | logHasDumpFlag logger Opt_D_dump_rule_firings       = log_rule Opt_D_dump_rule_firings "Rule fired:" $@@ -2654,13 +2679,23 @@ trySeqRules :: SimplEnv             -> OutExpr -> InExpr   -- Scrutinee and RHS             -> SimplCont-            -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))+            -> SimplM (Maybe (CoreExpr, SimplCont)) -- See Note [User-defined RULES for seq]+-- `in_env` applies to `rhs :: InExpr` but not to `scrut :: OutExpr` trySeqRules in_env scrut rhs cont   = do { rule_base <- getSimplRules-       ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont }+       ; let seq_rules = getRules rule_base seqId+       ; mb_match <- tryRules in_env seq_rules seqId out_args+       ; case mb_match of+            Nothing                -> return Nothing+            Just (rule_arity, rhs) -> return (Just (rhs, cont'))+                where+                  cont' = pushSimplifiedArgs in_env (drop rule_arity out_arg_specs) rule_cont+       }   where     no_cast_scrut = drop_casts scrut++    -- All these are OutTypes     scrut_ty  = exprType no_cast_scrut     seq_id_ty = idType seqId                    -- forall r a (b::TYPE r). a -> b -> b     res1_ty   = piResultTy seq_id_ty rhs_rep    -- forall a (b::TYPE rhs_rep). a -> b -> b@@ -2669,21 +2704,23 @@     res4_ty   = funResultTy res3_ty             -- rhs_ty -> rhs_ty     rhs_ty    = substTy in_env (exprType rhs)     rhs_rep   = getRuntimeRep rhs_ty-    out_args  = [ TyArg { as_arg_ty  = rhs_rep++    out_args = [Type rhs_rep, Type scrut_ty, Type rhs_ty, no_cast_scrut]+               -- Cheaper than (map argSpecArg out_arg_specs)+    out_arg_specs  = [ TyArg { as_arg_ty  = rhs_rep                         , as_hole_ty = seq_id_ty }-                , TyArg { as_arg_ty  = scrut_ty-                        , as_hole_ty = res1_ty }-                , TyArg { as_arg_ty  = rhs_ty-                        , as_hole_ty = res2_ty }-                , ValArg { as_arg = no_cast_scrut-                         , as_dmd = seqDmd-                         , as_hole_ty = res3_ty } ]+                     , TyArg { as_arg_ty  = scrut_ty+                             , as_hole_ty = res1_ty }+                     , TyArg { as_arg_ty  = rhs_ty+                             , as_hole_ty = res2_ty }+                     , ValArg { as_arg = no_cast_scrut+                              , as_dmd = seqDmd+                              , as_hole_ty = res3_ty } ]     rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs                            , sc_env = in_env, sc_cont = cont                            , sc_hole_ty = res4_ty }      -- Lazily evaluated, so we don't do most of this-     drop_casts (Cast e _) = drop_casts e     drop_casts e          = e @@ -3159,8 +3196,8 @@   | is_plain_seq   = do { mb_rule <- trySeqRules env scrut rhs cont        ; case mb_rule of-           Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont'-           Nothing                      -> reallyRebuildCase env scrut case_bndr alts cont }+           Just (rule_rhs, cont') -> simplExprF (zapSubstEnv env) rule_rhs cont'+           Nothing                -> reallyRebuildCase env scrut case_bndr alts cont }  -------------------------------------------------- --      3. Primop-related case-rules@@ -3211,7 +3248,7 @@                             --    Note [Case-of-case and full laziness]   = do { case_expr <- simplAlts env scrut case_bndr alts                                 (mkBoringStop (contHoleType cont))-       ; rebuild env case_expr cont }+       ; rebuild (zapSubstEnv env) case_expr cont }    | otherwise   = do { (floats, env', cont') <- mkDupableCaseCont env alts cont@@ -3461,7 +3498,7 @@  We really must record that b is already evaluated so that we don't go and re-evaluate it when constructing the result.-See Note [Data-con worker strictness] in GHC.Core.DataCon+See Note [Strict fields in Core] in GHC.Core.  NB: simplLamBndrs preserves this eval info @@ -3724,7 +3761,7 @@       | exprIsTrivial scrut = return (emptyFloats env                                      , extendIdSubst env bndr (DoneEx scrut NotJoinPoint))                               -- See Note [Do not duplicate constructor applications]-      | otherwise           = do { dc_args <- mapM (simplVar env) bs+      | otherwise           = do { dc_args <- mapM (simplInVar env) bs                                          -- dc_ty_args are already OutTypes,                                          -- but bs are InBndrs                                  ; let con_app = Var (dataConWorkId dc)@@ -3815,13 +3852,17 @@                                        --   extra let/join-floats and in-scope variables                         , SimplCont)   -- dup_cont: duplicable continuation mkDupableCont env cont-  = mkDupableContWithDmds env (repeat topDmd) cont+  = mkDupableContWithDmds (zapSubstEnv env) (repeat topDmd) cont  mkDupableContWithDmds-   :: SimplEnv  -> [Demand]  -- Demands on arguments; always infinite+   :: SimplEnvIS  -> [Demand]  -- Demands on arguments; always infinite    -> SimplCont -> SimplM ( SimplFloats, SimplCont)  mkDupableContWithDmds env _ cont+  -- Check the invariant+  | assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env) False+  = pprPanic "mkDupableContWithDmds" empty+   | contIsDupable cont   = return (emptyFloats env, cont) @@ -3864,7 +3905,7 @@   , thumbsUpPlanA cont   = -- Use Plan A of Note [Duplicating StrictArg] --    pprTrace "Using plan A" (ppr (ai_fun fun) $$ text "args" <+> ppr (ai_args fun) $$ text "cont" <+> ppr cont) $-    do { let (_ : dmds) = ai_dmds fun+    do { let _ :| dmds = expectNonEmpty $ ai_dmds fun        ; (floats1, cont')  <- mkDupableContWithDmds env dmds cont                               -- Use the demands from the function to add the right                               -- demand info on any bindings we make for further args@@ -3910,7 +3951,7 @@         --              let a = ...arg...         --              in [...hole...] a         -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable-    do  { let (dmd:cont_dmds) = dmds   -- Never fails+    do  { let dmd:|cont_dmds = expectNonEmpty dmds         ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont         ; let env' = env `setInScopeFromF` floats1         ; (_, se', arg') <- simplLazyArg env' dup hole_ty Nothing se arg@@ -3985,7 +4026,7 @@   | otherwise   = do { join_bndr <- newJoinId [arg_bndr] res_ty        ; let arg_info = ArgInfo { ai_fun   = join_bndr-                                , ai_rewrite = TryNothing, ai_args  = []+                                , ai_rules = [], ai_args  = []                                 , ai_encl  = False, ai_dmds  = repeat topDmd                                 , ai_discs = repeat 0 }        ; return ( addJoinFloats (emptyFloats env) $@@ -4170,17 +4211,40 @@       K g y -> blah[g,y]  But now we have to make `blah` into a join point, /abstracted/-over `g` and `y`.   In contrast, if we /don't/ inline $j we-don't need a join point for `blah` and we'll get-    join $j x = let g=f, y=x in blah[g,y]+over `g` and `y`. We get+    join $j2 g y = blah     in case v of-       p1 -> $j x1-       p2 -> $j x2-       p3 -> $j x3+         p1 -> $j2 f x1+         p2 -> $j2 f x2+         p3 -> $j2 f x3+So now we can't see that `g` is always `f` in `blah`. +In contrast, if we /don't/ inline $j we+don't need a new join point for `blah` and we'll get+    join $j' x = let g=f, y=x in blah[g,y]+    in case v of+       p1 -> $j' x1+       p2 -> $j' x2+       p3 -> $j' x3+ This can make a /massive/ difference, because `blah` can see what `f` is, instead of lambda-abstracting over it. +If instead the RHS of the join point is a simple application that has no free+variables, as in++    case (join $j x f = K f x )+         (in case v of      )+         (     p1 -> $j x1 f1 ) of+         (     p2 -> $j x2 f2 )+         (     p3 -> $j x3 f3 )+      K g y -> blah[g,y]++then no information can be gained by preserving the join point (c.f. `f` being+free in the join point above and being useful to `blah`). In this case, it's+more beneficial to inline the join point (see (DJ3)(c)) to allow further+optimisations to fire. An example where failing to do this went wrong is #25723.+ Beyond this, not-inlining join points reduces duplication.  In the above example, if `blah` was small enough we'd inline it, but that duplicates code, for no gain.  Best just to keep not-inline the join point in the first place.@@ -4205,11 +4269,26 @@    case-of-case friendly.  (DJ3) When should `uncondInlineJoin` return True?-   * (exprIsTrivial rhs); this includes uses of unsafeEqualityProof etc; see+   (a) (exprIsTrivial rhs); this includes uses of unsafeEqualityProof etc; see      the defn of exprIsTrivial.  Also nullary constructors. -   * The RHS is a call ($j x y z), where the arguments are all trivial and $j+   (b) The RHS is a call ($j x y z), where the arguments are all trivial and $j      is a join point: there is no point in creating an indirection.++   (c) The RHS is a data constructor application (K x y z) where++      - all the args x,y,z are trivial+      - the free LocalIds of `f x y z` are a subset of the join point binders++      Examples that return True+        $j x y = K y (x |> co)+        $j x y = x (y @Int)+      Examples that return False+        $j x = K y x    -- y is free+        $j y = f y      -- f is free++      Not duplicating these join points has no benefits and blocks other important+      optimisations from firing (see #25723)  (DJ4) By the same token we want to use Plan B in Note [Duplicating StrictArg] when    the RHS of the new join point is a data constructor application.  See the
compiler/GHC/Core/Opt/Simplify/Utils.hs view
@@ -25,15 +25,15 @@         isSimplified, contIsStop,         contIsDupable, contResultType, contHoleType, contHoleScaling,         contIsTrivial, contArgs, contIsRhs,-        countArgs,+        countArgs, contOutArgs, dropContArgs,         mkBoringStop, mkRhsStop, mkLazyArgStop,         interestingCallContext,          -- ArgInfo-        ArgInfo(..), ArgSpec(..), RewriteCall(..), mkArgInfo,-        addValArgTo, addCastTo, addTyArgTo,-        argInfoExpr, argInfoAppArgs,-        pushSimplifiedArgs, pushSimplifiedRevArgs,+        ArgInfo(..), ArgSpec(..), mkArgInfo,+        addValArgTo, addTyArgTo,+        argInfoExpr, argSpecArg,+        pushSimplifiedArgs,         isStrictArgInfo, lazyArgContext,          abstractFloats,@@ -55,7 +55,6 @@ import GHC.Core.TyCo.Ppr ( pprParendType ) import GHC.Core.FVs import GHC.Core.Utils-import GHC.Core.Rules( RuleEnv, getRules ) import GHC.Core.Opt.Arity import GHC.Core.Unfold import GHC.Core.Unfold.Make@@ -284,7 +283,7 @@   ppr (ApplyToTy  { sc_arg_ty = ty, sc_cont = cont })     = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont   ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty })-    = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole" <+> ppr hole_ty)+    = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole-ty:" <+> pprParendType hole_ty)           2 (pprParendExpr arg))       $$ ppr cont   ppr (StrictBind { sc_bndr = b, sc_cont = cont })@@ -324,11 +323,10 @@   = ArgInfo {         ai_fun   :: OutId,      -- The function         ai_args  :: [ArgSpec],  -- ...applied to these args (which are in *reverse* order)--        ai_rewrite :: RewriteCall,  -- What transformation to try next for this call-             -- See Note [Rewrite rules and inlining] in GHC.Core.Opt.Simplify.Iteration+                                -- NB: all these argumennts are already simplified -        ai_encl :: Bool,        -- Flag saying whether this function+        ai_rules :: [CoreRule], -- Rules for this function+        ai_encl  :: Bool,       -- Flag saying whether this function                                 -- or an enclosing one has rules (recursively)                                 --      True => be keener to inline in all args @@ -342,12 +340,6 @@                                 --   Always infinite     } -data RewriteCall  -- What rewriting to try next for this call-                  -- See Note [Rewrite rules and inlining] in GHC.Core.Opt.Simplify.Iteration-  = TryRules FullArgCount [CoreRule]-  | TryInlining-  | TryNothing- data ArgSpec   = ValArg { as_dmd  :: Demand        -- Demand placed on this argument            , as_arg  :: OutExpr       -- Apply to this (coercion or value); c.f. ApplyToVal@@ -356,62 +348,46 @@   | TyArg { as_arg_ty  :: OutType     -- Apply to this type; c.f. ApplyToTy           , as_hole_ty :: OutType }   -- Type of the function (presumably forall a. blah) -  | CastBy OutCoercion                -- Cast by this; c.f. CastIt-                                      -- Coercion is optimised- instance Outputable ArgInfo where-  ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds })+  ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds, ai_rules = rules })     = text "ArgInfo" <+> braces          (sep [ text "fun =" <+> ppr fun               , text "dmds(first 10) =" <+> ppr (take 10 dmds)-              , text "args =" <+> ppr args ])+              , text "args =" <+> ppr args+              , text "rewrite =" <+> ppr rules ])  instance Outputable ArgSpec where   ppr (ValArg { as_arg = arg })  = text "ValArg" <+> ppr arg   ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty-  ppr (CastBy c)                 = text "CastBy" <+> ppr c  addValArgTo :: ArgInfo ->  OutExpr -> OutType -> ArgInfo addValArgTo ai arg hole_ty-  | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs, ai_rewrite = rew } <- ai+  | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs } <- ai       -- Pop the top demand and and discounts off   , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_dmd = dmd }   = ai { ai_args    = arg_spec : ai_args ai        , ai_dmds    = dmds-       , ai_discs   = discs-       , ai_rewrite = decArgCount rew }+       , ai_discs   = discs }   | otherwise   = pprPanic "addValArgTo" (ppr ai $$ ppr arg)     -- There should always be enough demands and discounts  addTyArgTo :: ArgInfo -> OutType -> OutType -> ArgInfo-addTyArgTo ai arg_ty hole_ty = ai { ai_args    = arg_spec : ai_args ai-                                  , ai_rewrite = decArgCount (ai_rewrite ai) }+addTyArgTo ai arg_ty hole_ty = ai { ai_args    = arg_spec : ai_args ai }   where     arg_spec = TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty } -addCastTo :: ArgInfo -> OutCoercion -> ArgInfo-addCastTo ai co = ai { ai_args = CastBy co : ai_args ai }- isStrictArgInfo :: ArgInfo -> Bool -- True if the function is strict in the next argument isStrictArgInfo (ArgInfo { ai_dmds = dmds })   | dmd:_ <- dmds = isStrUsedDmd dmd   | otherwise     = False -argInfoAppArgs :: [ArgSpec] -> [OutExpr]-argInfoAppArgs []                              = []-argInfoAppArgs (CastBy {}                : _)  = []  -- Stop at a cast-argInfoAppArgs (ValArg { as_arg = arg }  : as) = arg     : argInfoAppArgs as-argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as--pushSimplifiedArgs, pushSimplifiedRevArgs-  :: SimplEnv-  -> [ArgSpec]   -- In normal, forward order for pushSimplifiedArgs,-                 -- in /reverse/ order for pushSimplifiedRevArgs-  -> SimplCont -> SimplCont-pushSimplifiedArgs    env args cont = foldr  (pushSimplifiedArg env)             cont args-pushSimplifiedRevArgs env args cont = foldl' (\k a -> pushSimplifiedArg env a k) cont args+pushSimplifiedArgs :: SimplEnv+                   -> [ArgSpec]   -- In normal, forward order+                   -> SimplCont -> SimplCont+pushSimplifiedArgs env args cont = foldr (pushSimplifiedArg env) cont args+-- pushSimplifiedRevArgs env args cont = foldl' (\k a -> pushSimplifiedArg env a k) cont args  pushSimplifiedArg :: SimplEnv -> ArgSpec -> SimplCont -> SimplCont pushSimplifiedArg _env (TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }) cont@@ -420,9 +396,11 @@   = ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified                  -- The SubstEnv will be ignored since sc_dup=Simplified                , sc_hole_ty = hole_ty, sc_cont = cont }-pushSimplifiedArg _ (CastBy c) cont-  = CastIt { sc_co = c, sc_cont = cont, sc_opt = True } +argSpecArg :: ArgSpec -> OutExpr+argSpecArg (ValArg { as_arg = arg })   = arg+argSpecArg (TyArg  { as_arg_ty = ty }) = Type ty+ argInfoExpr :: OutId -> [ArgSpec] -> OutExpr -- NB: the [ArgSpec] is reversed so that the first arg -- in the list is the last one in the application@@ -432,29 +410,7 @@     go []                              = Var fun     go (ValArg { as_arg = arg }  : as) = go as `App` arg     go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty-    go (CastBy co                : as) = mkCast (go as) co -decArgCount :: RewriteCall -> RewriteCall-decArgCount (TryRules n rules) = TryRules (n-1) rules-decArgCount rew                = rew--mkRewriteCall :: Id -> RuleEnv -> RewriteCall--- See Note [Rewrite rules and inlining] in GHC.Core.Opt.Simplify.Iteration--- We try to skip any unnecessary stages:---    No rules     => skip TryRules---    No unfolding => skip TryInlining--- This skipping is "just" for efficiency.  But rebuildCall is--- quite a heavy hammer, so skipping stages is a good plan.--- And it's extremely simple to do.-mkRewriteCall fun rule_env-  | not (null rules) = TryRules n_required rules-  | canUnfold unf    = TryInlining-  | otherwise        = TryNothing-  where-    n_required = maximum (map ruleArity rules)-    rules = getRules rule_env fun-    unf   = idUnfolding fun- {- ************************************************************************ *                                                                      *@@ -592,6 +548,34 @@                    -- Do *not* use short-cutting substitution here                    -- because we want to get as much IdInfo as possible +contOutArgs :: SimplEnv -> SimplCont -> [OutExpr]+-- Get the leading arguments from the `SimplCont`, as /OutExprs/+contOutArgs env cont+  = go cont+  where+    in_scope = seInScope env++    go (ApplyToTy { sc_arg_ty = ty, sc_cont = cont })+      = Type ty : go cont++    go (ApplyToVal { sc_dup = dup, sc_arg = arg, sc_env = env, sc_cont = cont })+      | isSimplified dup = arg : go cont+      | otherwise        = GHC.Core.Subst.substExpr (getFullSubst in_scope env) arg : go cont+        -- Make sure we apply the static environment `sc_env` as a substitution+        --   to get an OutExpr.  See (BF1) in Note [tryRules: plan (BEFORE)]+        --   in GHC.Core.Opt.Simplify.Iteration+        -- NB: we use substExpr, not substExprSC: we want to get the benefit of+        --     knowing what is evaluated etc, via the in-scope set++    -- No more arguments+    go _ = []++dropContArgs :: FullArgCount -> SimplCont -> SimplCont+dropContArgs 0 cont = cont+dropContArgs n (ApplyToTy  { sc_cont = cont }) = dropContArgs (n-1) cont+dropContArgs n (ApplyToVal { sc_cont = cont }) = dropContArgs (n-1) cont+dropContArgs n cont = pprPanic "dropContArgs" (ppr n $$ ppr cont)+ -- | Describes how the 'SimplCont' will evaluate the hole as a 'SubDemand'. -- This can be more insightful than the limited syntactic context that -- 'SimplCont' provides, because the 'Stop' constructor might carry a useful@@ -623,29 +607,26 @@     -- and case binder dmds, see addCaseBndrDmd. No priority right now.  --------------------mkArgInfo :: SimplEnv -> RuleEnv -> Id -> SimplCont -> ArgInfo--mkArgInfo env rule_base fun cont+mkArgInfo :: SimplEnv -> Id -> [CoreRule] -> SimplCont -> ArgInfo+mkArgInfo env fun rules_for_fun cont   | n_val_args < idArity fun            -- Note [Unsaturated functions]   = ArgInfo { ai_fun = fun, ai_args = []-            , ai_rewrite = fun_rewrite+            , ai_rules = rules_for_fun             , ai_encl = False             , ai_dmds = vanilla_dmds             , ai_discs = vanilla_discounts }   | otherwise   = ArgInfo { ai_fun   = fun             , ai_args  = []-            , ai_rewrite = fun_rewrite+            , ai_rules = rules_for_fun             , ai_encl  = fun_has_rules || contHasRules cont             , ai_dmds  = add_type_strictness (idType fun) arg_dmds             , ai_discs = arg_discounts }   where-    n_val_args    = countValArgs cont-    fun_rewrite   = mkRewriteCall fun rule_base-    fun_has_rules = case fun_rewrite of-                      TryRules {} -> True-                      _           -> False+    n_val_args  = countValArgs cont +    fun_has_rules = not (null rules_for_fun)+     vanilla_discounts, arg_discounts :: [Int]     vanilla_discounts = repeat 0     arg_discounts = case idUnfolding fun of@@ -872,7 +853,7 @@ got too much fruitless inlining, which led to regressions (#22317 is an example).  A good example of a function where this 'small incentive' is important is-GHC.Num.Integer where we ended up with calls like this:+GHC.Internal.Bignum.Integer where we ended up with calls like this:      case (integerSignum a b) of r -> ... but were failing to inline integerSignum, even though it always returns a single constructor, so it is very helpful to inline it. There is also an@@ -1068,7 +1049,7 @@    (a) NonTrivArg for an arg with an OtherCon [] unfolding    (b) ValueArg for an arg with an OtherCon [c1,c2..] unfolding. -Reason for (a): I found (in the GHC.Num.Integer library) that I was+Reason for (a): I found (in the GHC.Internal.Bignum.Integer module) that I was inlining a pretty big function when all we knew was that its arguments were evaluated, nothing more.  That in turn make the enclosing function too big to inline elsewhere.@@ -1515,6 +1496,10 @@     canInlineInLam (Lit _)    = True     canInlineInLam (Lam b e)  = isRuntimeVar b || canInlineInLam e     canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e+    canInlineInLam (Var v)    = case idOccInfo v of+                                  OneOcc { occ_in_lam = IsInsideLam } -> True+                                  ManyOccs {}                         -> True+                                  _                                   -> False     canInlineInLam _          = False       -- not ticks.  Counting ticks cannot be duplicated, and non-counting       -- ticks around a Lam will disappear anyway.@@ -2819,8 +2804,9 @@ isExitJoinId :: Var -> Bool isExitJoinId id   = isJoinId id-  && isOneOcc (idOccInfo id)-  && occ_in_lam (idOccInfo id) == IsInsideLam+  && case idOccInfo id of+        OneOcc { occ_in_lam = IsInsideLam } -> True+        _                                   -> False  {- Note [Dead binders]
compiler/GHC/Core/PatSyn.hs view
@@ -12,7 +12,8 @@         PatSyn, PatSynMatcher, PatSynBuilder, mkPatSyn,          -- ** Type deconstruction-        patSynName, patSynArity, patSynIsInfix, patSynResultType,+        patSynName, patSynArity, patSynVisArity,+        patSynIsInfix, patSynResultType,         isVanillaPatSyn,         patSynArgs,         patSynMatcher, patSynBuilder,@@ -421,6 +422,13 @@ -- | Arity of the pattern synonym patSynArity :: PatSyn -> Arity patSynArity = psArity++-- | Number of visible arguments of the pattern synonym+patSynVisArity :: PatSyn -> VisArity+patSynVisArity ps = n_of_required_ty_args + n_of_val_args+  where+    n_of_val_args = psArity ps+    n_of_required_ty_args = 0   -- no visible forall in pattern synonyms yet (#23704)  -- | Is this a \'vanilla\' pattern synonym (no existentials, no provided constraints)? isVanillaPatSyn :: PatSyn -> Bool
compiler/GHC/Core/Ppr.hs view
@@ -694,10 +694,10 @@             ppr modl, comma,             ppr ix,             text ">"]-  ppr (Breakpoint _ext ix vars modl) =+  ppr (Breakpoint _ext bid vars) =       hcat [text "break<",-            ppr modl, comma,-            ppr ix,+            ppr (bi_tick_mod bid), comma,+            ppr (bi_tick_index bid),             text ">",             parens (hcat (punctuate comma (map ppr vars)))]   ppr (ProfNote { profNoteCC = cc,
compiler/GHC/Core/Predicate.hs view
@@ -8,50 +8,117 @@  module GHC.Core.Predicate (   Pred(..), classifyPredType,-  isPredTy, isEvVarType,+  isPredTy, isSimplePredTy,    -- Equality predicates   EqRel(..), eqRelRole,-  isEqPrimPred, isNomEqPred, isReprEqPrimPred, isEqPred, isCoVarType,+  isEqPred, isReprEqPred, isEqClassPred, isCoVarType,   getEqPredTys, getEqPredTys_maybe, getEqPredRole,-  predTypeEqRel,-  mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,-  mkNomPrimEqPred,+  predTypeEqRel, pprPredType,+  mkNomEqPred, mkReprEqPred, mkEqPred, mkEqPredRole,    -- Class predicates   mkClassPred, isDictTy, typeDeterminesValue,-  isClassPred, isEqualityClass, isCTupleClass,+  isClassPred, isEqualityClass, isCTupleClass, isUnaryClass,   getClassPredTys, getClassPredTys_maybe,   classMethodTy, classMethodInstTy,    -- Implicit parameters-  isIPLikePred, mentionsIP, isIPTyCon, isIPClass,+  couldBeIPLike, mightMentionIP, isIPTyCon, isIPClass, decomposeIPPred,   isCallStackTy, isCallStackPred, isCallStackPredTy,   isExceptionContextPred, isExceptionContextTy,   isIPPred_maybe,    -- Evidence variables-  DictId, isEvVar, isDictId+  DictId, isEvId, isDictId, +  -- * Well-scoped free variables+  scopedSort, tyCoVarsOfTypeWellScoped,+  tyCoVarsOfTypesWellScoped,++  -- Equality left-hand sides+  CanEqLHS(..), canEqLHS_maybe, canTyFamEqLHS_maybe,+  canEqLHSKind, canEqLHSType, eqCanEqLHS+   ) where  import GHC.Prelude  import GHC.Core.Type import GHC.Core.Class+import GHC.Core.TyCo.Compare( tcEqTyConApps )+import GHC.Core.TyCo.FVs( tyCoVarsOfTypeList, tyCoVarsOfTypesList ) import GHC.Core.TyCon import GHC.Core.TyCon.RecWalk+import GHC.Types.Name( getOccName ) import GHC.Types.Var-import GHC.Core.Coercion+import GHC.Types.Var.Set import GHC.Core.Multiplicity ( scaledThing )  import GHC.Builtin.Names+import GHC.Builtin.Types.Prim( eqPrimTyCon, eqReprPrimTyCon )  import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Data.FastString ++{- *********************************************************************+*                                                                      *+*                   Pred and PredType                                  *+*                                                                      *+********************************************************************* -}++{- Note [Types for coercions, predicates, and evidence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A "predicate" or "predicate type",+    type synonym `PredType`+    returns True to `isPredTy`+is any type of kind (CONSTRAINT r) for some `r`.++  (a) A "class predicate" (aka dictionary type) is the type of a (boxed)+      type-class dictionary+        Test: isDictTy+        Binders: DictIds+        Kind: Constraint+        Examples: (Eq a), and (a ~ b)++  (b) An "equality predicate" is a primitive, unboxed equalities+        Test: isEqPred+        Binders: CoVars (can appear in coercions)+        Kind: CONSTRAINT (TupleRep [])+        Examples: (t1 ~# t2) or (t1 ~R# t2)++  (c) A "simple predicate type" is either a class predicate or an equality predicate+        Test: isSimplePredTy+        Kind: Constraint or CONSTRAINT (TupleRep [])+        Examples: all coercion types and dictionary types++  (d) A "forall-predicate" is the type of a possibly-polymorphic function+      returning a predicate; e.g.+           forall a. Eq a => Eq [a]++  (e) An "irred predicate" is any other type of kind (CONSTRAINT r),+      typically something like `c` or `c Int`, for some suitably-kinded `c`+++* Predicates are classified by `classifyPredType`.++* Equality types and dictionary types are mutually exclusive.++* Predicates are the things solved by the constraint solver; and+  /evidence terms/ witness those solutions.  An /evidence variable/+  (or EvId) has a type that is a PredType.++* Generally speaking, the /type/ of a predicate determines its /value/;+  that is, predicates are singleton types.  The big exception is implicit+  parameters.  See Note [Type determines value]++* In a FunTy { ft_af = af }, where af = FTF_C_T or FTF_C_C,+  the argument type is always a Predicate type.+-}+ -- | A predicate in the solver. The solver tries to prove Wanted predicates -- from Given ones. data Pred@@ -75,43 +142,136 @@   --     as ClassPred, as if we had a tuple class with two superclasses   --        class (c1, c2) => CTuple2 c1 c2 -classifyPredType :: PredType -> Pred-classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of-    Just (tc, [_, _, ty1, ty2])-      | tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2-      | tc `hasKey` eqPrimTyConKey     -> EqPred NomEq  ty1 ty2+classifyPredType :: HasDebugCallStack => PredType -> Pred+-- Precondition: the argument is a predicate type, with kind (CONSTRAINT _)+classifyPredType ev_ty+  = assertPpr (isPredTy ev_ty) (ppr ev_ty) $+    case splitTyConApp_maybe ev_ty of+      Just (tc, [_, _, ty1, ty2])+        | tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2+        | tc `hasKey` eqPrimTyConKey     -> EqPred NomEq  ty1 ty2 -    Just (tc, tys)-      | Just clas <- tyConClass_maybe tc-      -> ClassPred clas tys+      Just (tc, tys)+        | Just clas <- tyConClass_maybe tc+        -> ClassPred clas tys -    _ | (tvs, rho) <- splitForAllTyCoVars ev_ty-      , (theta, pred) <- splitFunTys rho-      , not (null tvs && null theta)-      -> ForAllPred tvs (map scaledThing theta) pred+      _ | (tvs, rho) <- splitForAllTyCoVars ev_ty+        , (theta, pred) <- splitFunTys rho+        , not (null tvs && null theta)+        -> ForAllPred tvs (map scaledThing theta) pred -      | otherwise-      -> IrredPred ev_ty+        | otherwise+        -> IrredPred ev_ty --- --------------------- Dictionary types ---------------------------------+isSimplePredTy :: HasDebugCallStack => Type -> Bool+-- Return True for (t1 ~# t2) regardless of role, and (C tys)+-- /Not/ true of quantified-predicate type like (forall a. Eq a => Eq [a])+-- Precondition: expects a type that classifies values (i.e. not a type constructor)+-- See Note [Types for coercions, predicates, and evidence]+isSimplePredTy ty+  = case tyConAppTyCon_maybe ty of+       Nothing -> False+       Just tc -> isClassTyCon tc ||+                  tc `hasKey` eqPrimTyConKey ||+                  tc `hasKey` eqReprPrimTyConKey +isPredTy :: Type -> Bool+-- True of all types of kind (CONSTRAINT r) for some `r`+-- See Note [Types for coercions, predicates, and evidence]+--+-- In particular it is True of+--    - the constraints handled by the constraint solver,+--      including quantified constraints+--    - dictionary functions (forall a. Eq a => Eq [a])+isPredTy ty = case typeTypeOrConstraint ty of+                        TypeLike       -> False+                        ConstraintLike -> True++typeDeterminesValue :: PredType -> Bool+-- ^ Is the type *guaranteed* to determine the value?+-- Might say No even if the type does determine the value.+-- See Note [Type determines value]+typeDeterminesValue ty = isDictTy ty && not (couldBeIPLike ty)+++{-+Note [Evidence for quantified constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The superclass mechanism in GHC.Tc.Solver.Dict.makeSuperClasses risks+taking a quantified constraint like+   (forall a. C a => a ~ b)+and generate superclass evidence+   (forall a. C a => a ~# b)++This is a funny thing: neither isPredTy nor isCoVarType are true+of it.  So we are careful not to generate it in the first place:+see Note [Equality superclasses in quantified constraints]+in GHC.Tc.Solver.Dict.+-}++-- --------------------- Equality predicates ---------------------------------++-- | Does this type classify a core (unlifted) Coercion?+-- At either role nominal or representational+--    (t1 ~# t2) or (t1 ~R# t2)+-- See Note [Types for coercions, predicates, and evidence] in "GHC.Core.TyCo.Rep"+isEqPred :: PredType -> Bool+-- True of (s ~# t) (s ~R# t)+-- NB: but NOT true of (s ~ t) or (s ~~ t) or (Coecible s t)+isEqPred ty+  | Just tc <- tyConAppTyCon_maybe ty+  = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey+  | otherwise+  = False++isCoVarType :: Type -> Bool+-- Just a synonym for isEqPred+isCoVarType = isEqPred++isReprEqPred :: PredType -> Bool+-- True of (s ~R# t)+isReprEqPred ty+  | Just tc <- tyConAppTyCon_maybe ty+  = tc `hasKey` eqReprPrimTyConKey+  | otherwise+  = False++-- --------------------- Class predicates ---------------------------------+ mkClassPred :: Class -> [Type] -> PredType mkClassPred clas tys = mkTyConApp (classTyCon clas) tys +isClassPred :: PredType -> Bool+isClassPred ty = case tyConAppTyCon_maybe ty of+    Just tc -> isClassTyCon tc+    _       -> False+ isDictTy :: Type -> Bool--- True of dictionaries (Eq a) and---         dictionary functions (forall a. Eq a => Eq [a])--- See Note [Type determines value]--- See #24370 (and the isDictId call in GHC.HsToCore.Binds.decomposeRuleLhs)---     for why it's important to catch dictionary bindings-isDictTy ty = isClassPred pred-  where-    (_, pred) = splitInvisPiTys ty+isDictTy = isClassPred -typeDeterminesValue :: Type -> Bool--- See Note [Type determines value]-typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty)+isEqClassPred :: PredType -> Bool+isEqClassPred ty  -- True of (s ~ t) and (s ~~ t)+                  -- ToDo: should we check saturation?+  | Just tc <- tyConAppTyCon_maybe ty+  , Just cls <- tyConClass_maybe tc+  = isEqualityClass cls+  | otherwise+  = False +isEqualityClass :: Class -> Bool+-- True of (~), (~~), and Coercible+-- These all have a single primitive-equality superclass, either (~N# or ~R#)+isEqualityClass cls+  = cls `hasKey` heqTyConKey+    || cls `hasKey` eqTyConKey+    || cls `hasKey` coercibleTyConKey++isCTupleClass :: Class -> Bool+isCTupleClass cls = isTupleTyCon (classTyCon cls)++isUnaryClass :: Class -> Bool+isUnaryClass cls = isUnaryClassTyCon (classTyCon cls)+ getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type]) getClassPredTys ty = case getClassPredTys_maybe ty of         Just (clas, tys) -> (clas, tys)@@ -153,6 +313,10 @@ purposes of specialisation.  Note that we still want to specialise functions with implicit params if they have *other* dicts which are class params; see #17930.++It's also not always possible to infer that a type determines the value+if type families are in play. See #19747 for one such example.+ -}  -- --------------------- Equality predicates ---------------------------------@@ -170,6 +334,37 @@ eqRelRole NomEq  = Nominal eqRelRole ReprEq = Representational +-- | Creates a primitive nominal type equality predicate.+--      t1 ~# t2+-- Invariant: the types are not Coercions+mkNomEqPred :: Type -> Type -> Type+mkNomEqPred ty1 ty2+  = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2]+  where+    k1 = typeKind ty1+    k2 = typeKind ty2++-- | Creates a primitive representational type equality predicate.+--      t1 ~R# t2+-- Invariant: the types are not Coercions+mkReprEqPred :: Type -> Type -> Type+mkReprEqPred ty1  ty2+  = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2]+  where+    k1 = typeKind ty1+    k2 = typeKind ty2++-- | Makes a lifted equality predicate at the given role+mkEqPred :: EqRel -> Type -> Type -> PredType+mkEqPred NomEq  = mkNomEqPred+mkEqPred ReprEq = mkReprEqPred++-- | Makes a lifted equality predicate at the given role+mkEqPredRole :: Role -> Type -> Type -> PredType+mkEqPredRole Nominal          = mkNomEqPred+mkEqPredRole Representational = mkReprEqPred+mkEqPredRole Phantom          = panic "mkEqPred phantom"+ getEqPredTys :: PredType -> (Type, Type) getEqPredTys ty   = case splitTyConApp_maybe ty of@@ -195,90 +390,19 @@ -- Returns NomEq for dictionary predicates, etc predTypeEqRel :: PredType -> EqRel predTypeEqRel ty-  | isReprEqPrimPred ty = ReprEq-  | otherwise           = NomEq--{--------------------------------------------Predicates on PredType---------------------------------------------}--{--Note [Evidence for quantified constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The superclass mechanism in GHC.Tc.Solver.Dict.makeSuperClasses risks-taking a quantified constraint like-   (forall a. C a => a ~ b)-and generate superclass evidence-   (forall a. C a => a ~# b)--This is a funny thing: neither isPredTy nor isCoVarType are true-of it.  So we are careful not to generate it in the first place:-see Note [Equality superclasses in quantified constraints]-in GHC.Tc.Solver.Dict.--}---- | Does this type classify a core (unlifted) Coercion?--- At either role nominal or representational---    (t1 ~# t2) or (t1 ~R# t2)--- See Note [Types for coercions, predicates, and evidence] in "GHC.Core.TyCo.Rep"-isCoVarType :: Type -> Bool-  -- ToDo: should we check saturation?-isCoVarType ty = isEqPrimPred ty--isEvVarType :: Type -> Bool--- True of (a) predicates, of kind Constraint, such as (Eq t), and (s ~ t)---         (b) coercion types, such as (s ~# t) or (s ~R# t)--- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep--- See Note [Evidence for quantified constraints]-isEvVarType ty = isCoVarType ty || isPredTy ty--isEqPrimPred :: PredType -> Bool--- True of (s ~# t) (s ~R# t)-isEqPrimPred ty-  | Just tc <- tyConAppTyCon_maybe ty-  = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey-  | otherwise-  = False--isReprEqPrimPred :: PredType -> Bool-isReprEqPrimPred ty-  | Just tc <- tyConAppTyCon_maybe ty-  = tc `hasKey` eqReprPrimTyConKey-  | otherwise-  = False--isNomEqPred :: PredType -> Bool--- A nominal equality, primitive or not  (s ~# t), (s ~ t), or (s ~~ t)-isNomEqPred ty-  | Just tc <- tyConAppTyCon_maybe ty-  = tc `hasKey` eqPrimTyConKey || tc `hasKey` heqTyConKey || tc `hasKey` eqTyConKey-  | otherwise-  = False--isClassPred :: PredType -> Bool-isClassPred ty = case tyConAppTyCon_maybe ty of-    Just tc -> isClassTyCon tc-    _       -> False--isEqPred :: PredType -> Bool-isEqPred ty  -- True of (s ~ t) and (s ~~ t)-             -- ToDo: should we check saturation?-  | Just tc <- tyConAppTyCon_maybe ty-  , Just cls <- tyConClass_maybe tc-  = isEqualityClass cls-  | otherwise-  = False--isEqualityClass :: Class -> Bool--- True of (~), (~~), and Coercible--- These all have a single primitive-equality superclass, either (~N# or ~R#)-isEqualityClass cls-  = cls `hasKey` heqTyConKey-    || cls `hasKey` eqTyConKey-    || cls `hasKey` coercibleTyConKey+  | isReprEqPred ty = ReprEq+  | otherwise       = NomEq -isCTupleClass :: Class -> Bool-isCTupleClass cls = isTupleTyCon (classTyCon cls)+pprPredType :: PredType -> SDoc+-- Special case for (t1 ~# t2) and (t1 ~R# t2)+pprPredType pred+  = case classifyPredType pred of+      EqPred eq_rel t1 t2 -> sep [ ppr t1, ppr (getOccName eq_tc) <+> ppr t2 ]+         where+           eq_tc = case eq_rel of+                     NomEq  -> eqPrimTyCon+                     ReprEq -> eqReprPrimTyCon+      _ -> ppr pred  {- ********************************************************************* *                                                                      *@@ -286,6 +410,8 @@ *                                                                      * ********************************************************************* -} +-- --------------------- Nomal implicit-parameter predicates ---------------+ isIPTyCon :: TyCon -> Bool isIPTyCon tc = tc `hasKey` ipClassKey   -- Class and its corresponding TyCon have the same Unique@@ -303,6 +429,18 @@   | otherwise   = Nothing +-- | Take a type (IP sym ty), where IP is the built in IP class+-- and return (ip, MkIP, [sym,ty]), where+--    `ip` is the class-op for class IP+--    `MkIP` is the data constructor for class IP+decomposeIPPred :: Type -> (Id, [Type])+decomposeIPPred ty+  | Just (cls, tys) <- getClassPredTys_maybe ty+  , [ip_op] <- classMethods cls+  = assertPpr (isIPClass cls && isUnaryClass cls) (ppr ty) $+    (ip_op, tys)+  | otherwise = pprPanic "decomposeIP" (ppr ty)+ -- --------------------- ExceptionContext predicates --------------------------  -- | Is a 'PredType' an @ExceptionContext@ implicit parameter?@@ -357,44 +495,44 @@   | otherwise   = False --- --------------------- isIPLike and mentionsIP  --------------------------+-- --------------------- couldBeIPLike and mightMentionIP  -------------------------- --                 See Note [Local implicit parameters] -isIPLikePred :: Type -> Bool+couldBeIPLike :: Type -> Bool -- Is `pred`, or any of its superclasses, an implicit parameter? -- See Note [Local implicit parameters]-isIPLikePred pred =-  mentions_ip_pred initIPRecTc (const True) (const True) pred+couldBeIPLike pred+  = might_mention_ip1 initIPRecTc (const True) (const True) pred -mentionsIP :: (Type -> Bool) -- ^ predicate on the string-           -> (Type -> Bool) -- ^ predicate on the type-           -> Class-           -> [Type] -> Bool--- ^ @'mentionsIP' str_cond ty_cond cls tys@ returns @True@ if:+mightMentionIP :: (Type -> Bool) -- ^ predicate on the string+               -> (Type -> Bool) -- ^ predicate on the type+               -> Class+               -> [Type] -> Bool+-- ^ @'mightMentionIP' str_cond ty_cond cls tys@ returns @True@ if: -- --    - @cls tys@ is of the form @IP str ty@, where @str_cond str@ and @ty_cond ty@ --      are both @True@, --    - or any superclass of @cls tys@ has this property. -- -- See Note [Local implicit parameters]-mentionsIP = mentions_ip initIPRecTc+mightMentionIP = might_mention_ip initIPRecTc -mentions_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool-mentions_ip rec_clss str_cond ty_cond cls tys+might_mention_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool+might_mention_ip rec_clss str_cond ty_cond cls tys   | Just (str_ty, ty) <- isIPPred_maybe cls tys   = str_cond str_ty && ty_cond ty   | otherwise-  = or [ mentions_ip_pred rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys)+  = or [ might_mention_ip1 rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys)        | sc_sel_id <- classSCSelIds cls ]  -mentions_ip_pred :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool-mentions_ip_pred rec_clss str_cond ty_cond ty+might_mention_ip1 :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool+might_mention_ip1 rec_clss str_cond ty_cond ty   | Just (cls, tys) <- getClassPredTys_maybe ty   , let tc = classTyCon cls   , Just rec_clss' <- if isTupleTyCon tc then Just rec_clss                       else checkRecTc rec_clss tc-  = mentions_ip rec_clss' str_cond ty_cond cls tys+  = might_mention_ip rec_clss' str_cond ty_cond cls tys   | otherwise   = False -- Includes things like (D []) where D is           -- a Constraint-ranged family; #7785@@ -407,7 +545,7 @@ See also wrinkle (SIP1) in Note [Shadowing of implicit parameters] in GHC.Tc.Solver.Dict. -The function isIPLikePred tells if this predicate, or any of its+The function couldBeIPLike tells if this predicate, or any of its superclasses, is an implicit parameter.  Why are implicit parameters special?  Unlike normal classes, we can@@ -415,7 +553,7 @@    let ?x = True in ... So in various places we must be careful not to assume that any value of the right type will do; we must carefully look for the innermost binding.-So isIPLikePred checks whether this is an implicit parameter, or has+So couldBeIPLike checks whether this is an implicit parameter, or has a superclass that is an implicit parameter.  Several wrinkles@@ -456,16 +594,16 @@   think nothing does. * I'm a little concerned about type variables; such a variable might   be instantiated to an implicit parameter.  I don't think this-  matters in the cases for which isIPLikePred is used, and it's pretty+  matters in the cases for which couldBeIPLike is used, and it's pretty   obscure anyway. * The superclass hunt stops when it encounters the same class again,   but in principle we could have the same class, differently instantiated,   and the second time it could have an implicit parameter I'm going to treat these as problems for another day. They are all exotic. -Note [Using typesAreApart when calling mentionsIP]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We call 'mentionsIP' in two situations:+Note [Using typesAreApart when calling mightMentionIP]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We call 'mightMentionIP' in two situations:    (1) to check that a predicate does not contain any implicit parameters       IP str ty, for a fixed literal str and any type ty,@@ -500,8 +638,175 @@ *                                                                      * ********************************************************************* -} -isEvVar :: Var -> Bool-isEvVar var = isEvVarType (varType var)+isEvId :: Var -> Bool+isEvId var = isPredTy (varType var)  isDictId :: Id -> Bool isDictId id = isDictTy (varType id)+++{- *********************************************************************+*                                                                      *+                 scopedSort++       This function lives here becuase it uses isEvId+*                                                                      *+********************************************************************* -}++{- Note [ScopedSort]+~~~~~~~~~~~~~~~~~~~~+Consider++  foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> ()++This function type is implicitly generalised over [a, b, k, k2]. These+variables will be Specified; that is, they will be available for visible+type application. This is because they are written in the type signature+by the user.++However, we must ask: what order will they appear in? In cases without+dependency, this is easy: we just use the lexical left-to-right ordering+of first occurrence. With dependency, we cannot get off the hook so+easily.++We thus state:++ * These variables appear in the order as given by ScopedSort, where+   the input to ScopedSort is the left-to-right order of first occurrence.++Note that this applies only to *implicit* quantification, without a+`forall`. If the user writes a `forall`, then we just use the order given.++ScopedSort is defined thusly (as proposed in #15743):+  * Work left-to-right through the input list, with a cursor.+  * If variable v at the cursor is depended on by any earlier variable w,+    move v immediately before the leftmost such w.++INVARIANT: The prefix of variables before the cursor form a valid telescope.++Note that ScopedSort makes sense only after type inference is done and all+types/kinds are fully settled and zonked.++-}++-- | Do a topological sort on a list of tyvars,+--   so that binders occur before occurrences+-- E.g. given  @[ a::k, k::Type, b::k ]@+-- it'll return a well-scoped list @[ k::Type, a::k, b::k ]@.+--+-- This is a deterministic sorting operation+-- (that is, doesn't depend on Uniques).+--+-- It is also meant to be stable: that is, variables should not+-- be reordered unnecessarily. This is specified in Note [ScopedSort]+-- See also Note [Ordering of implicit variables] in "GHC.Rename.HsType"++scopedSort :: [Var] -> [Var]+scopedSort = go [] []+  where+    go :: [Var] -- already sorted, in reverse order+       -> [TyCoVarSet] -- each set contains all the variables which must be placed+                       -- before the tv corresponding to the set; they are accumulations+                       -- of the fvs in the sorted Var's types++                       -- This list is in 1-to-1 correspondence with the sorted Vars+                       -- INVARIANT:+                       --   all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list)+                       -- That is, each set in the list is a superset of all later sets.++       -> [Var] -- yet to be sorted+       -> [Var]+    go acc _fv_list [] = reverse acc+    go acc  fv_list (tv:tvs)+      = go acc' fv_list' tvs+      where+        (acc', fv_list') = insert tv acc fv_list++    insert :: Var           -- var to insert+           -> [Var]         -- sorted list, in reverse order+           -> [TyCoVarSet]  -- list of fvs, as above+           -> ([Var], [TyCoVarSet])   -- augmented lists+    -- Generally we put the new Var at the front of the accumulating list+    -- (leading to a stable sort) unless there is are reason to put it later.+    insert v []     []         = ([v], [tyCoVarsOfType (varType v)])+    insert v (a:as) (fvs:fvss)+      | (isTyVar v && isId a) ||          -- TyVars precede Ids+        (isEvId v && isId a && not (isEvId a)) || -- DictIds precede non-DictIds+        (v `elemVarSet` fvs)+          -- (a) put Ids after TyVars, and (b) respect dependencies+      , (as', fvss') <- insert v as fvss+      = (a:as', fvs `unionVarSet` fv_v : fvss')++      | otherwise  -- Put `v` at the front+      = (v:a:as, fvs `unionVarSet` fv_v : fvs : fvss)+      where+        fv_v = tyCoVarsOfType (varType v)++       -- lists not in correspondence+    insert _ _ _ = panic "scopedSort"++-- | Get the free vars of a type in scoped order+tyCoVarsOfTypeWellScoped :: Type -> [TyVar]+tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList++-- | Get the free vars of types in scoped order+tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar]+tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList+++{- *********************************************************************+*                                                                      *+*                   Equality left-hand sides+*                                                                      *+********************************************************************* -}++-- | A 'CanEqLHS' is a type that can appear on the left of a canonical+-- equality: a type variable or /exactly-saturated/ type family application.+data CanEqLHS+  = TyVarLHS TyVar+  | TyFamLHS TyCon  -- ^ TyCon of the family+             [Type]   -- ^ Arguments, /exactly saturating/ the family++instance Outputable CanEqLHS where+  ppr (TyVarLHS tv)              = ppr tv+  ppr (TyFamLHS fam_tc fam_args) = ppr (mkTyConApp fam_tc fam_args)++-----------------------------------+-- | Is a type a canonical LHS? That is, is it a tyvar or an exactly-saturated+-- type family application?+-- Does not look through type synonyms.+canEqLHS_maybe :: Type -> Maybe CanEqLHS+canEqLHS_maybe xi+  | Just tv <- getTyVar_maybe xi+  = Just $ TyVarLHS tv++  | otherwise+  = canTyFamEqLHS_maybe xi++canTyFamEqLHS_maybe :: Type -> Maybe CanEqLHS+canTyFamEqLHS_maybe xi+  | Just (tc, args) <- tcSplitTyConApp_maybe xi+  , isTypeFamilyTyCon tc+  , args `lengthIs` tyConArity tc+  = Just $ TyFamLHS tc args++  | otherwise+  = Nothing++-- | Convert a 'CanEqLHS' back into a 'Type'+canEqLHSType :: CanEqLHS -> Type+canEqLHSType (TyVarLHS tv) = mkTyVarTy tv+canEqLHSType (TyFamLHS fam_tc fam_args) = mkTyConApp fam_tc fam_args++-- | Retrieve the kind of a 'CanEqLHS'+canEqLHSKind :: CanEqLHS -> Kind+canEqLHSKind (TyVarLHS tv) = tyVarKind tv+canEqLHSKind (TyFamLHS fam_tc fam_args) = piResultTys (tyConKind fam_tc) fam_args++-- | Are two 'CanEqLHS's equal?+eqCanEqLHS :: CanEqLHS -> CanEqLHS -> Bool+eqCanEqLHS (TyVarLHS tv1) (TyVarLHS tv2) = tv1 == tv2+eqCanEqLHS (TyFamLHS fam_tc1 fam_args1) (TyFamLHS fam_tc2 fam_args2)+  = tcEqTyConApps fam_tc1 fam_args1 fam_tc2 fam_args2+eqCanEqLHS _ _ = False+
compiler/GHC/Core/Rules.hs view
@@ -9,7 +9,7 @@ -- The 'CoreRule' datatype itself is declared elsewhere. module GHC.Core.Rules (         -- ** Looking up rules-        lookupRule, matchExprs,+        lookupRule, matchExprs, ruleLhsIsMoreSpecific,          -- ** RuleBase, RuleEnv         RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv,@@ -30,7 +30,8 @@         rulesOfBinds, getRules, pprRulesForUser,          -- * Making rules-        mkRule, mkSpecRule, roughTopNames+        mkRule, mkSpecRule, roughTopNames,+        ruleIsOrphan      ) where @@ -484,6 +485,10 @@ ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin }     = notOrphan orph || origin `elemModuleSet` vis_orphs +ruleIsOrphan :: CoreRule -> Bool+ruleIsOrphan (BuiltinRule {})            = False+ruleIsOrphan (Rule { ru_orphan = orph }) = isOrphan orph+ {- Note [Where rules are found] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The rules for an Id come from two places:@@ -538,7 +543,8 @@ -- supplied rules to this instance of an application in a given -- context, returning the rule applied and the resulting expression if -- successful.-lookupRule :: RuleOpts -> InScopeEnv+lookupRule :: HasDebugCallStack+           => RuleOpts -> InScopeEnv            -> (Activation -> Bool)      -- When rule is active            -> Id -- Function head            -> [CoreExpr] -- Args@@ -568,7 +574,7 @@       = go ((r,mkTicks ticks e):ms) rs       | otherwise       = -- pprTrace "match failed" (ppr r $$ ppr args $$-        --   ppr [ (arg_id, unfoldingTemplate unf)+        --   ppr [ (arg_id, maybeUnfoldingTemplate unf)         --       | Var arg_id <- args         --       , let unf = idUnfolding arg_id         --       , isCheapUnfolding unf] )@@ -582,8 +588,8 @@  findBest _        _      (rule,ans)   [] = (rule,ans) findBest in_scope target (rule1,ans1) ((rule2,ans2):prs)-  | isMoreSpecific in_scope rule1 rule2 = findBest in_scope target (rule1,ans1) prs-  | isMoreSpecific in_scope rule2 rule1 = findBest in_scope target (rule2,ans2) prs+  | ruleIsMoreSpecific in_scope rule1 rule2 = findBest in_scope target (rule1,ans1) prs+  | ruleIsMoreSpecific in_scope rule2 rule1 = findBest in_scope target (rule2,ans2) prs   | debugIsOn = let pp_rule rule                       = ifPprDebug (ppr rule)                                    (doubleQuotes (ftext (ruleName rule)))@@ -598,15 +604,25 @@   where     (fn,args) = target -isMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool--- The call (rule1 `isMoreSpecific` rule2)+ruleIsMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool+-- The call (rule1 `ruleIsMoreSpecific` rule2) -- sees if rule2 can be instantiated to look like rule1--- See Note [isMoreSpecific]-isMoreSpecific _        (BuiltinRule {}) _                = False-isMoreSpecific _        (Rule {})        (BuiltinRule {}) = True-isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 })-                        (Rule { ru_bndrs = bndrs2, ru_args = args2 })-  = isJust (matchExprs in_scope_env bndrs2 args2 args1)+-- See Note [ruleIsMoreSpecific]+ruleIsMoreSpecific in_scope rule1 rule2+  = case rule1 of+       BuiltinRule {} -> False+       Rule { ru_bndrs = bndrs1, ru_args = args1 }+                      -> ruleLhsIsMoreSpecific in_scope bndrs1 args1 rule2++ruleLhsIsMoreSpecific :: InScopeSet+                      -> [Var] -> [CoreExpr]  -- LHS of a possible new rule+                      -> CoreRule             -- An existing rule+                      -> Bool                 -- New one is more specific+ruleLhsIsMoreSpecific in_scope bndrs1 args1 rule2+  = case rule2 of+       BuiltinRule {} -> True+       Rule { ru_bndrs = bndrs2, ru_args = args2 }+                      -> isJust (matchExprs in_scope_env bndrs2 args2 args1)   where    full_in_scope = in_scope `extendInScopeSetList` bndrs1    in_scope_env  = ISE full_in_scope noUnfoldingFun@@ -615,9 +631,9 @@ noBlackList :: Activation -> Bool noBlackList _ = False           -- Nothing is black listed -{- Note [isMoreSpecific]+{- Note [ruleIsMoreSpecific] ~~~~~~~~~~~~~~~~~~~~~~~~-The call (rule1 `isMoreSpecific` rule2)+The call (rule1 `ruleIsMoreSpecific` rule2) sees if rule2 can be instantiated to look like rule1.  Wrinkle:@@ -660,7 +676,8 @@ -}  -------------------------------------matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool)+matchRule :: HasDebugCallStack+          => RuleOpts -> InScopeEnv -> (Activation -> Bool)           -> Id -> [CoreExpr] -> [Maybe Name]           -> CoreRule -> Maybe CoreExpr @@ -705,7 +722,8 @@   ----------------------------------------matchN  :: InScopeEnv+matchN  :: HasDebugCallStack+        => InScopeEnv         -> RuleName -> [Var] -> [CoreExpr]         -> [CoreExpr] -> CoreExpr           -- ^ Target; can have more elements than the template         -> Maybe CoreExpr@@ -724,7 +742,8 @@        ; return (bind_wrapper $                  mkLams tmpl_vars rhs `mkApps` matched_es) } -matchExprs :: InScopeEnv -> [Var] -> [CoreExpr] -> [CoreExpr]+matchExprs :: HasDebugCallStack+           => InScopeEnv -> [Var] -> [CoreExpr] -> [CoreExpr]            -> Maybe (BindWrapper, [CoreExpr])  -- 1-1 with the [Var] matchExprs (ISE in_scope id_unf) tmpl_vars tmpl_es target_es   = do  { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es@@ -780,7 +799,8 @@               , text "Actual args:" <+> ppr target_es ]  -----------------------match_exprs :: RuleMatchEnv -> RuleSubst+match_exprs :: HasDebugCallStack+            => RuleMatchEnv -> RuleSubst             -> [CoreExpr]       -- Templates             -> [CoreExpr]       -- Targets             -> Maybe RuleSubst@@ -820,7 +840,7 @@    The rule looks like     forall (a::*) (d::Eq Char) (x :: Foo a Char).-         f (Foo a Char) d x = True+         f @(Foo a Char) d x = True    Matching the rule won't bind 'a', and legitimately so.  We fudge by   pretending that 'a' is bound to (Any :: *).@@ -996,17 +1016,17 @@ variable.  And SpecConstr no longer does so: see Note [SpecConstr and casts] in SpecConstr. -It is, however, OK for a cast to appear in a template.  For example-    newtype N a = MkN (a,a)    -- Axiom ax:N a :: (a,a) ~R N a-    f :: N a -> bah-    RULE forall b x:b y:b. f @b ((x,y) |> (axN @b)) = ...--When matching we can just move these casts to the other side:-    match (tmpl |> co) tgt  -->   match tmpl (tgt |> sym co)-See matchTemplateCast.- Wrinkles: +(CT0) It is, however, OK for a cast to appear in a template provided the cast mentions+  none of the template variables.  For example+      newtype N a = MkN (a,a)    -- Axiom ax:N a :: (a,a) ~R N a+      f :: N a -> bah+      RULE forall b x:b y:b. f @b ((x,y) |> (axN @b)) = ...+  When matching we can just move these casts to the other side:+      match (tmpl |> co) tgt  -->   match tmpl (tgt |> sym co)+  See matchTemplateCast.+ (CT1) We need to be careful about scoping, and to match left-to-right, so that we   know the substitution [a :-> b] before we meet (co :: (a,a) ~R N a), and so we   can apply that substitition@@ -1041,7 +1061,8 @@ -}  -----------------------match :: RuleMatchEnv+match :: HasDebugCallStack+      => RuleMatchEnv       -> RuleSubst              -- Substitution applies to template only       -> CoreExpr               -- Template       -> CoreExpr               -- Target@@ -1277,7 +1298,7 @@              f (\(MkT @b (d::Num b) (x::b)) -> h @b d x) = ...      where the HOP is (h @b d x). In principle this might be possible, but      it seems fragile; e.g. we would still need to insist that the (invisible)-     @b was a type variable.  And since `h` gets a polymoprhic type, that+     @b was a type variable.  And since `h` gets a polymorphic type, that      type would have to be declared by the programmer.       Maybe one day.  But for now, we insist (in `arg_as_lcl_var`)that a HOP@@ -1491,11 +1512,12 @@     filterFV (`elemVarSet` rv_tmpls renv) $    -- Check that the coercion does not     tyCoFVsOfCo substed_co                     -- mention any of the template variables   = -- This is the good path-    -- See Note [Casts in the template]+    -- See Note [Casts in the template] wrinkle (CT0)     match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoL mco (mkSymCo substed_co)))    | otherwise   = -- This is the Deeply Suspicious Path+    -- See Note [Casts in the template]     do { let co2 = case mco of                      MRefl   -> mkRepReflCo (exprType e2)                      MCo co2 -> co2@@ -1577,7 +1599,8 @@     not_captured fv = not (inRnEnvR rn_env fv)  -------------------------------------------match_var :: RuleMatchEnv+match_var :: HasDebugCallStack+          => RuleMatchEnv           -> RuleSubst           -> Var        -- Template           -> CoreExpr   -- Target@@ -1613,7 +1636,8 @@         -- template x, so we must rename first!  -------------------------------------------match_tmpl_var :: RuleMatchEnv+match_tmpl_var :: HasDebugCallStack+               => RuleMatchEnv                -> RuleSubst                -> Var                -- Template                -> CoreExpr           -- Target
compiler/GHC/Core/Rules/Config.hs view
@@ -5,9 +5,15 @@  -- | Rule options data RuleOpts = RuleOpts-   { roPlatform                :: !Platform -- ^ Target platform-   , roNumConstantFolding      :: !Bool     -- ^ Enable more advanced numeric constant folding-   , roExcessRationalPrecision :: !Bool     -- ^ Cut down precision of Rational values to that of Float/Double if disabled-   , roBignumRules             :: !Bool     -- ^ Enable rules for bignums+   { roPlatform                :: !Platform+     -- ^ Target platform+   , roNumConstantFolding      :: !Bool+     -- ^ Enable constant folding through nested expressions.+     --+     -- See Note [Constant folding through nested expressions] in GHC.Core.Opt.ConstantFold+   , roExcessRationalPrecision :: !Bool+     -- ^ Cut down precision of Rational values to that of Float/Double if disabled+   , roBignumRules             :: !Bool+     -- ^ Enable rules for bignums    }
compiler/GHC/Core/SimpleOpt.hs view
@@ -8,7 +8,7 @@         SimpleOpts (..), defaultSimpleOpts,          -- ** Simple expression optimiser-        simpleOptPgm, simpleOptExpr, simpleOptExprWith,+        simpleOptPgm, simpleOptExpr, simpleOptExprNoInline, simpleOptExprWith,          -- ** Join points         joinPointBinding_maybe, joinPointBindings_maybe,@@ -89,6 +89,24 @@ expression.  In fact, the simple optimiser is a good example of this little dance in action; the full Simplifier is a lot more complicated. +Note [The InScopeSet for simpleOptExpr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Care must be taken to remove unfoldings from `Var`s collected by exprFreeVars+before using them to construct an in-scope set hence `zapIdUnfolding` in `init_subst`.+Consider calling `simpleOptExpr` on an expression like++```+ case x of (a,b) -> (x,a)+```++* One of those two occurrences of x has an unfolding (the one in (x,a), with+unfolding x = (a,b)) and the other does not. (Inside a case GHC adds+unfolding-info to the scrutinee's Id.)+* But exprFreeVars just builds a set, so it's a bit random which occurrence is collected.+* Then simpleOptExpr replaces each occurrence of x with the one in the in-scope set.+* Bad bad bad: then the x in  case x of ... may be replaced with a version that has an unfolding.++See ticket #25790 -}  -- | Simple optimiser options@@ -96,6 +114,8 @@    { so_uf_opts :: !UnfoldingOpts   -- ^ Unfolding options    , so_co_opts :: !OptCoercionOpts -- ^ Coercion optimiser options    , so_eta_red :: !Bool            -- ^ Eta reduction on?+   , so_inline :: !Bool             -- ^ False <=> do no inlining whatsoever,+                                    --    even for trivial or used-once things    }  -- | Default options for the Simple optimiser.@@ -104,6 +124,7 @@    { so_uf_opts = defaultUnfoldingOpts    , so_co_opts = OptCoercionOpts { optCoercionEnabled = False }    , so_eta_red = False+   , so_inline  = True    }  simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr@@ -135,17 +156,23 @@   = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)     simpleOptExprWith opts init_subst expr   where-    init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))-        -- It's potentially important to make a proper in-scope set-        -- Consider  let x = ..y.. in \y. ...x...-        -- Then we should remember to clone y before substituting-        -- for x.  It's very unlikely to occur, because we probably-        -- won't *be* substituting for x if it occurs inside a-        -- lambda.-        --+    init_subst = mkEmptySubst (mkInScopeSet (mapVarSet zapIdUnfolding (exprFreeVars expr)))+        -- zapIdUnfolding: see Note [The InScopeSet for simpleOptExpr]+         -- It's a bit painful to call exprFreeVars, because it makes         -- three passes instead of two (occ-anal, and go) +simpleOptExprNoInline :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr+-- A variant of simpleOptExpr, but without+-- occurrence analysis or inlining of any kind.+-- Result: we don't inline evidence bindings, which is useful for the specialiser+simpleOptExprNoInline opts expr+  = simple_opt_expr init_env expr+  where+    init_opts  = opts { so_inline = False }+    init_env   = (emptyEnv init_opts) { soe_subst = init_subst }+    init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))+ simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> InExpr -> OutExpr -- See Note [The simple optimiser] simpleOptExprWith opts subst expr@@ -219,7 +246,7 @@   = env { soe_inl = emptyVarEnv, soe_subst = zapSubst subst }  soeInScope :: SimpleOptEnv -> InScopeSet-soeInScope (SOE { soe_subst = subst }) = getSubstInScope subst+soeInScope (SOE { soe_subst = subst }) = substInScopeSet subst  soeSetInScope :: InScopeSet -> SimpleOptEnv -> SimpleOptEnv soeSetInScope in_scope env2@(SOE { soe_subst = subst2 })@@ -246,7 +273,7 @@   where     rec_ids      = soe_rec_ids env     subst        = soe_subst env-    in_scope     = getSubstInScope subst+    in_scope     = substInScopeSet subst     in_scope_env = ISE in_scope alwaysActiveUnfoldingFun      ---------------@@ -277,7 +304,7 @@           _       -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs             where               (env', mb_prs) = mapAccumL (simple_out_bind NotTopLevel) env $-                               zipEqual "simpleOptExpr" bs es+                               zipEqual bs es           -- See Note [Getting the map/coerce RULE to work]       | isDeadBinder b@@ -339,10 +366,12 @@   = simple_app (soeSetInScope (soeInScope env) env') e as    | let unf = idUnfolding v-  , isCompulsoryUnfolding (idUnfolding v)+  , isCompulsoryUnfolding unf   , isAlwaysActive (idInlineActivation v)     -- See Note [Unfold compulsory unfoldings in RULE LHSs]-  = simple_app (soeZapSubst env) (unfoldingTemplate unf) as+  , Just rhs <- maybeUnfoldingTemplate unf+    -- Always succeeds if isCompulsoryUnfolding does+  = simple_app (soeZapSubst env) rhs as    | otherwise   , let out_fn = lookupIdSubst (soe_subst env) v@@ -453,7 +482,7 @@     -- (simple_bind_pair subst in_var out_rhs)     --   either extends subst with (in_var -> out_rhs)     --   or     returns Nothing-simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })+simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst, soe_opts = opts })                  in_bndr mb_out_bndr clo@(rhs_env, in_rhs)                  top_level   | Type ty <- in_rhs        -- let a::* = TYPE ty in <body>@@ -479,7 +508,7 @@     stable_unf = isStableUnfolding (idUnfolding in_bndr)     active     = isAlwaysActive (idInlineActivation in_bndr)     occ        = idOccInfo in_bndr-    in_scope   = getSubstInScope subst+    in_scope   = substInScopeSet subst      out_rhs | JoinPoint join_arity <- idJoinPointHood in_bndr             = simple_join_rhs join_arity@@ -495,6 +524,7 @@      pre_inline_unconditionally :: Bool     pre_inline_unconditionally+       | not (so_inline opts)     = False    -- Not if so_inline is False        | isExportedId in_bndr     = False        | stable_unf               = False        | not active               = False    -- Note [Inline prag in simplOpt]@@ -546,13 +576,14 @@                      -> InId -> Maybe OutId -> OutExpr                      -> OccInfo -> Bool -> Bool -> TopLevelFlag                      -> (SimpleOptEnv, Maybe (OutVar, OutExpr))-simple_out_bind_pair env in_bndr mb_out_bndr out_rhs+simple_out_bind_pair env@(SOE { soe_subst = subst, soe_opts = opts })+                     in_bndr mb_out_bndr out_rhs                      occ_info active stable_unf top_level   | assertPpr (isNonCoVarId in_bndr) (ppr in_bndr)     -- Type and coercion bindings are caught earlier     -- See Note [Core type and coercion invariant]     post_inline_unconditionally-  = ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs }+  = ( env' { soe_subst = extendIdSubst subst in_bndr out_rhs }     , Nothing)    | otherwise@@ -565,6 +596,7 @@      post_inline_unconditionally :: Bool     post_inline_unconditionally+       | not (so_inline opts)  = False -- Not if so_inline is False        | isExportedId in_bndr  = False -- Note [Exported Ids and trivial RHSs]        | stable_unf            = False -- Note [Stable unfoldings and postInlineUnconditionally]        | not active            = False --     in GHC.Core.Opt.Simplify.Utils@@ -837,7 +869,7 @@ (MC1) We must compulsorily unfold MkAge to a cast.       See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make -(MC2) We must compulsorily unfolding coerce on the rule LHS, yielding+(MC2) We must compulsorily unfold coerce on the rule LHS, yielding         forall a b (dict :: Coercible * a b).           map @a @b (\(x :: a) -> case dict of             MkCoercible (co :: a ~R# b) -> x |> co) = ...@@ -854,7 +886,6 @@   Unfortunately, this still abstracts over a Coercible dictionary. We really   want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce,   which transforms the above to-  Desugar)      forall a b (co :: a ~R# b).       let dict = MkCoercible @* @a @b co in@@ -879,7 +910,7 @@  (MC4) The map/coerce rule is the only compelling reason for having a RULE that   quantifies over a coercion variable, something that is otherwise Very Deeply-  Suspicous.  See Note [Casts in the template] in GHC.Core.Rules. Ugh!+  Suspicious.  See Note [Casts in the template] in GHC.Core.Rules. Ugh!  This is all a fair amount of special-purpose hackery, but it's for a good cause. And it won't hurt other RULES and such that it comes across.@@ -1284,11 +1315,8 @@        --       simplifier produces rhs[exp/a], changing semantics if exp is not ok-for-spec        -- Good: returning (Mk#, [x]) with a float of  case exp of x { DEFAULT -> [] }        --       simplifier produces case exp of a { DEFAULT -> exp[x/a] }-       = let arg' = subst_expr subst arg-             bndr = uniqAway (subst_in_scope subst) (mkWildValBinder ManyTy arg_type)-             float = FloatCase arg' bndr DEFAULT []-             subst' = subst_extend_in_scope subst bndr-         in go subst' (float:floats) fun (CC (Var bndr : args) mco)+       , (subst', float, bndr) <- case_bind subst arg arg_type+       = go subst' (float:floats) fun (CC (Var bndr : args) mco)        | otherwise        = go subst floats fun (CC (subst_expr subst arg : args) mco) @@ -1322,7 +1350,7 @@           scrut'           = subst_expr subst scrut      go (Right sub) floats (Var v) cont-       = go (Left (getSubstInScope sub))+       = go (Left (substInScopeSet sub))             floats             (lookupIdSubst sub v)             cont@@ -1331,15 +1359,16 @@          | Just con <- isDataConWorkId_maybe fun         , count isValArg args == idArity fun-        = succeedWith in_scope floats $-          pushCoDataCon con args mco+        , (in_scope', seq_floats, args') <- mkFieldSeqFloats in_scope con args+          -- mkFieldSeqFloats: See (SFC2) in Note [Strict fields in Core]+        = succeedWith in_scope' (seq_floats ++ floats) $+          pushCoDataCon con args' mco          -- Look through data constructor wrappers: they inline late (See Note         -- [Activation for data constructor wrappers]) but we want to do         -- case-of-known-constructor optimisation eagerly (see Note         -- [exprIsConApp_maybe on data constructors with wrappers]).-        | isDataConWrapId fun-        , let rhs = uf_tmpl (realIdUnfolding fun)+        | Just rhs <- dataConWrapUnfolding_maybe fun         = go (Left in_scope) floats rhs cont          -- Look through dictionary functions; see Note [Unfolding DFuns]@@ -1394,7 +1423,7 @@     -- The Left case is wildly dominant      subst_in_scope (Left in_scope) = in_scope-    subst_in_scope (Right s) = getSubstInScope s+    subst_in_scope (Right s) = substInScopeSet s      subst_extend_in_scope (Left in_scope) v = Left (in_scope `extendInScopeSet` v)     subst_extend_in_scope (Right s) v = Right (s `extendSubstInScope` v)@@ -1418,6 +1447,38 @@     extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e)     extend (Right s)       v e = Right (extendSubst s v e) +    case_bind :: Either InScopeSet Subst -> CoreExpr -> Type -> (Either InScopeSet Subst, FloatBind, Id)+    case_bind subst expr expr_ty = (subst', float, bndr)+      where+        bndr   = setCaseBndrEvald MarkedStrict $+                 uniqAway (subst_in_scope subst) $+                 mkWildValBinder ManyTy expr_ty+        subst' = subst_extend_in_scope subst bndr+        expr'  = subst_expr subst expr+        float  = FloatCase expr' bndr DEFAULT []++    mkFieldSeqFloats :: InScopeSet -> DataCon -> [CoreExpr] -> (InScopeSet, [FloatBind], [CoreExpr])+    -- See Note [Strict fields in Core] for what a field seq is and (SFC2) for+    -- why we insert them+    mkFieldSeqFloats in_scope dc args+      | isLazyDataConRep dc+      = (in_scope, [], args)+      | otherwise+      = (in_scope', floats', ty_args ++ val_args')+      where+        (ty_args, val_args) = splitAtList (dataConUnivAndExTyCoVars dc) args+        (in_scope', floats', val_args') = foldr do_one (in_scope, [], []) $ zipEqual str_marks val_args+        str_marks = dataConRepStrictness dc+        do_one (str, arg) (in_scope,floats,args)+          | NotMarkedStrict <- str   = no_seq+          | exprIsHNF arg            = no_seq+          | otherwise                = (in_scope', float:floats, Var bndr:args)+          where+            no_seq = (in_scope, floats, arg:args)+            (in_scope', float, bndr) =+               case case_bind (Left in_scope) arg (exprType arg) of+                 (Left in_scope', float, bndr) -> (in_scope', float, bndr)+                 (right, _, _) -> pprPanic "case_bind did not preserve Left" (ppr in_scope $$ ppr arg $$ ppr right)  -- See Note [exprIsConApp_maybe on literal strings] dealWithStringLiteral :: Var -> BS.ByteString -> MCoercion
compiler/GHC/Core/Subst.hs view
@@ -24,13 +24,14 @@         extendIdSubstWithClone,         extendSubst, extendSubstList, extendSubstWithVar,         extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet,-        isInScope, setInScope, getSubstInScope,+        isInScope, setInScope, substInScopeSet,         extendTvSubst, extendCvSubst,         delBndr, delBndrs, zapSubst,          -- ** Substituting and cloning binders         substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr,         cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,+        cloneBndrsM, cloneRecIdBndrsM,      ) where @@ -162,12 +163,14 @@ -- | Add a substitution appropriate to the thing being substituted --   (whether an expression, type, or coercion). See also --   'extendIdSubst', 'extendTvSubst', 'extendCvSubst'-extendSubst :: Subst -> Var -> CoreArg -> Subst+extendSubst :: HasDebugCallStack => Subst -> Var -> CoreArg -> Subst extendSubst subst var arg   = case arg of-      Type ty     -> assert (isTyVar var) $ extendTvSubst subst var ty-      Coercion co -> assert (isCoVar var) $ extendCvSubst subst var co-      _           -> assert (isId    var) $ extendIdSubst subst var arg+      Type ty     -> assertPpr (isTyVar var) doc $ extendTvSubst subst var ty+      Coercion co -> assertPpr (isCoVar var) doc $ extendCvSubst subst var co+      _           -> assertPpr (isId    var) doc $ extendIdSubst subst var arg+  where+   doc = ppr var <+> text ":=" <+> ppr arg  extendSubstWithVar :: Subst -> Var -> Var -> Subst extendSubstWithVar subst v1 v2@@ -238,8 +241,7 @@ -- their canonical representatives in the in-scope set substExprSC subst orig_expr   | isEmptySubst subst = orig_expr-  | otherwise          = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $-                         substExpr subst orig_expr+  | otherwise          = substExpr subst orig_expr  -- | substExpr applies a substitution to an entire 'CoreExpr'. Remember, -- you may only apply the substitution /once/:@@ -418,25 +420,32 @@ cloneIdBndrs subst us ids   = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us) -cloneBndrs :: MonadUnique m => Subst -> [Var] -> m (Subst, [Var])+cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var]) -- Works for all kinds of variables (typically case binders) -- not just Ids-cloneBndrs subst vs-  = do us <- getUniquesM-       pure $ mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` us)+cloneBndrs subst us vs+  = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us) +cloneBndrsM :: MonadUnique m => Subst -> [Var] -> m (Subst, [Var])+-- Works for all kinds of variables (typically case binders)+-- not just Ids+cloneBndrsM subst vs = cloneBndrs subst `flip` vs <$> getUniqueSupplyM+ cloneBndr :: Subst -> Unique -> Var -> (Subst, Var) cloneBndr subst uniq v   | isTyVar v = cloneTyVarBndr subst v uniq   | otherwise = clone_id subst subst (v,uniq)  -- Works for coercion variables too  -- | Clone a mutually recursive group of 'Id's-cloneRecIdBndrs :: MonadUnique m => Subst -> [Id] -> m (Subst, [Id])-cloneRecIdBndrs subst ids-  = do us <- getUniquesM-       let (subst', ids') = mapAccumL (clone_id subst') subst (ids `zip` us)-       pure (subst', ids')+cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])+cloneRecIdBndrs subst us ids =+    let x@(subst', _) = mapAccumL (clone_id subst') subst (ids `zip` uniqsFromSupply us)+    in x +-- | Clone a mutually recursive group of 'Id's+cloneRecIdBndrsM :: MonadUnique m => Subst -> [Id] -> m (Subst, [Id])+cloneRecIdBndrsM subst ids = cloneRecIdBndrs subst `flip` ids <$> getUniqueSupplyM+ -- Just like substIdBndr, except that it always makes a new unique -- It is given the unique to use -- Discards non-Stable unfoldings@@ -482,7 +491,7 @@         -- in a Note in the id's type itself   where     old_ty = idType id-    old_w  = varMult id+    old_w  = idMult id  ------------------ -- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'.@@ -590,13 +599,13 @@      = tyCoFVsOfCo fv_co (const True) emptyVarSet $! acc      | otherwise      , let fv_expr = lookupIdSubst subst fv-     = exprFVs fv_expr (const True) emptyVarSet $! acc+     = exprLocalFVs fv_expr (const True) emptyVarSet $! acc  ------------------ -- | Drop free vars from the breakpoint if they have a non-variable substitution. substTickish :: Subst -> CoreTickish -> CoreTickish-substTickish subst (Breakpoint ext n ids modl)-   = Breakpoint ext n (mapMaybe do_one ids) modl+substTickish subst (Breakpoint ext bid ids)+   = Breakpoint ext bid (mapMaybe do_one ids)  where     do_one = getIdFromTrivialExpr_maybe . lookupIdSubst subst
compiler/GHC/Core/Tidy.hs view
@@ -16,12 +16,12 @@  import GHC.Core import GHC.Core.Type-+import GHC.Core.TyCo.Tidy import GHC.Core.Seq ( seqUnfolding )+ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Demand ( zapDmdEnvSig, isStrUsedDmd )-import GHC.Core.Coercion ( tidyCo ) import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Unique (getUnique)@@ -30,6 +30,7 @@ import GHC.Types.Name.Set import GHC.Types.SrcLoc import GHC.Types.Tickish+ import GHC.Data.Maybe import GHC.Utils.Misc import Data.List (mapAccumL)@@ -234,8 +235,8 @@  ------------  Tickish  -------------- tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish-tidyTickish env (Breakpoint ext ix ids modl)-  = Breakpoint ext ix (map (tidyVarOcc env) ids) modl+tidyTickish env (Breakpoint ext bid ids)+  = Breakpoint ext bid (map (tidyVarOcc env) ids) tidyTickish _   other_tickish       = other_tickish  ------------  Rules  --------------
compiler/GHC/Core/TyCo/Compare.hs view
@@ -12,7 +12,7 @@     eqVarBndrs,      pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck,-    tcEqTyConApps,+    tcEqTyConApps, tcEqTyConAppArgs,     mayLookIdentical,      -- * Type comparison@@ -226,12 +226,16 @@ -- are different, just checks the common prefix of arguments. tcEqTyConApps :: TyCon -> [Type] -> TyCon -> [Type] -> Bool tcEqTyConApps tc1 args1 tc2 args2-  = tc1 == tc2 &&-    and (zipWith tcEqTypeNoKindCheck args1 args2)+  = tc1 == tc2 && tcEqTyConAppArgs args1 args2++tcEqTyConAppArgs :: [Type] -> [Type] -> Bool+-- Args do not have to have equal length;+-- we discard the excess of the longer one+tcEqTyConAppArgs args1 args2+  = and (zipWith tcEqTypeNoKindCheck args1 args2)     -- No kind check necessary: if both arguments are well typed, then     -- any difference in the kinds of later arguments would show up     -- as differences in earlier (dependent) arguments-  -- | Type equality on lists of types, looking through type synonyms eqTypes :: [Type] -> [Type] -> Bool
compiler/GHC/Core/TyCo/FVs.hs view
@@ -40,10 +40,6 @@         -- * Occurrence-check expansion         occCheckExpand, -        -- * Well-scoped free variables-        scopedSort, tyCoVarsOfTypeWellScoped,-        tyCoVarsOfTypesWellScoped,-         -- * Closing over kinds         closeOverKindsDSet, closeOverKindsList,         closeOverKinds,@@ -72,7 +68,6 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Utils.Misc-import GHC.Utils.Panic import GHC.Data.Pair  import Data.Semigroup@@ -988,107 +983,6 @@ noFreeVarsOfCo co = not $ DM.getAny (f co)   where (_, _, f, _) = foldTyCo (afvFolder (const True)) emptyVarSet --{- *********************************************************************-*                                                                      *-                 scopedSort-*                                                                      *-********************************************************************* -}--{- Note [ScopedSort]-~~~~~~~~~~~~~~~~~~~~-Consider--  foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> ()--This function type is implicitly generalised over [a, b, k, k2]. These-variables will be Specified; that is, they will be available for visible-type application. This is because they are written in the type signature-by the user.--However, we must ask: what order will they appear in? In cases without-dependency, this is easy: we just use the lexical left-to-right ordering-of first occurrence. With dependency, we cannot get off the hook so-easily.--We thus state:-- * These variables appear in the order as given by ScopedSort, where-   the input to ScopedSort is the left-to-right order of first occurrence.--Note that this applies only to *implicit* quantification, without a-`forall`. If the user writes a `forall`, then we just use the order given.--ScopedSort is defined thusly (as proposed in #15743):-  * Work left-to-right through the input list, with a cursor.-  * If variable v at the cursor is depended on by any earlier variable w,-    move v immediately before the leftmost such w.--INVARIANT: The prefix of variables before the cursor form a valid telescope.--Note that ScopedSort makes sense only after type inference is done and all-types/kinds are fully settled and zonked.---}---- | Do a topological sort on a list of tyvars,---   so that binders occur before occurrences--- E.g. given  [ a::k, k::*, b::k ]--- it'll return a well-scoped list [ k::*, a::k, b::k ]------ This is a deterministic sorting operation--- (that is, doesn't depend on Uniques).------ It is also meant to be stable: that is, variables should not--- be reordered unnecessarily. This is specified in Note [ScopedSort]--- See also Note [Ordering of implicit variables] in "GHC.Rename.HsType"--scopedSort :: [TyCoVar] -> [TyCoVar]-scopedSort = go [] []-  where-    go :: [TyCoVar] -- already sorted, in reverse order-       -> [TyCoVarSet] -- each set contains all the variables which must be placed-                       -- before the tv corresponding to the set; they are accumulations-                       -- of the fvs in the sorted tvs' kinds--                       -- This list is in 1-to-1 correspondence with the sorted tyvars-                       -- INVARIANT:-                       --   all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list)-                       -- That is, each set in the list is a superset of all later sets.--       -> [TyCoVar] -- yet to be sorted-       -> [TyCoVar]-    go acc _fv_list [] = reverse acc-    go acc  fv_list (tv:tvs)-      = go acc' fv_list' tvs-      where-        (acc', fv_list') = insert tv acc fv_list--    insert :: TyCoVar       -- var to insert-           -> [TyCoVar]     -- sorted list, in reverse order-           -> [TyCoVarSet]  -- list of fvs, as above-           -> ([TyCoVar], [TyCoVarSet])   -- augmented lists-    insert tv []     []         = ([tv], [tyCoVarsOfType (tyVarKind tv)])-    insert tv (a:as) (fvs:fvss)-      | tv `elemVarSet` fvs-      , (as', fvss') <- insert tv as fvss-      = (a:as', fvs `unionVarSet` fv_tv : fvss')--      | otherwise-      = (tv:a:as, fvs `unionVarSet` fv_tv : fvs : fvss)-      where-        fv_tv = tyCoVarsOfType (tyVarKind tv)--       -- lists not in correspondence-    insert _ _ _ = panic "scopedSort"---- | Get the free vars of a type in scoped order-tyCoVarsOfTypeWellScoped :: Type -> [TyVar]-tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList---- | Get the free vars of types in scoped order-tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar]-tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList  {- ************************************************************************
compiler/GHC/Core/TyCo/Ppr.hs view
@@ -41,8 +41,11 @@ import GHC.Core.TyCo.Tidy import GHC.Core.TyCo.FVs import GHC.Core.Class-import GHC.Types.Var+import GHC.Core.Predicate( scopedSort ) import GHC.Core.Multiplicity( pprArrowWithMultiplicity )++import GHC.Types.Var+ import GHC.Iface.Type  import GHC.Types.Var.Set@@ -321,7 +324,7 @@ pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc]   where     (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc-    user_bndrs = tyVarSpecToBinders $ dataConUserTyVarBinders dc+    user_bndrs = dataConUserTyVarBinders dc     forAllDoc  = pprUserForAll user_bndrs     thetaDoc   = pprThetaArrowTy theta     argsDoc    = hsep (fmap pprParendType (map scaledThing arg_tys))
compiler/GHC/Core/TyCo/Rep.hs view
@@ -37,7 +37,7 @@         -- * Coercions         Coercion(..), CoSel(..), FunSel(..),         UnivCoProvenance(..),-        CoercionHole(..), coHoleCoVar, setCoHoleCoVar, isHeteroKindCoHole,+        CoercionHole(..), coHoleCoVar, setCoHoleCoVar,         CoercionN, CoercionR, CoercionP, KindCoercion,         MCoercion(..), MCoercionR, MCoercionN, @@ -261,47 +261,9 @@   multiplicity argument nondependent in #20164.  * Re the ft_af field: see Note [FunTyFlag] in GHC.Types.Var-  See Note [Types for coercions, predicates, and evidence]-  This visibility info makes no difference in Core; it matters-  only when we regard the type as a Haskell source type.--Note [Types for coercions, predicates, and evidence]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We treat differently:--  (a) Predicate types-        Test: isPredTy-        Binders: DictIds-        Kind: Constraint-        Examples: (Eq a), and (a ~ b)--  (b) Coercion types are primitive, unboxed equalities-        Test: isCoVarTy-        Binders: CoVars (can appear in coercions)-        Kind: TYPE (TupleRep [])-        Examples: (t1 ~# t2) or (t1 ~R# t2)--  (c) Evidence types is the type of evidence manipulated by-      the type constraint solver.-        Test: isEvVarType-        Binders: EvVars-        Kind: Constraint or TYPE (TupleRep [])-        Examples: all coercion types and predicate types--Coercion types and predicate types are mutually exclusive,-but evidence types are a superset of both.--When treated as a user type,--  - Predicates (of kind Constraint) are invisible and are-    implicitly instantiated--  - Coercion types, and non-pred evidence types (i.e. not-    of kind Constraint), are just regular old types, are-    visible, and are not implicitly instantiated.--In a FunTy { ft_af = af } and af = FTF_C_T or FTF_C_C, the argument-type is always a Predicate type.+  See Note [Types for coercions, predicates, and evidence] in+  GHC.Core.Predicate.  This visibility info makes no difference in Core;+  it matter only when we regard the type as a Haskell source type.  Note [Weird typing rule for ForAllTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -983,7 +945,6 @@   ppr SelForAll      = text "All"   ppr (SelFun fs)    = text "Fun" <> parens (ppr fs) - pprOneCharRole :: Role -> SDoc pprOneCharRole Nominal          = char 'N' pprOneCharRole Representational = char 'R'@@ -994,6 +955,11 @@   ppr SelArg  = text "arg"   ppr SelRes  = text "res" +instance NFData FunSel where+  rnf SelMult = ()+  rnf SelArg  = ()+  rnf SelRes  = ()+ instance Binary CoSel where    put_ bh (SelTyCon n r)   = do { putByte bh 0; put_ bh n; put_ bh r }    put_ bh SelForAll        = putByte bh 1@@ -1010,9 +976,9 @@                    _ -> return (SelFun SelRes) }  instance NFData CoSel where-  rnf (SelTyCon n r) = n `seq` r `seq` ()+  rnf (SelTyCon n r) = rnf n `seq` rnf r `seq` ()   rnf SelForAll      = ()-  rnf (SelFun fs)    = fs `seq` ()+  rnf (SelFun fs)    = rnf fs `seq` ()  -- | A semantically more meaningful type to represent what may or may not be a -- useful 'Coercion'.@@ -1092,19 +1058,21 @@ between ForallTys, or TyConApps, or FunTys.  There are three forms, split by the CoSel field inside the SelCo:-SelTyCon, SelForAll, and SelFun.+SelTyCon, SelForAll, and SelFun.  The typing rules below are directly+checked by the SelCo case of GHC.Core.Lint.lintCoercion.  * SelTyCon: -      co : (T s1..sn) ~r0 (T t1..tn)-      T is a data type, not a newtype, nor an arrow type-      r = tyConRole tc r0 i+      co : (T s1..sn) ~r (T t1..tn)+      T is not a saturated FunTyCon (use SelFun for that)+      T is injective at role r+      ri = tyConRole tc r i       i < n    (i is zero-indexed)       -----------------------------------      SelCo (SelTyCon i r) co : si ~r ti+      SelCo (SelTyCon i ri) co : si ~ri ti -  "Not a newtype": see Note [SelCo and newtypes]-  "Not an arrow type": see SelFun below+  "Injective at role r": see Note [SelCo and newtypes]+  "Not saturated FunTyCon": see SelFun below     See Note [SelCo Cached Roles] @@ -1200,11 +1168,12 @@    forall a. e_ty Note the Specified visibility of (forall a. e_ty); the Core type just isn't able to express more than one visiblity, and we pick `Specified`.  See `exprType` and-`mkLamType` in GHC.Core.Utils, and `GHC.Type.Var.coreLamForAllTyFlag`.+`mkLamType` in GHC.Core.Utils, and `GHC.Type.Var.coreTyLamForAllTyFlag`.  So how can we ever get a term of type (forall a -> e_ty)?  Answer: /only/ via a-cast built with ForAllCo.  See `GHC.Tc.Types.Evidence.mkWpForAllCast`.  This does-not seem very satisfying, but it does the job.+cast built with ForAllCo.  See `GHC.Core.Coercion.mkForAllVisCos`,+`GHC.Tc.Types.Evidence.mkWpForAllCast` and `GHC.Core.Make.mkCoreTyLams`.+This does not seem very satisfying, but it does the job.  An alternative would be to put a visibility flag into `Lam` (a huge change), or into a `TyVar` (a more plausible change), but we leave that for the future.@@ -1220,14 +1189,15 @@  The typing rule is: -  kind_co : k1 ~N k2-  tv1:k1 |- co : t1 ~r t2+  G |- kind_co : k1 ~N k2+  tv1 \not\in fv(typeKind(t1),typeKind(t2))  -- Skolem escape+  G, tv1:k1 |- co : t1 ~r t2   if r=N, then vis1=vis2   -------------------------------------  ForAllCo (tv1:k1) vis1 vis2 kind_co co-     : forall (tv1:k1) <vis1>. t1+  G |- ForAllCo (tv1:k1) vis1 vis2 kind_co co+         : forall (tv1:k1) <vis1>. t1               ~r-       forall (tv1:k2) <vis2>. (t2[tv1 |-> (tv1:k2) |> sym kind_co])+           forall (tv1:k2) <vis2>. (t2[tv1 |-> (tv1:k2) |> sym kind_co])  Several things to note here @@ -1471,6 +1441,10 @@  Yikes! Clearly, this is terrible. The solution is simple: forbid SelCo to be used on newtypes if the internal coercion is representational.+More specifically, we use isInjectiveTyCon to determine whether+T is injective at role r:+* Newtypes and datatypes are both injective at Nominal role, but+* Newtypes are not injective at Representational role See the SelCo equation for GHC.Core.Lint.lintCoercion.  This is not just some corner case discovered by a segfault somewhere;@@ -1566,9 +1540,9 @@   -- Why Ord?  See Note [Ord instance of IfaceType] in GHC.Iface.Type  instance Outputable UnivCoProvenance where-  ppr PhantomProv      = text "(phantom)"-  ppr ProofIrrelProv   = text "(proof irrel)"-  ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str))+  ppr PhantomProv          = text "(phantom)"+  ppr (ProofIrrelProv {})  = text "(proof irrel)"+  ppr (PluginProv str)     = parens (text "plugin" <+> brackets (text str))  instance NFData UnivCoProvenance where   rnf p = p `seq` ()@@ -1679,19 +1653,11 @@                        -- See Note [CoercionHoles and coercion free variables]                   , ch_ref :: IORef (Maybe Coercion)--                 , ch_hetero_kind :: Bool-                       -- True <=> arises from a kind-level equality-                       -- See Note [Equalities with incompatible kinds]-                       --     in GHC.Tc.Solver.Equality, wrinkle (EIK2)                  }  coHoleCoVar :: CoercionHole -> CoVar coHoleCoVar = ch_co_var -isHeteroKindCoHole :: CoercionHole -> Bool-isHeteroKindCoHole = ch_hetero_kind- setCoHoleCoVar :: CoercionHole -> CoVar -> CoercionHole setCoHoleCoVar h cv = h { ch_co_var = cv } @@ -1702,8 +1668,7 @@   dataTypeOf _ = mkNoRepType "CoercionHole"  instance Outputable CoercionHole where-  ppr (CoercionHole { ch_co_var = cv, ch_hetero_kind = hk })-    = braces (ppr cv <> ppWhen hk (text "[hk]"))+  ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv)  instance Uniquable CoercionHole where   getUnique (CoercionHole { ch_co_var = cv }) = getUnique cv
compiler/GHC/Core/TyCo/Subst.hs view
@@ -13,9 +13,9 @@         Subst(..), TvSubstEnv, CvSubstEnv, IdSubstEnv,         emptyIdSubstEnv, emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubst,         emptySubst, mkEmptySubst, isEmptyTCvSubst, isEmptySubst,-        mkTCvSubst, mkTvSubst, mkCvSubst, mkIdSubst,+        mkSubst, mkTCvSubst, mkTvSubst, mkCvSubst, mkIdSubst,         getTvSubstEnv, getIdSubstEnv,-        getCvSubstEnv, getSubstInScope, setInScope, getSubstRangeTyCoFVs,+        getCvSubstEnv, substInScopeSet, setInScope, getSubstRangeTyCoFVs,         isInScope, elemSubst, notElemSubst, zapSubst,         extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet,         extendTCvSubst, extendTCvSubstWithClone,@@ -60,7 +60,7 @@    , mkAxiomCo, mkAppCo, mkGReflCo    , mkInstCo, mkLRCo, mkTyConAppCo    , mkCoercionType-   , coercionKind, coercionLKind, coVarTypesRole )+   , coercionLKind, coVarTypesRole ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar ) import {-# SOURCE #-} GHC.Core.Ppr ( ) -- instance Outputable CoreExpr import {-# SOURCE #-} GHC.Core ( CoreExpr )@@ -68,12 +68,10 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs -import GHC.Types.Basic( SwapFlag(..), isSwapped, pickSwap, notSwapped ) import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Data.Pair import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc import GHC.Types.Unique.Supply@@ -104,9 +102,9 @@ data Subst   = Subst InScopeSet  -- Variables in scope (both Ids and TyVars) /after/                       -- applying the substitution-          IdSubstEnv  -- Substitution from NcIds to CoreExprs-          TvSubstEnv  -- Substitution from TyVars to Types-          CvSubstEnv  -- Substitution from CoVars to Coercions+          IdSubstEnv  -- Substitution from InId    to OutExpr+          TvSubstEnv  -- Substitution from InTyVar to OutType+          CvSubstEnv  -- Substitution from InCoVar to OutCoercion          -- INVARIANT 1: See Note [The substitution invariant]         -- This is what lets us deal with name capture properly@@ -115,7 +113,7 @@         --              see Note [Substitutions apply only once]         --         -- INVARIANT 3: See Note [Extending the IdSubstEnv] in "GHC.Core.Subst"-        -- and Note [Extending the TvSubstEnv and CvSubstEnv]+        -- and              Note [Extending the TvSubstEnv and CvSubstEnv]         --         -- INVARIANT 4: See Note [Substituting types, coercions, and expressions] @@ -183,8 +181,10 @@ we use during unifications, it must not be repeatedly applied.  Note [Extending the TvSubstEnv and CvSubstEnv]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See #tcvsubst_invariant# for the invariants that must hold.+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The TvSubstEnv and CvSubstEnv have a binding for each TyCoVar+  - whose unique has changed, OR+  - whose kind has changed  This invariant allows a short-cut when the subst envs are empty: if the TvSubstEnv and CvSubstEnv are empty --- i.e. (isEmptyTCvSubst subst)@@ -207,7 +207,7 @@ * In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty  Note [Substituting types, coercions, and expressions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Types and coercions are mutually recursive, and either may have variables "belonging" to the other. Thus, every time we wish to substitute in a type, we may also need to substitute in a coercion, and vice versa.@@ -271,6 +271,9 @@ isEmptyTCvSubst (Subst _ _ tv_env cv_env)   = isEmptyVarEnv tv_env && isEmptyVarEnv cv_env +mkSubst :: InScopeSet -> IdSubstEnv -> TvSubstEnv -> CvSubstEnv -> Subst+mkSubst = Subst+ mkTCvSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> Subst mkTCvSubst in_scope tvs cvs = Subst in_scope emptyIdSubstEnv tvs cvs @@ -295,8 +298,8 @@ getCvSubstEnv (Subst _ _ _ cenv) = cenv  -- | Find the in-scope set: see Note [The substitution invariant]-getSubstInScope :: Subst -> InScopeSet-getSubstInScope (Subst in_scope _ _ _) = in_scope+substInScopeSet :: Subst -> InScopeSet+substInScopeSet (Subst in_scope _ _ _) = in_scope  setInScope :: Subst -> InScopeSet -> Subst setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs@@ -501,7 +504,7 @@   , not (all isCoVar cvs)   = pprPanic "zipCoEnv" (ppr cvs <+> ppr cos)   | otherwise-  = mkVarEnv (zipEqual "zipCoEnv" cvs cos)+  = mkVarEnv (zipEqual cvs cos)  -- Pretty printing, for debugging only @@ -917,7 +920,7 @@ substForAllCoBndr :: Subst -> TyCoVar -> KindCoercion                   -> (Subst, TyCoVar, Coercion) substForAllCoBndr subst-  = substForAllCoBndrUsing NotSwapped (substCo subst) subst+  = substForAllCoBndrUsing (substCo subst) subst  -- | Like 'substForAllCoBndr', but disables sanity checks. -- The problems that the sanity checks in substCo catch are described in@@ -927,33 +930,26 @@ substForAllCoBndrUnchecked :: Subst -> TyCoVar -> KindCoercion                            -> (Subst, TyCoVar, Coercion) substForAllCoBndrUnchecked subst-  = substForAllCoBndrUsing NotSwapped (substCoUnchecked subst) subst+  = substForAllCoBndrUsing (substCoUnchecked subst) subst  -- See Note [Sym and ForAllCo]-substForAllCoBndrUsing :: SwapFlag  -- Apply sym to binder?-                       -> (Coercion -> Coercion)  -- transformation to kind co+substForAllCoBndrUsing :: (Coercion -> Coercion)  -- transformation to kind co                        -> Subst -> TyCoVar -> KindCoercion                        -> (Subst, TyCoVar, KindCoercion)-substForAllCoBndrUsing sym sco subst old_var-  | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var-  | otherwise       = substForAllCoCoVarBndrUsing sym sco subst old_var+substForAllCoBndrUsing sco subst old_var+  | isTyVar old_var = substForAllCoTyVarBndrUsing sco subst old_var+  | otherwise       = substForAllCoCoVarBndrUsing sco subst old_var -substForAllCoTyVarBndrUsing :: SwapFlag  -- Apply sym to binder?-                            -> (Coercion -> Coercion)  -- transformation to kind co+substForAllCoTyVarBndrUsing :: (Coercion -> Coercion)  -- transformation to kind co                             -> Subst -> TyVar -> KindCoercion                             -> (Subst, TyVar, KindCoercion)-substForAllCoTyVarBndrUsing sym sco (Subst in_scope idenv tenv cenv) old_var old_kind_co+substForAllCoTyVarBndrUsing sco (Subst in_scope idenv tenv cenv) old_var old_kind_co   = assert (isTyVar old_var )     ( Subst (in_scope `extendInScopeSet` new_var) idenv new_env cenv     , new_var, new_kind_co )   where-    new_env | no_change, notSwapped sym-            = delVarEnv tenv old_var-            | isSwapped sym-            = extendVarEnv tenv old_var $-              TyVarTy new_var `CastTy` new_kind_co-            | otherwise-            = extendVarEnv tenv old_var (TyVarTy new_var)+    new_env | no_change = delVarEnv tenv old_var+            | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)      no_kind_change = noFreeVarsOfCo old_kind_co     no_change = no_kind_change && (new_var == old_var)@@ -969,20 +965,17 @@      new_var  = uniqAway in_scope (setTyVarKind old_var new_ki1) -substForAllCoCoVarBndrUsing :: SwapFlag  -- Apply sym to binder?-                            -> (Coercion -> Coercion)  -- transformation to kind co+substForAllCoCoVarBndrUsing :: (Coercion -> Coercion)  -- transformation to kind co                             -> Subst -> CoVar -> KindCoercion                             -> (Subst, CoVar, KindCoercion)-substForAllCoCoVarBndrUsing sym sco (Subst in_scope idenv tenv cenv)+substForAllCoCoVarBndrUsing sco (Subst in_scope idenv tenv cenv)                             old_var old_kind_co   = assert (isCoVar old_var )     ( Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv     , new_var, new_kind_co )   where-    new_cenv | no_change, notSwapped sym-             = delVarEnv cenv old_var-             | otherwise-             = extendVarEnv cenv old_var (mkCoVarCo new_var)+    new_cenv | no_change = delVarEnv cenv old_var+             | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var)      no_kind_change = noFreeVarsOfCo old_kind_co     no_change = no_kind_change && (new_var == old_var)@@ -990,10 +983,8 @@     new_kind_co | no_kind_change = old_kind_co                 | otherwise      = sco old_kind_co -    Pair h1 h2 = coercionKind new_kind_co--    new_var       = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type-    new_var_type  = pickSwap sym h1 h2+    new_ki1       = coercionLKind new_kind_co+    new_var       = uniqAway in_scope $ mkCoVar (varName old_var) new_ki1  substCoVar :: Subst -> CoVar -> Coercion substCoVar (Subst _ _ _ cenv) cv
compiler/GHC/Core/TyCo/Tidy.hs view
@@ -1,5 +1,3 @@-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}- -- | Tidying types and coercions for printing in error messages. module GHC.Core.TyCo.Tidy   (@@ -21,6 +19,7 @@ import GHC.Prelude import GHC.Data.FastString +import GHC.Core.Predicate( scopedSort ) import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs import GHC.Types.Name hiding (varName)@@ -358,7 +357,7 @@      go_cv cv = tidyTyCoVarOcc env cv -    go_hole (CoercionHole cv r h) = (CoercionHole $! go_cv cv) r h+    go_hole (CoercionHole cv r) = (CoercionHole $! go_cv cv) r     -- Tidy even the holes; tidied types should have tidied kinds  tidyCos :: TidyEnv -> [Coercion] -> [Coercion]
compiler/GHC/Core/TyCon.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP  #-} {-# LANGUAGE FlexibleInstances  #-} {-# LANGUAGE LambdaCase         #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -25,7 +24,8 @@         mkRequiredTyConBinder,         mkAnonTyConBinder, mkAnonTyConBinders,         tyConBinderForAllTyFlag, tyConBndrVisForAllTyFlag, isNamedTyConBinder,-        isVisibleTyConBinder, isInvisibleTyConBinder,+        isVisibleTyConBinder, isInvisSpecTyConBinder, isInvisibleTyConBinder,+        isInferredTyConBinder,         isVisibleTcbVis, isInvisSpecTcbVis,          -- ** Field labels@@ -46,8 +46,9 @@         noTcTyConScopedTyVars,          -- ** Predicates on TyCons-        isAlgTyCon, isVanillaAlgTyCon,-        isClassTyCon, isFamInstTyCon,+        isAlgTyCon, isVanillaAlgTyCon, isClassTyCon,+        isUnaryClassTyCon, isUnaryClassTyCon_maybe,+        isFamInstTyCon,         isPrimTyCon,         isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon,         isUnboxedSumTyCon, isPromotedTupleTyCon,@@ -59,7 +60,7 @@         isKindTyCon, isKindName, isLiftedTypeKindTyConName,         isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon, -        isDataTyCon,+        isBoxedDataTyCon,         isTypeDataTyCon,         isEnumerationTyCon,         isNewTyCon, isAbstractTyCon,@@ -68,7 +69,7 @@         isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe,         tyConInjectivityInfo,         isBuiltInSynFamTyCon_maybe,-        isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs,+        isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon,         isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe,         isImplicitTyCon,         isTyConWithSrcDataCons,@@ -86,8 +87,6 @@         tyConCType_maybe,         tyConDataCons, tyConDataCons_maybe,         tyConSingleDataCon_maybe, tyConSingleDataCon,-        tyConAlgDataCons_maybe,-        tyConSingleAlgDataCon_maybe,         tyConFamilySize,         tyConStupidTheta,         tyConArity,@@ -181,6 +180,7 @@ import GHC.Utils.Misc import GHC.Types.Unique.Set import GHC.Unit.Module+import Control.DeepSeq  import Language.Haskell.Syntax.Basic (FieldLabelString(..)) @@ -488,7 +488,7 @@   | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv   | otherwise               = mkAnonTyConBinder tv -tyConBinderForAllTyFlag :: TyConBinder -> ForAllTyFlag+tyConBinderForAllTyFlag :: VarBndr a TyConBndrVis -> ForAllTyFlag tyConBinderForAllTyFlag (Bndr _ vis) = tyConBndrVisForAllTyFlag vis  tyConBndrVisForAllTyFlag :: TyConBndrVis -> ForAllTyFlag@@ -514,10 +514,22 @@ isInvisSpecTcbVis (NamedTCB Specified) = True isInvisSpecTcbVis _                    = False +isInvisInferTcbVis :: TyConBndrVis -> Bool+isInvisInferTcbVis (NamedTCB Inferred) = True+isInvisInferTcbVis _                   = False++isInvisSpecTyConBinder :: VarBndr tv TyConBndrVis -> Bool+-- Works for IfaceTyConBinder too+isInvisSpecTyConBinder (Bndr _ tcb_vis) = isInvisSpecTcbVis tcb_vis+ isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool -- Works for IfaceTyConBinder too isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb) +isInferredTyConBinder :: VarBndr var TyConBndrVis -> Bool+-- Works for IfaceTyConBinder too+isInferredTyConBinder (Bndr _ tcb_vis) = isInvisInferTcbVis tcb_vis+ -- Build the 'tyConKind' from the binders and the result kind. -- Keep in sync with 'mkTyConKind' in GHC.Iface.Type. mkTyConKind :: [TyConBinder] -> Kind -> Kind@@ -719,7 +731,12 @@                   0 -> return AnonTCB                   _ -> do { vis <- get bh; return (NamedTCB vis) } } +instance NFData TyConBndrVis where+  rnf AnonTCB        = ()+  rnf (NamedTCB vis) = rnf vis ++ {- ********************************************************************* *                                                                      *                The TyCon type@@ -1114,6 +1131,11 @@                         -- in tcHasFixedRuntimeRep.     } +  | UnaryClassTyCon {  -- See Note [Unary class magic], esp (UCM2)+                       -- INVARIANT: the algTcFlavour of this TyCon is ClassTyCon+      data_con :: DataCon+      }+ mkSumTyConRhs :: [DataCon] -> AlgTyConRhs mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons) @@ -1169,11 +1191,12 @@ -- that visibility in this sense does not correspond to visibility in -- the context of any particular user program! visibleDataCons :: AlgTyConRhs -> [DataCon]-visibleDataCons (AbstractTyCon {})            = []-visibleDataCons (DataTyCon{ data_cons = cs }) = cs-visibleDataCons (NewTyCon{ data_con = c })    = [c]-visibleDataCons (TupleTyCon{ data_con = c })  = [c]-visibleDataCons (SumTyCon{ data_cons = cs })  = cs+visibleDataCons (AbstractTyCon {})                = []+visibleDataCons (DataTyCon{ data_cons = cs })     = cs+visibleDataCons (NewTyCon{ data_con = c })        = [c]+visibleDataCons (UnaryClassTyCon{ data_con = c }) = [c]+visibleDataCons (TupleTyCon{ data_con = c })      = [c]+visibleDataCons (SumTyCon{ data_cons = cs })      = cs  -- | Describes the flavour of an algebraic type constructor. For -- classes and data families, this flavour includes a reference to@@ -1191,7 +1214,9 @@   | UnboxedSumTyCon    -- | Type constructors representing a class dictionary.-  -- See Note [ATyCon for classes] in "GHC.Core.TyCo.Rep"+  -- See Note [ATyCon for classes] in "GHC.Types.TyThing"+  -- INVARIANT: the algTcRhs is never NewTyCon; it could be+  --            TupleTyCon, DataTyCon, UnaryClassTyCon   | ClassTyCon         Class           -- INVARIANT: the classTyCon of this Class is the                         -- current tycon@@ -1409,6 +1434,194 @@  See also Note [Newtype eta and homogeneous axioms] in GHC.Tc.TyCl.Build. +Note [Unary class magic]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider a class with just one method, or with no methods and one+superclass:+  class UC a where { op :: a -> a }+  class Eq a => UD a where {}+Such a class is called a /unary class/.++We could represent the dictionary for a unary class with a data type:+  data UC a where { MkUC :: (a->a) -> UC a }+  data UD a where { MkUD :: Eq a =>  UD a }+But it would be more efficent to use a newtype; and for decades GHC did+exactly that, because:++  * Unary classes are surprisingly common, so it's a useful optimisation.++  * The `reflection` library uses `unsafeCoerce` to /rely/ on the fact that+    a unary class is ultimately represented by its payload.  We may not like+    it, and I hope to ultimately eliminate the necessity for this by using+    `withDict` (see Note [withDict] in GHC.Tc.Instance.Class).  But meanwhile+    we'd prefer not to break this usage.++But alas, using a newtype representation (surprisingly) led multiple, subtle,+Bad Things: see Note [Representing unary classes with newtypes: bad, bad, bad].++This Note explains what GHC now does for unary classes.++(UCM0) Throughout the compiler, right up to the code generator, GHC thinks that a+  unary class is just like a non-unary class:+    - Represented by a data type,+    - with one constructor,+    - which has one field++(UCM1) Then when converting from Core to STG, in GHC.CoreToStg, we effectively+  transform+    - op   ta tb tc dict_arg  -->  dict_arg+    - MkUC ta tb tc meth_arg  -->  meth_arg++  Note that we do this transformation well /after/ generating an interface file,+  so importing modules only see the data constructor.++  This late transformation has a lot in common with the treatment of+  `unsafeEqualityProof`; see (U2) in Note [Implementing unsafeCoerce]+  in GHC.Internal.Unsafe.Coerce.++In this way we get the efficiency of a newtype without the bugs that we get+by exposing the newtype representation too early.++There are a number of wrinkles++(UCM2) The TyCon for a unary class is /not/ identified as a newtype.+   Rather, it has its own AlgTyConRhs, namely `UnaryClassTyCon`++(UCM3) Unlike non-unary classes, a value of type (C ty), where `C` is a unary+   class, might be bottom, because it is represented by the method type alone.+   See GHC.Core.Type.isTerminatingType.++   Similarly in exprOkForSpeculation/exprOkToDiscard/exprOkForSpecEval,+   in GHC.Core.Utils.  In the utility funcion `app_ok` we need a special+   case for the DFunIds; they generally terminate, but not for unary classes.++(UMC4) To avoid regressions, in Core we want to remember that+             (MkUC x) is really just  x+             (op d)   is really just  d+    We account for this in several places:++    - `GHC.Core.Utils.exprIsTrivial` treats the above two forms as trivial++    - `GHC.Core.Unfold.sizeExpr` (which computes the size of an expression to+      guide inlining) treats (MkUC e) as the same size as `e`, and similarly+      (op d).++    - `GHC.Core.Unfold.inlineBoringOK` where we want to ensure that we+      always-inline (MkUC op), even into a boring context. See (IB6)+      in Note [inlineBoringOk]++(UCM5) `GHC.Core.Unfold.Make.mkDFunUnfolding` builds a `DFunUnfolding` for+   non-unary classes, but just an /ordinary/ unfolding for unary classes.+       instance Num a => Num [a] where { .. }       -- (I1)+       instance UC a => UC [a] where { op = $cop }  -- (I2)+   From (I1) we get+       $fNumList = /\a \(d:Num a). MkNum (..) (..) (..)+         -- $fNumList has a DFunUnfolding+    But from (I2) we get+       $fUCList = /\a (d:UC a). MkUC ($cop a d)+       -- $fUCList has a regular CoreUnfolding++    Why?  Because we can safely inline $fUCList without code-size blow-up.+    Just one less indirection. It'd probably work ok with a DFunUnfolding;+    and it'd add another case for (UCM4) to spot.++(UCM6) In the constraint solver, when constructing evidence for a unary class+    (e.g. implicit parameters, withDict) be careful to use+    - the data constructor to build it: see `evDictApp`, `evUnaryDictAppE`+    - the class op to take it apart: see `evUnwrapIP`++(UCM7) You might worry about+           class UC1 a where { op :: Int# }    -- Single unboxed field+           class (a ~# b) => UC2 a b where {}  -- Unboxed equality superclass+  But these are illegal: predicates are always boxed, and all classes must have+  lifted fields.++(UCM8) The data constructor for a unary class has no wrapper, just a worker.+  (And the worker is turned into a cast by GHC.CoreToStg.Prep.isUnaryClassApp,+  as described above.)++(UCM9) Unary classes are treated as injective by `isInjectiveTyCon`, just like+  non-unary classes (which are TupleTyCons or DataTyCons).  This matters,+  because of the injectivity check done by lintCoercion (SelCo cs co)+  in GHC.Core.Lint.  There is a similar injectivity check in+  GHC.Core.Opt.Arity.pushCoDataCon.++  Generally, we want unary classes to behave like ordinary non-unary ones.++(UCM10) When, precisely, is a class unary?  It is unary iff+                  it has one field (superclass or method)+                  of boxed type+  The boxed-ness important. Consider+          class (a ~# b) => a ~ b where {}+  which is `eqClass` in GHC.Builtin.Types.  This has only one field, but it is+  definitely not a unary class: it is definitely represented by an ordinary+  algebraic data type with a single field of type (a ~# b).++  See `unary_class` in `GHC.Tc.TyCl.tcClassDecl1`++(UCM11) When building evidence for classes (unary or not) and implicit parameters,+  the constraint solver is careful to use functions that hide the precise+  evidence construction method.  Eg.g `evWrapIPE`.++(UCM12) In an interface-file description of a Class, we record whether or not+  the class is unary.  In theory this field is redundant, but because its value+  depends on the superclass and method fields, it's very easy to end up with+  a black hole when rehydrating interface the interface file. Easiest just to+  store the bit!  See `ifUnary` in GHC.Iface.Synatax.IfaceClassBody.+++Note [Representing unary classes with newtypes: bad, bad, bad]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the past we represented a unary class with a newtype, but that led to+some at least three really subtle bad consequences.++* Problem 1: When we represented unary classes via a newtype, the+    newtype axiom looked like+           t1::CONSTRAINT r ~ t2::TYPE r+    If TYPE and CONSTRAINT are apart, this can create unsoundness, via KindCo;+    see #21623.  Now we never make such a coercion, so that worry about TYPE+    being apart from CONSTRAINT has gone away entirely.  Hooray.++* Problem 2: a horrible hack in GHC.Core.Opt.OccurAnal.scrutOkForBinderSwap;+  see Historical Note [Care with binder-swap on dictionaries].+  Now the hack is gone.++* Problem 3: bogus specialisation.  The gory details are explained+  at https://gitlab.haskell.org/ghc/ghc/-/issues/23109#note_499130++  We had (using newtype classes)+     newtype SNat a = MKSNat Natural           -- axiom  snCo a :: SNat a ~ Natural+     class KNat a where { natSing :: SNat a }  -- axiom  knCo a :: KNat a ~ SNat a+  and a pattern match+    K @a (g : 32 ~ a+1) -> ...(foo @a (d :: KNat a))...+  where K is a data constructor binding `a` as an existential.++  In the code I was looking at, after lots of inlining an simplification, we find+  that (d::KNat a) is built like this:+    (d1 :: KNat 32)    = 32 |> sym (snCo 32) |> sym (knCo 32)+    (d2 :: SNat (a+1)) = d1 |> knCo g+    (d3 :: Natural)    = d2 |> snCo (a+1)+    (d4 :: Natural)    = d3 - 1+    (d  :: KNat a)     = d4 |> sym (snCo a) |> sym (knCo a)++  But d3 :: Natural = 32 |> (co's involving g) :: Natural ~ Natural+  and that is just Refl.  So we drop all the co's, including the crucial `g`,+  and just say d3 = 32; and+        d :: KNat a = (32-1) |> sym (snCo a) |> sym (knCo a)+  Now, we can float `d` outwards, crucially aided by polymorphic specialisation,+  (Note [Specialising polymorphic dictionaries] in GHC.Core.Opt.Specialise)+  and use that evidence to get an utterly bogus specialisation for the function+      foo :: forall b. KNat b => blah++  Solution: don't use newtype classes.  Then we get+    (d1 :: KNat 32)    = MkKN @32 (32 |> sym (snCo 32))+    (d2 :: SNat (a+1)) = natSing d1 |> SN g+    (d3 :: Natural)    = d2 |> snCo (a+1)+    (d4 :: Natural)    = d3 -1+    (d  :: KNat a)     = MkKN @a (d4 |> sym (snCo a))+  Now we don't get cancelling-out coercions.++ ************************************************************************ *                                                                      *                  TyConRepName@@ -1542,11 +1755,7 @@ -- "GHC.Types.RepType" and Note [VoidRep] in "GHC.Types.RepType". data PrimRep -- Unpacking of sum types is only supported since 9.6.1-#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)   = BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value-#else-  = BoxedRep                !(Maybe Levity) -- ^ Boxed, heap value-#endif   | Int8Rep       -- ^ Signed, 8-bit value   | Int16Rep      -- ^ Signed, 16-bit value   | Int32Rep      -- ^ Signed, 32-bit value@@ -1986,21 +2195,26 @@ -- satisfies condition DTT2 of Note [DataToTag overview] in -- GHC.Tc.Instance.Class isValidDTT2TyCon :: TyCon -> Bool-isValidDTT2TyCon = isDataTyCon+isValidDTT2TyCon = isBoxedDataTyCon -isDataTyCon :: TyCon -> Bool+isBoxedDataTyCon :: TyCon -> Bool -- ^ Returns @True@ for data types that are /definitely/ represented by -- heap-allocated constructors.  These are scrutinised by Core-level -- @case@ expressions, and they get info tables allocated for them. ----- Generally, the function will be true for all @data@ types and false--- for @newtype@s, unboxed tuples, unboxed sums and type family--- 'TyCon's. But it is not guaranteed to return @True@ in all cases+-- Generally, the function will be+-- true for all `data` types and+-- false for  newtype+--            unboxed tuples+--            unboxed sums+--            type family+--            type data+-- 'TyCon's. But it is not guaranteed to return `True` in all cases -- that it could. -- -- NB: for a data type family, only the /instance/ 'TyCon's --     get an info table.  The family declaration 'TyCon' does not-isDataTyCon (TyCon { tyConDetails = details })+isBoxedDataTyCon (TyCon { tyConDetails = details })   | AlgTyCon {algTcRhs = rhs} <- details   = case rhs of         TupleTyCon { tup_sort = sort }@@ -2011,8 +2225,9 @@             -- See Note [Type data declarations] in GHC.Rename.Module.         DataTyCon { is_type_data = type_data } -> not type_data         NewTyCon {}        -> False+        UnaryClassTyCon {} -> False         AbstractTyCon {}   -> False      -- We don't know, so return False-isDataTyCon _ = False+isBoxedDataTyCon _ = False  -- | Was this 'TyCon' declared as "type data"? -- See Note [Type data declarations] in GHC.Rename.Module.@@ -2029,23 +2244,34 @@ -- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Equality" isInjectiveTyCon :: TyCon -> Role -> Bool isInjectiveTyCon (TyCon { tyConDetails = details }) role-  = go details role+  = go details   where-    go _                             Phantom          = True -- Vacuously; (t1 ~P t2) holds for all t1, t2!-    go (AlgTyCon {})                 Nominal          = True-    go (AlgTyCon {algTcRhs = rhs})   Representational = isGenInjAlgRhs rhs-    go (SynonymTyCon {})             _                = False+    go _ | Phantom <- role = True -- Vacuously; (t1 ~P t2) holds for all t1, t2!++    go (AlgTyCon {algTcRhs = rhs})+       | Nominal <- role                                = True+       | Representational <- role                       = go_alg_rep rhs+     go (FamilyTyCon { famTcFlav = DataFamilyTyCon _ })-                                                  Nominal = True-    go (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj-    go (FamilyTyCon {})              _                = False-    go (PrimTyCon {})                _                = True-    go (PromotedDataCon {})          _                = True-    go (TcTyCon {})                  _                = True+       | Nominal <- role                                = True+    go (FamilyTyCon { famTcInj = Injective inj })+       | Nominal <- role                                = and inj+    go (FamilyTyCon {})                                 = False -  -- Reply True for TcTyCon to minimise knock on type errors-  -- See (W1) in Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl+    go (SynonymTyCon {})    = False+    go (PrimTyCon {})       = True+    go (PromotedDataCon {}) = True+    go (TcTyCon {})         = True+       -- Reply True for TcTyCon to minimise knock on type errors+       -- See (W1) in Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl +    -- go_alg_rep used only at Representational role+    go_alg_rep (TupleTyCon {})      = True+    go_alg_rep (SumTyCon {})        = True+    go_alg_rep (DataTyCon {})       = True+    go_alg_rep (UnaryClassTyCon {}) = True -- See (UCM9) in Note [Unary class magic]+    go_alg_rep (AbstractTyCon {})   = False+    go_alg_rep (NewTyCon {})        = False  -- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds -- (where r is the role passed in):@@ -2065,15 +2291,6 @@     -- In all other cases, injectivity implies generativity     go r _ = isInjectiveTyCon tc r --- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective--- with respect to representational equality?-isGenInjAlgRhs :: AlgTyConRhs -> Bool-isGenInjAlgRhs (TupleTyCon {})          = True-isGenInjAlgRhs (SumTyCon {})            = True-isGenInjAlgRhs (DataTyCon {})           = True-isGenInjAlgRhs (AbstractTyCon {})       = False-isGenInjAlgRhs (NewTyCon {})            = False- -- | Is this 'TyCon' that for a @newtype@ isNewTyCon :: TyCon -> Bool isNewTyCon (TyCon { tyConDetails = details })@@ -2188,9 +2405,11 @@ isEnumerationTyCon (TyCon { tyConArity = arity, tyConDetails = details })   | AlgTyCon { algTcRhs = rhs } <- details   = case rhs of-       DataTyCon { is_enum = res } -> res-       TupleTyCon {}               -> arity == 0-       _                           -> False+       DataTyCon { is_enum = res }     -> res+       TupleTyCon { tup_sort = tsort }+         | arity == 0                  -> isBoxed (tupleSortBoxity tsort)+                                          -- () is an enumeration, but (##) is not+       _                               -> False   | otherwise = False  -- | Is this a 'TyCon', synonym or otherwise, that defines a family?@@ -2448,6 +2667,8 @@         SumTyCon {} -> False   -- only unboxed sums here +       UnaryClassTyCon {} -> True  -- Always boxed+        NewTyCon { nt_fixed_rep = fixed_rep } -> fixed_rep               -- A newtype might not have a fixed runtime representation               -- with UnliftedNewtypes (#17360)@@ -2579,11 +2800,12 @@ tyConDataCons_maybe (TyCon { tyConDetails = details })   | AlgTyCon {algTcRhs = rhs} <- details   = case rhs of-       DataTyCon { data_cons = cons } -> Just cons-       NewTyCon { data_con = con }    -> Just [con]-       TupleTyCon { data_con = con }  -> Just [con]-       SumTyCon { data_cons = cons }  -> Just cons-       _                              -> Nothing+       DataTyCon { data_cons = cons }     -> Just cons+       NewTyCon { data_con = con }        -> Just [con]+       UnaryClassTyCon { data_con = con } -> Just [con]+       TupleTyCon { data_con = con }      -> Just [con]+       SumTyCon { data_cons = cons }      -> Just cons+       _                                  -> Nothing tyConDataCons_maybe _ = Nothing  -- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@@@ -2594,11 +2816,12 @@ tyConSingleDataCon_maybe (TyCon { tyConDetails = details })   | AlgTyCon { algTcRhs = rhs } <- details   = case rhs of-      DataTyCon { data_cons = [c] } -> Just c-      TupleTyCon { data_con = c }   -> Just c-      NewTyCon { data_con = c }     -> Just c-      _                             -> Nothing-  | otherwise                        = Nothing+      DataTyCon { data_cons = [c] }    -> Just c+      TupleTyCon { data_con = c }      -> Just c+      NewTyCon { data_con = c }        -> Just c+      UnaryClassTyCon { data_con = c } -> Just c+      _                                -> Nothing+  | otherwise = Nothing  -- | Like 'tyConSingleDataCon_maybe', but panics if 'Nothing'. tyConSingleDataCon :: TyCon -> DataCon@@ -2607,23 +2830,6 @@       Just c  -> c       Nothing -> pprPanic "tyConDataCon" (ppr tc) --- | Like 'tyConSingleDataCon_maybe', but returns 'Nothing' for newtypes.-tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon-tyConSingleAlgDataCon_maybe tycon-  | isNewTyCon tycon = Nothing-  | otherwise        = tyConSingleDataCon_maybe tycon---- | Returns @Just dcs@ if the given 'TyCon' is a @data@ type, a tuple type--- or a sum type with data constructors dcs. If the 'TyCon' has more than one--- constructor, or represents a primitive or function type constructor then--- @Nothing@ is returned.------ Like 'tyConDataCons_maybe', but returns 'Nothing' for newtypes.-tyConAlgDataCons_maybe :: TyCon -> Maybe [DataCon]-tyConAlgDataCons_maybe tycon-  | isNewTyCon tycon = Nothing-  | otherwise        = tyConDataCons_maybe tycon- -- | Determine the number of value constructors a 'TyCon' has. Panics if the -- 'TyCon' is not algebraic or a tuple tyConFamilySize  :: TyCon -> Int@@ -2632,6 +2838,7 @@   = case rhs of       DataTyCon { data_cons_size = size } -> size       NewTyCon {}                    -> 1+      UnaryClassTyCon {}             -> 1       TupleTyCon {}                  -> 1       SumTyCon { data_cons_size = size }  -> size       _                              -> pprPanic "tyConFamilySize 1" (ppr tc)@@ -2721,6 +2928,22 @@   | FamilyTyCon {famTcFlav = flav} <- details = Just flav   | otherwise                                 = Nothing +isUnaryClassTyCon :: TyCon -> Bool+isUnaryClassTyCon tc@(TyCon { tyConDetails = details })+  | AlgTyCon { algTcFlavour = flav, algTcRhs = UnaryClassTyCon {} } <- details+  = assertPpr (case flav of { ClassTyCon {} -> True; _ -> False }) (ppr tc) $+    True+  | otherwise+  = False++isUnaryClassTyCon_maybe :: TyCon -> Maybe (Class, DataCon)+isUnaryClassTyCon_maybe (TyCon { tyConDetails = details })+  | AlgTyCon { algTcFlavour = ClassTyCon cls _+             , algTcRhs = UnaryClassTyCon { data_con = dc } } <- details+  = Just (cls, dc)+  | otherwise+  = Nothing+ -- | Is this 'TyCon' that for a class instance? isClassTyCon :: TyCon -> Bool isClassTyCon (TyCon { tyConDetails = details })@@ -2835,11 +3058,12 @@                   SumTyCon {}        -> SumFlavour                   DataTyCon {}       -> DataTypeFlavour                   NewTyCon {}        -> NewtypeFlavour+                  UnaryClassTyCon {} -> ClassFlavour                   AbstractTyCon {}   -> AbstractTypeFlavour    | FamilyTyCon { famTcFlav = flav, famTcParent = parent } <- details   = case flav of-      DataFamilyTyCon{}            -> OpenFamilyFlavour IAmData parent+      DataFamilyTyCon{}            -> OpenFamilyFlavour (IAmData DataType) parent       OpenSynFamilyTyCon           -> OpenFamilyFlavour IAmType parent       ClosedSynFamilyTyCon{}       -> ClosedTypeFamilyFlavour       AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour@@ -2860,7 +3084,7 @@ tcFlavourMustBeSaturated AbstractTypeFlavour {}  = False tcFlavourMustBeSaturated BuiltInTypeFlavour      = False tcFlavourMustBeSaturated PromotedDataConFlavour  = False-tcFlavourMustBeSaturated (OpenFamilyFlavour td _)= case td of { IAmData -> False; IAmType -> True }+tcFlavourMustBeSaturated (OpenFamilyFlavour td _)= case td of { IAmData {} -> False; IAmType -> True } tcFlavourMustBeSaturated TypeSynonymFlavour      = True tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True @@ -2908,6 +3132,10 @@                     0 -> return NotInjective                     _ -> do { xs <- get bh                             ; return (Injective xs) } }++instance NFData Injectivity where+  rnf NotInjective = ()+  rnf (Injective xs) = rnf xs  -- | Returns whether or not this 'TyCon' is definite, or a hole -- that may be filled in at some later point.  See Note [Skolem abstract data]
compiler/GHC/Core/TyCon/Env.hs view
@@ -103,7 +103,7 @@ anyTyConEnv f x          = nonDetFoldUFM ((||) . f) False x disjointTyConEnv x y     = disjointUFM x y -lookupTyConEnv_NF env n = expectJust "lookupTyConEnv_NF" (lookupTyConEnv env n)+lookupTyConEnv_NF env n = expectJust (lookupTyConEnv env n)  -- | Deterministic TyCon Environment --
compiler/GHC/Core/Type.hs view
@@ -33,7 +33,7 @@         mkScaledFunTys,         mkInvisFunTy, mkInvisFunTys,         tcMkVisFunTy, tcMkScaledFunTys, tcMkInvisFunTy,-        splitFunTy, splitFunTy_maybe,+        splitFunTy, splitFunTy_maybe, splitVisibleFunTy_maybe,         splitFunTys, funResultTy, funArgTy,         funTyConAppTy_maybe, funTyFlagTyCon,         tyConAppFunTy_maybe, tyConAppFunCo_maybe,@@ -55,7 +55,7 @@         splitForAllForAllTyBinders, splitForAllForAllTyBinder_maybe,         splitForAllTyCoVar_maybe, splitForAllTyCoVar,         splitForAllTyVar_maybe, splitForAllCoVar_maybe,-        splitPiTy_maybe, splitPiTy, splitPiTys,+        splitPiTy_maybe, splitPiTy, splitPiTys, collectPiTyBinders,         getRuntimeArgTys,         mkTyConBindersPreferAnon,         mkPiTy, mkPiTys,@@ -69,8 +69,6 @@         mkCharLitTy, isCharLitTy,         isLitTy, -        isPredTy,-         getRuntimeRep, splitRuntimeRep_maybe, kindRep_maybe, kindRep,         getLevity, levityType_maybe, @@ -82,8 +80,7 @@         coAxNthLHS,         stripCoercionTy, -        splitInvisPiTys, splitInvisPiTysN,-        invisibleTyBndrCount,+        splitInvisPiTys, splitInvisPiTysN, invisibleBndrCount,         filterOutInvisibleTypes, filterOutInferredTypes,         partitionInvisibleTypes, partitionInvisibles,         tyConForAllTyFlags, appTyForAllTyFlags,@@ -122,7 +119,7 @@         mkTYPEapp, mkTYPEapp_maybe,         mkCONSTRAINTapp, mkCONSTRAINTapp_maybe,         mkBoxedRepApp_maybe, mkTupleRepApp_maybe,-        typeOrConstraintKind,+        typeOrConstraintKind, liftedTypeOrConstraintKind,          -- *** Levity and boxity         sORTKind_maybe, typeTypeOrConstraint,@@ -135,7 +132,7 @@         kindBoxedRepLevity_maybe,         mightBeLiftedType, mightBeUnliftedType,         definitelyLiftedType, definitelyUnliftedType,-        isAlgType, isDataFamilyAppType,+        isAlgType, isDataFamilyApp, isSatTyFamApp,         isPrimitiveType, isStrictType, isTerminatingType,         isLevityTy, isLevityVar,         isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,@@ -178,10 +175,6 @@         closeOverKindsDSet, closeOverKindsList,         closeOverKinds, -        -- * Well-scoped lists of variables-        scopedSort, tyCoVarsOfTypeWellScoped,-        tyCoVarsOfTypesWellScoped,-         -- * Forcing evaluation of types         seqType, seqTypes, @@ -202,7 +195,7 @@         zipTCvSubst,         notElemSubst,         getTvSubstEnv,-        zapSubst, getSubstInScope, setInScope, getSubstRangeTyCoFVs,+        zapSubst, substInScopeSet, setInScope, getSubstRangeTyCoFVs,         extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet,         extendTCvSubst, extendCvSubst,         extendTvSubst, extendTvSubstList, extendTvSubstAndInScope,@@ -223,20 +216,10 @@         substTyCoBndr, substTyVarToTyVar,         cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, -        -- * Tidying type related things up for printing-        tidyType,      tidyTypes,-        tidyOpenType,  tidyOpenTypes,-        tidyOpenTypeX, tidyOpenTypesX,-        tidyVarBndr, tidyVarBndrs,-        tidyFreeTyCoVars,-        tidyFreeTyCoVarX, tidyFreeTyCoVarsX,-        tidyTyCoVarOcc,-        tidyTopType,-        tidyForAllTyBinder, tidyForAllTyBinders,-         -- * Kinds         isTYPEorCONSTRAINT,-        isConcreteType, isFixedRuntimeRepKind,+        isConcreteType,+        isFixedRuntimeRepKind     ) where  import GHC.Prelude@@ -248,7 +231,6 @@  import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Subst-import GHC.Core.TyCo.Tidy import GHC.Core.TyCo.FVs  -- friends:@@ -291,6 +273,7 @@ import GHC.Data.FastString  import GHC.Data.Maybe   ( orElse, isJust, firstJust )+import GHC.List (build)  -- $type_classification -- #type_classification#@@ -576,11 +559,7 @@     go_co _ (HoleCo h)       = pprPanic "expandTypeSynonyms hit a hole" (ppr h) -      -- the "False" and "const" are to accommodate the type of-      -- substForAllCoBndrUsing, which is general enough to-      -- handle coercion optimization (which sometimes swaps the-      -- order of a coercion)-    go_cobndr subst = substForAllCoBndrUsing NotSwapped (go_co subst) subst+    go_cobndr subst = substForAllCoBndrUsing (go_co subst) subst  {- Notes on type synonyms ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1443,6 +1422,15 @@   | FunTy af w arg res <- coreFullView ty = Just (af, w, arg, res)   | otherwise                             = Nothing +{-# INLINE splitVisibleFunTy_maybe #-}+splitVisibleFunTy_maybe :: Type -> Maybe (Type, Type)+-- ^ Works on visible function types only (t1 -> t2), and+--   returns t1 and t2, but not the multiplicity+splitVisibleFunTy_maybe ty+  | FunTy af _ arg res <- coreFullView ty+  , isVisibleFunArg af = Just (arg, res)+  | otherwise          = Nothing+ splitFunTys :: Type -> ([Scaled Type], Type) splitFunTys ty = split [] ty ty   where@@ -2047,6 +2035,18 @@     split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs     split orig_ty _                bs = (reverse bs, orig_ty) +collectPiTyBinders :: Type -> [PiTyBinder]+collectPiTyBinders ty = build $ \c n ->+  let+    split (ForAllTy b res) = Named b `c` split res+    split (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res })+                           = Anon (Scaled w arg) af `c` split res+    split ty | Just ty' <- coreView ty = split ty'+    split _                = n+  in+    split ty+{-# INLINE collectPiTyBinders #-}+ -- | Extracts a list of run-time arguments from a function type, -- looking through newtypes to the right of arrows. --@@ -2088,12 +2088,12 @@       | otherwise       = [] -invisibleTyBndrCount :: Type -> Int+invisibleBndrCount :: Type -> Int -- Returns the number of leading invisible forall'd binders in the type -- Includes invisible predicate arguments; e.g. for --    e.g.  forall {k}. (k ~ *) => k -> k -- returns 2 not 1-invisibleTyBndrCount ty = length (fst (splitInvisPiTys ty))+invisibleBndrCount ty = length (fst (splitInvisPiTys ty))  -- | Like 'splitPiTys', but returns only *invisible* binders, including constraints. -- Stops at the first visible binder.@@ -2291,6 +2291,21 @@ isFamFreeTy (CastTy ty _)     = isFamFreeTy ty isFamFreeTy (CoercionTy _)    = False  -- Not sure about this +-- | Check whether a type is a data family type+isDataFamilyApp :: Type -> Bool+isDataFamilyApp ty = case tyConAppTyCon_maybe ty of+                           Just tc -> isDataFamilyTyCon tc+                           _       -> False++isSatTyFamApp :: Type -> Maybe (TyCon, [Type])+-- Return the argument if we have a saturated type family application+-- Why saturated?  See (ATF4) in Note [Apartness and type families]+isSatTyFamApp (TyConApp tc tys)+  |  isTypeFamilyTyCon tc+  && not (tys `lengthExceeds` tyConArity tc)  -- Not over-saturated+  = Just (tc, tys)+isSatTyFamApp _ = Nothing+ buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind   -- ^ /result/ kind               -> [Role] -> KnotTied Type -> TyCon -- This function is here because here is where we have@@ -2458,12 +2473,6 @@                             isAlgTyCon tc       _other             -> False --- | Check whether a type is a data family type-isDataFamilyAppType :: Type -> Bool-isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of-                           Just tc -> isDataFamilyTyCon tc-                           _       -> False- -- | Computes whether an argument (or let right hand side) should -- be computed strictly or lazily, based only on its type. -- Currently, it's just 'isUnliftedType'.@@ -2478,7 +2487,9 @@ -- NB: unlifted types are not terminating types! --     e.g. you can write a term (loop 1)::Int# that diverges. isTerminatingType ty = case tyConAppTyCon_maybe ty of-    Just tc -> isClassTyCon tc && not (isNewTyCon tc)+    Just tc -> isClassTyCon tc && not (isUnaryClassTyCon tc)+               -- A non-unary class TyCon is terminating+               -- See (UCM3) in Note [Unary class magic] in GHC.Core.TyCon     _       -> False  isPrimitiveType :: Type -> Bool@@ -2664,9 +2675,7 @@ -- No need to expand synonyms typeKind (TyConApp tc tys)      = piResultTys (tyConKind tc) tys typeKind (LitTy l)              = typeLiteralKind l-typeKind (FunTy { ft_af = af }) = case funTyFlagResultTypeOrConstraint af of-                                     TypeLike       -> liftedTypeKind-                                     ConstraintLike -> constraintKind+typeKind (FunTy { ft_af = af }) = liftedTypeOrConstraintKind (funTyFlagResultTypeOrConstraint af) typeKind (TyVarTy tyvar)        = tyVarKind tyvar typeKind (CastTy _ty co)        = coercionRKind co typeKind (CoercionTy co)        = coercionType co@@ -2698,10 +2707,10 @@      lifted_kind_from_body  -- Implements (FORALL2)       = case sORTKind_maybe body_kind of-          Just (ConstraintLike, _) -> constraintKind-          Just (TypeLike,       _) -> liftedTypeKind-          Nothing -> pprPanic "typeKind" (ppr body_kind)+          Just (torc, _) -> liftedTypeOrConstraintKind torc+          Nothing        -> pprPanic "typeKind" (ppr body_kind) + ---------------------------------------------  sORTKind_maybe :: Kind -> Maybe (TypeOrConstraint, Type)@@ -2740,14 +2749,6 @@           | otherwise           -> pprPanic "typeOrConstraint" (ppr ty <+> dcolon <+> ppr (typeKind ty)) -isPredTy :: HasDebugCallStack => Type -> Bool--- Precondition: expects a type that classifies values--- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep--- Returns True for types of kind (CONSTRAINT _), False for ones of kind (TYPE _)-isPredTy ty = case typeTypeOrConstraint ty of-                  TypeLike       -> False-                  ConstraintLike -> True- -- | Does this classify a type allowed to have values? Responds True to things -- like *, TYPE Lifted, TYPE IntRep, TYPE v, Constraint. isTYPEorCONSTRAINT :: Kind -> Bool@@ -2850,12 +2851,14 @@ isConcreteType :: Type -> Bool isConcreteType = isConcreteTypeWith emptyVarSet -isConcreteTypeWith :: TyVarSet -> Type -> Bool+-- | Like 'isConcreteType', but allows passing in a set of 'TyVar's that+-- should be considered concrete.+-- -- See Note [Concrete types] in GHC.Tc.Utils.Concrete.--- For this "With" version we pass in a set of TyVars to be considered--- concrete.  This supports mkSynonymTyCon, which needs to test the RHS--- for concreteness, under the assumption that the binders are instantiated--- to concrete types+isConcreteTypeWith :: TyVarSet -> Type -> Bool+-- This version, with a 'TyVarSet' argument, supports 'mkSynonymTyCon',+-- which needs to test the RHS for concreteness, under the assumption that+-- the binders are instantiated to concrete types isConcreteTypeWith conc_tvs = go   where     go (TyVarTy tv)        = isConcreteTyVar tv || tv `elemVarSet` conc_tvs@@ -2869,6 +2872,7 @@     go CastTy{}            = False     go CoercionTy{}        = False +    go_tc :: TyCon -> [Type] -> Bool     go_tc tc tys       | isForgetfulSynTyCon tc  -- E.g. type S a = Int                                 -- Then (S x) is concrete even if x isn't@@ -2884,7 +2888,6 @@       | otherwise  -- E.g. type families       = False - {- %************************************************************************ %*                                                                      *@@ -3429,3 +3432,7 @@ typeOrConstraintKind :: TypeOrConstraint -> RuntimeRepType -> Kind typeOrConstraintKind TypeLike       rep = mkTYPEapp       rep typeOrConstraintKind ConstraintLike rep = mkCONSTRAINTapp rep++liftedTypeOrConstraintKind :: TypeOrConstraint -> Kind+liftedTypeOrConstraintKind TypeLike       = liftedTypeKind+liftedTypeOrConstraintKind ConstraintLike = constraintKind
compiler/GHC/Core/Type.hs-boot view
@@ -9,31 +9,18 @@ import GHC.Types.Var( FunTyFlag, TyVar ) import GHC.Types.Basic( TypeOrConstraint ) -isPredTy     :: HasDebugCallStack => Type -> Bool-isCoercionTy :: Type -> Bool -mkAppTy    :: Type -> Type -> Type-mkCastTy   :: Type -> Coercion -> Type-mkTyConApp :: TyCon -> [Type] -> Type-mkCoercionTy :: Coercion -> Type-piResultTy :: HasDebugCallStack => Type -> Type -> Type--typeKind :: HasDebugCallStack => Type -> Type-typeTypeOrConstraint :: HasDebugCallStack => Type -> TypeOrConstraint--coreView       :: Type -> Maybe Type-rewriterView   :: Type -> Maybe Type-isRuntimeRepTy :: Type -> Bool-isLevityTy :: Type -> Bool-isMultiplicityTy :: Type -> Bool+coreView         :: Type -> Maybe Type+rewriterView     :: Type -> Maybe Type+chooseFunTyFlag  :: HasDebugCallStack => Type -> Type -> FunTyFlag+typeKind         :: HasDebugCallStack => Type -> Type+isCoercionTy     :: Type -> Bool+mkAppTy          :: Type -> Type -> Type+mkCastTy         :: Type -> Coercion -> Type+mkTyConApp       :: TyCon -> [Type] -> Type+getLevity        :: HasDebugCallStack => Type -> Type+getTyVar_maybe   :: Type -> Maybe TyVar isLiftedTypeKind :: Type -> Bool -splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])-tyConAppTyCon_maybe :: Type -> Maybe TyCon-getTyVar_maybe      :: Type -> Maybe TyVar--getLevity :: HasDebugCallStack => Type -> Type- partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type])--chooseFunTyFlag :: HasDebugCallStack => Type -> Type -> FunTyFlag+typeTypeOrConstraint    :: HasDebugCallStack => Type -> TypeOrConstraint
compiler/GHC/Core/Unfold.hs view
@@ -41,6 +41,8 @@ import GHC.Core.Utils import GHC.Core.DataCon import GHC.Core.Type+import GHC.Core.Class( Class )+import GHC.Core.Predicate( isUnaryClass )  import GHC.Types.Id import GHC.Types.Literal@@ -52,11 +54,15 @@  import GHC.Builtin.PrimOps import GHC.Builtin.Names+ import GHC.Data.Bag+ import GHC.Utils.Misc import GHC.Utils.Outputable  import qualified Data.ByteString as BS+import Data.List.NonEmpty (nonEmpty)+import qualified Data.List.NonEmpty as NE  -- | Unfolding options data UnfoldingOpts = UnfoldingOpts@@ -213,35 +219,122 @@ ************************************************************************ -} +{- Note [inlineBoringOk]+~~~~~~~~~~~~~~~~~~~~~~~~+See Note [INLINE for small functions]++The function `inlineBoringOk` returns True (boringCxtOk) if the supplied+unfolding, which looks like (\x y z. body), is such that the result of+inlining a saturated call is no bigger than `body`.  Some wrinkles:++(IB1) An important case is+    - \x. (x `cast` co)++(IB2) If `body` looks like a data constructor worker, we become keener+  to inline, by ignoring the number of arguments; we just insist they+  are all trivial.  Reason: in a call like `f (g x y)`, if `g` unfolds+  to a data construtor, we can allocate a data constructor instead of+  a thunk (g x y).++  A case in point where a GADT data constructor failed to inline (#25713)+      $WK = /\a \x. K @a <co> x+  We really want to inline a boring call to $WK so that we allocate+  a data constructor not a thunk ($WK @ty x).++  But not for nullary constructors!  We don't want to turn+     f ($WRefl @ty)+  into+     f (Refl @ty <co>)+   because the latter might allocate, whereas the former shares.+   (You might wonder if (Refl @ty <co>) should allocate, but I think+   that currently it does.)  So for nullary constructors, `inlineBoringOk`+   returns False.++(IB3) Types and coercions do not count towards the expression size.+      They are ultimately erased.++(IB4) If there are no value arguments, `inlineBoringOk` we have to be+  careful (#17182).  If we have+      let y = x @Int in f y y+  there’s no reason not to inline y at both use sites — no work is+  actually duplicated.++  But not so for coercion arguments! Unlike type arguments, which have+  no runtime representation, coercion arguments *do* have a runtime+  representation (albeit the zero-width VoidRep, see Note [Coercion+  tokens] in "GHC.CoreToStg").  For example:+       let y = g @Int <co> in g y y+  Here `co` is a value argument, and calling it twice might duplicate+  work.++  Even if `g` is a data constructor, so no work is duplicated,+  inlining `y` might duplicate allocation of a data constructor object+  (#17787). See also (IB2).++  TL;DR: if `is_fun` is False, so we have no value arguments, we /do/+  count coercion arguments, despite (IB3).++(IB5) You might wonder about an unfolding like  (\x y z -> x (y z)),+  whose body is, in some sense, just as small as (g x y z).+  But `inlineBoringOk` doesn't attempt anything fancy; it just looks+  for a function call with trivial arguments, Keep it simple.++(IB6) If we have an unfolding (K op) where K is a unary-class data constructor,+  we want to inline it!  So that we get calls (f op), which in turn can see (in+  STG land) that `op` is already evaluated and properly tagged. (If `op` isn't+  trivial we will have baled out before we get to the Var case.)  This made+  a big difference in benchmarks for the `effectful` library; details in !10479.++  See Note [Unary class magic] in GHC/Core/TyCon.+-}+ inlineBoringOk :: CoreExpr -> Bool--- See Note [INLINE for small functions] -- True => the result of inlining the expression is --         no bigger than the expression itself --     eg      (\x y -> f y x)--- This is a quick and dirty version. It doesn't attempt--- to deal with  (\x y z -> x (y z))--- The really important one is (x `cast` c)+-- See Note [inlineBoringOk] inlineBoringOk e   = go 0 e   where+    is_fun = isValFun e+     go :: Int -> CoreExpr -> Bool-    go credit (Lam x e) | isId x           = go (credit+1) e-                        | otherwise        = go credit e-        -- See Note [Count coercion arguments in boring contexts]-    go credit (App f (Type {}))            = go credit f-    go credit (App f a) | credit > 0-                        , exprIsTrivial a  = go (credit-1) f-    go credit (Tick _ e)                   = go credit e -- dubious-    go credit (Cast e _)                   = go credit e+    -- credit = #(value lambdas) = #(value args)+    go credit (Lam x e) | isRuntimeVar x  = go (credit+1) e+                        | otherwise       = go credit e      -- See (IB3)++    go credit (App f (Type {}))           = go credit f      -- See (IB3)+    go credit (App f (Coercion {}))+      | is_fun                            = go credit f      -- See (IB3)+      | otherwise                         = go (credit-1) f  -- See (IB4)+    go credit (App f a) | exprIsTrivial a = go (credit-1) f+     go credit (Case e b _ alts)       | null alts       = go credit e   -- EmptyCase is like e       | Just rhs <- isUnsafeEqualityCase e b alts       = go credit rhs -- See Note [Inline unsafeCoerce]-    go _      (Var {})                     = boringCxtOk-    go _      (Lit l)                      = litIsTrivial l && boringCxtOk-    go _      _                            = boringCxtNotOk +    go credit (Tick _ e) = go credit e      -- dubious+    go credit (Cast e _) = go credit e      -- See (IB3)++    -- Lit: we assume credit >= 0; literals aren't functions+    go _      (Lit l)    = litIsTrivial l && boringCxtOk++    go credit (Var v) | isDataConWorkId v, is_fun = boringCxtOk  -- See (IB2)+                      | isUnaryClassId v          = boringCxtOk  -- See (IB6)+                      | credit >= 0               = boringCxtOk+                      | otherwise                 = boringCxtNotOk++    go _ _ = boringCxtNotOk++isValFun :: CoreExpr -> Bool+-- True of functions with at least+-- one top-level value lambda+isValFun (Lam b e) | isRuntimeVar b = True+                   | otherwise      = isValFun e+isValFun _                          = False+ calcUnfoldingGuidance         :: UnfoldingOpts         -> Bool          -- Definitely a top-level, bottoming binding@@ -398,29 +491,6 @@     NB: you might think that PostInlineUnconditionally would do this     but it doesn't fire for top-level things; see GHC.Core.Opt.Simplify.Utils     Note [Top level and postInlineUnconditionally]--Note [Count coercion arguments in boring contexts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In inlineBoringOK, we ignore type arguments when deciding whether an-expression is okay to inline into boring contexts. This is good, since-if we have a definition like--  let y = x @Int in f y y--there’s no reason not to inline y at both use sites — no work is-actually duplicated. It may seem like the same reasoning applies to-coercion arguments, and indeed, in #17182 we changed inlineBoringOK to-treat coercions the same way.--However, this isn’t a good idea: unlike type arguments, which have-no runtime representation, coercion arguments *do* have a runtime-representation (albeit the zero-width VoidRep, see Note [Coercion tokens]-in "GHC.CoreToStg"). This caused trouble in #17787 for DataCon wrappers for-nullary GADT constructors: the wrappers would be inlined and each use of-the constructor would lead to a separate allocation instead of just-sharing the wrapper closure.--The solution: don’t ignore coercion arguments after all. -}  uncondInline :: Bool -> CoreExpr -> [Var] -> Arity -> CoreExpr -> Int -> Bool@@ -434,19 +504,57 @@  uncondInlineJoin :: [Var] -> CoreExpr -> Bool -- See Note [Duplicating join points] point (DJ3) in GHC.Core.Opt.Simplify.Iteration-uncondInlineJoin _bndrs body+uncondInlineJoin bndrs body++  -- (DJ3)(a)   | exprIsTrivial body   = True   -- Nullary constructors, literals -  | (Var v, args) <- collectArgs body-  , all exprIsTrivial args-  , isJoinId v   -- Indirection to another join point; always inline+  -- (DJ3)(b) and (DJ3)(c) combined+  | indirectionOrAppWithoutFVs   = True    | otherwise   = False +  where+    -- (DJ3)(b):+    -- - $j1 x = $j2 y x |> co  -- YES, inline indirection regardless of free vars+    -- (DJ3)(c):+    -- - $j1 x y = K y x |> co  -- YES, inline!+    -- - $j2 x = K f x          -- No, don't! (because f is free)+    indirectionOrAppWithoutFVs = go False body +    go !seen_fv (App f a)+      | Just has_fv <- go_arg a+                          = go (seen_fv || has_fv) f+      | otherwise         = False       -- Not trivial+    go seen_fv (Var v)+      | isJoinId v        = True        -- Indirection to another join point; always inline+      | isDataConId v     = not seen_fv -- e.g. $j a b = K a b+      | v `elem` bndrs    = not seen_fv -- e.g. $j a b = b a+    go seen_fv (Cast e _) = go seen_fv e+    go seen_fv (Tick _ e) = go seen_fv e+    go _ _                = False++    -- go_arg returns:+    --  - `Nothing` if arg is not trivial+    --  - `Just True` if arg is trivial but contains free var, literal, or constructor+    --  - `Just False` if arg is trivial without free vars+    go_arg (Type {})     = Just False+    go_arg (Coercion {}) = Just False+    go_arg (Lit l)+      | litIsTrivial l   = Just True    -- e.g. $j x = $j2 x 7 YES, but $j x = K x 7 NO+      | otherwise        = Nothing+    go_arg (App f a)+      | isTyCoArg a      = go_arg f     -- e.g. $j f = K (f @a)+      | otherwise        = Nothing+    go_arg (Cast e _)    = go_arg e+    go_arg (Tick _ e)    = go_arg e+    go_arg (Var f)       = Just $! f `notElem` bndrs+    go_arg _             = Nothing++ sizeExpr :: UnfoldingOpts          -> Int             -- Bomb out if it gets bigger than this          -> [Id]            -- Arguments; we're interested in which of these@@ -490,15 +598,12 @@               (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs))               pairs -    size_up (Case e _ _ alts)-        | null alts-        = size_up e    -- case e of {} never returns, so take size of scrutinee--    size_up (Case e _ _ alts)-        -- Now alts is non-empty-        | Just v <- is_top_arg e -- We are scrutinising an argument variable-        = let-            alt_sizes = map size_up_alt alts+    size_up (Case e _ _ alts) = case nonEmpty alts of+      Nothing -> size_up e    -- case e of {} never returns, so take size of scrutinee+      Just alts+        | Just v <- is_top_arg e -> -- We are scrutinising an argument variable+          let+            alt_sizes = NE.map size_up_alt alts                    -- alts_size tries to compute a good discount for                   -- the case when we are scrutinising an argument variable@@ -525,14 +630,15 @@                 -- Good to inline if an arg is scrutinised, because                 -- that may eliminate allocation in the caller                 -- And it eliminates the case itself++        | otherwise -> size_up e  `addSizeNSD`+                                foldr (addAltSize . size_up_alt) case_size alts+         where           is_top_arg (Var v) | v `elem` top_args = Just v           is_top_arg (Cast e _) = is_top_arg e           is_top_arg _ = Nothing --    size_up (Case e _ _ alts) = size_up e  `addSizeNSD`-                                foldr (addAltSize . size_up_alt) case_size alts       where           case_size            | is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10)@@ -597,11 +703,13 @@     size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize     size_up_call fun val_args voids        = case idDetails fun of-           FCallId _        -> sizeN (callSize (length val_args) voids)-           DataConWorkId dc -> conSize    dc (length val_args)-           PrimOpId op _    -> primOpSize op (length val_args)-           ClassOpId {}     -> classOpSize opts top_args val_args-           _                -> funSize opts top_args fun (length val_args) voids+           FCallId _                     -> sizeN (callSize (length val_args) voids)+           DataConWorkId dc              -> conSize    dc (length val_args)+           PrimOpId op _                 -> primOpSize op (length val_args)+           ClassOpId cls _               -> classOpSize opts cls top_args val_args+           _ | fun `hasKey` buildIdKey   -> buildSize+             | fun `hasKey` augmentIdKey -> augmentSize+             | otherwise                 -> funSize opts top_args fun (length val_args) voids      ------------     size_up_alt (Alt _con _bndrs rhs) = size_up rhs `addSizeN` 10@@ -666,21 +774,24 @@                       -- Key point: if  x |-> 4, then x must inline unconditionally                       --            (eg via case binding) -classOpSize :: UnfoldingOpts -> [Id] -> [CoreExpr] -> ExprSize+classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> ExprSize -- See Note [Conlike is interesting]-classOpSize _ _ []-  = sizeZero-classOpSize opts top_args (arg1 : other_args)-  = SizeIs size arg_discount 0+classOpSize opts cls top_args args+  | isUnaryClass cls+  = sizeZero   -- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon+  | otherwise+  = case args of+       []                -> sizeZero+       (arg1:other_args) -> SizeIs (size other_args) (arg_discount arg1) 0   where-    size = 20 + (10 * length other_args)+    size other_args = 20 + (10 * length other_args)+     -- If the class op is scrutinising a lambda bound dictionary then     -- give it a discount, to encourage the inlining of this function     -- The actual discount is rather arbitrarily chosen-    arg_discount = case arg1 of-                     Var dict | dict `elem` top_args-                              -> unitBag (dict, unfoldingDictDiscount opts)-                     _other   -> emptyBag+    arg_discount (Var dict) | dict `elem` top_args+                   = unitBag (dict, unfoldingDictDiscount opts)+    arg_discount _ = emptyBag  -- | The size of a function call callSize@@ -707,11 +818,9 @@   -- better solution?  funSize :: UnfoldingOpts -> [Id] -> Id -> Int -> Int -> ExprSize--- Size for functions that are not constructors or primops+-- Size for function calls where the function is not a constructor or primops -- Note [Function applications] funSize opts top_args fun n_val_args voids-  | fun `hasKey` buildIdKey   = buildSize-  | fun `hasKey` augmentIdKey = augmentSize   | otherwise = SizeIs size arg_discount res_discount   where     some_val_args = n_val_args > 0@@ -740,6 +849,8 @@  -- See Note [Unboxed tuple size and result discount]   | isUnboxedTupleDataCon dc = SizeIs 0 emptyBag 10++  | isUnaryClassDataCon dc = sizeZero  -- See Note [Constructor size and result discount]   | otherwise = SizeIs 10 emptyBag 10
compiler/GHC/Core/Unfold/Make.hs view
@@ -84,6 +84,16 @@  mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding mkDFunUnfolding bndrs con ops+  | isUnaryClassDataCon con+  = -- See (UCM5) in Note [Unary class magic] in GHC.Core.TyCon+    mkDataConUnfolding $+    mkLams bndrs  $+    mkApps (Var (dataConWrapId con)) ops+                -- This application will satisfy the Core invariants+                -- from Note [Representation polymorphism invariants] in GHC.Core,+                -- because typeclass method types are never unlifted.++  | otherwise   = DFunUnfolding { df_bndrs = bndrs                   , df_con = con                   , df_args = map occurAnalyseExpr ops }@@ -97,7 +107,10 @@   where     guide = UnfWhen { ug_arity     = manifestArity expr                     , ug_unsat_ok  = unSaturatedOk-                    , ug_boring_ok = False }+                    , ug_boring_ok = inlineBoringOk expr }+            -- inineBoringOk; sometimes wrappers are very simple, like+            --    \@a p q. K @a <coercion> p q+            -- and then we definitely want to inline it #25713  mkWrapperUnfolding :: SimpleOpts -> CoreExpr -> Arity -> Unfolding -- Make the unfolding for the wrapper in a worker/wrapper split@@ -184,6 +197,9 @@                    spec_app (mkLams old_bndrs arg)                    -- The beta-redexes created by spec_app will be                    -- simplified away by simplOptExpr+                   -- ToDo: this is VERY DELICATE for type args.  We make+                   --        (\@a @b x y. TYPE ty) ty1 ty2 d1 d2+                   -- and rely on it simplifying to ty[ty1/a, ty2/b]  specUnfolding opts spec_bndrs spec_app rule_lhs_args               (CoreUnfolding { uf_src = src, uf_tmpl = tmpl
compiler/GHC/Core/Unify.hs view
@@ -11,2201 +11,2531 @@         tcMatchTyX_BM, ruleMatchTyKiX,          -- Side-effect free unification-        tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis,-        tcUnifyTysFG, tcUnifyTyWithTFs,-        BindFun, BindFlag(..), matchBindFun, alwaysBindFun,-        UnifyResult, UnifyResultM(..), MaybeApartReason(..),-        typesCantMatch, typesAreApart,--        -- Matching a type against a lifted type (coercion)-        liftCoMatch,--        -- The core flattening algorithm-        flattenTys, flattenTysX,--   ) where--import GHC.Prelude--import GHC.Types.Var-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Types.Name( Name, mkSysTvName, mkSystemVarName )-import GHC.Builtin.Names( tYPETyConKey, cONSTRAINTTyConKey )-import GHC.Core.Type     hiding ( getTvSubstEnv )-import GHC.Core.Coercion hiding ( getCvSubstEnv )-import GHC.Core.TyCon-import GHC.Core.TyCo.Rep-import GHC.Core.TyCo.Compare ( eqType, tcEqType )-import GHC.Core.TyCo.FVs     ( tyCoVarsOfCoList, tyCoFVsOfTypes )-import GHC.Core.TyCo.Subst   ( mkTvSubst, emptyIdSubstEnv )-import GHC.Core.Map.Type-import GHC.Utils.FV( FV, fvVarList )-import GHC.Utils.Misc-import GHC.Data.Pair-import GHC.Utils.Outputable-import GHC.Types.Unique-import GHC.Types.Unique.FM-import GHC.Types.Unique.Set-import GHC.Exts( oneShot )-import GHC.Utils.Panic-import GHC.Data.FastString--import Data.List ( mapAccumL )-import Control.Monad-import qualified Data.Semigroup as S-import GHC.Builtin.Types.Prim (fUNTyCon)-import GHC.Core.Multiplicity--{---Unification is much tricker than you might think.--1. The substitution we generate binds the *template type variables*-   which are given to us explicitly.--2. We want to match in the presence of foralls;-        e.g     (forall a. t1) ~ (forall b. t2)--   That is what the RnEnv2 is for; it does the alpha-renaming-   that makes it as if a and b were the same variable.-   Initialising the RnEnv2, so that it can generate a fresh-   binder when necessary, entails knowing the free variables of-   both types.--3. We must be careful not to bind a template type variable to a-   locally bound variable.  E.g.-        (forall a. x) ~ (forall b. b)-   where x is the template type variable.  Then we do not want to-   bind x to a/b!  This is a kind of occurs check.-   The necessary locals accumulate in the RnEnv2.--Note [tcMatchTy vs tcMatchTyKi]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This module offers two variants of matching: with kinds and without.-The TyKi variant takes two types, of potentially different kinds,-and matches them. Along the way, it necessarily also matches their-kinds. The Ty variant instead assumes that the kinds are already-eqType and so skips matching up the kinds.--How do you choose between them?--1. If you know that the kinds of the two types are eqType, use-   the Ty variant. It is more efficient, as it does less work.--2. If the kinds of variables in the template type might mention type families,-   use the Ty variant (and do other work to make sure the kinds-   work out). These pure unification functions do a straightforward-   syntactic unification and do no complex reasoning about type-   families. Note that the types of the variables in instances can indeed-   mention type families, so instance lookup must use the Ty variant.--   (Nothing goes terribly wrong -- no panics -- if there might be type-   families in kinds in the TyKi variant. You just might get match-   failure even though a reducing a type family would lead to success.)--3. Otherwise, if you're sure that the variable kinds do not mention-   type families and you're not already sure that the kind of the template-   equals the kind of the target, then use the TyKi version.--}---- | Some unification functions are parameterised by a 'BindFun', which--- says whether or not to allow a certain unification to take place.--- A 'BindFun' takes the 'TyVar' involved along with the 'Type' it will--- potentially be bound to.------ It is possible for the variable to actually be a coercion variable--- (Note [Matching coercion variables]), but only when one-way matching.--- In this case, the 'Type' will be a 'CoercionTy'.-type BindFun = TyCoVar -> Type -> BindFlag---- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1))--- @s@ such that @s(t1)@ equals @t2@.--- The returned substitution might bind coercion variables,--- if the variable is an argument to a GADT constructor.------ Precondition: typeKind ty1 `eqType` typeKind ty2------ We don't pass in a set of "template variables" to be bound--- by the match, because tcMatchTy (and similar functions) are--- always used on top-level types, so we can bind any of the--- free variables of the LHS.--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTy :: Type -> Type -> Maybe Subst-tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2]--tcMatchTyX_BM :: BindFun -> Subst-              -> Type -> Type -> Maybe Subst-tcMatchTyX_BM bind_me subst ty1 ty2-  = tc_match_tys_x bind_me False subst [ty1] [ty2]---- | Like 'tcMatchTy', but allows the kinds of the types to differ,--- and thus matches them as well.--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTyKi :: Type -> Type -> Maybe Subst-tcMatchTyKi ty1 ty2-  = tc_match_tys alwaysBindFun True [ty1] [ty2]---- | This is similar to 'tcMatchTy', but extends a substitution--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTyX :: Subst            -- ^ Substitution to extend-           -> Type                -- ^ Template-           -> Type                -- ^ Target-           -> Maybe Subst-tcMatchTyX subst ty1 ty2-  = tc_match_tys_x alwaysBindFun False subst [ty1] [ty2]---- | Like 'tcMatchTy' but over a list of types.--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTys :: [Type]         -- ^ Template-           -> [Type]         -- ^ Target-           -> Maybe Subst    -- ^ One-shot; in principle the template-                             -- variables could be free in the target-tcMatchTys tys1 tys2-  = tc_match_tys alwaysBindFun False tys1 tys2---- | Like 'tcMatchTyKi' but over a list of types.--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTyKis :: [Type]         -- ^ Template-             -> [Type]         -- ^ Target-             -> Maybe Subst -- ^ One-shot substitution-tcMatchTyKis tys1 tys2-  = tc_match_tys alwaysBindFun True tys1 tys2---- | Like 'tcMatchTys', but extending a substitution--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTysX :: Subst       -- ^ Substitution to extend-            -> [Type]         -- ^ Template-            -> [Type]         -- ^ Target-            -> Maybe Subst -- ^ One-shot substitution-tcMatchTysX subst tys1 tys2-  = tc_match_tys_x alwaysBindFun False subst tys1 tys2---- | Like 'tcMatchTyKis', but extending a substitution--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTyKisX :: Subst        -- ^ Substitution to extend-              -> [Type]          -- ^ Template-              -> [Type]          -- ^ Target-              -> Maybe Subst  -- ^ One-shot substitution-tcMatchTyKisX subst tys1 tys2-  = tc_match_tys_x alwaysBindFun True subst tys1 tys2---- | Same as tc_match_tys_x, but starts with an empty substitution-tc_match_tys :: BindFun-             -> Bool          -- ^ match kinds?-             -> [Type]-             -> [Type]-             -> Maybe Subst-tc_match_tys bind_me match_kis tys1 tys2-  = tc_match_tys_x bind_me match_kis (mkEmptySubst in_scope) tys1 tys2-  where-    in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2)---- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX'-tc_match_tys_x :: BindFun-               -> Bool          -- ^ match kinds?-               -> Subst-               -> [Type]-               -> [Type]-               -> Maybe Subst-tc_match_tys_x bind_me match_kis (Subst in_scope id_env tv_env cv_env) tys1 tys2-  = case tc_unify_tys bind_me-                      False  -- Matching, not unifying-                      False  -- Not an injectivity check-                      match_kis-                      RespectMultiplicities-                      (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of-      Unifiable (tv_env', cv_env')-        -> Just $ Subst in_scope id_env tv_env' cv_env'-      _ -> Nothing---- | This one is called from the expression matcher,--- which already has a MatchEnv in hand-ruleMatchTyKiX-  :: TyCoVarSet          -- ^ template variables-  -> RnEnv2-  -> TvSubstEnv          -- ^ type substitution to extend-  -> Type                -- ^ Template-  -> Type                -- ^ Target-  -> Maybe TvSubstEnv-ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target--- See Note [Kind coercions in Unify]-  = case tc_unify_tys (matchBindFun tmpl_tvs) False False-                      True -- <-- this means to match the kinds-                      IgnoreMultiplicities-                        -- See Note [Rewrite rules ignore multiplicities in FunTy]-                      rn_env tenv emptyCvSubstEnv [tmpl] [target] of-      Unifiable (tenv', _) -> Just tenv'-      _                    -> Nothing---- | Allow binding only for any variable in the set. Variables may--- be bound to any type.--- Used when doing simple matching; e.g. can we find a substitution------ @--- S = [a :-> t1, b :-> t2] such that---     S( Maybe (a, b->Int )  =   Maybe (Bool, Char -> Int)--- @-matchBindFun :: TyCoVarSet -> BindFun-matchBindFun tvs tv _ty-  | tv `elemVarSet` tvs = BindMe-  | otherwise           = Apart---- | Allow the binding of any variable to any type-alwaysBindFun :: BindFun-alwaysBindFun _tv _ty = BindMe--{--************************************************************************-*                                                                      *-                GADTs-*                                                                      *-************************************************************************--Note [Pruning dead case alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider        data T a where-                   T1 :: T Int-                   T2 :: T a--                newtype X = MkX Int-                newtype Y = MkY Char--                type family F a-                type instance F Bool = Int--Now consider    case x of { T1 -> e1; T2 -> e2 }--The question before the house is this: if I know something about the type-of x, can I prune away the T1 alternative?--Suppose x::T Char.  It's impossible to construct a (T Char) using T1,-        Answer = YES we can prune the T1 branch (clearly)--Suppose x::T (F a), where 'a' is in scope.  Then 'a' might be instantiated-to 'Bool', in which case x::T Int, so-        ANSWER = NO (clearly)--We see here that we want precisely the apartness check implemented within-tcUnifyTysFG. So that's what we do! Two types cannot match if they are surely-apart. Note that since we are simply dropping dead code, a conservative test-suffices.--}---- | Given a list of pairs of types, are any two members of a pair surely--- apart, even after arbitrary type function evaluation and substitution?-typesCantMatch :: [(Type,Type)] -> Bool--- See Note [Pruning dead case alternatives]-typesCantMatch prs = any (uncurry typesAreApart) prs--typesAreApart :: Type -> Type -> Bool-typesAreApart t1 t2 = case tcUnifyTysFG alwaysBindFun [t1] [t2] of-                        SurelyApart -> True-                        _           -> False-{--************************************************************************-*                                                                      *-             Unification-*                                                                      *-************************************************************************--Note [Fine-grained unification]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" ---no substitution to finite types makes these match. But, a substitution to-*infinite* types can unify these two types: [x |-> [[[...]]], y |-> [[[...]]] ].-Why do we care? Consider these two type family instances:--type instance F x x   = Int-type instance F [y] y = Bool--If we also have--type instance Looper = [Looper]--then the instances potentially overlap. The solution is to use unification-over infinite terms. This is possible (see [1] for lots of gory details), but-a full algorithm is a little more power than we need. Instead, we make a-conservative approximation and just omit the occurs check.--[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf--tcUnifyTys considers an occurs-check problem as the same as general unification-failure.--tcUnifyTysFG ("fine-grained") returns one of three results: success, occurs-check-failure ("MaybeApart"), or general failure ("SurelyApart").--See also #8162.--It's worth noting that unification in the presence of infinite types is not-complete. This means that, sometimes, a closed type family does not reduce-when it should. See test case indexed-types/should_fail/Overlap15 for an-example.--Note [Unification result]-~~~~~~~~~~~~~~~~~~~~~~~~~-When unifying t1 ~ t2, we return-* Unifiable s, if s is a substitution such that s(t1) is syntactically the-  same as s(t2), modulo type-synonym expansion.-* SurelyApart, if there is no substitution s such that s(t1) = s(t2),-  where "=" includes type-family reductions.-* MaybeApart mar s, when we aren't sure. `mar` is a MaybeApartReason.--Examples-* [a] ~ Maybe b: SurelyApart, because [] and Maybe can't unify-* [(a,Int)] ~ [(Bool,b)]:  Unifiable-* [F Int] ~ [Bool]: MaybeApart MARTypeFamily, because F Int might reduce to Bool (the unifier-                    does not try this)-* a ~ Maybe a: MaybeApart MARInfinite. Not Unifiable clearly, but not SurelyApart either; consider-       a := Loop-       where  type family Loop where Loop = Maybe Loop--There is the possibility that two types are MaybeApart for *both* reasons:--* (a, F Int) ~ (Maybe a, Bool)--What reason should we use? The *only* consumer of the reason is described-in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv. The goal-there is identify which instances might match a target later (but don't-match now) -- except that we want to ignore the possibility of infinitary-substitutions. So let's examine a concrete scenario:--  class C a b c-  instance C a (Maybe a) Bool-  -- other instances, including one that will actually match-  [W] C b b (F Int)--Do we want the instance as a future possibility? No. The only way that-instance can match is in the presence of an infinite type (infinitely-nested Maybes). We thus say that MARInfinite takes precedence, so that-InstEnv treats this case as an infinitary substitution case; the fact-that a type family is involved is only incidental. We thus define-the Semigroup instance for MaybeApartReason to prefer MARInfinite.--Note [The substitution in MaybeApart]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why?-Because consider unifying these:--(a, a, Int) ~ (b, [b], Bool)--If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we-apply the subst we have so far and discover that we need [b |-> [b]]. Because-this fails the occurs check, we say that the types are MaybeApart (see above-Note [Fine-grained unification]). But, we can't stop there! Because if we-continue, we discover that Int is SurelyApart from Bool, and therefore the-types are apart. This has practical consequences for the ability for closed-type family applications to reduce. See test case-indexed-types/should_compile/Overlap14.--Note [Rewrite rules ignore multiplicities in FunTy]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the following (higher-order) rule:--m :: Bool -> Bool -> Bool-{-# RULES "m" forall f. m (f True) = f #-}--let x = m ((,) @Bool @Bool True True)--The rewrite rule expects an `f :: Bool -> Bool`, but `(,) @Bool @Bool True ::-Bool %1 -> Bool` is linear (see Note [Data constructors are linear by default]-in GHC.Core.Multiplicity) Should the rule match? Yes! According to the-principles laid out in Note [Linting linearity] in GHC.Core.Lint, optimisation-shouldn't be constrained by linearity.--However, when matching the template variable `f` to `(,) True`, we do check that-their types unify (see Note [Matching variable types] in GHC.Core.Rules). So-when unifying types for the sake of rule-matching, the unification algorithm-must be able to ignore multiplicities altogether.--How is this done?-  (1) The `um_arr_mult` field of `UMEnv` recordsw when we are doing rule-matching,-      and hence want to ignore multiplicities.-  (2) The field is set to True in by `ruleMatchTyKiX`.-  (3) It is consulted when matching `FunTy` in `unify_ty`.--Wrinkle in (3). In `unify_tc_app`, in `unify_ty`, `FunTy` is handled as if it-was a regular type constructor. In this case, and when the types being unified-are *function* arrows, but not constraint arrows, then the first argument is a-multiplicity.--We select this situation by comparing the type constructor with fUNTyCon. In-this case, and this case only, we can safely drop the first argument (using the-tail function) and unify the rest.--}---- | Simple unification of two types; all type variables are bindable--- Precondition: the kinds are already equal-tcUnifyTy :: Type -> Type       -- All tyvars are bindable-          -> Maybe Subst-                       -- A regular one-shot (idempotent) substitution-tcUnifyTy t1 t2 = tcUnifyTys alwaysBindFun [t1] [t2]---- | Like 'tcUnifyTy', but also unifies the kinds-tcUnifyTyKi :: Type -> Type -> Maybe Subst-tcUnifyTyKi t1 t2 = tcUnifyTyKis alwaysBindFun [t1] [t2]---- | Unify two types, treating type family applications as possibly unifying--- with anything and looking through injective type family applications.--- Precondition: kinds are the same-tcUnifyTyWithTFs :: Bool  -- ^ True <=> do two-way unification;-                          --   False <=> do one-way matching.-                          --   See end of sec 5.2 from the paper-                 -> InScopeSet     -- Should include the free tyvars of both Type args-                 -> Type -> Type   -- Types to unify-                 -> Maybe Subst--- This algorithm is an implementation of the "Algorithm U" presented in--- the paper "Injective type families for Haskell", Figures 2 and 3.--- The code is incorporated with the standard unifier for convenience, but--- its operation should match the specification in the paper.-tcUnifyTyWithTFs twoWay in_scope t1 t2-  = case tc_unify_tys alwaysBindFun twoWay True False RespectMultiplicities-                       rn_env emptyTvSubstEnv emptyCvSubstEnv-                       [t1] [t2] of-      Unifiable          (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst-      MaybeApart _reason (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst-      -- we want to *succeed* in questionable cases. This is a-      -- pre-unification algorithm.-      SurelyApart      -> Nothing-  where-    rn_env   = mkRnEnv2 in_scope--    maybe_fix | twoWay    = niFixSubst in_scope-              | otherwise = mkTvSubst in_scope -- when matching, don't confuse-                                               -- domain with range--------------------tcUnifyTys :: BindFun-           -> [Type] -> [Type]-           -> Maybe Subst-                                -- ^ A regular one-shot (idempotent) substitution-                                -- that unifies the erased types. See comments-                                -- for 'tcUnifyTysFG'---- The two types may have common type variables, and indeed do so in the--- second call to tcUnifyTys in GHC.Tc.Instance.FunDeps.checkClsFD-tcUnifyTys bind_fn tys1 tys2-  = case tcUnifyTysFG bind_fn tys1 tys2 of-      Unifiable result -> Just result-      _                -> Nothing---- | Like 'tcUnifyTys' but also unifies the kinds-tcUnifyTyKis :: BindFun-             -> [Type] -> [Type]-             -> Maybe Subst-tcUnifyTyKis bind_fn tys1 tys2-  = case tcUnifyTyKisFG bind_fn tys1 tys2 of-      Unifiable result -> Just result-      _                -> Nothing---- This type does double-duty. It is used in the UM (unifier monad) and to--- return the final result. See Note [Fine-grained unification]-type UnifyResult = UnifyResultM Subst---- | See Note [Unification result]-data UnifyResultM a = Unifiable a        -- the subst that unifies the types-                    | MaybeApart MaybeApartReason-                                 a       -- the subst has as much as we know-                                         -- it must be part of a most general unifier-                                         -- See Note [The substitution in MaybeApart]-                    | SurelyApart-                    deriving Functor---- | Why are two types 'MaybeApart'? 'MARInfinite' takes precedence:--- This is used (only) in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv--- As of Feb 2022, we never differentiate between MARTypeFamily and MARTypeVsConstraint;--- it's really only MARInfinite that's interesting here.-data MaybeApartReason-  = MARTypeFamily   -- ^ matching e.g. F Int ~? Bool--  | MARInfinite     -- ^ matching e.g. a ~? Maybe a--  | MARTypeVsConstraint  -- ^ matching Type ~? Constraint or the arrow types-    -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim--instance Outputable MaybeApartReason where-  ppr MARTypeFamily       = text "MARTypeFamily"-  ppr MARInfinite         = text "MARInfinite"-  ppr MARTypeVsConstraint = text "MARTypeVsConstraint"--instance Semigroup MaybeApartReason where-  -- see end of Note [Unification result] for why-  MARTypeFamily       <> r = r-  MARInfinite         <> _ = MARInfinite-  MARTypeVsConstraint <> r = r--instance Applicative UnifyResultM where-  pure  = Unifiable-  (<*>) = ap--instance Monad UnifyResultM where-  SurelyApart  >>= _ = SurelyApart-  MaybeApart r1 x >>= f = case f x of-                            Unifiable y     -> MaybeApart r1 y-                            MaybeApart r2 y -> MaybeApart (r1 S.<> r2) y-                            SurelyApart     -> SurelyApart-  Unifiable x  >>= f = f x---- | @tcUnifyTysFG bind_tv tys1 tys2@ attempts to find a substitution @s@ (whose--- domain elements all respond 'BindMe' to @bind_tv@) such that--- @s(tys1)@ and that of @s(tys2)@ are equal, as witnessed by the returned--- Coercions. This version requires that the kinds of the types are the same,--- if you unify left-to-right.-tcUnifyTysFG :: BindFun-             -> [Type] -> [Type]-             -> UnifyResult-tcUnifyTysFG bind_fn tys1 tys2-  = tc_unify_tys_fg False bind_fn tys1 tys2--tcUnifyTyKisFG :: BindFun-               -> [Type] -> [Type]-               -> UnifyResult-tcUnifyTyKisFG bind_fn tys1 tys2-  = tc_unify_tys_fg True bind_fn tys1 tys2--tc_unify_tys_fg :: Bool-                -> BindFun-                -> [Type] -> [Type]-                -> UnifyResult-tc_unify_tys_fg match_kis bind_fn tys1 tys2-  = do { (env, _) <- tc_unify_tys bind_fn True False match_kis RespectMultiplicities rn_env-                                  emptyTvSubstEnv emptyCvSubstEnv-                                  tys1 tys2-       ; return $ niFixSubst in_scope env }-  where-    in_scope = mkInScopeSet $ tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2-    rn_env   = mkRnEnv2 in_scope---- | This function is actually the one to call the unifier -- a little--- too general for outside clients, though.-tc_unify_tys :: BindFun-             -> AmIUnifying -- ^ True <=> unify; False <=> match-             -> Bool        -- ^ True <=> doing an injectivity check-             -> Bool        -- ^ True <=> treat the kinds as well-             -> MultiplicityFlag -- ^ see Note [Rewrite rules ignore multiplicities in FunTy] in GHC.Core.Unify-             -> RnEnv2-             -> TvSubstEnv  -- ^ substitution to extend-             -> CvSubstEnv-             -> [Type] -> [Type]-             -> UnifyResultM (TvSubstEnv, CvSubstEnv)--- NB: It's tempting to ASSERT here that, if we're not matching kinds, then--- the kinds of the types should be the same. However, this doesn't work,--- as the types may be a dependent telescope, where later types have kinds--- that mention variables occurring earlier in the list of types. Here's an--- example (from typecheck/should_fail/T12709):---   template: [rep :: RuntimeRep,       a :: TYPE rep]---   target:   [LiftedRep :: RuntimeRep, Int :: TYPE LiftedRep]--- We can see that matching the first pair will make the kinds of the second--- pair equal. Yet, we still don't need a separate pass to unify the kinds--- of these types, so it's appropriate to use the Ty variant of unification.--- See also Note [tcMatchTy vs tcMatchTyKi].-tc_unify_tys bind_fn unif inj_check match_kis match_mults rn_env tv_env cv_env tys1 tys2-  = initUM tv_env cv_env $-    do { when match_kis $-         unify_tys env kis1 kis2-       ; unify_tys env tys1 tys2-       ; (,) <$> getTvSubstEnv <*> getCvSubstEnv }-  where-    env = UMEnv { um_bind_fun = bind_fn-                , um_skols    = emptyVarSet-                , um_unif     = unif-                , um_inj_tf   = inj_check-                , um_arr_mult = match_mults-                , um_rn_env   = rn_env }--    kis1 = map typeKind tys1-    kis2 = map typeKind tys2--instance Outputable a => Outputable (UnifyResultM a) where-  ppr SurelyApart      = text "SurelyApart"-  ppr (Unifiable x)    = text "Unifiable" <+> ppr x-  ppr (MaybeApart r x) = text "MaybeApart" <+> ppr r <+> ppr x--{--************************************************************************-*                                                                      *-                Non-idempotent substitution-*                                                                      *-************************************************************************--Note [Non-idempotent substitution]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-During unification we use a TvSubstEnv/CvSubstEnv pair that is-  (a) non-idempotent-  (b) loop-free; ie repeatedly applying it yields a fixed point--Note [Finding the substitution fixpoint]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Finding the fixpoint of a non-idempotent substitution arising from a-unification is much trickier than it looks, because of kinds.  Consider-   T k (H k (f:k)) ~ T * (g:*)-If we unify, we get the substitution-   [ k -> *-   , g -> H k (f:k) ]-To make it idempotent we don't want to get just-   [ k -> *-   , g -> H * (f:k) ]-We also want to substitute inside f's kind, to get-   [ k -> *-   , g -> H k (f:*) ]-If we don't do this, we may apply the substitution to something,-and get an ill-formed type, i.e. one where typeKind will fail.-This happened, for example, in #9106.--It gets worse.  In #14164 we wanted to take the fixpoint of-this substitution-   [ xs_asV :-> F a_aY6 (z_aY7 :: a_aY6)-                        (rest_aWF :: G a_aY6 (z_aY7 :: a_aY6))-   , a_aY6  :-> a_aXQ ]--We have to apply the substitution for a_aY6 two levels deep inside-the invocation of F!  We don't have a function that recursively-applies substitutions inside the kinds of variable occurrences (and-probably rightly so).--So, we work as follows:-- 1. Start with the current substitution (which we are-    trying to fixpoint-       [ xs :-> F a (z :: a) (rest :: G a (z :: a))-       , a  :-> b ]-- 2. Take all the free vars of the range of the substitution:-       {a, z, rest, b}-    NB: the free variable finder closes over-    the kinds of variable occurrences-- 3. If none are in the domain of the substitution, stop.-    We have found a fixpoint.-- 4. Remove the variables that are bound by the substitution, leaving-       {z, rest, b}-- 5. Do a topo-sort to put them in dependency order:-       [ b :: *, z :: a, rest :: G a z ]-- 6. Apply the substitution left-to-right to the kinds of these-    tyvars, extending it each time with a new binding, so we-    finish up with-       [ xs   :-> ..as before..-       , a    :-> b-       , b    :-> b    :: *-       , z    :-> z    :: b-       , rest :-> rest :: G b (z :: b) ]-    Note that rest now has the right kind-- 7. Apply this extended substitution (once) to the range of-    the /original/ substitution.  (Note that we do the-    extended substitution would go on forever if you tried-    to find its fixpoint, because it maps z to z.)-- 8. And go back to step 1--In Step 6 we use the free vars from Step 2 as the initial-in-scope set, because all of those variables appear in the-range of the substitution, so they must all be in the in-scope-set.  But NB that the type substitution engine does not look up-variables in the in-scope set; it is used only to ensure no-shadowing.--}--niFixSubst :: InScopeSet -> TvSubstEnv -> Subst--- Find the idempotent fixed point of the non-idempotent substitution--- This is surprisingly tricky:---   see Note [Finding the substitution fixpoint]--- ToDo: use laziness instead of iteration?-niFixSubst in_scope tenv-  | not_fixpoint = niFixSubst in_scope (mapVarEnv (substTy subst) tenv)-  | otherwise    = subst-  where-    range_fvs :: FV-    range_fvs = tyCoFVsOfTypes (nonDetEltsUFM tenv)-          -- It's OK to use nonDetEltsUFM here because the-          -- order of range_fvs, range_tvs is immaterial--    range_tvs :: [TyVar]-    range_tvs = fvVarList range_fvs--    not_fixpoint  = any in_domain range_tvs-    in_domain tv  = tv `elemVarEnv` tenv--    free_tvs = scopedSort (filterOut in_domain range_tvs)--    -- See Note [Finding the substitution fixpoint], Step 6-    subst = foldl' add_free_tv-                  (mkTvSubst in_scope tenv)-                  free_tvs--    add_free_tv :: Subst -> TyVar -> Subst-    add_free_tv subst tv-      = extendTvSubst subst tv (mkTyVarTy tv')-     where-        tv' = updateTyVarKind (substTy subst) tv--niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet--- Apply the non-idempotent substitution to a set of type variables,--- remembering that the substitution isn't necessarily idempotent--- This is used in the occurs check, before extending the substitution-niSubstTvSet tsubst tvs-  = nonDetStrictFoldUniqSet (unionVarSet . get) emptyVarSet tvs-  -- It's OK to use a non-deterministic fold here because we immediately forget-  -- the ordering by creating a set.-  where-    get tv-      | Just ty <- lookupVarEnv tsubst tv-      = niSubstTvSet tsubst (tyCoVarsOfType ty)--      | otherwise-      = unitVarSet tv--{--************************************************************************-*                                                                      *-                unify_ty: the main workhorse-*                                                                      *-************************************************************************--Note [Specification of unification]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The pure unifier, unify_ty, defined in this module, tries to work out-a substitution to make two types say True to eqType. NB: eqType is-itself not purely syntactic; it accounts for CastTys;-see Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep--Unlike the "impure unifiers" in the typechecker (the eager unifier in-GHC.Tc.Utils.Unify, and the constraint solver itself in GHC.Tc.Solver.Equality),-the pure unifier does /not/ work up to ~.--The algorithm implemented here is rather delicate, and we depend on it-to uphold certain properties. This is a summary of these required-properties.--Notation:- θ,φ  substitutions- ξ    type-function-free types- τ,σ  other types- τ♭   type τ, flattened-- ≡    eqType--(U1) Soundness.-     If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂).-     θ is a most general unifier for τ₁ and τ₂.--(U2) Completeness.-     If (unify ξ₁ ξ₂) = SurelyApart,-     then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂).--These two properties are stated as Property 11 in the "Closed Type Families"-paper (POPL'14). Below, this paper is called [CTF].--(U3) Apartness under substitution.-     If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart,-     for any θ. (Property 12 from [CTF])--(U4) Apart types do not unify.-     If (unify ξ τ♭) = SurelyApart, then there exists no θ-     such that θ(ξ) = θ(τ). (Property 13 from [CTF])--THEOREM. Completeness w.r.t ~-    If (unify τ₁♭ τ₂♭) = SurelyApart,-    then there exists no proof that (τ₁ ~ τ₂).--PROOF. See appendix of [CTF].---The unification algorithm is used for type family injectivity, as described-in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run-in this mode, it has the following properties.--(I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even-     after arbitrary type family reductions. Note that σ and τ are-     not flattened here.--(I2) If (unify σ τ) = MaybeApart θ, and if some-     φ exists such that φ(σ) ~ φ(τ), then φ extends θ.---Furthermore, the RULES matching algorithm requires this property,-but only when using this algorithm for matching:--(M1) If (match σ τ) succeeds with θ, then all matchable tyvars-     in σ are bound in θ.--     Property M1 means that we must extend the substitution with,-     say (a ↦ a) when appropriate during matching.-     See also Note [Self-substitution when matching].--(M2) Completeness of matching.-     If θ(σ) = τ, then (match σ τ) = Unifiable φ,-     where θ is an extension of φ.--Sadly, property M2 and I2 conflict. Consider--type family F1 a b where-  F1 Int    Bool   = Char-  F1 Double String = Char--Consider now two matching problems:--P1. match (F1 a Bool) (F1 Int Bool)-P2. match (F1 a Bool) (F1 Double String)--In case P1, we must find (a ↦ Int) to satisfy M2.-In case P2, we must /not/ find (a ↦ Double), in order to satisfy I2. (Note-that the correct mapping for I2 is (a ↦ Int). There is no way to discover-this, but we mustn't map a to anything else!)--We thus must parameterize the algorithm over whether it's being used-for an injectivity check (refrain from looking at non-injective arguments-to type families) or not (do indeed look at those arguments).  This is-implemented  by the um_inj_tf field of UMEnv.--(It's all a question of whether or not to include equation (7) from Fig. 2-of [ITF].)--This extra parameter is a bit fiddly, perhaps, but seemingly less so than-having two separate, almost-identical algorithms.--Note [Self-substitution when matching]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-What should happen when we're *matching* (not unifying) a1 with a1? We-should get a substitution [a1 |-> a1]. A successful match should map all-the template variables (except ones that disappear when expanding synonyms).-But when unifying, we don't want to do this, because we'll then fall into-a loop.--This arrangement affects the code in three places:- - If we're matching a refined template variable, don't recur. Instead, just-   check for equality. That is, if we know [a |-> Maybe a] and are matching-   (a ~? Maybe Int), we want to just fail.-- - Skip the occurs check when matching. This comes up in two places, because-   matching against variables is handled separately from matching against-   full-on types.--Note that this arrangement was provoked by a real failure, where the same-unique ended up in the template as in the target. (It was a rule firing when-compiling Data.List.NonEmpty.)--Note [Matching coercion variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this:--   type family F a--   data G a where-     MkG :: F a ~ Bool => G a--   type family Foo (x :: G a) :: F a-   type instance Foo MkG = False--We would like that to be accepted. For that to work, we need to introduce-a coercion variable on the left and then use it on the right. Accordingly,-at use sites of Foo, we need to be able to use matching to figure out the-value for the coercion. (See the desugared version:--   axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c)--) We never want this action to happen during *unification* though, when-all bets are off.--Note [Kind coercions in Unify]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We wish to match/unify while ignoring casts. But, we can't just ignore-them completely, or we'll end up with ill-kinded substitutions. For example,-say we're matching `a` with `ty |> co`. If we just drop the cast, we'll-return [a |-> ty], but `a` and `ty` might have different kinds. We can't-just match/unify their kinds, either, because this might gratuitously-fail. After all, `co` is the witness that the kinds are the same -- they-may look nothing alike.--So, we pass a kind coercion to the match/unify worker. This coercion witnesses-the equality between the substed kind of the left-hand type and the substed-kind of the right-hand type. Note that we do not unify kinds at the leaves-(as we did previously). We thus have--Hence: (Unification Kind Invariant)-------------------------------------In the call-     unify_ty ty1 ty2 kco-it must be that-     subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2))-where `subst` is the ambient substitution in the UM monad.  And in the call-     unify_tys tys1 tys2-(which has no kco), after we unify any prefix of tys1,tys2, the kinds of the-head of the remaining tys1,tys2 are identical after substitution.  This-implies, for example, that the kinds of the head of tys1,tys2 are identical-after substitution.--To get this coercion, we first have to match/unify-the kinds before looking at the types. Happily, we need look only one level-up, as all kinds are guaranteed to have kind *.--When we're working with type applications (either TyConApp or AppTy) we-need to worry about establishing INVARIANT, as the kinds of the function-& arguments aren't (necessarily) included in the kind of the result.-When unifying two TyConApps, this is easy, because the two TyCons are-the same. Their kinds are thus the same. As long as we unify left-to-right,-we'll be sure to unify types' kinds before the types themselves. (For example,-think about Proxy :: forall k. k -> *. Unifying the first args matches up-the kinds of the second args.)--For AppTy, we must unify the kinds of the functions, but once these are-unified, we can continue unifying arguments without worrying further about-kinds.--The interface to this module includes both "...Ty" functions and-"...TyKi" functions. The former assume that INVARIANT is already-established, either because the kinds are the same or because the-list of types being passed in are the well-typed arguments to some-type constructor (see two paragraphs above). The latter take a separate-pre-pass over the kinds to establish INVARIANT. Sometimes, it's important-not to take the second pass, as it caused #12442.--We thought, at one point, that this was all unnecessary: why should-casts be in types in the first place? But they are sometimes. In-dependent/should_compile/KindEqualities2, we see, for example the-constraint Num (Int |> (blah ; sym blah)).  We naturally want to find-a dictionary for that constraint, which requires dealing with-coercions in this manner.--Note [Matching in the presence of casts (1)]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When matching, it is crucial that no variables from the template-end up in the range of the matching substitution (obviously!).-When unifying, that's not a constraint; instead we take the fixpoint-of the substitution at the end.--So what should we do with this, when matching?-   unify_ty (tmpl |> co) tgt kco--Previously, wrongly, we pushed 'co' in the (horrid) accumulating-'kco' argument like this:-   unify_ty (tmpl |> co) tgt kco-     = unify_ty tmpl tgt (kco ; co)--But that is obviously wrong because 'co' (from the template) ends-up in 'kco', which in turn ends up in the range of the substitution.--This all came up in #13910.  Because we match tycon arguments-left-to-right, the ambient substitution will already have a matching-substitution for any kinds; so there is an easy fix: just apply-the substitution-so-far to the coercion from the LHS.--Note that--* When matching, the first arg of unify_ty is always the template;-  we never swap round.--* The above argument is distressingly indirect. We seek a-  better way.--* One better way is to ensure that type patterns (the template-  in the matching process) have no casts.  See #14119.--Note [Matching in the presence of casts (2)]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There is another wrinkle (#17395).  Suppose (T :: forall k. k -> Type)-and we are matching-   tcMatchTy (T k (a::k))  (T j (b::j))--Then we'll match k :-> j, as expected. But then in unify_tys-we invoke-   unify_tys env (a::k) (b::j) (Refl j)--Although we have unified k and j, it's very important that we put-(Refl j), /not/ (Refl k) as the fourth argument to unify_tys.-If we put (Refl k) we'd end up with the substitution-  a :-> b |> Refl k-which is bogus because one of the template variables, k,-appears in the range of the substitution.  Eek.--Similar care is needed in unify_ty_app.---Note [Polykinded tycon applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose  T :: forall k. Type -> K-and we are unifying-  ty1:  T @Type         Int       :: Type-  ty2:  T @(Type->Type) Int Int   :: Type--These two TyConApps have the same TyCon at the front but they-(legitimately) have different numbers of arguments.  They-are surelyApart, so we can report that without looking any-further (see #15704).--Note [Unifying type applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Unifying type applications is quite subtle, as we found-in #23134 and #22647, when type families are involved.--Suppose-   type family F a :: Type -> Type-   type family G k :: k = r | r -> k--and consider these examples:--* F Int ~ F Char, where F is injective-  Since F is injective, we can reduce this to Int ~ Char,-  therefore SurelyApart.--* F Int ~ F Char, where F is not injective-  Without injectivity, return MaybeApart.--* G Type ~ G (Type -> Type) Int-  Even though G is injective and the arguments to G are different,-  we cannot deduce apartness because the RHS is oversaturated.-  For example, G might be defined as-    G Type = Maybe Int-    G (Type -> Type) = Maybe-  So we return MaybeApart.--* F Int Bool ~ F Int Char       -- SurelyApart (since Bool is apart from Char)-  F Int Bool ~ Maybe a          -- MaybeApart-  F Int Bool ~ a b              -- MaybeApart-  F Int Bool ~ Char -> Bool     -- MaybeApart-  An oversaturated type family can match an application,-  whether it's a TyConApp, AppTy or FunTy. Decompose.--* F Int ~ a b-  We cannot decompose a saturated, or under-saturated-  type family application. We return MaybeApart.--To handle all those conditions, unify_ty goes through-the following checks in sequence, where Fn is a type family-of arity n:--* (C1) Fn x_1 ... x_n ~ Fn y_1 .. y_n-  A saturated application.-  Here we can unify arguments in which Fn is injective.-* (C2) Fn x_1 ... x_n ~ anything, anything ~ Fn x_1 ... x_n-  A saturated type family can match anything - we return MaybeApart.-* (C3) Fn x_1 ... x_m ~ a b, a b ~ Fn x_1 ... x_m where m > n-  An oversaturated type family can be decomposed.-* (C4) Fn x_1 ... x_m ~ anything, anything ~ Fn x_1 ... x_m, where m > n-  If we couldn't decompose in the previous step, we return SurelyApart.--Afterwards, the rest of the code doesn't have to worry about type families.--Note [Unifying type synonyms]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the task of unifying two 'Type's of the form--  TyConApp tc [] ~ TyConApp tc []--where `tc` is a type synonym. A naive way to perform this comparison these-would first expand the synonym and then compare the resulting expansions.--However, this is obviously wasteful and the RHS of `tc` may be large; it is-much better to rather compare the TyCons directly. Consequently, before-expanding type synonyms in type comparisons we first look for a nullary-TyConApp and simply compare the TyCons if we find one.--Of course, if we find that the TyCons are *not* equal then we still need to-perform the expansion as their RHSs may still be unifiable.  E.g-    type T = S (a->a)-    type S a = [a]-and consider-    T Int ~ S (Int -> Int)--We can't decompose non-nullary synonyms.  E.g.-    type R a = F a    -- Where F is a type family-and consider-    R (a->a) ~ R Int-We can't conclude that  (a->) ~ Int.  (There is a currently-missed opportunity-here; if we knew that R was /injective/, perhaps we could decompose.)--We perform the nullary-type-synonym optimisation in a number of places:-- * GHC.Core.Unify.unify_ty- * GHC.Tc.Solver.Equality.can_eq_nc'- * GHC.Tc.Utils.Unify.uType--This optimisation is especially helpful for the ubiquitous GHC.Types.Type,-since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications-whenever possible. See Note [Using synonyms to compress types] in-GHC.Core.Type for details.--c.f. Note [Comparing type synonyms] in GHC.Core.TyCo.Compare--}---------------- unify_ty: the main workhorse -------------type AmIUnifying = Bool   -- True  <=> Unifying-                          -- False <=> Matching--unify_ty :: UMEnv-         -> Type -> Type  -- Types to be unified and a co-         -> CoercionN     -- A coercion between their kinds-                          -- See Note [Kind coercions in Unify]-         -> UM ()--- Precondition: see (Unification Kind Invariant)------ See Note [Specification of unification]--- Respects newtypes, PredTypes--- See Note [Computing equality on types] in GHC.Core.Type-unify_ty _env (TyConApp tc1 []) (TyConApp tc2 []) _kco-  -- See Note [Unifying type synonyms]-  | tc1 == tc2-  = return ()--unify_ty env ty1 ty2 kco-    -- Now handle the cases we can "look through": synonyms and casts.-  | Just ty1' <- coreView ty1 = unify_ty env ty1' ty2 kco-  | Just ty2' <- coreView ty2 = unify_ty env ty1 ty2' kco-  | CastTy ty1' co <- ty1     = if um_unif env-                                then unify_ty env ty1' ty2 (co `mkTransCo` kco)-                                else -- See Note [Matching in the presence of casts (1)]-                                     do { subst <- getSubst env-                                        ; let co' = substCo subst co-                                        ; unify_ty env ty1' ty2 (co' `mkTransCo` kco) }-  | CastTy ty2' co <- ty2     = unify_ty env ty1 ty2' (kco `mkTransCo` mkSymCo co)--unify_ty env (TyVarTy tv1) ty2 kco-  = uVar env tv1 ty2 kco-unify_ty env ty1 (TyVarTy tv2) kco-  | um_unif env  -- If unifying, can swap args-  = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco)--unify_ty env ty1 ty2 _kco--  -- Handle non-oversaturated type families first-  -- See Note [Unifying type applications]-  ---  -- (C1) If we have T x1 ... xn ~ T y1 ... yn, use injectivity information of T-  -- Note that both sides must not be oversaturated-  | Just (tc1, tys1) <- isSatTyFamApp mb_tc_app1-  , Just (tc2, tys2) <- isSatTyFamApp mb_tc_app2-  , tc1 == tc2-  = do { let inj = case tyConInjectivityInfo tc1 of-                          NotInjective -> repeat False-                          Injective bs -> bs--             (inj_tys1, noninj_tys1) = partitionByList inj tys1-             (inj_tys2, noninj_tys2) = partitionByList inj tys2--       ; unify_tys env inj_tys1 inj_tys2-       ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification]-         don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 }--  | Just _ <- isSatTyFamApp mb_tc_app1  -- (C2) A (not-over-saturated) type-family application-  = maybeApart MARTypeFamily            -- behaves like a type variable; might match--  | Just _ <- isSatTyFamApp mb_tc_app2  -- (C2) A (not-over-saturated) type-family application-                                        -- behaves like a type variable; might unify-                                        -- but doesn't match (as in the TyVarTy case)-  = if um_unif env then maybeApart MARTypeFamily else surelyApart--  -- Handle oversaturated type families.-  ---  -- They can match an application (TyConApp/FunTy/AppTy), this is handled-  -- the same way as in the AppTy case below.-  ---  -- If there is no application, an oversaturated type family can only-  -- match a type variable or a saturated type family,-  -- both of which we handled earlier. So we can say surelyApart.-  | Just (tc1, _) <- mb_tc_app1-  , isTypeFamilyTyCon tc1-  = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1-       , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2-       -> unify_ty_app env ty1a [ty1b] ty2a [ty2b]            -- (C3)-       | otherwise -> surelyApart                             -- (C4)--  | Just (tc2, _) <- mb_tc_app2-  , isTypeFamilyTyCon tc2-  = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1-       , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2-       -> unify_ty_app env ty1a [ty1b] ty2a [ty2b]            -- (C3)-       | otherwise -> surelyApart                             -- (C4)--  -- At this point, neither tc1 nor tc2 can be a type family.-  | Just (tc1, tys1) <- mb_tc_app1-  , Just (tc2, tys2) <- mb_tc_app2-  , tc1 == tc2-  = do { massertPpr (isInjectiveTyCon tc1 Nominal) (ppr tc1)-       ; unify_tc_app tc1 tys1 tys2-       }--  -- TYPE and CONSTRAINT are not Apart-  -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim-  -- NB: at this point we know that the two TyCons do not match-  | Just (tc1,_) <- mb_tc_app1, let u1 = tyConUnique tc1-  , Just (tc2,_) <- mb_tc_app2, let u2 = tyConUnique tc2-  , (u1 == tYPETyConKey && u2 == cONSTRAINTTyConKey) ||-    (u2 == tYPETyConKey && u1 == cONSTRAINTTyConKey)-  = maybeApart MARTypeVsConstraint-    -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim-    -- Note [Type and Constraint are not apart]--  -- The arrow types are not Apart-  -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim-  --     wrinkle (W2)-  -- NB1: at this point we know that the two TyCons do not match-  -- NB2: In the common FunTy/FunTy case you might wonder if we want to go via-  --      splitTyConApp_maybe.  But yes we do: we need to look at those implied-  --      kind argument in order to satisfy (Unification Kind Invariant)-  | FunTy {} <- ty1-  , FunTy {} <- ty2-  = maybeApart MARTypeVsConstraint-    -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim-    -- Note [Type and Constraint are not apart]--  where-    mb_tc_app1 = splitTyConApp_maybe ty1-    mb_tc_app2 = splitTyConApp_maybe ty2--    unify_tc_app tc tys1 tys2-      | tc == fUNTyCon-      , IgnoreMultiplicities <- um_arr_mult env-      , (_mult1 : no_mult_tys1) <- tys1-      , (_mult2 : no_mult_tys2) <- tys2-      = -- We're comparing function arrow types here (not constraint arrow-        -- types!), and they have at least one argument, which is the arrow's-        -- multiplicity annotation. The flag `um_arr_mult` instructs us to-        -- ignore multiplicities in this very case. This is a little tricky: see-        -- point (3) in Note [Rewrite rules ignore multiplicities in FunTy].-         unify_tys env no_mult_tys1 no_mult_tys2--      | otherwise-      = unify_tys env tys1 tys2--        -- Applications need a bit of care!-        -- They can match FunTy and TyConApp, so use splitAppTy_maybe-        -- NB: we've already dealt with type variables,-        -- so if one type is an App the other one jolly well better be too-unify_ty env (AppTy ty1a ty1b) ty2 _kco-  | Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2-  = unify_ty_app env ty1a [ty1b] ty2a [ty2b]--unify_ty env ty1 (AppTy ty2a ty2b) _kco-  | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1-  = unify_ty_app env ty1a [ty1b] ty2a [ty2b]--unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return ()--unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco-  = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind)-       ; let env' = umRnBndr2 env tv1 tv2-       ; unify_ty env' ty1 ty2 kco }---- See Note [Matching coercion variables]-unify_ty env (CoercionTy co1) (CoercionTy co2) kco-  = do { c_subst <- getCvSubstEnv-       ; case co1 of-           CoVarCo cv-             | not (um_unif env)-             , not (cv `elemVarEnv` c_subst)-             , let (_, co_l, co_r) = decomposeFunCo kco-                     -- Because the coercion is used in a type, it should be safe to-                     -- ignore the multiplicity coercion.-                      -- cv :: t1 ~ t2-                      -- co2 :: s1 ~ s2-                      -- co_l :: t1 ~ s1-                      -- co_r :: t2 ~ s2-                   rhs_co = co_l `mkTransCo` co2 `mkTransCo` mkSymCo co_r-             , BindMe <- tvBindFlag env cv (CoercionTy rhs_co)-             -> do { checkRnEnv env (tyCoVarsOfCo co2)-                   ; extendCvEnv cv rhs_co }-           _ -> return () }--unify_ty _ _ _ _ = surelyApart--unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM ()-unify_ty_app env ty1 ty1args ty2 ty2args-  | Just (ty1', ty1a) <- splitAppTyNoView_maybe ty1-  , Just (ty2', ty2a) <- splitAppTyNoView_maybe ty2-  = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args)--  | otherwise-  = do { let ki1 = typeKind ty1-             ki2 = typeKind ty2-           -- See Note [Kind coercions in Unify]-       ; unify_ty  env ki1 ki2 (mkNomReflCo liftedTypeKind)-       ; unify_ty  env ty1 ty2 (mkNomReflCo ki2)-                 -- Very important: 'ki2' not 'ki1'-                 -- See Note [Matching in the presence of casts (2)]-       ; unify_tys env ty1args ty2args }--unify_tys :: UMEnv -> [Type] -> [Type] -> UM ()--- Precondition: see (Unification Kind Invariant)-unify_tys env orig_xs orig_ys-  = go orig_xs orig_ys-  where-    go []     []     = return ()-    go (x:xs) (y:ys)-      -- See Note [Kind coercions in Unify]-      = do { unify_ty env x y (mkNomReflCo $ typeKind y)-                 -- Very important: 'y' not 'x'-                 -- See Note [Matching in the presence of casts (2)]-           ; go xs ys }-    go _ _ = surelyApart-      -- Possibly different saturations of a polykinded tycon-      -- See Note [Polykinded tycon applications]--isSatTyFamApp :: Maybe (TyCon, [Type]) -> Maybe (TyCon, [Type])--- Return the argument if we have a saturated type family application--- If it is /over/ saturated then we return False.  E.g.---     unify_ty (F a b) (c d)    where F has arity 1--- we definitely want to decompose that type application! (#22647)-isSatTyFamApp tapp@(Just (tc, tys))-  |  isTypeFamilyTyCon tc-  && not (tys `lengthExceeds` tyConArity tc)  -- Not over-saturated-  = tapp-isSatTyFamApp _ = Nothing------------------------------------uVar :: UMEnv-     -> InTyVar         -- Variable to be unified-     -> Type            -- with this Type-     -> Coercion        -- :: kind tv ~N kind ty-     -> UM ()--uVar env tv1 ty kco- = do { -- Apply the ambient renaming-        let tv1' = umRnOccL env tv1--        -- Check to see whether tv1 is refined by the substitution-      ; subst <- getTvSubstEnv-      ; case (lookupVarEnv subst tv1') of-          Just ty' | um_unif env                -- Unifying, so call-                   -> unify_ty env ty' ty kco   -- back into unify-                   | otherwise-                   -> -- Matching, we don't want to just recur here.-                      -- this is because the range of the subst is the target-                      -- type, not the template type. So, just check for-                      -- normal type equality.-                      unless ((ty' `mkCastTy` kco) `tcEqType` ty) $-                        surelyApart-                      -- NB: it's important to use `tcEqType` instead of `eqType` here,-                      -- otherwise we might not reject a substitution-                      -- which unifies `Type` with `Constraint`, e.g.-                      -- a call to tc_unify_tys with arguments-                      ---                      --   tys1 = [k,k]-                      --   tys2 = [Type, Constraint]-                      ---                      -- See test cases: T11715b, T20521.-          Nothing  -> uUnrefined env tv1' ty ty kco } -- No, continue--uUnrefined :: UMEnv-           -> OutTyVar          -- variable to be unified-           -> Type              -- with this Type-           -> Type              -- (version w/ expanded synonyms)-           -> Coercion          -- :: kind tv ~N kind ty-           -> UM ()---- We know that tv1 isn't refined--uUnrefined env tv1' ty2 ty2' kco-  | Just ty2'' <- coreView ty2'-  = uUnrefined env tv1' ty2 ty2'' kco    -- Unwrap synonyms-                -- This is essential, in case we have-                --      type Foo a = a-                -- and then unify a ~ Foo a--  | TyVarTy tv2 <- ty2'-  = do { let tv2' = umRnOccR env tv2-       ; unless (tv1' == tv2' && um_unif env) $ do-           -- If we are unifying a ~ a, just return immediately-           -- Do not extend the substitution-           -- See Note [Self-substitution when matching]--          -- Check to see whether tv2 is refined-       { subst <- getTvSubstEnv-       ; case lookupVarEnv subst tv2 of-         {  Just ty' | um_unif env -> uUnrefined env tv1' ty' ty' kco-         ;  _ ->--    do {   -- So both are unrefined-           -- Bind one or the other, depending on which is bindable-       ; let rhs1 = ty2 `mkCastTy` mkSymCo kco-             rhs2 = ty1 `mkCastTy` kco-             b1  = tvBindFlag env tv1' rhs1-             b2  = tvBindFlag env tv2' rhs2-             ty1 = mkTyVarTy tv1'-       ; case (b1, b2) of-           (BindMe, _) -> bindTv env tv1' rhs1-           (_, BindMe) | um_unif env-                       -> bindTv (umSwapRn env) tv2 rhs2--           _ | tv1' == tv2' -> return ()-             -- How could this happen? If we're only matching and if-             -- we're comparing forall-bound variables.--           _ -> surelyApart-  }}}}--uUnrefined env tv1' ty2 _ kco -- ty2 is not a type variable-  = case tvBindFlag env tv1' rhs of-      Apart  -> surelyApart-      BindMe -> bindTv env tv1' rhs-  where-    rhs = ty2 `mkCastTy` mkSymCo kco--bindTv :: UMEnv -> OutTyVar -> Type -> UM ()--- OK, so we want to extend the substitution with tv := ty--- But first, we must do a couple of checks-bindTv env tv1 ty2-  = do  { let free_tvs2 = tyCoVarsOfType ty2--        -- Make sure tys mentions no local variables-        -- E.g.  (forall a. b) ~ (forall a. [a])-        -- We should not unify b := [a]!-        ; checkRnEnv env free_tvs2--        -- Occurs check, see Note [Fine-grained unification]-        -- Make sure you include 'kco' (which ty2 does) #14846-        ; occurs <- occursCheck env tv1 free_tvs2--        ; if occurs then maybeApart MARInfinite-                    else extendTvEnv tv1 ty2 }--occursCheck :: UMEnv -> TyVar -> VarSet -> UM Bool-occursCheck env tv free_tvs-  | um_unif env-  = do { tsubst <- getTvSubstEnv-       ; return (tv `elemVarSet` niSubstTvSet tsubst free_tvs) }--  | otherwise      -- Matching; no occurs check-  = return False   -- See Note [Self-substitution when matching]--{--%************************************************************************-%*                                                                      *-                Binding decisions-*                                                                      *-************************************************************************--}--data BindFlag-  = BindMe      -- ^ A regular type variable--  | Apart       -- ^ Declare that this type variable is /apart/ from the-                -- type provided. That is, the type variable will never-                -- be instantiated to that type.-                -- See also Note [Binding when looking up instances]-                -- in GHC.Core.InstEnv.-  deriving Eq--- NB: It would be conceivable to have an analogue to MaybeApart here,--- but there is not yet a need.--{--************************************************************************-*                                                                      *-                Unification monad-*                                                                      *-************************************************************************--}--data UMEnv-  = UMEnv { um_unif :: AmIUnifying--          , um_inj_tf :: Bool-            -- Checking for injectivity?-            -- See (end of) Note [Specification of unification]--          , um_arr_mult :: MultiplicityFlag-            -- Whether to unify multiplicity arguments when unifying arrows.-            -- See Note [Rewrite rules ignore multiplicities in FunTy]--          , um_rn_env :: RnEnv2-            -- Renaming InTyVars to OutTyVars; this eliminates-            -- shadowing, and lines up matching foralls on the left-            -- and right--          , um_skols :: TyVarSet-            -- OutTyVars bound by a forall in this unification;-            -- Do not bind these in the substitution!-            -- See the function tvBindFlag--          , um_bind_fun :: BindFun-            -- User-supplied BindFlag function,-            -- for variables not in um_skols-          }--data UMState = UMState-                   { um_tv_env   :: TvSubstEnv-                   , um_cv_env   :: CvSubstEnv }--newtype UM a-  = UM' { unUM :: UMState -> UnifyResultM (UMState, a) }-    -- See Note [The one-shot state monad trick] in GHC.Utils.Monad--pattern UM :: (UMState -> UnifyResultM (UMState, a)) -> UM a--- See Note [The one-shot state monad trick] in GHC.Utils.Monad-pattern UM m <- UM' m-  where-    UM m = UM' (oneShot m)-{-# COMPLETE UM #-}--instance Functor UM where-  fmap f (UM m) = UM (\s -> fmap (\(s', v) -> (s', f v)) (m s))--instance Applicative UM where-      pure a = UM (\s -> pure (s, a))-      (<*>)  = ap--instance Monad UM where-  {-# INLINE (>>=) #-}-  -- See Note [INLINE pragmas and (>>)] in GHC.Utils.Monad-  m >>= k  = UM (\state ->-                  do { (state', v) <- unUM m state-                     ; unUM (k v) state' })--instance MonadFail UM where-    fail _   = UM (\_ -> SurelyApart) -- failed pattern match--initUM :: TvSubstEnv  -- subst to extend-       -> CvSubstEnv-       -> UM a -> UnifyResultM a-initUM subst_env cv_subst_env um-  = case unUM um state of-      Unifiable (_, subst)    -> Unifiable subst-      MaybeApart r (_, subst) -> MaybeApart r subst-      SurelyApart             -> SurelyApart-  where-    state = UMState { um_tv_env = subst_env-                    , um_cv_env = cv_subst_env }--tvBindFlag :: UMEnv -> OutTyVar -> Type -> BindFlag-tvBindFlag env tv rhs-  | tv `elemVarSet` um_skols env = Apart-  | otherwise                    = um_bind_fun env tv rhs--getTvSubstEnv :: UM TvSubstEnv-getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state)--getCvSubstEnv :: UM CvSubstEnv-getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state)--getSubst :: UMEnv -> UM Subst-getSubst env = do { tv_env <- getTvSubstEnv-                  ; cv_env <- getCvSubstEnv-                  ; let in_scope = rnInScopeSet (um_rn_env env)-                  ; return (mkTCvSubst in_scope tv_env cv_env) }--extendTvEnv :: TyVar -> Type -> UM ()-extendTvEnv tv ty = UM $ \state ->-  Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ())--extendCvEnv :: CoVar -> Coercion -> UM ()-extendCvEnv cv co = UM $ \state ->-  Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ())--umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv-umRnBndr2 env v1 v2-  = env { um_rn_env = rn_env', um_skols = um_skols env `extendVarSet` v' }-  where-    (rn_env', v') = rnBndr2_var (um_rn_env env) v1 v2--checkRnEnv :: UMEnv -> VarSet -> UM ()-checkRnEnv env varset-  | isEmptyVarSet skol_vars           = return ()-  | varset `disjointVarSet` skol_vars = return ()-  | otherwise                         = surelyApart-  where-    skol_vars = um_skols env-    -- NB: That isEmptyVarSet guard is a critical optimization;-    -- it means we don't have to calculate the free vars of-    -- the type, often saving quite a bit of allocation.---- | Converts any SurelyApart to a MaybeApart-don'tBeSoSure :: MaybeApartReason -> UM () -> UM ()-don'tBeSoSure r um = UM $ \ state ->-  case unUM um state of-    SurelyApart -> MaybeApart r (state, ())-    other       -> other--umRnOccL :: UMEnv -> TyVar -> TyVar-umRnOccL env v = rnOccL (um_rn_env env) v--umRnOccR :: UMEnv -> TyVar -> TyVar-umRnOccR env v = rnOccR (um_rn_env env) v--umSwapRn :: UMEnv -> UMEnv-umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) }--maybeApart :: MaybeApartReason -> UM ()-maybeApart r = UM (\state -> MaybeApart r (state, ()))--surelyApart :: UM a-surelyApart = UM (\_ -> SurelyApart)--{--%************************************************************************-%*                                                                      *-            Matching a (lifted) type against a coercion-%*                                                                      *-%************************************************************************--This section defines essentially an inverse to liftCoSubst. It is defined-here to avoid a dependency from Coercion on this module.---}--data MatchEnv = ME { me_tmpls :: TyVarSet-                   , me_env   :: RnEnv2 }---- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'.  In particular, if---   @liftCoMatch vars ty co == Just s@, then @liftCoSubst s ty == co@,---   where @==@ there means that the result of 'liftCoSubst' has the same---   type as the original co; but may be different under the hood.---   That is, it matches a type against a coercion of the same---   "shape", and returns a lifting substitution which could have been---   used to produce the given coercion from the given type.---   Note that this function is incomplete -- it might return Nothing---   when there does indeed exist a possible lifting context.------ This function is incomplete in that it doesn't respect the equality--- in `eqType`. That is, it's possible that this will succeed for t1 and--- fail for t2, even when t1 `eqType` t2. That's because it depends on--- there being a very similar structure between the type and the coercion.--- This incompleteness shouldn't be all that surprising, especially because--- it depends on the structure of the coercion, which is a silly thing to do.------ The lifting context produced doesn't have to be exacting in the roles--- of the mappings. This is because any use of the lifting context will--- also require a desired role. Thus, this algorithm prefers mapping to--- nominal coercions where it can do so.-liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext-liftCoMatch tmpls ty co-  = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co-       ; cenv2 <- ty_co_match menv cenv1       ty co-                              (mkNomReflCo co_lkind) (mkNomReflCo co_rkind)-       ; return (LC (mkEmptySubst in_scope) cenv2) }-  where-    menv     = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope }-    in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co)-    -- Like tcMatchTy, assume all the interesting variables-    -- in ty are in tmpls--    ki       = typeKind ty-    ki_co    = promoteCoercion co-    ki_ki_co = mkNomReflCo liftedTypeKind--    Pair co_lkind co_rkind = coercionKind ki_co---- | 'ty_co_match' does all the actual work for 'liftCoMatch'.-ty_co_match :: MatchEnv   -- ^ ambient helpful info-            -> LiftCoEnv  -- ^ incoming subst-            -> Type       -- ^ ty, type to match-            -> Coercion   -- ^ co :: lty ~r rty, coercion to match against-            -> Coercion   -- ^ :: kind(lsubst(ty)) ~N kind(lty)-            -> Coercion   -- ^ :: kind(rsubst(ty)) ~N kind(rty)-            -> Maybe LiftCoEnv-   -- ^ Just env ==> liftCoSubst Nominal env ty == co, modulo roles.-   -- Also: Just env ==> lsubst(ty) == lty and rsubst(ty) == rty,-   -- where lsubst = lcSubstLeft(env) and rsubst = lcSubstRight(env)-ty_co_match menv subst ty co lkco rkco-  | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco--  -- handle Refl case:-  | tyCoVarsOfType ty `isNotInDomainOf` subst-  , Just (ty', _) <- isReflCo_maybe co-  , ty `eqType` ty'-    -- Why `eqType` and not `tcEqType`? Because this function is only used-    -- during coercion optimisation, after type-checking has finished.-  = Just subst--  where-    isNotInDomainOf :: VarSet -> VarEnv a -> Bool-    isNotInDomainOf set env-      = noneSet (\v -> elemVarEnv v env) set--    noneSet :: (Var -> Bool) -> VarSet -> Bool-    noneSet f = allVarSet (not . f)--ty_co_match menv subst ty co lkco rkco-  | CastTy ty' co' <- ty-     -- See Note [Matching in the presence of casts (1)]-  = let empty_subst  = mkEmptySubst (rnInScopeSet (me_env menv))-        substed_co_l = substCo (liftEnvSubstLeft empty_subst subst)  co'-        substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co'-    in-    ty_co_match menv subst ty' co (substed_co_l `mkTransCo` lkco)-                                  (substed_co_r `mkTransCo` rkco)--  | SymCo co' <- co-  = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco--  -- Match a type variable against a non-refl coercion-ty_co_match menv subst (TyVarTy tv1) co lkco rkco-  | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1-  = if eqCoercionX (nukeRnEnvL rn_env) co1' co-    then Just subst-    else Nothing       -- no match since tv1 matches two different coercions--  | tv1' `elemVarSet` me_tmpls menv           -- tv1' is a template var-  = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co)-    then Nothing      -- occurs check failed-    else Just $ extendVarEnv subst tv1' $-                castCoercionKind co (mkSymCo lkco) (mkSymCo rkco)--  | otherwise-  = Nothing--  where-    rn_env = me_env menv-    tv1' = rnOccL rn_env tv1--  -- just look through SubCo's. We don't really care about roles here.-ty_co_match menv subst ty (SubCo co) lkco rkco-  = ty_co_match menv subst ty co lkco rkco--ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco-  | Just (co2, arg2) <- splitAppCo_maybe co     -- c.f. Unify.match on AppTy-  = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2]-ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco-  | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1-       -- yes, the one from Type, not TcType; this is for coercion optimization-  = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2]--ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco-  = ty_co_match_tc menv subst tc1 tys tc2 cos--ty_co_match menv subst (FunTy { ft_mult = w, ft_arg = ty1, ft_res = ty2 })-            (FunCo { fco_mult = co_w, fco_arg = co1, fco_res = co2 }) _lkco _rkco-  = ty_co_match_args menv subst [w,    rep1,    rep2,    ty1, ty2]-                                [co_w, co1_rep, co2_rep, co1, co2]-  where-     rep1    = getRuntimeRep ty1-     rep2    = getRuntimeRep ty2-     co1_rep = mkRuntimeRepCo co1-     co2_rep = mkRuntimeRepCo co2-    -- NB: we include the RuntimeRep arguments in the matching;-    --     not doing so caused #21205.--ty_co_match menv subst (ForAllTy (Bndr tv1 vis1t) ty1)-                       (ForAllCo tv2 vis1c vis2c kind_co2 co2)-                       lkco rkco-  | isTyVar tv1 && isTyVar tv2-  , vis1t == vis1c && vis1c == vis2c -- Is this necessary?-      -- Is this visibility check necessary?  @rae says: yes, I think the-      -- check is necessary, if we're caring about visibility (and we are).-      -- But ty_co_match is a dark and not important corner.-  = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2-                               ki_ki_co ki_ki_co-       ; let rn_env0 = me_env menv-             rn_env1 = rnBndr2 rn_env0 tv1 tv2-             menv'   = menv { me_env = rn_env1 }-       ; ty_co_match menv' subst1 ty1 co2 lkco rkco }-  where-    ki_ki_co = mkNomReflCo liftedTypeKind---- ty_co_match menv subst (ForAllTy (Bndr cv1 _) ty1)---                        (ForAllCo cv2 kind_co2 co2)---                        lkco rkco---   | isCoVar cv1 && isCoVar cv2---   We seems not to have enough information for this case---   1. Given:---        cv1      :: (s1 :: k1) ~r (s2 :: k2)---        kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2)---        eta1      = mkSelCo (SelTyCon 2 role) (downgradeRole r Nominal kind_co2)---                 :: s1' ~ t1---        eta2      = mkSelCo (SelTyCon 3 role) (downgradeRole r Nominal kind_co2)---                 :: s2' ~ t2---      Wanted:---        subst1 <- ty_co_match menv subst  s1 eta1 kco1 kco2---        subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4---      Question: How do we get kcoi?---   2. Given:---        lkco :: <*>    -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep---        rkco :: <*>---      Wanted:---        ty_co_match menv' subst2 ty1 co2 lkco' rkco'---      Question: How do we get lkco' and rkco'?--ty_co_match _ subst (CoercionTy {}) _ _ _-  = Just subst -- don't inspect coercions--ty_co_match menv subst ty (GRefl r t (MCo co)) lkco rkco-  =  ty_co_match menv subst ty (GRefl r t MRefl) lkco (rkco `mkTransCo` mkSymCo co)--ty_co_match menv subst ty co1 lkco rkco-  | Just (CastTy t co, r) <- isReflCo_maybe co1-  -- In @pushRefl@, pushing reflexive coercion inside CastTy will give us-  -- t |> co ~ t ; <t> ; t ~ t |> co-  -- But transitive coercions are not helpful. Therefore we deal-  -- with it here: we do recursion on the smaller reflexive coercion,-  -- while propagating the correct kind coercions.-  = let kco' = mkSymCo co-    in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco')-                                                (rkco `mkTransCo` kco')--ty_co_match menv subst ty co lkco rkco-  | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco-  | otherwise               = Nothing--ty_co_match_tc :: MatchEnv -> LiftCoEnv-               -> TyCon -> [Type]-               -> TyCon -> [Coercion]-               -> Maybe LiftCoEnv-ty_co_match_tc menv subst tc1 tys1 tc2 cos2-  = do { guard (tc1 == tc2)-       ; ty_co_match_args menv subst tys1 cos2 }--ty_co_match_app :: MatchEnv -> LiftCoEnv-                -> Type -> [Type] -> Coercion -> [Coercion]-                -> Maybe LiftCoEnv-ty_co_match_app menv subst ty1 ty1args co2 co2args-  | Just (ty1', ty1a) <- splitAppTyNoView_maybe ty1-  , Just (co2', co2a) <- splitAppCo_maybe co2-  = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args)--  | otherwise-  = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co-       ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2-       ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco-       ; ty_co_match_args menv subst2 ty1args co2args }-  where-    ki1 = typeKind ty1-    ki2 = promoteCoercion co2-    ki_ki_co = mkNomReflCo liftedTypeKind--ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] -> [Coercion]-                 -> Maybe LiftCoEnv-ty_co_match_args menv subst (ty:tys) (arg:args)-  = do { let Pair lty rty = coercionKind arg-             lkco = mkNomReflCo (typeKind lty)-             rkco = mkNomReflCo (typeKind rty)-       ; subst' <- ty_co_match menv subst ty arg lkco rkco-       ; ty_co_match_args menv subst' tys args }-ty_co_match_args _    subst []       [] = Just subst-ty_co_match_args _    _     _        _  = Nothing--pushRefl :: Coercion -> Maybe Coercion-pushRefl co =-  case (isReflCo_maybe co) of-    Just (AppTy ty1 ty2, Nominal)-      -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2))-    Just (FunTy af w ty1 ty2, r)-      ->  Just (FunCo r af af (mkReflCo r w) (mkReflCo r ty1) (mkReflCo r ty2))-    Just (TyConApp tc tys, r)-      -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRoleListX r tc) tys))-    Just (ForAllTy (Bndr tv vis) ty, r)-      -> Just (ForAllCo { fco_tcv = tv, fco_visL = vis, fco_visR = vis-                        , fco_kind = mkNomReflCo (varType tv)-                        , fco_body = mkReflCo r ty })-    _ -> Nothing--{--************************************************************************-*                                                                      *-              Flattening-*                                                                      *-************************************************************************--Note [Flattening type-family applications when matching instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As described in "Closed type families with overlapping equations"-http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf-we need to flatten core types before unifying them, when checking for "surely-apart"-against earlier equations of a closed type family.-Flattening means replacing all top-level uses of type functions with-fresh variables, *taking care to preserve sharing*. That is, the type-(Either (F a b) (F a b)) should flatten to (Either c c), never (Either-c d).--Here is a nice example of why it's all necessary:--  type family F a b where-    F Int Bool = Char-    F a   b    = Double-  type family G a         -- open, no instances--How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match,-while the second equation does. But, before reducing, we must make sure that the-target can never become (F Int Bool). Well, no matter what G Float becomes, it-certainly won't become *both* Int and Bool, so indeed we're safe reducing-(F (G Float) (G Float)) to Double.--This is necessary not only to get more reductions (which we might be-willing to give up on), but for substitutivity. If we have (F x x), we-can see that (F x x) can reduce to Double. So, it had better be the-case that (F blah blah) can reduce to Double, no matter what (blah)-is!  Flattening as done below ensures this.--We also use this flattening operation to check for class instances.-If we have-  instance C (Maybe b)-  instance {-# OVERLAPPING #-} C (Maybe Bool)-  [W] C (Maybe (F a))-we want to know that the second instance might match later. So we-flatten the (F a) in the target before trying to unify with instances.-(This is done in GHC.Core.InstEnv.lookupInstEnv'.)--The algorithm works by building up a TypeMap TyVar, mapping-type family applications to fresh variables. This mapping must-be threaded through all the function calls, as any entry in-the mapping must be propagated to all future nodes in the tree.--The algorithm also must track the set of in-scope variables, in-order to make fresh variables as it flattens. (We are far from a-source of fresh Uniques.) See Wrinkle 2, below.--There are wrinkles, of course:--1. The flattening algorithm must account for the possibility-   of inner `forall`s. (A `forall` seen here can happen only-   because of impredicativity. However, the flattening operation-   is an algorithm in Core, which is impredicative.)-   Suppose we have (forall b. F b) -> (forall b. F b). Of course,-   those two bs are entirely unrelated, and so we should certainly-   not flatten the two calls F b to the same variable. Instead, they-   must be treated separately. We thus carry a substitution that-   freshens variables; we must apply this substitution (in-   `coreFlattenTyFamApp`) before looking up an application in the environment.-   Note that the range of the substitution contains only TyVars, never anything-   else.--   For the sake of efficiency, we only apply this substitution when absolutely-   necessary. Namely:--   * We do not perform the substitution at all if it is empty.-   * We only need to worry about the arguments of a type family that are within-     the arity of said type family, so we can get away with not applying the-     substitution to any oversaturated type family arguments.-   * Importantly, we do /not/ achieve this substitution by recursively-     flattening the arguments, as this would be wrong. Consider `F (G a)`,-     where F and G are type families. We might decide that `F (G a)` flattens-     to `beta`. Later, the substitution is non-empty (but does not map `a`) and-     so we flatten `G a` to `gamma` and try to flatten `F gamma`. Of course,-     `F gamma` is unknown, and so we flatten it to `delta`, but it really-     should have been `beta`! Argh!--     Moral of the story: instead of flattening the arguments, just substitute-     them directly.--2. There are two different reasons we might add a variable-   to the in-scope set as we work:--     A. We have just invented a new flattening variable.-     B. We have entered a `forall`.--   Annoying here is that in-scope variable source (A) must be-   threaded through the calls. For example, consider (F b -> forall c. F c).-   Suppose that, when flattening F b, we invent a fresh variable c.-   Now, when we encounter (forall c. F c), we need to know c is already in-   scope so that we locally rename c to c'. However, if we don't thread through-   the in-scope set from one argument of (->) to the other, we won't know this-   and might get very confused.--   In contrast, source (B) increases only as we go deeper, as in-scope sets-   normally do. However, even here we must be careful. The TypeMap TyVar that-   contains mappings from type family applications to freshened variables will-   be threaded through both sides of (forall b. F b) -> (forall b. F b). We-   thus must make sure that the two `b`s don't get renamed to the same b1. (If-   they did, then looking up `F b1` would yield the same flatten var for-   each.) So, even though `forall`-bound variables should really be in the-   in-scope set only when they are in scope, we retain these variables even-   outside of their scope. This ensures that, if we encounter a fresh-   `forall`-bound b, we will rename it to b2, not b1. Note that keeping a-   larger in-scope set than strictly necessary is always OK, as in-scope sets-   are only ever used to avoid collisions.--   Sadly, the freshening substitution described in (1) really mustn't bind-   variables outside of their scope: note that its domain is the *unrenamed*-   variables. This means that the substitution gets "pushed down" (like a-   reader monad) while the in-scope set gets threaded (like a state monad).-   Because a Subst contains its own in-scope set, we don't carry a Subst;-   instead, we just carry a TvSubstEnv down, tying it to the InScopeSet-   traveling separately as necessary.--3. Consider `F ty_1 ... ty_n`, where F is a type family with arity k:--     type family F ty_1 ... ty_k :: res_k--   It's tempting to just flatten `F ty_1 ... ty_n` to `alpha`, where alpha is a-   flattening skolem. But we must instead flatten it to-   `alpha ty_(k+1) ... ty_n`—that is, by only flattening up to the arity of the-   type family.--   Why is this better? Consider the following concrete example from #16995:--     type family Param :: Type -> Type--     type family LookupParam (a :: Type) :: Type where-       LookupParam (f Char) = Bool-       LookupParam x        = Int--     foo :: LookupParam (Param ())-     foo = 42--   In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to-   `Int`. But if we flatten `Param ()` to `alpha`, then GHC can't be sure if-   `alpha` is apart from `f Char`, so it won't fall through to the second-   equation. But since the `Param` type family has arity 0, we can instead-   flatten `Param ()` to `alpha ()`, about which GHC knows with confidence is-   apart from `f Char`, permitting the second equation to be reached.--   Not only does this allow more programs to be accepted, it's also important-   for correctness. Not doing this was the root cause of the Core Lint error-   in #16995.--flattenTys is defined here because of module dependencies.--}--data FlattenEnv-  = FlattenEnv { fe_type_map :: TypeMap (TyVar, TyCon, [Type])-                 -- domain: exactly-saturated type family applications-                 -- range: (fresh variable, type family tycon, args)-               , fe_in_scope :: InScopeSet }-                 -- See Note [Flattening type-family applications when matching instances]--emptyFlattenEnv :: InScopeSet -> FlattenEnv-emptyFlattenEnv in_scope-  = FlattenEnv { fe_type_map = emptyTypeMap-               , fe_in_scope = in_scope }--updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv-updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) }--flattenTys :: InScopeSet -> [Type] -> [Type]--- See Note [Flattening type-family applications when matching instances]-flattenTys in_scope tys = fst (flattenTysX in_scope tys)--flattenTysX :: InScopeSet -> [Type] -> ([Type], TyVarEnv (TyCon, [Type]))--- See Note [Flattening type-family applications when matching instances]--- NB: the returned types mention the fresh type variables---     in the domain of the returned env, whose range includes---     the original type family applications. Building a substitution---     from this information and applying it would yield the original---     types -- almost. The problem is that the original type might---     have something like (forall b. F a b); the returned environment---     can't really sensibly refer to that b. So it may include a locally----     bound tyvar in its range. Currently, the only usage of this env't---     checks whether there are any meta-variables in it---     (in GHC.Tc.Solver.Monad.mightEqualLater), so this is all OK.-flattenTysX in_scope tys-  = let (env, result) = coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys in-    (result, build_env (fe_type_map env))-  where-    build_env :: TypeMap (TyVar, TyCon, [Type]) -> TyVarEnv (TyCon, [Type])-    build_env env_in-      = foldTM (\(tv, tc, tys) env_out -> extendVarEnv env_out tv (tc, tys))-               env_in emptyVarEnv--coreFlattenTys :: TvSubstEnv -> FlattenEnv-               -> [Type] -> (FlattenEnv, [Type])-coreFlattenTys subst = mapAccumL (coreFlattenTy subst)--coreFlattenTy :: TvSubstEnv -> FlattenEnv-              -> Type -> (FlattenEnv, Type)-coreFlattenTy subst = go-  where-    go env ty | Just ty' <- coreView ty = go env ty'--    go env (TyVarTy tv)-      | Just ty <- lookupVarEnv subst tv = (env, ty)-      | otherwise                        = let (env', ki) = go env (tyVarKind tv) in-                                           (env', mkTyVarTy $ setTyVarKind tv ki)-    go env (AppTy ty1 ty2) = let (env1, ty1') = go env  ty1-                                 (env2, ty2') = go env1 ty2 in-                             (env2, AppTy ty1' ty2')-    go env (TyConApp tc tys)-         -- NB: Don't just check if isFamilyTyCon: this catches *data* families,-         -- which are generative and thus can be preserved during flattening-      | not (isGenerativeTyCon tc Nominal)-      = coreFlattenTyFamApp subst env tc tys--      | otherwise-      = let (env', tys') = coreFlattenTys subst env tys in-        (env', mkTyConApp tc tys')--    go env ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 })-      = let (env1, ty1') = go env  ty1-            (env2, ty2') = go env1 ty2-            (env3, mult') = go env2 mult in-        (env3, ty { ft_mult = mult', ft_arg = ty1', ft_res = ty2' })--    go env (ForAllTy (Bndr tv vis) ty)-      = let (env1, subst', tv') = coreFlattenVarBndr subst env tv-            (env2, ty') = coreFlattenTy subst' env1 ty in-        (env2, ForAllTy (Bndr tv' vis) ty')--    go env ty@(LitTy {}) = (env, ty)--    go env (CastTy ty co)-      = let (env1, ty') = go env ty-            (env2, co') = coreFlattenCo subst env1 co in-        (env2, CastTy ty' co')--    go env (CoercionTy co)-      = let (env', co') = coreFlattenCo subst env co in-        (env', CoercionTy co')----- when flattening, we don't care about the contents of coercions.--- so, just return a fresh variable of the right (flattened) type-coreFlattenCo :: TvSubstEnv -> FlattenEnv-              -> Coercion -> (FlattenEnv, Coercion)-coreFlattenCo subst env co-  = (env2, mkCoVarCo covar)-  where-    (env1, kind') = coreFlattenTy subst env (coercionType co)-    covar         = mkFlattenFreshCoVar (fe_in_scope env1) kind'-    -- Add the covar to the FlattenEnv's in-scope set.-    -- See Note [Flattening type-family applications when matching instances], wrinkle 2A.-    env2          = updateInScopeSet env1 (flip extendInScopeSet covar)--coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv-                   -> TyCoVar -> (FlattenEnv, TvSubstEnv, TyVar)-coreFlattenVarBndr subst env tv-  = (env2, subst', tv')-  where-    -- See Note [Flattening type-family applications when matching instances], wrinkle 2B.-    kind          = varType tv-    (env1, kind') = coreFlattenTy subst env kind-    tv'           = uniqAway (fe_in_scope env1) (setVarType tv kind')-    subst'        = extendVarEnv subst tv (mkTyVarTy tv')-    env2          = updateInScopeSet env1 (flip extendInScopeSet tv')--coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv-                    -> TyCon         -- type family tycon-                    -> [Type]        -- args, already flattened-                    -> (FlattenEnv, Type)-coreFlattenTyFamApp tv_subst env fam_tc fam_args-  = case lookupTypeMap type_map fam_ty of-      Just (tv, _, _) -> (env', mkAppTys (mkTyVarTy tv) leftover_args')-      Nothing ->-        let tyvar_name = mkFlattenFreshTyName fam_tc-            tv         = uniqAway in_scope $-                         mkTyVar tyvar_name (typeKind fam_ty)--            ty'   = mkAppTys (mkTyVarTy tv) leftover_args'-            env'' = env' { fe_type_map = extendTypeMap type_map fam_ty-                                                       (tv, fam_tc, sat_fam_args)-                         , fe_in_scope = extendInScopeSet in_scope tv }-        in (env'', ty')-  where-    arity = tyConArity fam_tc-    tcv_subst = Subst (fe_in_scope env) emptyIdSubstEnv tv_subst emptyVarEnv-    (sat_fam_args, leftover_args) = assert (arity <= length fam_args) $-                                    splitAt arity fam_args-    -- Apply the substitution before looking up an application in the-    -- environment. See Note [Flattening type-family applications when matching instances],-    -- wrinkle 1.-    -- NB: substTys short-cuts the common case when the substitution is empty.-    sat_fam_args' = substTys tcv_subst sat_fam_args-    (env', leftover_args') = coreFlattenTys tv_subst env leftover_args-    -- `fam_tc` may be over-applied to `fam_args` (see-    -- Note [Flattening type-family applications when matching instances]-    -- wrinkle 3), so we split it into the arguments needed to saturate it-    -- (sat_fam_args') and the rest (leftover_args')-    fam_ty = mkTyConApp fam_tc sat_fam_args'-    FlattenEnv { fe_type_map = type_map-               , fe_in_scope = in_scope } = env'--mkFlattenFreshTyName :: Uniquable a => a -> Name-mkFlattenFreshTyName unq-  = mkSysTvName (getUnique unq) (fsLit "flt")--mkFlattenFreshCoVar :: InScopeSet -> Kind -> CoVar-mkFlattenFreshCoVar in_scope kind-  = let uniq = unsafeGetFreshLocalUnique in_scope-        name = mkSystemVarName uniq (fsLit "flc")-    in mkCoVar name kind-+        tcUnifyTy, tcUnifyTys, tcUnifyFunDeps, tcUnifyDebugger,+        tcUnifyTysFG, tcUnifyTyForInjectivity,+        BindTvFun, BindFamFun, BindFlag(..),+        matchBindTv, alwaysBindTv, alwaysBindFam, dontCareBindFam,+        UnifyResult, UnifyResultM(..), MaybeApartReason(..),+        typesCantMatch, typesAreApart,++        -- Matching a type against a lifted type (coercion)+        liftCoMatch+   ) where++import GHC.Prelude++import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Builtin.Names( tYPETyConKey, cONSTRAINTTyConKey )+import GHC.Core.Type     hiding ( getTvSubstEnv )+import GHC.Core.Coercion hiding ( getCvSubstEnv )+import GHC.Core.Predicate( scopedSort )+import GHC.Core.TyCon+import GHC.Core.Predicate( CanEqLHS(..), canEqLHS_maybe )+import GHC.Core.TyCon.Env+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Compare ( eqType, tcEqType, tcEqTyConAppArgs )+import GHC.Core.TyCo.FVs     ( tyCoVarsOfCoList, tyCoFVsOfTypes )+import GHC.Core.TyCo.Subst   ( mkTvSubst )+import GHC.Core.Map.Type+import GHC.Core.Multiplicity++import GHC.Utils.FV( FV, fvVarList )+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Types.Basic( SwapFlag(..) )+import GHC.Types.Unique.FM+import GHC.Exts( oneShot )+import GHC.Utils.Panic++import GHC.Data.Pair+import GHC.Data.TrieMap+import GHC.Data.Maybe( orElse )++import Control.Monad+import qualified Data.Semigroup as S+import GHC.Builtin.Types.Prim (fUNTyCon)++{- Note [The Core unifier]+~~~~~~~~~~~~~~~~~~~~~~~~~~+This module contains the (pure) unifier two types.  It is subtle in a number+of ways.  Here we summarise, but see Note [Specification of unification].++(CU1) It creates a substition only for "bindable" or "template" type variables.+  These are identified by a `um_bind_tv_fun` function passed down in the `UMEnv`+  environment.++(CU2) We want to match in the presence of foralls;+        e.g     (forall a. t1) ~ (forall b. t2)+   That is what the `um_rn_env :: RnEnv2` field of `UMEnv` is for; it does the+   alpha-renaming that makes it as if `a` and `b` were the same variable.+   Initialising the `RnEnv2`, so that it can generate a fresh binder when+   necessary, entails knowing the free variables of both types.++   Of course, we must be careful not to bind a template type variable to a+   locally bound variable.  E.g.+        (forall a. x) ~ (forall b. b)+   where `x` is the template type variable.  Then we do not want to+   bind `x` to a/b!  See `mentionsForAllBoundTyVarsL/R`.++(CU3) We want to take special care for type families.+  See the big Note [Apartness and type families]++(CU4) Rather than returning just "unifiable" or "not-unifiable" we do "fine-grained"+  unification (hence "fg" or "FG" in this module) returning three possiblities,+  captured in `UnifyResult`:+    - Unifiable subst : certainly unifiable with this type substitution+    - SurelyApart     : cannot be unifiable, regardless of how type familes reduce+    - MaybeApart      : neither of the above+  See Note [Unification result].++  Four reasons for MaybeApart (see `MaybeApartReason`).  The first two are the+  big ones!+    * MARTypeFamily:+         Family reduction might make the two types equal+             Maybe (F Int) ~ Maybe Bool+         See Note [Apartness and type families]+    * MARInfinite (occurs check):+         See Note [Infinitary substitutions]+    * MARTypeVsConstraint:+         See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim+    * MARCast (obscure):+         See (KCU2) in Note [Kind coercions in Unify]++(CU5) We need to take care with kinds.  See Note [tcMatchTy vs tcMatchTyKi]++(CU6) The "unifier" can also do /matching/, governed by `um_unif :: AmIUnifying`.+   When matching, the LHS and RHS namespaces are unrelated. In particular, the+   bindable type variable can occur (unrelatedly) in the RHS.  E.g.+        match  (a,Maybe a) ~  ([a], Maybe [a])+   We get the substitution [a :-> [a]], without confusing the+   LHS `a` with the RHS `a`.  The substitition is "one-shot", and should not be+   iterated.++Note [Infinitary substitutions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" --+no substitution to finite types makes these match. This is the famous+"occurs check".++But, a substitution to *infinite* types can unify these two types:+  [x |-> [[...]]], y |-> [[[...]]] ].++Why do we care? Consider these two type family instances:++  type instance F x x   = Int+  type instance F [y] y = Bool++If we also have++  type instance Looper = [Looper]++then the instances potentially overlap -- they are not "apart". So we must+distinguish failure-to-unify from definitely-apart. The solution is to use+unification over infinite terms. This is possible (see [1] for lots of gory+details), but a full algorithm is a little more powerful than we need. Instead,+we make a conservative approximation and just omit the occurs check.++  [1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf++tcUnifyTys considers an occurs-check problem as the same as general unification+failure.++See also #8162.++It's worth noting that unification in the presence of infinite types is not+complete. This means that, sometimes, a closed type family does not reduce+when it should. See test case indexed-types/should_fail/Overlap15 for an+example.++Note [tcMatchTy vs tcMatchTyKi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This module offers two variants of matching: with kinds and without.+The TyKi variant takes two types, of potentially different kinds,+and matches them. Along the way, it necessarily also matches their+kinds. The Ty variant instead assumes that the kinds are already+eqType and so skips matching up the kinds.++How do you choose between them?++1. If you know that the kinds of the two types are eqType, use+   the Ty variant. It is more efficient, as it does less work.++2. If the kinds of variables in the template type might mention type families,+   use the Ty variant (and do other work to make sure the kinds+   work out). These pure unification functions do a straightforward+   syntactic unification and do no complex reasoning about type+   families. Note that the types of the variables in instances can indeed+   mention type families, so instance lookup must use the Ty variant.++   (Nothing goes terribly wrong -- no panics -- if there might be type+   families in kinds in the TyKi variant. You just might get match+   failure even though a reducing a type family would lead to success.)++3. Otherwise, if you're sure that the variable kinds do not mention+   type families and you're not already sure that the kind of the template+   equals the kind of the target, then use the TyKi version.++Note [Unification result]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See `UnifyResult` and `UnifyResultM`.  When unifying t1 ~ t2, we return+* Unifiable s, if s is a substitution such that s(t1) is syntactically the+  same as s(t2), modulo type-synonym expansion.+* SurelyApart, if there is no substitution s such that s(t1) = s(t2),+  where "=" includes type-family reductions.+* MaybeApart mar s, when we aren't sure. `mar` is a MaybeApartReason.++Examples+* [a] ~ Maybe b: SurelyApart, because [] and Maybe can't unify++* [(a,Int)] ~ [(Bool,b)]:  Unifiable++* [F Int] ~ [Bool]: MaybeApart MARTypeFamily, because F Int might reduce to Bool+                    (the unifier does not try this)++* a ~ Maybe a: MaybeApart MARInfinite. Not Unifiable clearly, but not SurelyApart+    either; consider+       a := Loop+       where  type family Loop where Loop = Maybe Loop++Wrinkle (UR1): see `combineMAR`+   There is the possibility that two types are MaybeApart for *both* reasons:++   * (a, F Int) ~ (Maybe a, Bool)++   What reason should we use? The *only* consumer of the reason is described+   in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv. The goal+   there is identify which instances might match a target later (but don't+   match now) -- except that we want to ignore the possibility of infinitary+   substitutions. So let's examine a concrete scenario:++     class C a b c+     instance C a (Maybe a) Bool+     -- other instances, including one that will actually match+     [W] C b b (F Int)++   Do we want the instance as a future possibility? No. The only way that+   instance can match is in the presence of an infinite type (infinitely nested+   Maybes). We thus say that `MARInfinite` takes precedence, so that InstEnv treats+   this case as an infinitary substitution case; the fact that a type family is+   involved is only incidental. We thus define `combineMAR` to prefer+   `MARInfinite`.++Note [Apartness and type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:++  type family F a b where+    F Int Bool = Char+    F a   b    = Double+  type family G a         -- open, no instances++How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't+match immediately while the second equation does. But, before reducing, we must+make sure that the target can never become (F Int Bool). Well, no matter what G+Float becomes, it certainly won't become *both* Int and Bool, so indeed we're+safe reducing (F (G Float) (G Float)) to Double.++So we must say that the argument list+     (G Float) (G Float)   is SurelyApart from   Int Bool++This is necessary not only to get more reductions (which we might be willing to+give up on), but for /substitutivity/. If we have (F x x), we can see that (F x x)+can reduce to Double. So, it had better be the case that (F blah blah) can+reduce to Double, no matter what (blah) is!++To achieve this, `go` in `uVarOrFam` does this;++* We maintain /two/ substitutions, not just one:+     * um_tv_env: the regular substitution, mapping TyVar :-> Type+     * um_fam_env: maps (TyCon,[Type]) :-> Type, where the LHS is a type-fam application+  In effect, these constitute one substitution mapping+     CanEqLHS :-> Types++* When we attempt to unify (G Float) ~ Int, we return MaybeApart..+  but we /also/ add a "family substitution" [G Float :-> Int],+  to `um_fam_env`. See the `BindMe` case of `go` in `uVarOrFam`.++* When we later encounter (G Float) ~ Bool, we apply the family substitution,+  very much as we apply the conventional [tyvar :-> type] substitution+  when we encounter a type variable.  See the `lookupFamEnv` in `go` in+  `uVarOrFam`.++  So (G Float ~ Bool) becomes (Int ~ Bool) which is SurelyApart.  Bingo.+++Wrinkles++(ATF0) Once we encounter a type-family application, we only ever return+             MaybeApart   or   SurelyApart+  but never `Unifiable`.  Accordingly, we only return a TyCoVar substitution+  from `tcUnifyTys` and friends; we don't return a type-family substitution as+  well.  (We could imagine doing so, though.)++(ATF1) Exactly the same mechanism is used in class-instance checking.+    If we have+        instance C (Maybe b)+        instance {-# OVERLAPPING #-} C (Maybe Bool)+        [W] C (Maybe (F a))+    we want to know that the second instance might match later, when we know more about `a`.+    The function `GHC.Core.InstEnv.instEnvMatchesAndUnifiers` uses `tcUnifyTysFG` to+    account for type families in the type being matched.++(ATF2) A very similar check is made in `GHC.Tc.Utils.Unify.mightEqualLater`, which+  again uses `tcUnifyTysFG` to account for the possibility of type families.  See+  Note [What might equal later?] in GHC.Tc.Utils.Unify, esp example (10).++(ATF3) What about foralls?   For example, supppose we are unifying+           (forall a. F a) -> (forall a. F a)+   against some other type. Those two (F a) types are unrelated, bound by+   different foralls; we cannot extend the um_fam_env with a binding [F a :-> blah]++   So to keep things simple, the entire family-substitution machinery is used+   only if there are no enclosing foralls (see the `under_forall` check in+   `uSatFamApp`).  That's fine, because the apartness business is used only for+   reducing type-family applications, and class instances, and their arguments+   can't have foralls anyway.++   The bottom line is that we won't discover that+       (forall a. (a, F Int, F Int))+   is surely apart from+       (forall a. (a, Int, Bool))+   but that doesn't matter.  Fixing this would be possible, but would require+   quite a bit of head-scratching.++(ATF4) The family substitution only has /saturated/ family applications in+   its domain. Consider the following concrete example from #16995:++     type family Param :: Type -> Type   -- arity 0++     type family LookupParam (a :: Type) :: Type where+       LookupParam (f Char) = Bool+       LookupParam x        = Int++     foo :: LookupParam (Param ())+     foo = 42++   In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to+   `Int`.  So    (f Char) ~ (Param ())   must be SurelyApart.  Remember, since+   `Param` is a nullary type family, it is over-saturated in (Param ()).+   This unification will only be SurelyApart if we decompose the outer AppTy+   separately, to then give (() ~ Char).++   Not only does this allow more programs to be accepted, it's also important+   for correctness. Not doing this was the root cause of the Core Lint error+   in #16995.++(ATF5) Consider+          instance (Generic1 f, Ord (Rep1 f a))+                => Ord (Generically1 f a) where ...+              -- The "..." gives rise to [W] Ord (Generically1 f a)+   where Rep1 is a type family.++   We must use the instance decl (recursively) to simplify the [W] constraint;+   we do /not/ want to worry that the `[G] Ord (Rep1 f a)` might be an+   alternative path.  So `noMatchableGivenDicts` must return False;+   so `mightMatchLater` must return False; so when um_bind_fam_fun returns+   `DontBindMe`, the unifier must return `SurelyApart`, not `MaybeApart`.  See+   `go` in `uVarOrFam`++   This looks a bit sketchy, because they aren't SurelyApart, but see+   Note [What might equal later?] in GHC.Tc.Utils.Unify, esp "Red Herring".++   If we are under a forall, we return `MaybeApart`; that seems more conservative,+   and class constraints are on tau-types so it doesn't matter.++(ATF6) When /matching/ can we ever have a type-family application on the LHS, in+   the template?  You might think not, because type-class-instance and+   type-family-instance heads can't include type families.  E.g.+            instance C (F a) where ...  -- Illegal++   But you'd be wrong: even when matching, we can see type families in the LHS template:+   * In `checkValidClass`, in `check_dm` we check that the default method has the+      right type, using matching, both ways.  And that type may have type-family+      applications in it. Examples in test CoOpt_Singletons and T26457.++   * In the specialiser: see the call to `tcMatchTy` in+     `GHC.Core.Opt.Specialise.beats_or_same`++   * With -fpolymorphic-specialisation, we might get a specialiation rule like+         RULE forall a (d :: Eq (Maybe (F a))) .+                 f @(Maybe (F a)) d = ...+     See #25965.++   * A user-written RULE could conceivably have a type-family application+     in the template.  It might not be a good rule, but I don't think we currently+     check for this.++    In all these cases we are only interested in finding a substitution /for+    type variables/ that makes the match work.  So we simply want to recurse into+    the arguments of the type family.  E.g.+       Template:   forall a.  Maybe (F a)+       Target:     Maybe (F Int)+    We want to succeed with substitution [a :-> Int].  See (ATF9).++    Conclusion: where we enter via `tcMatchTy`, `tcMatchTys`, `tc_match_tys`,+    etc, we always end up in `tc_match_tys_x`.  There we invoke the unifier+    but we do not distinguish between `SurelyApart` and `MaybeApart`. So in+    these cases we can set `um_bind_fam_fun` to `neverBindFam`.++(ATF7) There is one other, very special case of matching where we /do/ want to+   bind type families in `um_fam_env`, namely in GHC.Tc.Solver.Equality, the call+   to `tcUnifyTyForInjectivity False` in `improve_injective_wanted_top`.+   Consider+   of a match. Consider+      type family G6 a = r | r -> a+      type instance G6 [a]  = [G a]+      type instance G6 Bool = Int+   and suppose we have a Wanted constraint+      [W] G6 alpha ~ [Int]+   According to Section 5.2 of "Injective type families for Haskell", we /match/+   the RHS each of type instance with [Int].  So we try+        Template: [G a]    Target: [Int]+   and we want to succeed with MaybeApart, so that we can generate the improvement+   constraint+        [W] alpha ~ [beta]+   where beta is fresh.  We do this by binding [G a :-> Int]++(ATF8) The treatment of type families is governed by+         um_bind_fam_fun :: BindFamFun+  in UMEnv, where+         type BindFamFun = TyCon -> [Type] -> Type -> BindFlag+  There are some simple BindFamFun functions provided:+     alwaysBindFam    do the clever stuff above+     neverBindFam     treat type families as SurelyApart+     dontCareBindFam  type families shouldn't exist at all+  This function only affects the difference between the results MaybeApart and+  SurelyApart; it never does not affect whether or not we return Unifiable.++(ATF9) Decomposition.  Consider unifying+          F a  ~  F Int+  when `um_bind_fam_fun` says DontBindMe.  There is a unifying substitition [a :-> Int],+  and we want to find it, returning Unifiable. Why?+    - Remember, this is the Core unifier -- we are not doing type inference+    - When we have two equal types, like  F a ~ F a, it is ridiculous to say that they+      are MaybeApart.  Example: the two-way tcMatchTy in `checkValidClass` and #26457.++  (ATF9-1) But consider unifying+          F Int ~ F Bool+    Although Int and Bool are SurelyApart, we must return MaybeApart for the outer+    unification.  Hence the use of `don'tBeSoSure` in `go_fam_fam`; it leaves Unifiable+    alone, but weakens `SurelyApart` to `MaybeApart`.++  (ATF9-2) We want this decomposition to occur even under a forall (this was #26457).+    E.g.    (forall a. F Int) -> Int  ~   (forall a. F Int) ~ Int+++(ATF10) Injectivity.  Consider (AFT9) where F is known to be injective.  Then if we+  are unifying+          F Int ~ F Bool+  we /can/ say SurelyApart.  See the inj/noninj stuff in `go_fam_fam`.++(ATF11) Consider unifying+          [F Int, F Int, F Bool]  ~  [F Bool, Char, Double]+  We find (F Int ~ F Bool), so we can decompose.  But we /also/ want to remember+  the substitution [F Int :-> F Bool].  Then from (F Int ~ Char) we get the+  substitution [F Bool :-> Char].  And that flat-out contradicts (F Bool ~ Double)+  so we should get SurelyApart.++  Key point: when decomposing (F tys1 ~ F tys2), we should /also/ extend the+  type-family substitution.++  (ATF11-1) All this cleverness only matters when unifying, not when matching++(ATF12) There is a horrid exception for the injectivity check. See (UR1) in+  in Note [Specification of unification].++(ATF13) We have to be careful about the occurs check.+  See Note [The occurs check in the Core unifier]++SIDE NOTE.  The paper "Closed type families with overlapping equations"+http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf+tries to achieve the same effect with a standard yes/no unifier, by "flattening"+the types (replacing each type-family application with a fresh type variable)+and then unifying.  But that does not work well. Consider (#25657)++    type MyEq :: k -> k -> Bool+    type family MyEq a b where+       MyEq a a = 'True+       MyEq _ _ = 'False++    type Var :: forall {k}. Tag -> k+    type family Var tag = a | a -> tag++Then, because Var is injective, we want+     MyEq (Var A) (Var B) --> False+     MyEq (Var A) (Var A) --> True++But if we flattten the types (Var A) and (Var B) we'll just get fresh type variables,+and all is lost.  But with the current algorithm we have that+    a a   ~    (Var A) (Var B)+is SurelyApart, so the first equation definitely doesn't match and we can try the+second, which does.  END OF SIDE NOTE.++Note [Shortcomings of the apartness test]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Apartness and type families] is very clever.++But it still has shortcomings (#26358).  Consider unifying+    [F a, F Int, Int]  ~  [Bool, Char, a]+Working left to right you might think we would build the mapping+  F a   :-> Bool+  F Int :-> Char+Now we discover that `a` unifies with `Int`. So really these two lists are Apart+because F Int can't be both Bool and Char.++Just the same applies when adding a type-family binding to um_fam_env:+  [F (G Float), F Int, G Float] ~ [Bool, Char, Iont]+Again these are Apart, because (G Float = Int),+and (F Int) can't be both Bool and Char++But achieving this is very tricky! Perhaps whenever we unify a type variable,+or a type family, we should run it over the domain and (maybe range) of the+type-family mapping too?  Sigh.++For now we make no such attempt.+* The um_fam_env has only /un-substituted/ types.+* We look up only /un-substituted/ types in um_fam_env++This may make us say MaybeApart when we could say SurelyApart, but it has no+effect on the correctness of unification: if we return Unifiable, it really is+Unifiable.++This is all quite subtle. suppose we have:+    um_tv_env:   c :-> b+    um_fam_env   F b :-> a+and we are trying to add a :-> F c. We will call lookupFamEnv on (F, [c]), which will+fail because b and c are not equal. So we go ahead and add a :-> F c as a new tyvar eq,+getting:+    um_tv_env:   a :-> F c, c :-> b+    um_fam_env   F b :-> a++Does that loop, like this:+   a --> F c --> F b --> a?+No, because we do not substitute (F c) to (F b) and then look up in um_fam_env;+we look up only un-substituted types.+-}++{- *********************************************************************+*                                                                      *+                Binding decisions+*                                                                      *+********************************************************************* -}++data BindFlag+  = BindMe      -- ^ A bindable type variable++  | DontBindMe  -- ^ Do not bind this type variable is /apart/+                -- See also Note [Super skolems: binding when looking up instances]+                -- in GHC.Core.InstEnv.+  deriving Eq++-- | Some unification functions are parameterised by a 'BindTvFun', which+-- says whether or not to allow a certain unification to take place.+-- A 'BindTvFun' takes the 'TyVar' involved along with the 'Type' it will+-- potentially be bound to.+--+-- It is possible for the variable to actually be a coercion variable+-- (Note [Matching coercion variables]), but only when one-way matching.+-- In this case, the 'Type' will be a 'CoercionTy'.+type BindTvFun = TyCoVar -> Type -> BindFlag++-- | BindFamFun is similiar to BindTvFun, but deals with a saturated+-- type-family application.  See Note [Apartness and type families].+type BindFamFun = TyCon -> [Type] -> Type -> BindFlag++-- | Allow binding only for any variable in the set. Variables may+-- be bound to any type.+-- Used when doing simple matching; e.g. can we find a substitution+--+-- @+-- S = [a :-> t1, b :-> t2] such that+--     S( Maybe (a, b->Int )  =   Maybe (Bool, Char -> Int)+-- @+matchBindTv :: TyCoVarSet -> BindTvFun+matchBindTv tvs tv _ty+  | tv `elemVarSet` tvs = BindMe+  | otherwise           = DontBindMe++-- | Allow the binding of any variable to any type+alwaysBindTv :: BindTvFun+alwaysBindTv _tv _ty = BindMe++-- | Allow the binding of a type-family application to any type+alwaysBindFam :: BindFamFun+-- See (ATF8) in Note [Apartness and type families]+alwaysBindFam _tc _args _rhs = BindMe++dontCareBindFam :: HasCallStack => BindFamFun+-- See (ATF8) in Note [Apartness and type families]+dontCareBindFam tc args rhs+  = pprPanic "dontCareBindFam" $+    vcat [ ppr tc <+> ppr args, text "rhs" <+> ppr rhs ]++-- | Don't allow the binding of a type-family application at all+neverBindFam :: BindFamFun+-- See (ATF8) in Note [Apartness and type families]+neverBindFam _tc _args _rhs = DontBindMe+++{- *********************************************************************+*                                                                      *+                Various wrappers for matching+*                                                                      *+********************************************************************* -}++-- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1))+-- @s@ such that @s(t1)@ equals @t2@.+-- The returned substitution might bind coercion variables,+-- if the variable is an argument to a GADT constructor.+--+-- Precondition: typeKind ty1 `eqType` typeKind ty2+--+-- We don't pass in a set of "template variables" to be bound+-- by the match, because tcMatchTy (and similar functions) are+-- always used on top-level types, so we can bind any of the+-- free variables of the LHS.+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTy :: HasDebugCallStack => Type -> Type -> Maybe Subst+tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2]++tcMatchTyX_BM :: HasDebugCallStack+              => BindTvFun -> Subst+              -> Type -> Type -> Maybe Subst+tcMatchTyX_BM bind_tv subst ty1 ty2+  = tc_match_tys_x bind_tv False subst [ty1] [ty2]++-- | Like 'tcMatchTy', but allows the kinds of the types to differ,+-- and thus matches them as well.+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTyKi :: HasDebugCallStack => Type -> Type -> Maybe Subst+tcMatchTyKi ty1 ty2+  = tc_match_tys alwaysBindTv True [ty1] [ty2]++-- | This is similar to 'tcMatchTy', but extends a substitution+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTyX :: HasDebugCallStack+           => Subst               -- ^ Substitution to extend+           -> Type                -- ^ Template+           -> Type                -- ^ Target+           -> Maybe Subst+tcMatchTyX subst ty1 ty2+  = tc_match_tys_x alwaysBindTv False subst [ty1] [ty2]++-- | Like 'tcMatchTy' but over a list of types.+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTys :: HasDebugCallStack+           => [Type]         -- ^ Template+           -> [Type]         -- ^ Target+           -> Maybe Subst    -- ^ One-shot; in principle the template+                             -- variables could be free in the target+                             -- See (CU6) in Note [The Core unifier]+tcMatchTys tys1 tys2+  = tc_match_tys alwaysBindTv False tys1 tys2++-- | Like 'tcMatchTyKi' but over a list of types.+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTyKis :: HasDebugCallStack+             => [Type]         -- ^ Template+             -> [Type]         -- ^ Target+             -> Maybe Subst    -- ^ One-shot substitution+                               -- See (CU6) in Note [The Core unifier]+tcMatchTyKis tys1 tys2+  = tc_match_tys alwaysBindTv True tys1 tys2++-- | Like 'tcMatchTys', but extending a substitution+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTysX :: HasDebugCallStack+            => Subst          -- ^ Substitution to extend+            -> [Type]         -- ^ Template+            -> [Type]         -- ^ Target+            -> Maybe Subst    -- ^ One-shot substitution+tcMatchTysX subst tys1 tys2+  = tc_match_tys_x alwaysBindTv False subst tys1 tys2++-- | Like 'tcMatchTyKis', but extending a substitution+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTyKisX :: HasDebugCallStack+              => Subst        -- ^ Substitution to extend+              -> [Type]       -- ^ Template+              -> [Type]       -- ^ Target+              -> Maybe Subst  -- ^ One-shot substitution+tcMatchTyKisX subst tys1 tys2+  = tc_match_tys_x alwaysBindTv True subst tys1 tys2++-- | Same as tc_match_tys_x, but starts with an empty substitution+tc_match_tys :: HasDebugCallStack+             => BindTvFun+             -> Bool          -- ^ match kinds?+             -> [Type]+             -> [Type]+             -> Maybe Subst+tc_match_tys bind_me match_kis tys1 tys2+  = tc_match_tys_x bind_me match_kis (mkEmptySubst in_scope) tys1 tys2+  where+    in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2)++-- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX'+tc_match_tys_x :: HasDebugCallStack+               => BindTvFun+               -> Bool          -- ^ match kinds?+               -> Subst+               -> [Type]+               -> [Type]+               -> Maybe Subst+tc_match_tys_x bind_tv match_kis (Subst in_scope id_env tv_env cv_env) tys1 tys2+  = case tc_unify_tys neverBindFam  -- (ATF7) in Note [Apartness and type families]+                      bind_tv+                      False  -- Matching, not unifying+                      False  -- Not an injectivity check+                      match_kis+                      RespectMultiplicities+                      (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of+      Unifiable (tv_env', cv_env')+        -> Just $ Subst in_scope id_env tv_env' cv_env'+      _ -> Nothing++-- | This one is called from the expression matcher,+-- which already has a MatchEnv in hand+ruleMatchTyKiX+  :: TyCoVarSet          -- ^ template variables+  -> RnEnv2+  -> TvSubstEnv          -- ^ type substitution to extend+  -> Type                -- ^ Template+  -> Type                -- ^ Target+  -> Maybe TvSubstEnv+ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target+-- See Note [Kind coercions in Unify]+  = case tc_unify_tys neverBindFam (matchBindTv tmpl_tvs)+      -- neverBindFam: a type family probably shouldn't appear+      -- on the LHS of a RULE, although we don't currently prevent it.+      -- But even if it did, (ATF8) in Note [Apartness and type families]+      -- says it doesn't matter becuase here we only care about Unifiable.+      -- So neverBindFam is efficient, and sufficient.+                      False    -- Matching, not unifying+                      False    -- No doing an injectivity check+                      True     -- Match the kinds+                      IgnoreMultiplicities+                        -- See Note [Rewrite rules ignore multiplicities in FunTy]+                      rn_env tenv emptyCvSubstEnv [tmpl] [target] of+      Unifiable (tenv', _) -> Just tenv'+      _                    -> Nothing++{-+************************************************************************+*                                                                      *+                GADTs+*                                                                      *+************************************************************************++Note [Pruning dead case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider        data T a where+                   T1 :: T Int+                   T2 :: T a++                newtype X = MkX Int+                newtype Y = MkY Char++                type family F a+                type instance F Bool = Int++Now consider    case x of { T1 -> e1; T2 -> e2 }++The question before the house is this: if I know something about the type+of x, can I prune away the T1 alternative?++Suppose x::T Char.  It's impossible to construct a (T Char) using T1,+        Answer = YES we can prune the T1 branch (clearly)++Suppose x::T (F a), where 'a' is in scope.  Then 'a' might be instantiated+to 'Bool', in which case x::T Int, so+        ANSWER = NO (clearly)++We see here that we want precisely the apartness check implemented within+tcUnifyTysFG. So that's what we do! Two types cannot match if they are surely+apart. Note that since we are simply dropping dead code, a conservative test+suffices.+-}++-- | Given a list of pairs of types, are any two members of a pair surely+-- apart, even after arbitrary type function evaluation and substitution?+typesCantMatch :: [(Type,Type)] -> Bool+-- See Note [Pruning dead case alternatives]+typesCantMatch prs = any (uncurry typesAreApart) prs++typesAreApart :: Type -> Type -> Bool+typesAreApart t1 t2 = case tcUnifyTysFG alwaysBindFam alwaysBindTv [t1] [t2] of+                        SurelyApart -> True+                        _           -> False+{-+************************************************************************+*                                                                      *+             Various wrappers for unification+*                                                                      *+********************************************************************* -}++-- | Simple unification of two types; all type variables are bindable+-- Precondition: the kinds are already equal+tcUnifyTy :: Type -> Type       -- All tyvars are bindable+          -> Maybe Subst+                       -- A regular one-shot (idempotent) substitution+tcUnifyTy t1 t2 = tcUnifyTys alwaysBindTv [t1] [t2]++tcUnifyDebugger :: Type -> Type -> Maybe Subst+tcUnifyDebugger t1 t2+  = case tc_unify_tys_fg+             True            -- Unify kinds+             neverBindFam    -- Does not affect Unifiable, so pick max efficient+                             -- See (ATF8) in Note [Apartness and type families]+             alwaysBindTv+             [t1] [t2] of+      Unifiable subst -> Just subst+      _               -> Nothing++-- | Like 'tcUnifyTys' but also unifies the kinds+tcUnifyFunDeps :: TyCoVarSet+               -> [Type] -> [Type]+               -> Maybe Subst+tcUnifyFunDeps qtvs tys1 tys2+  = case tc_unify_tys_fg+             True               -- Unify kinds+             dontCareBindFam    -- Class-instance heads never mention type families+             (matchBindTv qtvs)+             tys1 tys2 of+      Unifiable subst -> Just subst+      _               -> Nothing++-- | Unify or match a type-family RHS with a type (possibly another type-family RHS)+-- Precondition: kinds are the same+tcUnifyTyForInjectivity+    :: AmIUnifying  -- ^ True <=> do two-way unification;+                    --   False <=> do one-way matching.+                    --   See end of sec 5.2 from the paper+    -> InScopeSet     -- Should include the free tyvars of both Type args+    -> Type -> Type   -- Types to unify+    -> Maybe Subst+-- This algorithm is an implementation of the "Algorithm U" presented in+-- the paper "Injective type families for Haskell", Figures 2 and 3.+-- The code is incorporated with the standard unifier for convenience, but+-- its operation should match the specification in the paper.+tcUnifyTyForInjectivity unif in_scope t1 t2+  = case tc_unify_tys alwaysBindFam alwaysBindTv+                       unif   -- Am I unifying?+                       True   -- Do injectivity checks+                       False  -- Don't check outermost kinds+                       RespectMultiplicities+                       rn_env emptyTvSubstEnv emptyCvSubstEnv+                       [t1] [t2] of+      Unifiable          (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst+      MaybeApart _reason (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst+                 -- We want to *succeed* in questionable cases.+                 -- This is a pre-unification algorithm.+      SurelyApart      -> Nothing+  where+    rn_env   = mkRnEnv2 in_scope++    maybe_fix | unif      = niFixSubst in_scope+              | otherwise = mkTvSubst in_scope -- when matching, don't confuse+                                               -- domain with range++-----------------+tcUnifyTys :: BindTvFun+           -> [Type] -> [Type]+           -> Maybe Subst+                                -- ^ A regular one-shot (idempotent) substitution+                                -- that unifies the erased types. See comments+                                -- for 'tcUnifyTysFG'++-- The two types may have common type variables, and indeed do so in the+-- second call to tcUnifyTys in GHC.Tc.Instance.FunDeps.checkClsFD+tcUnifyTys bind_fn tys1 tys2+  = case tcUnifyTysFG neverBindFam bind_fn tys1 tys2 of+      Unifiable result -> Just result+      _                -> Nothing++-- | (tcUnifyTysFG bind_fam bind_tv tys1 tys2) does "fine-grain" unification+-- of tys1 and tys2, under the control of `bind_fam` and `bind_tv`.+-- This version requires that the kinds of the types are the same,+-- if you unify left-to-right.+-- See Note [The Core unifier]+tcUnifyTysFG :: BindFamFun -> BindTvFun+             -> [Type] -> [Type]+             -> UnifyResult+tcUnifyTysFG bind_fam bind_tv tys1 tys2+  = tc_unify_tys_fg False bind_fam bind_tv tys1 tys2++tc_unify_tys_fg :: Bool+                -> BindFamFun -> BindTvFun+                -> [Type] -> [Type]+                -> UnifyResult+tc_unify_tys_fg match_kis bind_fam bind_tv tys1 tys2+  = do { (tv_env, _) <- tc_unify_tys bind_fam bind_tv+                                  True       -- Unifying+                                  False      -- Not doing an injectivity check+                                  match_kis  -- Match outer kinds+                                  RespectMultiplicities rn_env+                                  emptyTvSubstEnv emptyCvSubstEnv+                                  tys1 tys2+       ; return $ niFixSubst in_scope tv_env }+  where+    in_scope = mkInScopeSet $ tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2+    rn_env   = mkRnEnv2 in_scope++-- | This function is actually the one to call the unifier -- a little+-- too general for outside clients, though.+tc_unify_tys :: BindFamFun -> BindTvFun+             -> AmIUnifying -- ^ True <=> unify; False <=> match+             -> Bool        -- ^ True <=> doing an injectivity check+             -> Bool        -- ^ True <=> treat the kinds as well+             -> MultiplicityFlag -- ^ see Note [Rewrite rules ignore multiplicities in FunTy] in GHC.Core.Unify+             -> RnEnv2+             -> TvSubstEnv  -- ^ substitution to extend+             -> CvSubstEnv+             -> [Type] -> [Type]+             -> UnifyResultM (TvSubstEnv, CvSubstEnv)+-- NB: It's tempting to ASSERT here that, if we're not matching kinds, then+-- the kinds of the types should be the same. However, this doesn't work,+-- as the types may be a dependent telescope, where later types have kinds+-- that mention variables occurring earlier in the list of types. Here's an+-- example (from typecheck/should_fail/T12709):+--   template: [rep :: RuntimeRep,       a :: TYPE rep]+--   target:   [LiftedRep :: RuntimeRep, Int :: TYPE LiftedRep]+-- We can see that matching the first pair will make the kinds of the second+-- pair equal. Yet, we still don't need a separate pass to unify the kinds+-- of these types, so it's appropriate to use the Ty variant of unification.+-- See also Note [tcMatchTy vs tcMatchTyKi].+tc_unify_tys bind_fam bind_tv unif inj_check match_kis match_mults rn_env tv_env cv_env tys1 tys2+  = initUM tv_env cv_env $+    do { when match_kis $+         unify_tys env kis1 kis2+       ; unify_tys env tys1 tys2 }+  where+    env = UMEnv { um_bind_tv_fun  = bind_tv+                , um_bind_fam_fun = bind_fam+                , um_foralls      = emptyVarSet+                , um_unif         = unif+                , um_inj_tf       = inj_check+                , um_arr_mult     = match_mults+                , um_rn_env       = rn_env }++    kis1 = map typeKind tys1+    kis2 = map typeKind tys2+++{- *********************************************************************+*                                                                      *+                UnifyResult, MaybeApart etc+*                                                                      *+********************************************************************* -}++{- Note [Rewrite rules ignore multiplicities in FunTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following (higher-order) rule:++m :: Bool -> Bool -> Bool+{-# RULES "m" forall f. m (f True) = f #-}++let x = m ((,) @Bool @Bool True True)++The rewrite rule expects an `f :: Bool -> Bool`, but `(,) @Bool @Bool True ::+Bool %1 -> Bool` is linear (see Note [Data constructors are linear by default]+in GHC.Core.Multiplicity) Should the rule match? Yes! According to the+principles laid out in Note [Linting linearity] in GHC.Core.Lint, optimisation+shouldn't be constrained by linearity.++However, when matching the template variable `f` to `(,) True`, we do check that+their types unify (see Note [Matching variable types] in GHC.Core.Rules). So+when unifying types for the sake of rule-matching, the unification algorithm+must be able to ignore multiplicities altogether.++How is this done?+  (1) The `um_arr_mult` field of `UMEnv` recordsw when we are doing rule-matching,+      and hence want to ignore multiplicities.+  (2) The field is set to True in by `ruleMatchTyKiX`.+  (3) It is consulted when matching `FunTy` in `unify_ty`.++Wrinkle in (3). In `unify_tc_app`, in `unify_ty`, `FunTy` is handled as if it+was a regular type constructor. In this case, and when the types being unified+are *function* arrows, but not constraint arrows, then the first argument is a+multiplicity.++We select this situation by comparing the type constructor with fUNTyCon. In+this case, and this case only, we can safely drop the first argument (using the+tail function) and unify the rest.++Note [The substitution in MaybeApart]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why?+Because consider unifying these:++(a, a, Int) ~ (b, [b], Bool)++If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we+apply the subst we have so far and discover that we need [b |-> [b]]. Because+this fails the occurs check, we say that the types are MaybeApart (see above+Note [Infinitary substitutions]). But, we can't stop there! Because if we+continue, we discover that Int is SurelyApart from Bool, and therefore the+types are apart. This has practical consequences for the ability for closed+type family applications to reduce. See test case+indexed-types/should_compile/Overlap14.+-}++-- This type does double-duty. It is used in the UM (unifier monad) and to+-- return the final result. See Note [Unification result]+type UnifyResult = UnifyResultM Subst++-- | See Note [Unification result]+data UnifyResultM a = Unifiable a        -- the subst that unifies the types+                    | MaybeApart MaybeApartReason+                                 a       -- the subst has as much as we know+                                         -- it must be part of a most general unifier+                                         -- See Note [The substitution in MaybeApart]+                    | SurelyApart+                    deriving Functor++-- | Why are two types 'MaybeApart'? 'MARInfinite' takes precedence:+-- This is used (only) in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv+-- As of Feb 2022, we never differentiate between MARTypeFamily and MARTypeVsConstraint;+-- it's really only MARInfinite that's interesting here.+data MaybeApartReason+  = MARTypeFamily   -- ^ matching e.g. F Int ~? Bool++  | MARInfinite     -- ^ matching e.g. a ~? Maybe a++  | MARTypeVsConstraint  -- ^ matching Type ~? Constraint or the arrow types+    -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim++  | MARCast         -- ^ Very obscure.+    -- See (KCU2) in Note [Kind coercions in Unify]+++combineMAR :: MaybeApartReason -> MaybeApartReason -> MaybeApartReason+-- See (UR1) in Note [Unification result] for why MARInfinite wins+combineMAR MARInfinite         _ = MARInfinite   -- MARInfinite wins+combineMAR MARTypeFamily       r = r             -- Otherwise it doesn't really matter+combineMAR MARTypeVsConstraint r = r+combineMAR MARCast             r = r++instance Outputable MaybeApartReason where+  ppr MARTypeFamily       = text "MARTypeFamily"+  ppr MARInfinite         = text "MARInfinite"+  ppr MARTypeVsConstraint = text "MARTypeVsConstraint"+  ppr MARCast             = text "MARCast"++instance Semigroup MaybeApartReason where+  (<>) = combineMAR++instance Applicative UnifyResultM where+  pure  = Unifiable+  (<*>) = ap++instance Monad UnifyResultM where+  SurelyApart  >>= _ = SurelyApart+  MaybeApart r1 x >>= f = case f x of+                            Unifiable y     -> MaybeApart r1 y+                            MaybeApart r2 y -> MaybeApart (r1 S.<> r2) y+                            SurelyApart     -> SurelyApart+  Unifiable x  >>= f = f x++instance Outputable a => Outputable (UnifyResultM a) where+  ppr SurelyApart      = text "SurelyApart"+  ppr (Unifiable x)    = text "Unifiable" <+> ppr x+  ppr (MaybeApart r x) = text "MaybeApart" <+> ppr r <+> ppr x++{-+************************************************************************+*                                                                      *+                Non-idempotent substitution+*                                                                      *+************************************************************************++Note [Non-idempotent substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During unification we use a TvSubstEnv/CvSubstEnv pair that is+  (a) non-idempotent+  (b) loop-free; ie repeatedly applying it yields a fixed point++Note [Finding the substitution fixpoint]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Finding the fixpoint of a non-idempotent substitution arising from a+unification is much trickier than it looks, because of kinds.  Consider+   T k (H k (f:k)) ~ T * (g:*)+If we unify, we get the substitution+   [ k -> *+   , g -> H k (f:k) ]+To make it idempotent we don't want to get just+   [ k -> *+   , g -> H * (f:k) ]+We also want to substitute inside f's kind, to get+   [ k -> *+   , g -> H k (f:*) ]+If we don't do this, we may apply the substitution to something,+and get an ill-formed type, i.e. one where typeKind will fail.+This happened, for example, in #9106.++It gets worse.  In #14164 we wanted to take the fixpoint of+this substitution+   [ xs_asV :-> F a_aY6 (z_aY7 :: a_aY6)+                        (rest_aWF :: G a_aY6 (z_aY7 :: a_aY6))+   , a_aY6  :-> a_aXQ ]++We have to apply the substitution for a_aY6 two levels deep inside+the invocation of F!  We don't have a function that recursively+applies substitutions inside the kinds of variable occurrences (and+probably rightly so).++So, we work as follows:++ 1. Start with the current substitution (which we are+    trying to fixpoint+       [ xs :-> F a (z :: a) (rest :: G a (z :: a))+       , a  :-> b ]++ 2. Take all the free vars of the range of the substitution:+       {a, z, rest, b}+    NB: the free variable finder closes over+    the kinds of variable occurrences++ 3. If none are in the domain of the substitution, stop.+    We have found a fixpoint.++ 4. Remove the variables that are bound by the substitution, leaving+       {z, rest, b}++ 5. Do a topo-sort to put them in dependency order:+       [ b :: *, z :: a, rest :: G a z ]++ 6. Apply the substitution left-to-right to the kinds of these+    tyvars, extending it each time with a new binding, so we+    finish up with+       [ xs   :-> ..as before..+       , a    :-> b+       , b    :-> b    :: *+       , z    :-> z    :: b+       , rest :-> rest :: G b (z :: b) ]+    Note that rest now has the right kind++ 7. Apply this extended substitution (once) to the range of+    the /original/ substitution.  (Note that we do the+    extended substitution would go on forever if you tried+    to find its fixpoint, because it maps z to z.)++ 8. And go back to step 1++In Step 6 we use the free vars from Step 2 as the initial+in-scope set, because all of those variables appear in the+range of the substitution, so they must all be in the in-scope+set.  But NB that the type substitution engine does not look up+variables in the in-scope set; it is used only to ensure no+shadowing.+-}++niFixSubst :: InScopeSet -> TvSubstEnv -> Subst+-- Find the idempotent fixed point of the non-idempotent substitution+-- This is surprisingly tricky:+--   see Note [Finding the substitution fixpoint]+-- ToDo: use laziness instead of iteration?+niFixSubst in_scope tenv+  | not_fixpoint = niFixSubst in_scope (mapVarEnv (substTy subst) tenv)+  | otherwise    = subst+  where+    range_fvs :: FV+    range_fvs = tyCoFVsOfTypes (nonDetEltsUFM tenv)+          -- It's OK to use nonDetEltsUFM here because the+          -- order of range_fvs, range_tvs is immaterial++    range_tvs :: [TyVar]+    range_tvs = fvVarList range_fvs++    not_fixpoint  = any in_domain range_tvs+    in_domain tv  = tv `elemVarEnv` tenv++    free_tvs = scopedSort (filterOut in_domain range_tvs)++    -- See Note [Finding the substitution fixpoint], Step 6+    subst = foldl' add_free_tv+                  (mkTvSubst in_scope tenv)+                  free_tvs++    add_free_tv :: Subst -> TyVar -> Subst+    add_free_tv subst tv+      = extendTvSubst subst tv (mkTyVarTy tv')+     where+        tv' = updateTyVarKind (substTy subst) tv++{-+************************************************************************+*                                                                      *+                unify_ty: the main workhorse+*                                                                      *+************************************************************************++Note [Specification of unification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The pure unifier, unify_ty, defined in this module, tries to work out+a substitution to make two types say True to eqType. NB: eqType is+itself not purely syntactic; it accounts for CastTys;+see Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep++Unlike the "impure unifiers" in the typechecker (the eager unifier in+GHC.Tc.Utils.Unify, and the constraint solver itself in GHC.Tc.Solver.Equality),+the pure unifier does /not/ work up to ~.++The algorithm implemented here is rather delicate, and we depend on it+to uphold certain properties. This is a summary of these required+properties.++Notation:+ θ,φ  substitutions+ ξ    type-function-free types+ τ,σ  other types+ τ♭   type τ, flattened++ ≡    eqType++(U1) Soundness.+     If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂).+     θ is a most general unifier for τ₁ and τ₂.++(U2) Completeness.+     If (unify ξ₁ ξ₂) = SurelyApart,+     then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂).++These two properties are stated as Property 11 in the "Closed Type Families"+paper (POPL'14). Below, this paper is called [CTF].++(U3) Apartness under substitution.+     If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart,+     for any θ. (Property 12 from [CTF])++(U4) Apart types do not unify.+     If (unify ξ τ♭) = SurelyApart, then there exists no θ+     such that θ(ξ) = θ(τ). (Property 13 from [CTF])++THEOREM. Completeness w.r.t ~+    If (unify τ₁♭ τ₂♭) = SurelyApart,+    then there exists no proof that (τ₁ ~ τ₂).++PROOF. See appendix of [CTF].+++The unification algorithm is used for type family injectivity, as described+in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run+in this mode, it has the following properties.++(I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even+     after arbitrary type family reductions.++(I2) If (unify σ τ) = MaybeApart θ, and if some+     φ exists such that φ(σ) ~ φ(τ), then φ extends θ.+++Furthermore, the RULES matching algorithm requires this property,+but only when using this algorithm for matching:++(M1) If (match σ τ) succeeds with θ, then all matchable tyvars+     in σ are bound in θ.++     Property M1 means that we must extend the substitution with,+     say (a ↦ a) when appropriate during matching.+     See also Note [Self-substitution when unifying or matching].++(M2) Completeness of matching.+     If θ(σ) = τ, then (match σ τ) = Unifiable φ,+     where θ is an extension of φ.++Wrinkle (SI1): um_inj_tf:+    Sadly, property M2 and I2 conflict. Consider++    type family F1 a b where+      F1 Int    Bool   = Char+      F1 Double String = Char++    Consider now two matching problems:++    P1. match (F1 a Bool) (F1 Int Bool)+    P2. match (F1 a Bool) (F1 Double String)++    In case P1, we must find (a ↦ Int) to satisfy M2.  In case P2, we must /not/+    find (a ↦ Double), in order to satisfy I2. (Note that the correct mapping for+    I2 is (a ↦ Int). There is no way to discover this, but we mustn't map a to+    anything else!)++    We thus must parameterize the algorithm over whether it's being used+    for an injectivity check (refrain from looking at non-injective arguments+    to type families) or not (do indeed look at those arguments).  This is+    implemented  by the um_inj_tf field of UMEnv.++    (It's all a question of whether or not to include equation (7) from Fig. 2+    of [ITF].)++    This extra parameter is a bit fiddly, perhaps, but seemingly less so than+    having two separate, almost-identical algorithms.++Note [Self-substitution when unifying or matching]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What happens when we are unifying or matching two identical type variables?+     a ~ a++* When /unifying/, just succeed, without binding [a :-> a] in the substitution,+  else we'd get an infinite substitution.  We need to make this check before+  we do the occurs check, of course.++* When /matching/, and `a` is a bindable variable from the template, we /do/+  want to extend the substitution.  Remember, a successful match should map all+  the template variables (except ones that disappear when expanding synonyms),++  But when `a` is /not/ a bindable variable (perhaps it is a globally-in-scope+  skolem) we want to treat it like a constant `Int ~ Int` and succeed.++  Notice: no occurs check!  It's fine to match (a ~ Maybe a), because the+  template vars of the template come from a different name space to the free+  vars of the target.++  Note that this arrangement was provoked by a real failure, where the same+  unique ended up in the template as in the target. (It was a rule firing when+  compiling Data.List.NonEmpty.)++* What about matching a /non-bindable/ variable?  For example:+      template-vars   : {a}+      matching problem: (forall b. b -> a) ~ (forall c. c -> Int)+  We want to emerge with the substitution [a :-> Int]+  But on the way we will encounter (b ~ b), when we match the bits before the+  arrow under the forall, having renamed `c` to `b`.  This match should just+  succeed, just like (Int ~ Int), without extending the substitution.++  It's important to do this for /non-bindable/ variables, not just for+  forall-bound ones.  In an associated type+         instance C (Maybe a) where {  type F (Maybe a) = Int }+  `checkConsistentFamInst` matches (Maybe a) from the header against (Maybe a)+  from the type-family instance, with `a` marked as non-bindable.+++Note [Matching coercion variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:++   type family F a++   data G a where+     MkG :: F a ~ Bool => G a++   type family Foo (x :: G a) :: F a+   type instance Foo MkG = False++We would like that to be accepted. For that to work, we need to introduce+a coercion variable on the left and then use it on the right. Accordingly,+at use sites of Foo, we need to be able to use matching to figure out the+value for the coercion. (See the desugared version:++   axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c)++) We never want this action to happen during *unification* though, when+all bets are off.++Note [Kind coercions in Unify]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We wish to match/unify while ignoring casts. But, we can't just ignore+them completely, or we'll end up with ill-kinded substitutions. For example,+say we're matching `a` with `ty |> co`. If we just drop the cast, we'll+return [a |-> ty], but `a` and `ty` might have different kinds. We can't+just match/unify their kinds, either, because this might gratuitously+fail. After all, `co` is the witness that the kinds are the same -- they+may look nothing alike.++So, we pass a kind coercion `kco` to the main `unify_ty`. This coercion witnesses+the equality between the substed kind of the left-hand type and the substed+kind of the right-hand type. Note that we do not unify kinds at the leaves+(as we did previously).++Hence: (UKINV) Unification Kind Invariant+* In the call+     unify_ty ty1 ty2 kco+  it must be that+     subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2))+  where `subst` is the ambient substitution in the UM monad+* In the call+     unify_tys tys1 tys2+  (which has no kco), after we unify any prefix of tys1,tys2, the kinds of the+  head of the remaining tys1,tys2 are identical after substitution.  This+  implies, for example, that the kinds of the head of tys1,tys2 are identical+  after substitution.++Preserving (UKINV) takes a bit of work, governed by the `match_kis` flag in+`tc_unify_tys`:++* When we're working with type applications (either TyConApp or AppTy) we+  need to worry about establishing (UKINV), as the kinds of the function+  & arguments aren't (necessarily) included in the kind of the result.+  When unifying two TyConApps, this is easy, because the two TyCons are+  the same. Their kinds are thus the same. As long as we unify left-to-right,+  we'll be sure to unify types' kinds before the types themselves. (For example,+  think about Proxy :: forall k. k -> *. Unifying the first args matches up+  the kinds of the second args.)++* For AppTy, we must unify the kinds of the functions, but once these are+  unified, we can continue unifying arguments without worrying further about+  kinds.++* The interface to this module includes both "...Ty" functions and+  "...TyKi" functions. The former assume that (UKINV) is already+  established, either because the kinds are the same or because the+  list of types being passed in are the well-typed arguments to some+  type constructor (see two paragraphs above). The latter take a separate+  pre-pass over the kinds to establish (UKINV). Sometimes, it's important+  not to take the second pass, as it caused #12442.++Wrinkles++(KCU1) We ensure that the `kco` argument never mentions variables in the+  domain of either RnEnvL or RnEnvR.  Why?++  * `kco` is used only to build the final well-kinded substitution+         a :-> ty |> kco+    The range of the substitution never mentions forall-bound variables,+    so `kco` cannot either.++  * `kco` mixes up types from both left and right arguments of+    `unify_ty`, which have different renamings in the RnEnv2.++  The easiest thing is to insist that `kco` does not need renaming with+  the RnEnv2; it mentions no forall-bound variables.++  To achieve this we do a `mentionsForAllBoundTyVars` test in the+  `CastTy` cases of `unify_ty`.++(KCU2) Suppose we are unifying+            (forall a. x |> (...F a b...) ~ (forall a. y)+  We can't bind y :-> x |> (...F a b...), becuase of that free `a`.++  But if we later learn that b=Int, and F a Int = Bool,+  that free `a` might disappear, so we could unify with+      y :-> x |> (...Bool...)++  Conclusion: if there is a free forall-bound variable in a cast,+  return MaybeApart, with a MaybeApartReason of MARCast.++(KCU3) We thought, at one point, that this was all unnecessary: why should+    casts be in types in the first place? But they are sometimes. In+    dependent/should_compile/KindEqualities2, we see, for example the+    constraint Num (Int |> (blah ; sym blah)).  We naturally want to find+    a dictionary for that constraint, which requires dealing with+    coercions in this manner.++Note [Matching in the presence of casts (1)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When matching, it is crucial that no variables from the template+end up in the range of the matching substitution (obviously!).+When unifying, that's not a constraint; instead we take the fixpoint+of the substitution at the end.++So what should we do with this, when matching?+   unify_ty (tmpl |> co) tgt kco++Previously, wrongly, we pushed 'co' in the (horrid) accumulating+'kco' argument like this:+   unify_ty (tmpl |> co) tgt kco+     = unify_ty tmpl tgt (kco ; co)++But that is obviously wrong because 'co' (from the template) ends+up in 'kco', which in turn ends up in the range of the substitution.++This all came up in #13910.  Because we match tycon arguments+left-to-right, the ambient substitution will already have a matching+substitution for any kinds; so there is an easy fix: just apply+the substitution-so-far to the coercion from the LHS.++Note that++* When matching, the first arg of unify_ty is always the template;+  we never swap round.++* The above argument is distressingly indirect. We seek a+  better way.++* One better way is to ensure that type patterns (the template+  in the matching process) have no casts.  See #14119.++Note [Matching in the presence of casts (2)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is another wrinkle (#17395).  Suppose (T :: forall k. k -> Type)+and we are matching+   tcMatchTy (T k (a::k))  (T j (b::j))++Then we'll match k :-> j, as expected. But then in unify_tys+we invoke+   unify_tys env (a::k) (b::j) (Refl j)++Although we have unified k and j, it's very important that we put+(Refl j), /not/ (Refl k) as the fourth argument to unify_tys.+If we put (Refl k) we'd end up with the substitution+  a :-> b |> Refl k+which is bogus because one of the template variables, k,+appears in the range of the substitution.  Eek.++Similar care is needed in unify_ty_app.+++Note [Polykinded tycon applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose  T :: forall k. Type -> K+and we are unifying+  ty1:  T @Type         Int       :: Type+  ty2:  T @(Type->Type) Int Int   :: Type++These two TyConApps have the same TyCon at the front but they+(legitimately) have different numbers of arguments.  They+are surelyApart, so we can report that without looking any+further (see #15704).++Note [Unifying type applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unifying type applications is quite subtle, as we found+in #23134 and #22647, when type families are involved.++Suppose+   type family F a :: Type -> Type+   type family G k :: k = r | r -> k++and consider these examples:++* F Int ~ F Char, where F is injective+  Since F is injective, we can reduce this to Int ~ Char,+  therefore SurelyApart.++* F Int ~ F Char, where F is not injective+  Without injectivity, return MaybeApart.++* G Type ~ G (Type -> Type) Int+  Even though G is injective and the arguments to G are different,+  we cannot deduce apartness because the RHS is oversaturated.+  For example, G might be defined as+    G Type = Maybe Int+    G (Type -> Type) = Maybe+  So we return MaybeApart.++* F Int Bool ~ F Int Char       -- SurelyApart (since Bool is apart from Char)+  F Int Bool ~ Maybe a          -- MaybeApart+  F Int Bool ~ a b              -- MaybeApart+  F Int Bool ~ Char -> Bool     -- MaybeApart+  An oversaturated type family can match an application,+  whether it's a TyConApp, AppTy or FunTy. Decompose.++* F Int ~ a b+  We cannot decompose a saturated, or under-saturated+  type family application. We return MaybeApart.++To handle all those conditions, unify_ty goes through+the following checks in sequence, where Fn is a type family+of arity n:++* (C1) Fn x_1 ... x_n ~ Fn y_1 .. y_n+  A saturated application.+  Here we can unify arguments in which Fn is injective.+* (C2) Fn x_1 ... x_n ~ anything, anything ~ Fn x_1 ... x_n+  A saturated type family can match anything - we return MaybeApart.+* (C3) Fn x_1 ... x_m ~ a b, a b ~ Fn x_1 ... x_m where m > n+  An oversaturated type family can be decomposed.+* (C4) Fn x_1 ... x_m ~ anything, anything ~ Fn x_1 ... x_m, where m > n+  If we couldn't decompose in the previous step, we return SurelyApart.++Afterwards, the rest of the code doesn't have to worry about type families.++Note [Unifying type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the task of unifying two 'Type's of the form++  TyConApp tc [] ~ TyConApp tc []++where `tc` is a type synonym. A naive way to perform this comparison these+would first expand the synonym and then compare the resulting expansions.++However, this is obviously wasteful and the RHS of `tc` may be large; it is+much better to rather compare the TyCons directly. Consequently, before+expanding type synonyms in type comparisons we first look for a nullary+TyConApp and simply compare the TyCons if we find one.++Of course, if we find that the TyCons are *not* equal then we still need to+perform the expansion as their RHSs may still be unifiable.  E.g+    type T = S (a->a)+    type S a = [a]+and consider+    T Int ~ S (Int -> Int)++We can't decompose non-nullary synonyms.  E.g.+    type R a = F a    -- Where F is a type family+and consider+    R (a->a) ~ R Int+We can't conclude that  (a->) ~ Int.  (There is a currently-missed opportunity+here; if we knew that R was /injective/, perhaps we could decompose.)++We perform the nullary-type-synonym optimisation in a number of places:++ * GHC.Core.Unify.unify_ty+ * GHC.Tc.Solver.Equality.can_eq_nc'+ * GHC.Tc.Utils.Unify.uType++This optimisation is especially helpful for the ubiquitous GHC.Types.Type,+since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications+whenever possible. See Note [Using synonyms to compress types] in+GHC.Core.Type for details.++c.f. Note [Comparing type synonyms] in GHC.Core.TyCo.Compare+-}++-------------- unify_ty: the main workhorse -----------++type AmIUnifying = Bool   -- True  <=> Unifying+                          -- False <=> Matching++type InType      = Type       -- Before applying the RnEnv2+type OutCoercion = Coercion   -- After applying the RnEnv2+++unify_ty :: UMEnv+         -> InType -> InType  -- Types to be unified+         -> OutCoercion       -- A nominal coercion between their kinds+                              -- OutCoercion: the RnEnv has already been applied+                              -- When matching, the coercion is in "target space",+                              --   not "template space"+                              -- See Note [Kind coercions in Unify]+         -> UM ()+-- Precondition: see (Unification Kind Invariant)+--+-- See Note [Specification of unification]+-- Respects newtypes, PredTypes+-- See Note [Computing equality on types] in GHC.Core.Type+unify_ty _env (TyConApp tc1 []) (TyConApp tc2 []) _kco+  -- See Note [Unifying type synonyms]+  | tc1 == tc2+  = return ()++unify_ty env ty1 ty2 kco+    -- Now handle the cases we can "look through": synonyms and casts.+  | Just ty1' <- coreView ty1 = unify_ty env ty1' ty2 kco+  | Just ty2' <- coreView ty2 = unify_ty env ty1 ty2' kco++unify_ty env (CastTy ty1 co1) ty2 kco+  | mentionsForAllBoundTyVarsL env (tyCoVarsOfCo co1)+    -- See (KCU1) in Note [Kind coercions in Unify]+  = maybeApart MARCast  -- See (KCU2)++  | um_unif env+  = unify_ty env ty1 ty2 (co1 `mkTransCo` kco)++  | otherwise -- We are matching, not unifying+  = do { subst <- getSubst env+       ; let co' = substCo subst co1+         -- We match left-to-right, so the free template vars of the+         -- coercion should already have been matched.+         -- See Note [Matching in the presence of casts (1)]+         -- NB: co1 does not mention forall-bound vars, so no need to rename+       ; unify_ty env ty1 ty2 (co' `mkTransCo` kco) }++unify_ty env ty1 (CastTy ty2 co2) kco+  | mentionsForAllBoundTyVarsR env (tyCoVarsOfCo co2)+    -- See (KCU1) in Note [Kind coercions in Unify]+  = maybeApart MARCast  -- See (KCU2)+  | otherwise+  = unify_ty env ty1 ty2 (kco `mkTransCo` mkSymCo co2)+    -- NB: co2 does not mention forall-bound variables++-- Applications need a bit of care!+-- They can match FunTy and TyConApp, so use splitAppTy_maybe+unify_ty env (AppTy ty1a ty1b) ty2 _kco+  | Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2+  = unify_ty_app env ty1a [ty1b] ty2a [ty2b]++unify_ty env ty1 (AppTy ty2a ty2b) _kco+  | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1+  = unify_ty_app env ty1a [ty1b] ty2a [ty2b]++unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return ()++unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco+  -- ToDo: See Note [Unifying coercion-foralls]+  = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind)+       ; let env' = umRnBndr2 env tv1 tv2+       ; unify_ty env' ty1 ty2 kco }++-- See Note [Matching coercion variables]+unify_ty env (CoercionTy co1) (CoercionTy co2) kco+  = do { c_subst <- getCvSubstEnv+       ; case co1 of+           CoVarCo cv+             | not (um_unif env)+             , not (cv `elemVarEnv` c_subst)   -- Not forall-bound+             , let (_mult_co, co_l, co_r) = decomposeFunCo kco+                     -- Because the coercion is used in a type, it should be safe to+                     -- ignore the multiplicity coercion, _mult_co+                      -- cv :: t1 ~ t2+                      -- co2 :: s1 ~ s2+                      -- co_l :: t1 ~ s1+                      -- co_r :: t2 ~ s2+                   rhs_co = co_l `mkTransCo` co2 `mkTransCo` mkSymCo co_r+             , BindMe <- um_bind_tv_fun env cv (CoercionTy rhs_co)+             -> if mentionsForAllBoundTyVarsR env (tyCoVarsOfCo co2)+                then surelyApart+                else extendCvEnv cv rhs_co++           _ -> return () }++unify_ty env (TyVarTy tv1) ty2 kco+  = uVarOrFam env (TyVarLHS tv1) ty2 kco++unify_ty env ty1 (TyVarTy tv2) kco+  | um_unif env  -- If unifying, can swap args; but not when matching+  = uVarOrFam (umSwapRn env) (TyVarLHS tv2) ty1 (mkSymCo kco)++-- Deal with TyConApps+unify_ty env ty1 ty2 kco+  -- Handle non-oversaturated type families first+  -- See Note [Unifying type applications]+  | Just (tc,tys) <- mb_sat_fam_app1+  = uVarOrFam env (TyFamLHS tc tys) ty2 kco++  | um_unif env+  , Just (tc,tys) <- mb_sat_fam_app2+  = uVarOrFam (umSwapRn env) (TyFamLHS tc tys) ty1 (mkSymCo kco)++  -- Handle oversaturated type families. Suppose we have+  --     (F a b) ~ (c d)    where F has arity 1+  -- We definitely want to decompose that type application! (#22647)+  --+  -- If there is no application, an oversaturated type family can only+  -- match a type variable or a saturated type family,+  -- both of which we handled earlier. So we can say surelyApart.+  | Just (tc1, _) <- mb_tc_app1+  , isTypeFamilyTyCon tc1+  = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1+       , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2+       -> unify_ty_app env ty1a [ty1b] ty2a [ty2b]            -- (C3)+       | otherwise -> surelyApart                             -- (C4)++  | Just (tc2, _) <- mb_tc_app2+  , isTypeFamilyTyCon tc2+  = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1+       , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2+       -> unify_ty_app env ty1a [ty1b] ty2a [ty2b]            -- (C3)+       | otherwise -> surelyApart                             -- (C4)++  -- At this point, neither tc1 nor tc2 can be a type family.+  | Just (tc1, tys1) <- mb_tc_app1+  , Just (tc2, tys2) <- mb_tc_app2+  , tc1 == tc2+  = do { massertPpr (isInjectiveTyCon tc1 Nominal) (ppr tc1)+       ; unify_tc_app env tc1 tys1 tys2+       }++  -- TYPE and CONSTRAINT are not Apart+  -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim+  -- NB: at this point we know that the two TyCons do not match+  | Just (tc1,_) <- mb_tc_app1, let u1 = tyConUnique tc1+  , Just (tc2,_) <- mb_tc_app2, let u2 = tyConUnique tc2+  , (u1 == tYPETyConKey && u2 == cONSTRAINTTyConKey) ||+    (u2 == tYPETyConKey && u1 == cONSTRAINTTyConKey)+  = maybeApart MARTypeVsConstraint+    -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim+    -- Note [Type and Constraint are not apart]++  -- The arrow types are not Apart+  -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim+  --     wrinkle (W2)+  -- NB1: at this point we know that the two TyCons do not match+  -- NB2: In the common FunTy/FunTy case you might wonder if we want to go via+  --      splitTyConApp_maybe.  But yes we do: we need to look at those implied+  --      kind argument in order to satisfy (Unification Kind Invariant)+  | FunTy {} <- ty1+  , FunTy {} <- ty2+  = maybeApart MARTypeVsConstraint+    -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim+    -- Note [Type and Constraint are not apart]++  where+    mb_tc_app1 = splitTyConApp_maybe ty1+    mb_tc_app2 = splitTyConApp_maybe ty2+    mb_sat_fam_app1 = isSatTyFamApp ty1+    mb_sat_fam_app2 = isSatTyFamApp ty2++unify_ty _ _ _ _ = surelyApart++-----------------------------+unify_tc_app :: UMEnv -> TyCon -> [Type] -> [Type] -> UM ()+-- Mainly just unifies the argument types;+-- but with a special case for fUNTyCon+unify_tc_app env tc tys1 tys2+  | tc == fUNTyCon+  , IgnoreMultiplicities <- um_arr_mult env+  , (_mult1 : no_mult_tys1) <- tys1+  , (_mult2 : no_mult_tys2) <- tys2+  = -- We're comparing function arrow types here (not constraint arrow+    -- types!), and they have at least one argument, which is the arrow's+    -- multiplicity annotation. The flag `um_arr_mult` instructs us to+    -- ignore multiplicities in this very case. This is a little tricky: see+    -- point (3) in Note [Rewrite rules ignore multiplicities in FunTy].+     unify_tys env no_mult_tys1 no_mult_tys2++  | otherwise+  = unify_tys env tys1 tys2++-----------------------------+unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM ()+-- Deal with (t1 t1args) ~ (t2 t2args)+-- where   length t1args = length t2args+unify_ty_app env ty1 ty1args ty2 ty2args+  | Just (ty1', ty1a) <- splitAppTyNoView_maybe ty1+  , Just (ty2', ty2a) <- splitAppTyNoView_maybe ty2+  = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args)++  | otherwise+  = do { let ki1 = typeKind ty1+             ki2 = typeKind ty2+           -- See Note [Kind coercions in Unify]+       ; unify_ty  env ki1 ki2 (mkNomReflCo liftedTypeKind)+       ; unify_ty  env ty1 ty2 (mkNomReflCo ki2)+                 -- Very important: 'ki2' not 'ki1'+                 -- See Note [Matching in the presence of casts (2)]+       ; unify_tys env ty1args ty2args }++-----------------------------+unify_tys :: UMEnv -> [Type] -> [Type] -> UM ()+-- Precondition: see (Unification Kind Invariant)+unify_tys env orig_xs orig_ys+  = go orig_xs orig_ys+  where+    go []     []     = return ()+    go (x:xs) (y:ys)+      -- See Note [Kind coercions in Unify]+      = do { unify_ty env x y (mkNomReflCo $ typeKind y)+                 -- Very important: 'y' not 'x'+                 -- See Note [Matching in the presence of casts (2)]+           ; go xs ys }+    go _ _ = surelyApart+      -- Possibly different saturations of a polykinded tycon+      -- See Note [Polykinded tycon applications]++---------------------------------+uVarOrFam :: UMEnv -> CanEqLHS -> InType -> OutCoercion -> UM ()+-- Invariants: (a) If ty1 is a TyFamLHS, then ty2 is NOT a TyVarTy+--             (b) both args have had coreView already applied+-- Why saturated?  See (ATF4) in Note [Apartness and type families]+uVarOrFam env ty1 ty2 kco+  = do { substs <- getSubstEnvs+--       ; pprTrace "uVarOrFam" (vcat+--           [ text "ty1" <+> ppr ty1+--           , text "ty2" <+> ppr ty2+--           , text "tv_env" <+> ppr (um_tv_env substs)+--           , text "fam_env" <+> ppr (um_fam_env substs) ]) $+       ; go NotSwapped substs ty1 ty2 kco }+  where+    foralld_tvs  = um_foralls env+    under_forall = not (isEmptyVarSet foralld_tvs)++    -- `go` takes two bites at the cherry; if the first one fails+    -- it swaps the arguments and tries again; and then it fails.+    -- The SwapFlag argument tells `go` whether it is on the first+    -- bite (NotSwapped) or the second (IsSwapped).+    -- E.g.    a ~ F p q+    --         Starts with: go a (F p q)+    --         if `a` not bindable, swap to: go (F p q) a++    -----------------------------+    -- LHS is a type variable+    -- The sequence of tests is very similar to go_tv+    go :: SwapFlag -> UMState -> CanEqLHS -> InType -> OutCoercion -> UM ()+    go swapped substs lhs@(TyVarLHS tv1) ty2 kco+      | Just ty1' <- lookupVarEnv (um_tv_env substs) tv1'+      = -- We already have a substitution for tv1+        if | um_unif env                          -> unify_ty env ty1' ty2 kco+           | (ty1' `mkCastTy` kco) `tcEqType` ty2 -> return ()+           | otherwise                            -> surelyApart+           -- Unifying: recurse into unify_ty+           -- Matching: we /don't/ want to just recurse here, because the range of+           --    the subst is the target type, not the template type. So, just check+           --    for normal type equality.+           -- NB: it's important to use `tcEqType` instead of `eqType` here,+           -- otherwise we might not reject a substitution+           -- which unifies `Type` with `Constraint`, e.g.+           -- a call to tc_unify_tys with arguments+           --+           --   tys1 = [k,k]+           --   tys2 = [Type, Constraint]+           --+           -- See test cases: T11715b, T20521.++      -- If we are matching or unifying a ~ a, take care+      -- See Note [Self-substitution when unifying or matching]+      | TyVarTy tv2 <- ty2+      , let tv2' = umRnOccR env tv2+      , tv1' == tv2'+      = if | um_unif env     -> return ()+           | tv1_is_bindable -> extendTvEnv tv1' ty2+           | otherwise       -> return ()++      | tv1_is_bindable+      , not (mentionsForAllBoundTyVarsR env ty2_fvs)+            -- ty2_fvs: kco does not mention forall-bound vars+      , not occurs_check+      = -- No occurs check, nor skolem-escape; just bind the tv+        -- We don't need to rename `rhs` because it mentions no forall-bound vars+        extendTvEnv tv1' rhs     -- Bind tv1:=rhs and continue++      -- When unifying, try swapping:+      -- e.g.   a    ~ F p q       with `a` not bindable: we might succeed with go_fam+      -- e.g.   a    ~ beta        with `a` not bindable: we might be able to bind `beta`+      -- e.g.   beta ~ F beta Int  occurs check; but MaybeApart after swapping+      | um_unif env+      , NotSwapped <- swapped  -- If we have swapped already, don't do so again+      , Just lhs2 <- canEqLHS_maybe ty2+      = go IsSwapped substs lhs2 (mkTyVarTy tv1) (mkSymCo kco)++      | occurs_check = maybeApart MARInfinite   -- Occurs check+      | otherwise    = surelyApart++      where+        tv1'            = umRnOccL env tv1+        ty2_fvs         = tyCoVarsOfType ty2+        rhs             = ty2 `mkCastTy` mkSymCo kco+        tv1_is_bindable | not (tv1' `elemVarSet` foralld_tvs)+                          -- tv1' is not forall-bound, but tv1 can still differ+                          -- from tv1; see Note [Cloning the template binders]+                          -- in GHC.Core.Rules.  So give tv1' to um_bind_tv_fun.+                        , BindMe <- um_bind_tv_fun env tv1' rhs+                        = True+                        | otherwise+                        = False++        occurs_check = um_unif env && uOccursCheck substs foralld_tvs lhs rhs+          -- Occurs check, only when unifying+          -- see Note [Infinitary substitutions]+          -- Make sure you include `kco` in rhs #14846++    -----------------------------+    -- LHS is a saturated type-family application+    -- Invariant: ty2 is not a TyVarTy+    go swapped substs lhs@(TyFamLHS tc1 tys1) ty2 kco+      -- Check if we have an existing substitution for the LHS; if so, recurse+      -- But not under a forall; see (ATF3) in Note [Apartness and type families]+      -- Hence the RnEnv2 is empty+      | not under_forall+      , Just ty1' <- lookupFamEnv (um_fam_env substs) tc1 tys1+      = if | um_unif env                          -> unify_ty env ty1' ty2 kco+           -- Below here we are matching+           -- The return () case deals with:+           --    Template:   (F a)..(F a)+           --    Target:     (F b)..(F b)+           -- This should match! With [a :-> b]+           | (ty1' `mkCastTy` kco) `tcEqType` ty2 -> return ()+           | otherwise                            -> maybeApart MARTypeFamily++      -- Check for equality  F tys1 ~ F tys2+      -- Very important that this can happen under a forall, so that we+      -- successfully match  (forall a. F a) ~ (forall b. F b)  See (ATF9-2)+      | Just (tc2, tys2) <- isSatTyFamApp ty2+      , tc1 == tc2+      = go_fam_fam substs tc1 tys1 tys2 kco++      -- If we are under a forall, just give up+      -- see (ATF3) and (ATF5) in Note [Apartness and type families]+      | under_forall+      = maybeApart MARTypeFamily++      -- Now check if we can bind the (F tys) to the RHS+      -- Again, not under a forall; see (ATF3)+      -- This can happen even when matching: see (ATF7)+      | BindMe <- um_bind_fam_fun env tc1 tys1 rhs+      = if uOccursCheck substs emptyVarSet lhs rhs+        then maybeApart MARInfinite+        else do { extendFamEnv tc1 tys1 rhs+                     -- We don't substitute tys1 before extending+                     -- See Note [Shortcomings of the apartness test]+                ; maybeApart MARTypeFamily }++      -- Swap in case of (F a b) ~ (G c d e)+      -- Maybe um_bind_fam_fun is False of (F a b) but true of (G c d e)+      -- NB: a type family can appear on the template when matching+      --     see (ATF6) in Note [Apartness and type families]+      -- (Only worth doing this if we are not under a forall.)+      | um_unif env+      , NotSwapped <- swapped+      , Just lhs2 <- canEqLHS_maybe ty2+      = go IsSwapped substs lhs2 (mkTyConApp tc1 tys1) (mkSymCo kco)++      | otherwise   -- See (ATF5) in Note [Apartness and type families]+      = surelyApart++      where+        rhs = ty2 `mkCastTy` mkSymCo kco++    -----------------------------+    -- go_fam_fam: LHS and RHS are both saturated type-family applications,+    --             for the same type-family F+    go_fam_fam substs tc tys1 tys2 kco+       -- Decompose (F tys1 ~ F tys2): (ATF9)+       -- Use injectivity information of F: (ATF10)+       -- But first bind the type-fam if poss: (ATF11)+      = do { bind_fam_if_poss                 -- (ATF11)+           ; unify_tys env inj_tys1 inj_tys2  -- (ATF10)+           ; unless (um_inj_tf env) $         -- (ATF12)+             don'tBeSoSure MARTypeFamily $    -- (ATF9-1)+             unify_tys env noninj_tys1 noninj_tys2 }+     where+       inj = case tyConInjectivityInfo tc of+                NotInjective -> repeat False+                Injective bs -> bs++       (inj_tys1, noninj_tys1) = partitionByList inj tys1+       (inj_tys2, noninj_tys2) = partitionByList inj tys2++       bind_fam_if_poss+         | not (um_unif env)  -- Not when matching (ATF11-1)+         = return ()+         | under_forall       -- Not under a forall (ATF3)+         = return ()+         | BindMe <- um_bind_fam_fun env tc tys1 rhs1+         = unless (uOccursCheck substs emptyVarSet (TyFamLHS tc tys1) rhs1) $+           extendFamEnv tc tys1 rhs1+         -- At this point um_unif=True, so we can unify either way+         | BindMe <- um_bind_fam_fun env tc tys2 rhs2+         = unless (uOccursCheck substs emptyVarSet (TyFamLHS tc tys2) rhs2) $+           extendFamEnv tc tys2 rhs2+         | otherwise+         = return ()++       rhs1 = mkTyConApp tc tys2 `mkCastTy` mkSymCo kco+       rhs2 = mkTyConApp tc tys1 `mkCastTy` kco+++uOccursCheck :: UMState+             -> TyVarSet -- Bound by enclosing foralls; see (OCU1)+             -> CanEqLHS -> Type   -- Can we unify (lhs := ty)?+             -> Bool+-- See Note [The occurs check in the Core unifier] and (ATF13)+uOccursCheck (UMState { um_tv_env = tv_env, um_fam_env = fam_env }) bvs lhs ty+  = go bvs ty+  where+    go :: TyCoVarSet   -- Bound by enclosing foralls; see (OCU1)+       -> Type -> Bool+    go bvs ty | Just ty' <- coreView ty = go bvs ty'+    go bvs (TyVarTy tv) | Just ty' <- lookupVarEnv tv_env tv+                        = go bvs ty'+                        | TyVarLHS tv' <- lhs, tv==tv'+                        = True+                        | otherwise+                        = go bvs (tyVarKind tv)+    go bvs (AppTy ty1 ty2)           = go bvs ty1 || go bvs ty2+    go _   (LitTy {})                = False+    go bvs (FunTy _ w arg res)       = go bvs w || go bvs arg || go bvs res+    go bvs (TyConApp tc tys)         = go_tc bvs tc tys++    go bvs (ForAllTy (Bndr tv _) ty)+      = go bvs (tyVarKind tv) ||+        (case lhs of+           TyVarLHS tv' | tv==tv'   -> False  -- Shadowing+                        | otherwise -> go (bvs `extendVarSet` tv) ty+           TyFamLHS {} -> False)  -- Lookups don't happen under a forall++    go bvs (CastTy ty  _co) = go bvs ty  -- ToDo: should we worry about `co`?+    go _   (CoercionTy _co) = False      -- ToDo: should we worry about `co`?++    go_tc bvs tc tys+      | isEmptyVarSet bvs   -- Never look up in um_fam_env under a forall (ATF3)+      , isTypeFamilyTyCon tc+      , Just ty' <- lookupFamEnv fam_env tc (take arity tys)+             -- NB: we look up /un-substituted/ types;+             -- See Note [Shortcomings of the apartness test]+      = go bvs ty' || any (go bvs) (drop arity tys)++      | TyFamLHS tc' tys' <- lhs+      , tc == tc'+      , tys `lengthAtLeast` arity  -- Saturated, or over-saturated+      , tcEqTyConAppArgs tys tys'+      = True++      | otherwise+      = any (go bvs) tys+      where+        arity = tyConArity tc++{- Note [The occurs check in the Core unifier]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The unifier applies both substitutions (um_tv_env and um_fam_env) as it goes,+so we'll get an infinite loop if we have, for example+    um_tv_env:   a :-> F b      -- (1)+    um_fam_env   F b :-> a      -- (2)++So (uOccursCheck substs lhs ty) returns True iff extending `substs` with `lhs :-> ty`+could lead to a loop. That is, could there by a type `s` such that+  applySubsts( (substs + lhs:->ty), s ) is infinite++It's vital that we do both at once: we might have (1) already and add (2);+or we might have (2) already and add (1).++A very similar task is done by GHC.Tc.Utils.Unify.checkTyEqRhs.++(OCU1) We keep track of the forall-bound variables because the um_fam_env is inactive+  under a forall; indeed it is /unsound/ to consult it because we may have a binding+  (F a :-> Int), and then unify (forall a. ...(F a)...) with something.  We don't+  want to map that (F a) to Int!++(OCU2) Performance. Consider unifying+         [a, b] ~ [big-ty, (a,a,a)]+  We'll unify a:=big-ty.  Then we'll attempt b:=(a,a,a), but must do an occurs check.+  So we'll walk over big-ty, looking for `b`.  And then again, and again, once for+  each occurrence of `a`.  A similar thing happens for+         [a, (b,b,b)] ~ [big-ty, (a,a,a)]+  albeit a bit less obviously.++  Potentially we could use a cache to record checks we have already done;+  but I have not attempted that yet.  Precisely similar remarks would apply+  to GHC.Tc.Utils.Unify.checkTyEqRhs++Note [Unifying coercion-foralls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we try to unify (forall cv. t1) ~ (forall cv. t2).+See Note [ForAllTy] in GHC.Core.TyCo.Rep.++The problem with coercion variables is that coercion abstraction is not erased:+the `kco` shouldn't propagate from outside the ForAllTy to inside. Instead, I think+the correct new `kco` for the recursive call is `mkNomReflCo liftedTypeKind` (but I'm+a little worried it might be Constraint sometimes).++This potential problem has been there a long time, and I'm going to let+sleeping dogs lie for now.+-}++{-+************************************************************************+*                                                                      *+                Unification monad+*                                                                      *+************************************************************************+-}++data UMEnv+  = UMEnv { um_unif :: AmIUnifying++          , um_inj_tf :: Bool+            -- Checking for injectivity?+            -- See (SI1) in Note [Specification of unification]++          , um_arr_mult :: MultiplicityFlag+            -- Whether to unify multiplicity arguments when unifying arrows.+            -- See Note [Rewrite rules ignore multiplicities in FunTy]++          , um_rn_env :: RnEnv2+            -- Renaming InTyVars to OutTyVars; this eliminates shadowing, and+            -- lines up matching foralls on the left and right+            -- See (CU2) in Note [The Core unifier]++          , um_foralls :: TyVarSet+            -- OutTyVars bound by a forall in this unification;+            -- Do not bind these in the substitution!+            -- See the function tvBindFlag++          , um_bind_tv_fun :: BindTvFun+            -- User-supplied BindFlag function, for variables not in um_foralls+            -- See (CU1) in Note [The Core unifier]++          , um_bind_fam_fun :: BindFamFun+            -- Similar to um_bind_tv_fun, but for type-family applications+            -- See (ATF8) in Note [Apartness and type families]+          }++type FamSubstEnv = TyConEnv (ListMap TypeMap Type)+  -- Map a TyCon and a list of types to a type+  -- Domain of FamSubstEnv is exactly-saturated type-family+  -- applications (F t1...tn)++lookupFamEnv :: FamSubstEnv -> TyCon -> [Type] -> Maybe Type+lookupFamEnv env tc tys+  = do { tys_map <- lookupTyConEnv env tc+       ; lookupTM tys tys_map }++data UMState = UMState+                   { um_tv_env   :: TvSubstEnv+                   , um_cv_env   :: CvSubstEnv+                   , um_fam_env  :: FamSubstEnv }+  -- um_tv_env, um_cv_env, um_fam_env are all "global" substitutions;+  -- that is, neither their domains nor their ranges mention any variables+  -- in um_foralls; i.e. variables bound by foralls inside the types being unified++  -- When /matching/ um_fam_env is usually empty; but not quite always.+  -- See (ATF7) of Note [Apartness and type families]++newtype UM a+  = UM' { unUM :: UMState -> UnifyResultM (UMState, a) }+    -- See Note [The one-shot state monad trick] in GHC.Utils.Monad++pattern UM :: (UMState -> UnifyResultM (UMState, a)) -> UM a+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad+pattern UM m <- UM' m+  where+    UM m = UM' (oneShot m)+{-# COMPLETE UM #-}++instance Functor UM where+  fmap f (UM m) = UM (\s -> fmap (\(s', v) -> (s', f v)) (m s))++instance Applicative UM where+      pure a = UM (\s -> pure (s, a))+      (<*>)  = ap++instance Monad UM where+  {-# INLINE (>>=) #-}+  -- See Note [INLINE pragmas and (>>)] in GHC.Utils.Monad+  m >>= k  = UM (\state ->+                  do { (state', v) <- unUM m state+                     ; unUM (k v) state' })++instance MonadFail UM where+    fail _   = UM (\_ -> SurelyApart) -- failed pattern match++initUM :: TvSubstEnv  -- subst to extend+       -> CvSubstEnv+       -> UM ()+       -> UnifyResultM (TvSubstEnv, CvSubstEnv)+initUM subst_env cv_subst_env um+  = case unUM um state of+      Unifiable (state, _)    -> Unifiable (get state)+      MaybeApart r (state, _) -> MaybeApart r (get state)+      SurelyApart             -> SurelyApart+  where+    state = UMState { um_tv_env = subst_env+                    , um_cv_env = cv_subst_env+                    , um_fam_env = emptyTyConEnv }+    get (UMState { um_tv_env = tv_env, um_cv_env = cv_env }) = (tv_env, cv_env)++getTvSubstEnv :: UM TvSubstEnv+getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state)++getCvSubstEnv :: UM CvSubstEnv+getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state)++getSubstEnvs :: UM UMState+getSubstEnvs = UM $ \state -> Unifiable (state, state)++getSubst :: UMEnv -> UM Subst+getSubst env = do { tv_env <- getTvSubstEnv+                  ; cv_env <- getCvSubstEnv+                  ; let in_scope = rnInScopeSet (um_rn_env env)+                  ; return (mkTCvSubst in_scope tv_env cv_env) }++extendTvEnv :: TyVar -> Type -> UM ()+extendTvEnv tv ty = UM $ \state ->+  Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ())++extendCvEnv :: CoVar -> Coercion -> UM ()+extendCvEnv cv co = UM $ \state ->+  Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ())++extendFamEnv :: TyCon -> [Type] -> Type -> UM ()+extendFamEnv tc tys ty = UM $ \state ->+  Unifiable (state { um_fam_env = extend (um_fam_env state) tc }, ())+  where+    extend :: FamSubstEnv -> TyCon -> FamSubstEnv+    extend = alterTyConEnv alter_tm++    alter_tm :: Maybe (ListMap TypeMap Type) -> Maybe (ListMap TypeMap Type)+    alter_tm m_elt = Just (alterTM tys (\_ -> Just ty) (m_elt `orElse` emptyTM))++umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv+umRnBndr2 env v1 v2+  = env { um_rn_env = rn_env', um_foralls = um_foralls env `extendVarSet` v' }+  where+    (rn_env', v') = rnBndr2_var (um_rn_env env) v1 v2++mentionsForAllBoundTyVarsL, mentionsForAllBoundTyVarsR :: UMEnv -> VarSet -> Bool+-- See (CU2) in Note [The Core unifier]+mentionsForAllBoundTyVarsL = mentions_forall_bound_tvs inRnEnvL+mentionsForAllBoundTyVarsR = mentions_forall_bound_tvs inRnEnvR++mentions_forall_bound_tvs :: (RnEnv2 -> TyVar -> Bool) -> UMEnv -> VarSet -> Bool+mentions_forall_bound_tvs in_rn_env env varset+  | isEmptyVarSet (um_foralls env)               = False+  | anyVarSet (in_rn_env (um_rn_env env)) varset = True+  | otherwise                                    = False+    -- NB: That isEmptyVarSet guard is a critical optimization;+    -- it means we don't have to calculate the free vars of+    -- the type, often saving quite a bit of allocation.++-- | Converts any SurelyApart to a MaybeApart+don'tBeSoSure :: MaybeApartReason -> UM () -> UM ()+don'tBeSoSure r um = UM $ \ state ->+  case unUM um state of+    SurelyApart -> MaybeApart r (state, ())+    other       -> other++umRnOccL :: UMEnv -> TyVar -> TyVar+umRnOccL env v = rnOccL (um_rn_env env) v++umRnOccR :: UMEnv -> TyVar -> TyVar+umRnOccR env v = rnOccR (um_rn_env env) v++umSwapRn :: UMEnv -> UMEnv+umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) }++maybeApart :: MaybeApartReason -> UM ()+maybeApart r = UM (\state -> MaybeApart r (state, ()))++surelyApart :: UM a+surelyApart = UM (\_ -> SurelyApart)++{-+%************************************************************************+%*                                                                      *+            Matching a (lifted) type against a coercion+%*                                                                      *+%************************************************************************++This section defines essentially an inverse to liftCoSubst. It is defined+here to avoid a dependency from Coercion on this module.++-}++data MatchEnv = ME { me_tmpls :: TyVarSet+                   , me_env   :: RnEnv2 }++-- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'.  In particular, if+--   @liftCoMatch vars ty co == Just s@, then @liftCoSubst s ty == co@,+--   where @==@ there means that the result of 'liftCoSubst' has the same+--   type as the original co; but may be different under the hood.+--   That is, it matches a type against a coercion of the same+--   "shape", and returns a lifting substitution which could have been+--   used to produce the given coercion from the given type.+--   Note that this function is incomplete -- it might return Nothing+--   when there does indeed exist a possible lifting context.+--+-- This function is incomplete in that it doesn't respect the equality+-- in `eqType`. That is, it's possible that this will succeed for t1 and+-- fail for t2, even when t1 `eqType` t2. That's because it depends on+-- there being a very similar structure between the type and the coercion.+-- This incompleteness shouldn't be all that surprising, especially because+-- it depends on the structure of the coercion, which is a silly thing to do.+--+-- The lifting context produced doesn't have to be exacting in the roles+-- of the mappings. This is because any use of the lifting context will+-- also require a desired role. Thus, this algorithm prefers mapping to+-- nominal coercions where it can do so.+liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext+liftCoMatch tmpls ty co+  = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co+       ; cenv2 <- ty_co_match menv cenv1       ty co+                              (mkNomReflCo co_lkind) (mkNomReflCo co_rkind)+       ; return (LC (mkEmptySubst in_scope) cenv2) }+  where+    menv     = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope }+    in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co)+    -- Like tcMatchTy, assume all the interesting variables+    -- in ty are in tmpls++    ki       = typeKind ty+    ki_co    = promoteCoercion co+    ki_ki_co = mkNomReflCo liftedTypeKind++    Pair co_lkind co_rkind = coercionKind ki_co++-- | 'ty_co_match' does all the actual work for 'liftCoMatch'.+ty_co_match :: MatchEnv   -- ^ ambient helpful info+            -> LiftCoEnv  -- ^ incoming subst+            -> Type       -- ^ ty, type to match+            -> Coercion   -- ^ co :: lty ~r rty, coercion to match against+            -> Coercion   -- ^ :: kind(lsubst(ty)) ~N kind(lty)+            -> Coercion   -- ^ :: kind(rsubst(ty)) ~N kind(rty)+            -> Maybe LiftCoEnv+   -- ^ Just env ==> liftCoSubst Nominal env ty == co, modulo roles.+   -- Also: Just env ==> lsubst(ty) == lty and rsubst(ty) == rty,+   -- where lsubst = lcSubstLeft(env) and rsubst = lcSubstRight(env)+ty_co_match menv subst ty co lkco rkco+  | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco++  -- handle Refl case:+  | tyCoVarsOfType ty `isNotInDomainOf` subst+  , Just (ty', _) <- isReflCo_maybe co+  , ty `eqType` ty'+    -- Why `eqType` and not `tcEqType`? Because this function is only used+    -- during coercion optimisation, after type-checking has finished.+  = Just subst++  where+    isNotInDomainOf :: VarSet -> VarEnv a -> Bool+    isNotInDomainOf set env+      = noneSet (\v -> elemVarEnv v env) set++    noneSet :: (Var -> Bool) -> VarSet -> Bool+    noneSet f = allVarSet (not . f)++ty_co_match menv subst ty co lkco rkco+  | CastTy ty' co' <- ty+     -- See Note [Matching in the presence of casts (1)]+  = let empty_subst  = mkEmptySubst (rnInScopeSet (me_env menv))+        substed_co_l = substCo (liftEnvSubstLeft empty_subst subst)  co'+        substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co'+    in+    ty_co_match menv subst ty' co (substed_co_l `mkTransCo` lkco)+                                  (substed_co_r `mkTransCo` rkco)++  | SymCo co' <- co+  = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco++  -- Match a type variable against a non-refl coercion+ty_co_match menv subst (TyVarTy tv1) co lkco rkco+  | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1+  = if eqCoercionX (nukeRnEnvL rn_env) co1' co+    then Just subst+    else Nothing       -- no match since tv1 matches two different coercions++  | tv1' `elemVarSet` me_tmpls menv           -- tv1' is a template var+  = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co)+    then Nothing      -- occurs check failed+    else Just $ extendVarEnv subst tv1' $+                castCoercionKind co (mkSymCo lkco) (mkSymCo rkco)++  | otherwise+  = Nothing++  where+    rn_env = me_env menv+    tv1' = rnOccL rn_env tv1++  -- just look through SubCo's. We don't really care about roles here.+ty_co_match menv subst ty (SubCo co) lkco rkco+  = ty_co_match menv subst ty co lkco rkco++ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco+  | Just (co2, arg2) <- splitAppCo_maybe co     -- c.f. Unify.match on AppTy+  = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2]+ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco+  | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1+       -- yes, the one from Type, not TcType; this is for coercion optimization+  = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2]++ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco+  = ty_co_match_tc menv subst tc1 tys tc2 cos++ty_co_match menv subst (FunTy { ft_mult = w, ft_arg = ty1, ft_res = ty2 })+            (FunCo { fco_mult = co_w, fco_arg = co1, fco_res = co2 }) _lkco _rkco+  = ty_co_match_args menv subst [w,    rep1,    rep2,    ty1, ty2]+                                [co_w, co1_rep, co2_rep, co1, co2]+  where+     rep1    = getRuntimeRep ty1+     rep2    = getRuntimeRep ty2+     co1_rep = mkRuntimeRepCo co1+     co2_rep = mkRuntimeRepCo co2+    -- NB: we include the RuntimeRep arguments in the matching;+    --     not doing so caused #21205.++ty_co_match menv subst (ForAllTy (Bndr tv1 vis1t) ty1)+                       (ForAllCo tv2 vis1c vis2c kind_co2 co2)+                       lkco rkco+  | isTyVar tv1 && isTyVar tv2+  , vis1t == vis1c && vis1c == vis2c -- Is this necessary?+      -- Is this visibility check necessary?  @rae says: yes, I think the+      -- check is necessary, if we're caring about visibility (and we are).+      -- But ty_co_match is a dark and not important corner.+  = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2+                               ki_ki_co ki_ki_co+       ; let rn_env0 = me_env menv+             rn_env1 = rnBndr2 rn_env0 tv1 tv2+             menv'   = menv { me_env = rn_env1 }+       ; ty_co_match menv' subst1 ty1 co2 lkco rkco }+  where+    ki_ki_co = mkNomReflCo liftedTypeKind++-- ty_co_match menv subst (ForAllTy (Bndr cv1 _) ty1)+--                        (ForAllCo cv2 kind_co2 co2)+--                        lkco rkco+--   | isCoVar cv1 && isCoVar cv2+--   We seems not to have enough information for this case+--   1. Given:+--        cv1      :: (s1 :: k1) ~r (s2 :: k2)+--        kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2)+--        eta1      = mkSelCo (SelTyCon 2 role) (downgradeRole r Nominal kind_co2)+--                 :: s1' ~ t1+--        eta2      = mkSelCo (SelTyCon 3 role) (downgradeRole r Nominal kind_co2)+--                 :: s2' ~ t2+--      Wanted:+--        subst1 <- ty_co_match menv subst  s1 eta1 kco1 kco2+--        subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4+--      Question: How do we get kcoi?+--   2. Given:+--        lkco :: <*>    -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep+--        rkco :: <*>+--      Wanted:+--        ty_co_match menv' subst2 ty1 co2 lkco' rkco'+--      Question: How do we get lkco' and rkco'?++ty_co_match _ subst (CoercionTy {}) _ _ _+  = Just subst -- don't inspect coercions++ty_co_match menv subst ty (GRefl r t (MCo co)) lkco rkco+  =  ty_co_match menv subst ty (GRefl r t MRefl) lkco (rkco `mkTransCo` mkSymCo co)++ty_co_match menv subst ty co1 lkco rkco+  | Just (CastTy t co, r) <- isReflCo_maybe co1+  -- In @pushRefl@, pushing reflexive coercion inside CastTy will give us+  -- t |> co ~ t ; <t> ; t ~ t |> co+  -- But transitive coercions are not helpful. Therefore we deal+  -- with it here: we do recursion on the smaller reflexive coercion,+  -- while propagating the correct kind coercions.+  = let kco' = mkSymCo co+    in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco')+                                                (rkco `mkTransCo` kco')++ty_co_match menv subst ty co lkco rkco+  | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco+  | otherwise               = Nothing++ty_co_match_tc :: MatchEnv -> LiftCoEnv+               -> TyCon -> [Type]+               -> TyCon -> [Coercion]+               -> Maybe LiftCoEnv+ty_co_match_tc menv subst tc1 tys1 tc2 cos2+  = do { guard (tc1 == tc2)+       ; ty_co_match_args menv subst tys1 cos2 }++ty_co_match_app :: MatchEnv -> LiftCoEnv+                -> Type -> [Type] -> Coercion -> [Coercion]+                -> Maybe LiftCoEnv+ty_co_match_app menv subst ty1 ty1args co2 co2args+  | Just (ty1', ty1a) <- splitAppTyNoView_maybe ty1+  , Just (co2', co2a) <- splitAppCo_maybe co2+  = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args)++  | otherwise+  = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co+       ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2+       ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco+       ; ty_co_match_args menv subst2 ty1args co2args }+  where+    ki1 = typeKind ty1+    ki2 = promoteCoercion co2+    ki_ki_co = mkNomReflCo liftedTypeKind++ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] -> [Coercion]+                 -> Maybe LiftCoEnv+ty_co_match_args menv subst (ty:tys) (arg:args)+  = do { let Pair lty rty = coercionKind arg+             lkco = mkNomReflCo (typeKind lty)+             rkco = mkNomReflCo (typeKind rty)+       ; subst' <- ty_co_match menv subst ty arg lkco rkco+       ; ty_co_match_args menv subst' tys args }+ty_co_match_args _    subst []       [] = Just subst+ty_co_match_args _    _     _        _  = Nothing++pushRefl :: Coercion -> Maybe Coercion+pushRefl co =+  case (isReflCo_maybe co) of+    Just (AppTy ty1 ty2, Nominal)+      -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2))+    Just (FunTy af w ty1 ty2, r)+      ->  Just (FunCo r af af (mkReflCo r w) (mkReflCo r ty1) (mkReflCo r ty2))+    Just (TyConApp tc tys, r)+      -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRoleListX r tc) tys))+    Just (ForAllTy (Bndr tv vis) ty, r)+      -> Just (ForAllCo { fco_tcv = tv, fco_visL = vis, fco_visR = vis+                        , fco_kind = mkNomReflCo (varType tv)+                        , fco_body = mkReflCo r ty })+    _ -> Nothing
compiler/GHC/Core/UsageEnv.hs view
@@ -90,9 +90,13 @@          combineUsage Nothing  Nothing  = pprPanic "supUE" (ppr e1 <+> ppr e2) -- Note: If you are changing this logic, check 'mkMultSup' in Multiplicity as well. -supUEs :: [UsageEnv] -> UsageEnv+-- Used with @f = '[]'@ and @f = 'NonEmpty'@+supUEs :: Foldable f => f UsageEnv -> UsageEnv supUEs = foldr supUE bottomUE +-- INLINE to ensure specialization at use site, and to avoid multiple specialization on the same+-- type+{-# INLINE supUEs #-}  deleteUE :: NamedThing n => UsageEnv -> n -> UsageEnv deleteUE (UsageEnv e b) x = UsageEnv (delFromNameEnv e (getName x)) b
compiler/GHC/Core/Utils.hs view
@@ -32,6 +32,7 @@         isCheapApp, isExpandableApp, isSaturatedConApp,         exprIsTickedString, exprIsTickedString_maybe,         exprIsTopLevelBindable,+        exprIsUnaryClassFun, isUnaryClassId,         altsAreExhaustive, etaExpansionTick,          -- * Equality@@ -74,7 +75,8 @@ import GHC.Core.FVs( bindFreeVars ) import GHC.Core.DataCon import GHC.Core.Type as Type-import GHC.Core.Predicate( isCoVarType )+import GHC.Core.Predicate( isEqPred )+import GHC.Core.Predicate( isUnaryClass ) import GHC.Core.FamInstEnv import GHC.Core.TyCo.Compare( eqType, eqTypeX ) import GHC.Core.Coercion@@ -113,6 +115,7 @@ import Data.ByteString     ( ByteString ) import Data.Function       ( on ) import Data.List           ( sort, sortBy, partition, zipWith4, mapAccumL )+import qualified Data.List as Partial ( init, last ) import Data.Ord            ( comparing ) import Control.Monad       ( guard ) import qualified Data.Set as Set@@ -142,7 +145,7 @@ exprType (Lam binder expr)   = mkLamType binder (exprType expr) exprType e@(App _ _)   = case collectArgs e of-        (fun, args) -> applyTypeToArgs (pprCoreExpr e) (exprType fun) args+        (fun, args) -> applyTypeToArgs (exprType fun) args exprType (Type ty) = pprPanic "exprType" (ppr ty)  coreAltType :: CoreAlt -> Type@@ -180,7 +183,7 @@    = mkForAllTy (Bndr v coreTyLamForAllTyFlag) body_ty     | otherwise-   = mkFunctionType (varMult v) (varType v) body_ty+   = mkFunctionType (idMult v) (idType v) body_ty  mkLamTypes vs ty = foldr mkLamType ty vs @@ -221,11 +224,10 @@ Note that there might be existentially quantified coercion variables, too. -} -applyTypeToArgs :: HasDebugCallStack => SDoc -> Type -> [CoreExpr] -> Type+applyTypeToArgs :: HasDebugCallStack => Type -> [CoreExpr] -> Type -- ^ Determines the type resulting from applying an expression with given type --- to given argument expressions.--- The first argument is just for debugging, and gives some context-applyTypeToArgs pp_e op_ty args+applyTypeToArgs op_ty args   = go op_ty args   where     go op_ty []                   = op_ty@@ -244,8 +246,7 @@     go_ty_args op_ty rev_tys args        = go (piResultTys op_ty (reverse rev_tys)) args -    panic_msg as = vcat [ text "Expression:" <+> pp_e-                        , text "Type:" <+> ppr op_ty+    panic_msg as = vcat [ text "Type:" <+> ppr op_ty                         , text "Args:" <+> ppr args                         , text "Args':" <+> ppr as ] @@ -283,7 +284,7 @@       Cast expr co2 -> mkCast expr (mkTransCo co2 co)       Tick t expr   -> Tick t (mkCast expr co) -      Coercion e_co | isCoVarType (coercionRKind co)+      Coercion e_co | isEqPred (coercionRKind co)          -- The guard here checks that g has a (~#) on both sides,          -- otherwise decomposeCo fails.  Can in principle happen          -- with unsafeCoerce@@ -1295,14 +1296,17 @@ -- * `case e of {}` an empty case trivial_expr_fold k_id k_lit k_triv k_not_triv = go   where-    -- If you change this function, be sure to change SetLevels.notWorthFloating-    -- as well!+    -- If you change this function, be sure to change+    -- SetLevels.notWorthFloating as well!     -- (Or yet better: Come up with a way to share code with this function.)     go (Var v)                            = k_id v  -- See Note [Variables are trivial]     go (Lit l)    | litIsTrivial l        = k_lit l     go (Type _)                           = k_triv     go (Coercion _)                       = k_triv-    go (App f t)  | not (isRuntimeArg t)  = go f+    go (App f arg)+      | not (isRuntimeArg arg)            = go f+      | exprIsUnaryClassFun f             = go arg+      | otherwise                         = k_not_triv     go (Lam b e)  | not (isRuntimeVar b)  = go e     go (Tick t e) | not (tickishIsCode t) = go e              -- See Note [Tick trivial]     go (Cast e _)                         = go e@@ -1497,18 +1501,23 @@             in \w. v True -} ----------------------exprIsWorkFree :: CoreExpr -> Bool   -- See Note [exprIsWorkFree]-exprIsWorkFree e = exprIsCheapX isWorkFreeApp e--exprIsCheap :: CoreExpr -> Bool-exprIsCheap e = exprIsCheapX isCheapApp e+-------------------------------------+type CheapAppFun = Id -> Arity -> Bool+  -- Is an application of this function to n *value* args+  -- always cheap, assuming the arguments are cheap?+  -- True mainly of data constructors, partial applications;+  -- but with minor variations:+  --    isWorkFreeApp+  --    isCheapApp+  --    isExpandableApp -exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool+exprIsCheapX :: CheapAppFun -> Bool -> CoreExpr -> Bool {-# INLINE exprIsCheapX #-}--- allow specialization of exprIsCheap and exprIsWorkFree+-- allow specialization of exprIsCheap, exprIsWorkFree and exprIsExpandable -- instead of having an unknown call to ok_app-exprIsCheapX ok_app e+-- expandable=True <=> Treat Case and Let as cheap, if their sub-expressions are.+--                     This flag is set for exprIsExpandable+exprIsCheapX ok_app expandable e   = ok e   where     ok e = go 0 e@@ -1519,7 +1528,7 @@     go _ (Type {})                    = True     go _ (Coercion {})                = True     go n (Cast e _)                   = go n e-    go n (Case scrut _ _ alts)        = ok scrut &&+    go n (Case scrut _ _ alts)        = not expandable && ok scrut &&                                         and [ go n rhs | Alt _ _ rhs <- alts ]     go n (Tick t e) | tickishCounts t = False                     | otherwise       = go n e@@ -1527,90 +1536,26 @@                     | otherwise       = go n e     go n (App f e)  | isRuntimeArg e  = go (n+1) f && ok e                     | otherwise       = go n f-    go n (Let (NonRec _ r) e)         = go n e && ok r-    go n (Let (Rec prs) e)            = go n e && all (ok . snd) prs+    go n (Let (NonRec _ r) e)         = not expandable && go n e && ok r+    go n (Let (Rec prs) e)            = not expandable && go n e && all (ok . snd) prs        -- Case: see Note [Case expressions are work-free]       -- App, Let: see Note [Arguments and let-bindings exprIsCheapX] --{- Note [exprIsExpandable]-~~~~~~~~~~~~~~~~~~~~~~~~~~-An expression is "expandable" if we are willing to duplicate it, if doing-so might make a RULE or case-of-constructor fire.  Consider-   let x = (a,b)-       y = build g-   in ....(case x of (p,q) -> rhs)....(foldr k z y)....--We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold),-but we do want-- * the case-expression to simplify-   (via exprIsConApp_maybe, exprIsLiteral_maybe)-- * the foldr/build RULE to fire-   (by expanding the unfolding during rule matching)--So we classify the unfolding of a let-binding as "expandable" (via the-uf_expandable field) if we want to do this kind of on-the-fly-expansion.  Specifically:--* True of constructor applications (K a b)--* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic.-  (NB: exprIsCheap might not be true of this)--* False of case-expressions.  If we have-    let x = case ... in ...(case x of ...)...-  we won't simplify.  We have to inline x.  See #14688.--* False of let-expressions (same reason); and in any case we-  float lets out of an RHS if doing so will reveal an expandable-  application (see SimplEnv.doFloatFromRhs).--* Take care: exprIsExpandable should /not/ be true of primops.  I-  found this in test T5623a:-    let q = /\a. Ptr a (a +# b)-    in case q @ Float of Ptr v -> ...q...+--------------------+exprIsWorkFree :: CoreExpr -> Bool+-- See Note [exprIsWorkFree]+exprIsWorkFree e = exprIsCheapX isWorkFreeApp False e -  q's inlining should not be expandable, else exprIsConApp_maybe will-  say that (q @ Float) expands to (Ptr a (a +# b)), and that will-  duplicate the (a +# b) primop, which we should not do lightly.-  (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.)--}+--------------------+exprIsCheap :: CoreExpr -> Bool+-- See Note [exprIsCheap]+exprIsCheap e = exprIsCheapX isCheapApp False e --------------------------------------+-------------------- exprIsExpandable :: CoreExpr -> Bool -- See Note [exprIsExpandable]-exprIsExpandable e-  = ok e-  where-    ok e = go 0 e--    -- n is the number of value arguments-    go n (Var v)                      = isExpandableApp v n-    go _ (Lit {})                     = True-    go _ (Type {})                    = True-    go _ (Coercion {})                = True-    go n (Cast e _)                   = go n e-    go n (Tick t e) | tickishCounts t = False-                    | otherwise       = go n e-    go n (Lam x e)  | isRuntimeVar x  = n==0 || go (n-1) e-                    | otherwise       = go n e-    go n (App f e)  | isRuntimeArg e  = go (n+1) f && ok e-                    | otherwise       = go n f-    go _ (Case {})                    = False-    go _ (Let {})                     = False-----------------------------------------type CheapAppFun = Id -> Arity -> Bool-  -- Is an application of this function to n *value* args-  -- always cheap, assuming the arguments are cheap?-  -- True mainly of data constructors, partial applications;-  -- but with minor variations:-  --    isWorkFreeApp-  --    isCheapApp+exprIsExpandable e = exprIsCheapX isExpandableApp True e  isWorkFreeApp :: CheapAppFun isWorkFreeApp fn n_val_args@@ -1630,7 +1575,7 @@   | isDeadEndId fn              = True  -- See Note [isCheapApp: bottoming functions]   | otherwise   = case idDetails fn of-      DataConWorkId {} -> True  -- Actually handled by isWorkFreeApp+      -- DataConWorkId {} -> _  -- Handled by isWorkFreeApp       RecSelId {}      -> n_val_args == 1  -- See Note [Record selection]       ClassOpId {}     -> n_val_args == 1       PrimOpId op _    -> primOpIsCheap op@@ -1645,6 +1590,7 @@   | isWorkFreeApp fn n_val_args = True   | otherwise   = case idDetails fn of+      -- DataConWorkId {} -> _  -- Handled by isWorkFreeApp       RecSelId {}  -> n_val_args == 1  -- See Note [Record selection]       ClassOpId {} -> n_val_args == 1       PrimOpId {}  -> False@@ -1676,6 +1622,50 @@ I'm not sure why we have a special case for bottoming functions in isCheapApp.  Maybe we don't need it. +Note [exprIsExpandable]+~~~~~~~~~~~~~~~~~~~~~~~+An expression is "expandable" if we are willing to duplicate it, if doing+so might make a RULE or case-of-constructor fire.  Consider+   let x = (a,b)+       y = build g+   in ....(case x of (p,q) -> rhs)....(foldr k z y)....++We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold),+but we do want++ * the case-expression to simplify+   (via exprIsConApp_maybe, exprIsLiteral_maybe)++ * the foldr/build RULE to fire+   (by expanding the unfolding during rule matching)++So we classify the unfolding of a let-binding as "expandable" (via the+uf_expandable field) if we want to do this kind of on-the-fly+expansion.  Specifically:++* True of constructor applications (K a b)++* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic.+  (NB: exprIsCheap might not be true of this)++* False of case-expressions.  If we have+    let x = case ... in ...(case x of ...)...+  we won't simplify.  We have to inline x.  See #14688.++* False of let-expressions (same reason); and in any case we+  float lets out of an RHS if doing so will reveal an expandable+  application (see SimplEnv.doFloatFromRhs).++* Take care: exprIsExpandable should /not/ be true of primops.  I+  found this in test T5623a:+    let q = /\a. Ptr a (a +# b)+    in case q @ Float of Ptr v -> ...q...++  q's inlining should not be expandable, else exprIsConApp_maybe will+  say that (q @ Float) expands to (Ptr a (a +# b)), and that will+  duplicate the (a +# b) primop, which we should not do lightly.+  (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.)+ Note [isExpandableApp: bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's important that isExpandableApp does not respond True to bottoming@@ -1719,14 +1709,31 @@ So we treat the application of a function (negate in this case) to a *dictionary* as expandable.  In effect, every function is CONLIKE when it's applied only to dictionaries.+-} +isUnaryClassId :: Id -> Bool+-- True of (a) the method selector (classop)+--         (b) the dictionary data constructor+-- of a unary class+isUnaryClassId v+  | Just cls <- isClassOpId_maybe v     = isUnaryClass cls+  | Just dc  <- isDataConWorkId_maybe v = isUnaryClassDataCon dc+  | otherwise                           = False -************************************************************************+exprIsUnaryClassFun :: CoreExpr -> Bool+-- True of an a type application (f @t1 .. @tn),+-- where `f` is a unary-class-id+-- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon+exprIsUnaryClassFun (App f (Type {}))       = exprIsUnaryClassFun f+exprIsUnaryClassFun (Var v)                 = isUnaryClassId v+exprIsUnaryClassFun _                       = False+++{- ********************************************************************* *                                                                      *              exprOkForSpeculation *                                                                      *-************************************************************************--}+********************************************************************* -}  ----------------------------- -- | To a first approximation, 'exprOkForSpeculation' returns True of@@ -1856,7 +1863,7 @@         _ -> False  ------------------------------app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool+app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreArg] -> Bool app_ok fun_ok primop_ok fun args   | not (fun_ok fun)   = False -- This code path is only taken for Note [Speculative evaluation]@@ -1867,17 +1874,16 @@    | otherwise   = case idDetails fun of-      DFunId new_type -> not new_type+      DFunId unary_class -> not unary_class          -- DFuns terminate, unless the dict is implemented-         -- with a newtype in which case they may not+         -- by a no-op in which case they may not+         -- See (UCM3) in Note [Unary class magic] in GHC.Core.TyCon -      DataConWorkId {} -> args_ok-                -- The strictness of the constructor has already-                -- been expressed by its "wrapper", so we don't need-                -- to take the arguments into account-                   -- Well, we thought so.  But it's definitely wrong!-                   -- See #20749 and Note [How untagged pointers can-                   -- end up in strict fields] in GHC.Stg.InferTags+      DataConWorkId dc+        | isLazyDataConRep dc+        -> args_ok+        | otherwise+        -> fields_ok (dataConRepStrictness dc)        ClassOpId _ is_terminating_result         | is_terminating_result -- See Note [exprOkForSpeculation and type classes]@@ -1888,10 +1894,10 @@        PrimOpId op _         | primOpIsDiv op-        , Lit divisor <- last args+        , Lit divisor <- Partial.last args             -- there can be 2 args (most div primops) or 3 args             -- (WordQuotRem2Op), hence the use of last/init-        -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) (init args)+        -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) (Partial.init args)               -- Special case for dividing operations that fail               -- In general they are NOT ok-for-speculation               -- (which primop_ok will catch), but they ARE OK@@ -1927,7 +1933,7 @@      -- Even if a function call itself is OK, any unlifted     -- args are still evaluated eagerly and must be checked-    args_ok = and (zipWith arg_ok arg_tys args)+    args_ok = all2Prefix arg_ok arg_tys args     arg_ok :: PiTyVarBinder -> CoreExpr -> Bool     arg_ok (Named _) _ = True   -- A type argument     arg_ok (Anon ty _) arg      -- A term argument@@ -1936,6 +1942,18 @@        | otherwise        = expr_ok fun_ok primop_ok arg +    -- Used for strict DataCon worker arguments+    -- See (SFC1) of Note [Strict fields in Core]+    fields_ok str_marks = all3Prefix field_ok arg_tys str_marks args+    field_ok :: PiTyVarBinder -> StrictnessMark -> CoreExpr -> Bool+    field_ok (Named _)   _   _ = True+    field_ok (Anon ty _) str arg+       | NotMarkedStrict <- str                 -- iff it's a lazy field+       , definitelyLiftedType (scaledThing ty)  -- and its type is lifted+       = True                                   -- then the worker app does not eval+       | otherwise+       = expr_ok fun_ok primop_ok arg+ ----------------------------- altsAreExhaustive :: [Alt b] -> Bool -- True  <=> the case alternatives are definitely exhaustive@@ -2132,6 +2150,7 @@ -- and in so doing makes the binding lazy. -- -- So, it does /not/ treat variables as evaluated, unless they say they are.+-- -- However, it /does/ treat partial applications and constructor applications -- as values, even if their arguments are non-trivial, provided the argument -- type is lifted. For example, both of these are values:@@ -2161,12 +2180,14 @@ -- or PAPs. -- exprIsHNFlike :: HasDebugCallStack => (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool-exprIsHNFlike is_con is_con_unf = is_hnf_like+exprIsHNFlike is_con is_con_unf e+  = -- pprTraceWith "hnf" (\r -> ppr r <+> ppr e) $+    is_hnf_like e   where     is_hnf_like (Var v) -- NB: There are no value args at this point-      =  id_app_is_value v 0 -- Catches nullary constructors,-                             --      so that [] and () are values, for example-                             -- and (e.g.) primops that don't have unfoldings+      =  id_app_is_value v [] -- Catches nullary constructors,+                              --      so that [] and () are values, for example+                              -- and (e.g.) primops that don't have unfoldings       || is_con_unf (idUnfolding v)         -- Check the thing's unfolding; it might be bound to a value         --   or to a guaranteed-evaluated variable (isEvaldUnfolding)@@ -2190,7 +2211,7 @@                                       -- See Note [exprIsHNF Tick]     is_hnf_like (Cast e _)       = is_hnf_like e     is_hnf_like (App e a)-      | isValArg a               = app_is_value e 1+      | isValArg a               = app_is_value e [a]       | otherwise                = is_hnf_like e     is_hnf_like (Let _ e)        = is_hnf_like e  -- Lazy let(rec)s don't affect us     is_hnf_like (Case e b _ as)@@ -2198,27 +2219,71 @@       = is_hnf_like rhs     is_hnf_like _                = False -    -- 'n' is the number of value args to which the expression is applied-    -- And n>0: there is at least one value argument-    app_is_value :: CoreExpr -> Int -> Bool-    app_is_value (Var f)    nva = id_app_is_value f nva-    app_is_value (Tick _ f) nva = app_is_value f nva-    app_is_value (Cast f _) nva = app_is_value f nva-    app_is_value (App f a)  nva-      | isValArg a              =-        app_is_value f (nva + 1) &&-        not (needsCaseBinding (exprType a) a)-          -- For example  f (x /# y)  where f has arity two, and the first-          -- argument is unboxed. This is not a value!-          -- But  f 34#  is a value.-          -- NB: Check app_is_value first, the arity check is cheaper-      | otherwise               = app_is_value f nva-    app_is_value _          _   = False+    -- Collect arguments through Casts and Ticks and call id_app_is_value+    app_is_value :: CoreExpr -> [CoreArg] -> Bool+    app_is_value (Var f)    as = id_app_is_value f as+    app_is_value (Tick _ f) as = app_is_value f as+    app_is_value (Cast f _) as = app_is_value f as+    app_is_value (App f a)  as | isValArg a = app_is_value f (a:as)+                               | otherwise  = app_is_value f as+    app_is_value _          _  = False -    id_app_is_value id n_val_args-       = is_con id-       || idArity id > n_val_args+    id_app_is_value id val_args+      | Just dc <- isDataConWorkId_maybe id+      , isUnaryClassDataCon  dc+      = all is_hnf_like val_args  -- Look through unary class data cons+      | otherwise+      -- See Note [exprIsHNF for function applications]+      --   for the specification and examples+      = case compare (idArity id) (length val_args) of+          EQ | is_con id ->      -- Saturated app of a DataCon/CONLIKE Id+            case mb_str_marks id of+              Just str_marks ->  -- with strict fields; see (SFC1) of Note [Strict fields in Core]+                assert (val_args `equalLength` str_marks) $+                fields_hnf str_marks+              Nothing ->         -- without strict fields: like PAP+                args_hnf         -- NB: CONLIKEs are lazy! +          GT ->                  -- PAP: Check unlifted val_args+            args_hnf++          _  -> False++      where+        -- Saturated, Strict DataCon: Check unlifted val_args and strict fields+        fields_hnf str_marks = all3Prefix check_field val_arg_tys str_marks val_args++        -- PAP: Check unlifted val_args+        args_hnf             = all2Prefix check_arg   val_arg_tys           val_args++        fun_ty = idType id+        val_arg_tys = mapMaybe anonPiTyBinderType_maybe (collectPiTyBinders fun_ty)+          -- val_arg_tys = map exprType val_args, but much less costly.+          -- The obvious definition regresses T16577 by 30% so we don't do it.++        check_arg a_ty a+          | mightBeUnliftedType a_ty = is_hnf_like a+          | otherwise                = True+         -- Check unliftedness; for example f (x /# 12#) where f has arity two,+         -- and the first argument is unboxed. This is not a value!+         -- But  f 34#  is a value, so check args for HNFs.+         -- NB: We check arity (and CONLIKEness) first because it's cheaper+         --     and we reject quickly on saturated apps.+        check_field a_ty str a+          | mightBeUnliftedType a_ty = is_hnf_like a+          | isMarkedStrict str       = is_hnf_like a+          | otherwise                = True+          -- isMarkedStrict: Respect Note [Strict fields in Core]++        mb_str_marks id+          | Just dc <- isDataConWorkId_maybe id+          , not (isLazyDataConRep dc)+          = Just (dataConRepStrictness dc)+          | otherwise+          = Nothing++{-# INLINE exprIsHNFlike #-}+ {- Note [exprIsHNF Tick] ~~~~~~~~~~~~~~~~~~~~~@@ -2232,6 +2297,58 @@ regarded as HNF if the expression they surround is HNF, because the tick is there to tell us that the expression was evaluated, so we don't want to discard a seq on it.++Note [exprIsHNF for function applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider an application with an Id head where the argument is a redex:++  f <redex>++Is this expression a value?++The answer depends on the type of `f`, its arity and whether or not it is a+strict data constructor. The decision diagram is as follows:++* If <redex> is unlifted, it is *not* a value (regardless of arity!)+* Otherwise, <redex> is lifted.+  Does its `idArity` (a lower bound on the actual arity)+  exceed the number of actual arguments (= 1)?+  * If so, it is a PAP and thus a value+  * If not, it is a saturated call.+    Is it a lazy data constructor?   Then it is a value.+    Is it a strict data constructor? Then it is *not* a value. (See also Note [Strict fields in Core].)+    Otherwise, it is a regular, possibly saturated function call, and hence *not* a value.++The code in exprIsHNF is tweaked for efficiency, hence it delays the+unliftedness check after the arity check.++Here are a few examples (enshrined in testcase AppIsHNF) to bring home this+point. Let us say that++  f :: Int# -> Int -> Int -> Int, with idArity 3+  expensive# :: Int -> Int#  -- unlifted result+  expensive  :: Int -> Int   -- lifted result+  data T where+    K1 :: !Int -> Int -> T -- strict field+    K2 :: Int# -> Int -> T -- unlifted field++Now consider++  f (expensive# 1) 2    -- Not HNF+  f 1# (expensive 2)    -- HNF++  K1 1 (expensive 2)   -- HNF+  K1 (expensive 1) 2   -- Not HNF+  K1 (expensive 1)     -- HNF      (!)++  K2 1# (expensive 1)   -- HNF+  K2 (expensive# 1) 2   -- Not HNF+  K2 (expensive# 1)     -- Not HNF (!)++Note that the cases marked (!) exemplify that strict fields are different to+unlifted fields when considering partial applications: Unlifted fields are+evaluated eagerly whereas evaluation of strict fields is delayed until the call+is saturated. -}  -- | Can we bind this 'CoreExpr' at the top level?@@ -2403,11 +2520,10 @@  -- Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool-eqTickish env (Breakpoint lext lid lids lmod) (Breakpoint rext rid rids rmod)+eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids)       = lid == rid &&         map (rnOccL env) lids == map (rnOccR env) rids &&-        lext == rext &&-        lmod == rmod+        lext == rext eqTickish _ l r = l == r  -- | Finds differences between core bindings, see @diffExpr@.@@ -2607,11 +2723,16 @@ -- | If @normSplitTyConApp_maybe _ ty = Just (tc, tys, co)@ -- then @ty |> co = tc tys@. It's 'splitTyConApp_maybe', but looks through -- coercions via 'topNormaliseType_maybe'. Hence the \"norm\" prefix.+--+-- Postcondition: tc is not a newtype (guaranteed by topNormaliseType_maybe) normSplitTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion) normSplitTyConApp_maybe fam_envs ty   | let Reduction co ty1 = topNormaliseType_maybe fam_envs ty                            `orElse` (mkReflRedn Representational ty)   , Just (tc, tc_args) <- splitTyConApp_maybe ty1+  , not (isNewTyCon tc)  -- How can tc be a newtype, after `topNormaliseType`?+                         -- Answer: if it is a recursive newtype, `topNormaliseType`+                         --         may be a no-op.   Example: tc226   = Just (tc, tc_args, co) normSplitTyConApp_maybe _ _ = Nothing @@ -2779,7 +2900,7 @@  The downside is that the caller of $wfoo potentially has to evaluate `y` once if we can't prove it isn't already evaluated. But y coming out of a strict field is in WHNF so safe to evaluated. And most of the time it will be properly tagged+evaluated-already at the call site because of the Strict Field Invariant! See Note [Strict Field Invariant] for more in this.+already at the call site because of the EPT Invariant! See Note [EPT enforcement] for more in this. This makes GHC itself around 1% faster despite doing slightly more work! So this is generally quite good.  We only apply this when we think there is a benefit in doing so however. There are a number of cases in which@@ -2872,7 +2993,7 @@  5) Functions -Functions are tricky (see Note [TagInfo of functions] in InferTags).+Functions are tricky (see Note [TagInfo of functions] in EnforceEpt). But the gist of it even if we make a higher order function argument strict we can't avoid the tag check when it's used later in the body. So there is no benefit.@@ -2904,7 +3025,7 @@   -- See Note [Which Ids should be strictified] point 2)   , mightBeLiftedType ty   -- Functions sometimes get a zero tag so we can't eliminate the tag check.-  -- See Note [TagInfo of functions] in InferTags.+  -- See Note [TagInfo of functions] in EnforceEpt.   -- See Note [Which Ids should be strictified] point 5)   , not $ isFunTy ty   -- If the var is strict already a seq is redundant.
compiler/GHC/CoreToIface.hs view
@@ -43,16 +43,13 @@     , toIfaceVar       -- * Other stuff     , toIfaceLFInfo-      -- * CgBreakInfo-    , dehydrateCgBreakInfo+    , toIfaceBooleanFormula     ) where  import GHC.Prelude  import GHC.StgToCmm.Types -import GHC.ByteCode.Types- import GHC.Core import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom@@ -62,13 +59,14 @@ import GHC.Core.PatSyn import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Compare( eqType )-import GHC.Core.TyCo.Tidy ( tidyCo )+import GHC.Core.TyCo.Tidy  import GHC.Builtin.Types.Prim ( eqPrimTyCon, eqReprPrimTyCon ) import GHC.Builtin.Types ( heqTyCon )  import GHC.Iface.Syntax import GHC.Data.FastString+import GHC.Data.BooleanFormula qualified as BF(BooleanFormula(..))  import GHC.Types.Id import GHC.Types.Id.Info@@ -82,11 +80,14 @@ import GHC.Types.Tickish import GHC.Types.Demand ( isNopSig ) import GHC.Types.Cpr ( topCprSig )+import GHC.Types.SrcLoc (unLoc)  import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Hs.Extension (GhcRn)+ import Data.Maybe ( isNothing, catMaybes )  {- Note [Avoiding space leaks in toIface*]@@ -430,7 +431,7 @@ toIfaceBang _   (HsStrict _)         = IfStrict  toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang-toIfaceSrcBang (HsSrcBang _ (HsBang unpk bang)) = IfSrcBang unpk bang+toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang  toIfaceLetBndr :: Id -> IfaceLetBndr toIfaceLetBndr id  = IfLetBndr (mkIfLclName (occNameFS (getOccName id)))@@ -537,6 +538,14 @@   , isStableSource src = IfWhen arity unsat_ok boring_ok   | otherwise          = IfNoGuidance +toIfaceBooleanFormula :: BF.BooleanFormula GhcRn -> IfaceBooleanFormula+toIfaceBooleanFormula = go+  where+    go (BF.Var nm   ) = IfVar    $ mkIfLclName . getOccFS . unLoc $  nm+    go (BF.And bfs  ) = IfAnd    $ map (go . unLoc) bfs+    go (BF.Or bfs   ) = IfOr     $ map (go . unLoc) bfs+    go (BF.Parens bf) = IfParens $     (go . unLoc) bf+ {- ************************************************************************ *                                                                      *@@ -573,8 +582,8 @@ toIfaceTickish (HpcTick modl ix)       = IfaceHpcTick modl ix toIfaceTickish (SourceNote src (LexicalFastString names)) =   IfaceSource src names-toIfaceTickish (Breakpoint _ ix fv m) =-  IfaceBreakpoint ix (toIfaceVar <$> fv) m+toIfaceTickish (Breakpoint _ ix fv) =+  IfaceBreakpoint ix (toIfaceVar <$> fv)  --------------------- toIfaceBind :: Bind Id -> IfaceBinding IfaceLetBndr@@ -689,16 +698,7 @@     LFLetNoEscape ->       panic "toIfaceLFInfo: LFLetNoEscape" --- Dehydrating CgBreakInfo -dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> CgBreakInfo-dehydrateCgBreakInfo ty_vars idOffSets tick_ty =-          CgBreakInfo-            { cgb_tyvars = map toIfaceTvBndr ty_vars-            , cgb_vars = map (fmap (\(i, offset) -> (toIfaceIdBndr i, offset))) idOffSets-            , cgb_resty = toIfaceType tick_ty-            }- {- Note [Inlining and hs-boot files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this example (#10083, #12789):@@ -785,9 +785,9 @@  * When creating the interface, check the criteria above and don't serialise the RHS   if such a case.-  See-* When reading an interface, look at the realIdUnfolding, and then the unfoldingTemplate.-  See `tc_iface_binding` for where this happens.++* When reading an interface, look at the realIdUnfolding, and then the+  maybeUnfoldingTemplate.  See `tc_iface_binding` for where this happens.  There are two main reasons why the mi_extra_decls field exists rather than shoe-horning all the core bindings
compiler/GHC/Data/Bag.hs view
@@ -16,7 +16,7 @@         mapBag, pprBag,         elemBag, lengthBag,         filterBag, partitionBag, partitionBagWith,-        concatBag, catBagMaybes, foldBag,+        concatBag, catBagMaybes, foldBag_flip,         isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag,         listToBag, nonEmptyToBag, bagToList, headMaybe, mapAccumBagL,         concatMapBag, concatMapBagPair, mapMaybeBag, mapMaybeBagM, unzipBag,@@ -194,24 +194,10 @@ partitionBagWith pred (ListBag vs) = (listToBag sats, listToBag fails)   where (sats, fails) = partitionWith pred (toList vs) -foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative-        -> (a -> r)      -- Replace UnitBag with this-        -> r             -- Replace EmptyBag with this-        -> Bag a-        -> r--{- Standard definition-foldBag t u e EmptyBag        = e-foldBag t u e (UnitBag x)     = u x-foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2)-foldBag t u e (ListBag xs)    = foldr (t.u) e xs--}---- More tail-recursive definition, exploiting associativity of "t"-foldBag _ _ e EmptyBag        = e-foldBag t u e (UnitBag x)     = u x `t` e-foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1-foldBag t u e (ListBag xs)    = foldr (t.u) e xs+foldBag_flip :: (a -> b -> b) -> Bag a -> b -> b+-- Just foldr with flipped arguments,+-- so it can be chained more nicely+foldBag_flip k bag z = foldr k z bag  mapBag :: (a -> b) -> Bag a -> Bag b mapBag = fmap
compiler/GHC/Data/BooleanFormula.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveTraversable  #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}  -------------------------------------------------------------------------------- -- | Boolean formulas without quantifiers and without negation.@@ -8,75 +9,64 @@ -- This module is used to represent minimal complete definitions for classes. -- module GHC.Data.BooleanFormula (-        BooleanFormula(..), LBooleanFormula,-        mkFalse, mkTrue, mkAnd, mkOr, mkVar,+        module Language.Haskell.Syntax.BooleanFormula,         isFalse, isTrue,+        bfMap, bfTraverse,         eval, simplify, isUnsatisfied,         implies, impliesAtom,-        pprBooleanFormula, pprBooleanFormulaNice+        pprBooleanFormula, pprBooleanFormulaNice, pprBooleanFormulaNormal   ) where -import GHC.Prelude hiding ( init, last )--import Data.List ( nub, intersperse )+import Data.List ( intersperse ) import Data.List.NonEmpty ( NonEmpty (..), init, last )-import Data.Data -import GHC.Utils.Monad-import GHC.Utils.Outputable-import GHC.Parser.Annotation ( LocatedL )-import GHC.Types.SrcLoc+import GHC.Prelude hiding ( init, last ) import GHC.Types.Unique import GHC.Types.Unique.Set+import GHC.Types.SrcLoc (unLoc)+import GHC.Utils.Outputable+import GHC.Parser.Annotation ( SrcSpanAnnL )+import GHC.Hs.Extension (GhcPass (..), OutputableBndrId)+import Language.Haskell.Syntax.Extension (Anno, LIdP, IdP)+import Language.Haskell.Syntax.BooleanFormula + ---------------------------------------------------------------------- -- Boolean formula type and smart constructors ---------------------------------------------------------------------- -type LBooleanFormula a = LocatedL (BooleanFormula a)--data BooleanFormula a = Var a | And [LBooleanFormula a] | Or [LBooleanFormula a]-                      | Parens (LBooleanFormula a)-  deriving (Eq, Data, Functor, Foldable, Traversable)--mkVar :: a -> BooleanFormula a-mkVar = Var--mkFalse, mkTrue :: BooleanFormula a-mkFalse = Or []-mkTrue = And []+type instance Anno (BooleanFormula (GhcPass p)) = SrcSpanAnnL --- Convert a Bool to a BooleanFormula-mkBool :: Bool -> BooleanFormula a-mkBool False = mkFalse-mkBool True  = mkTrue+-- if we had Functor/Traversable (LbooleanFormula p) we could use that+-- as a constraint and we wouldn't need to specialize to just GhcPass p,+-- but becuase LBooleanFormula is a type synonym such a constraint is+-- impossible. --- Make a conjunction, and try to simplify-mkAnd :: Eq a => [LBooleanFormula a] -> BooleanFormula a-mkAnd = maybe mkFalse (mkAnd' . nub) . concatMapM fromAnd+-- BooleanFormula can't be an instance of functor because it can't lift+-- arbitrary functions `a -> b`, only functions of type `LIdP a -> LIdP b`+-- ditto for Traversable.+bfMap :: (LIdP (GhcPass p) -> LIdP (GhcPass p'))+      -> BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p')+bfMap f = go   where-  -- See Note [Simplification of BooleanFormulas]-  fromAnd :: LBooleanFormula a -> Maybe [LBooleanFormula a]-  fromAnd (L _ (And xs)) = Just xs-     -- assume that xs are already simplified-     -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs-  fromAnd (L _ (Or [])) = Nothing-     -- in case of False we bail out, And [..,mkFalse,..] == mkFalse-  fromAnd x = Just [x]-  mkAnd' [x] = unLoc x-  mkAnd' xs = And xs+    go (Var    a  ) = Var     $ f a+    go (And    bfs) = And     $ map (fmap go) bfs+    go (Or     bfs) = Or      $ map (fmap go) bfs+    go (Parens bf ) = Parens  $ fmap go bf -mkOr :: Eq a => [LBooleanFormula a] -> BooleanFormula a-mkOr = maybe mkTrue (mkOr' . nub) . concatMapM fromOr+bfTraverse  :: Applicative f+            => (LIdP (GhcPass p) -> f (LIdP (GhcPass p')))+            -> BooleanFormula (GhcPass p)+            -> f (BooleanFormula (GhcPass p'))+bfTraverse f = go   where-  -- See Note [Simplification of BooleanFormulas]-  fromOr (L _ (Or xs)) = Just xs-  fromOr (L _ (And [])) = Nothing-  fromOr x = Just [x]-  mkOr' [x] = unLoc x-  mkOr' xs = Or xs+    go (Var    a  ) = Var    <$> f a+    go (And    bfs) = And    <$> traverse @[] (traverse go) bfs+    go (Or     bfs) = Or     <$> traverse @[] (traverse go) bfs+    go (Parens bf ) = Parens <$> traverse go bf  + {- Note [Simplification of BooleanFormulas] ~~~~~~~~~~~~~~~~~~~~~~@@ -115,15 +105,15 @@ -- Evaluation and simplification ---------------------------------------------------------------------- -isFalse :: BooleanFormula a -> Bool+isFalse :: BooleanFormula (GhcPass p) -> Bool isFalse (Or []) = True isFalse _ = False -isTrue :: BooleanFormula a -> Bool+isTrue :: BooleanFormula (GhcPass p) -> Bool isTrue (And []) = True isTrue _ = False -eval :: (a -> Bool) -> BooleanFormula a -> Bool+eval :: (LIdP (GhcPass p) -> Bool) -> BooleanFormula (GhcPass p) -> Bool eval f (Var x)  = f x eval f (And xs) = all (eval f . unLoc) xs eval f (Or xs)  = any (eval f . unLoc) xs@@ -131,18 +121,24 @@  -- Simplify a boolean formula. -- The argument function should give the truth of the atoms, or Nothing if undecided.-simplify :: Eq a => (a -> Maybe Bool) -> BooleanFormula a -> BooleanFormula a+simplify :: forall p. Eq (LIdP (GhcPass p))+          => (LIdP (GhcPass p) ->  Maybe Bool)+          -> BooleanFormula (GhcPass p)+          -> BooleanFormula (GhcPass p) simplify f (Var a) = case f a of   Nothing -> Var a   Just b  -> mkBool b-simplify f (And xs) = mkAnd (map (\(L l x) -> L l (simplify f x)) xs)-simplify f (Or xs) = mkOr (map (\(L l x) -> L l (simplify f x)) xs)+simplify f (And xs) = mkAnd (map (fmap (simplify f)) xs)+simplify f (Or xs)  = mkOr  (map (fmap (simplify f)) xs) simplify f (Parens x) = simplify f (unLoc x)  -- Test if a boolean formula is satisfied when the given values are assigned to the atoms -- if it is, returns Nothing -- if it is not, return (Just remainder)-isUnsatisfied :: Eq a => (a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a)+isUnsatisfied :: Eq (LIdP (GhcPass p))+              => (LIdP (GhcPass p) -> Bool)+              -> BooleanFormula (GhcPass p)+              -> Maybe (BooleanFormula (GhcPass p)) isUnsatisfied f bf     | isTrue bf' = Nothing     | otherwise  = Just bf'@@ -155,42 +151,42 @@ --   eval f x == False  <==>  isFalse (simplify (Just . f) x)  -- If the boolean formula holds, does that mean that the given atom is always true?-impliesAtom :: Eq a => BooleanFormula a -> a -> Bool-Var x  `impliesAtom` y = x == y-And xs `impliesAtom` y = any (\x -> (unLoc x) `impliesAtom` y) xs+impliesAtom :: Eq (IdP (GhcPass p)) => BooleanFormula (GhcPass p) -> LIdP (GhcPass p) -> Bool+Var x  `impliesAtom` y = (unLoc x) == (unLoc y)+And xs `impliesAtom` y = any (\x -> unLoc x `impliesAtom` y) xs            -- we have all of xs, so one of them implying y is enough-Or  xs `impliesAtom` y = all (\x -> (unLoc x) `impliesAtom` y) xs-Parens x `impliesAtom` y = (unLoc x) `impliesAtom` y+Or  xs `impliesAtom` y = all (\x -> unLoc x `impliesAtom` y) xs+Parens x `impliesAtom` y = unLoc x `impliesAtom` y -implies :: Uniquable a => BooleanFormula a -> BooleanFormula a -> Bool+implies :: (Uniquable (IdP (GhcPass p))) => BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p) -> Bool implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2])   where-    go :: Uniquable a => Clause a -> Clause a -> Bool+    go :: Uniquable (IdP (GhcPass p)) => Clause (GhcPass p) -> Clause (GhcPass p) -> Bool     go l@Clause{ clauseExprs = hyp:hyps } r =         case hyp of-            Var x | memberClauseAtoms x r -> True-                  | otherwise -> go (extendClauseAtoms l x) { clauseExprs = hyps } r+            Var x | memberClauseAtoms (unLoc x) r -> True+                  | otherwise -> go (extendClauseAtoms l (unLoc x)) { clauseExprs = hyps } r             Parens hyp' -> go l { clauseExprs = unLoc hyp':hyps }     r             And hyps'  -> go l { clauseExprs = map unLoc hyps' ++ hyps } r             Or hyps'   -> all (\hyp' -> go l { clauseExprs = unLoc hyp':hyps } r) hyps'     go l r@Clause{ clauseExprs = con:cons } =         case con of-            Var x | memberClauseAtoms x l -> True-                  | otherwise -> go l (extendClauseAtoms r x) { clauseExprs = cons }+            Var x | memberClauseAtoms (unLoc x) l -> True+                  | otherwise -> go l (extendClauseAtoms r (unLoc x)) { clauseExprs = cons }             Parens con' -> go l r { clauseExprs = unLoc con':cons }             And cons'   -> all (\con' -> go l r { clauseExprs = unLoc con':cons }) cons'             Or cons'    -> go l r { clauseExprs = map unLoc cons' ++ cons }     go _ _ = False  -- A small sequent calculus proof engine.-data Clause a = Clause {-        clauseAtoms :: UniqSet a,-        clauseExprs :: [BooleanFormula a]+data Clause p = Clause {+        clauseAtoms :: UniqSet (IdP p),+        clauseExprs :: [BooleanFormula p]     }-extendClauseAtoms :: Uniquable a => Clause a -> a -> Clause a+extendClauseAtoms :: Uniquable (IdP p) => Clause p -> IdP p -> Clause p extendClauseAtoms c x = c { clauseAtoms = addOneToUniqSet (clauseAtoms c) x } -memberClauseAtoms :: Uniquable a => a -> Clause a -> Bool+memberClauseAtoms :: Uniquable (IdP p) => IdP p -> Clause p -> Bool memberClauseAtoms x c = x `elementOfUniqSet` clauseAtoms c  ----------------------------------------------------------------------@@ -199,28 +195,29 @@  -- Pretty print a BooleanFormula, -- using the arguments as pretty printers for Var, And and Or respectively-pprBooleanFormula' :: (Rational -> a -> SDoc)-                   -> (Rational -> [SDoc] -> SDoc)-                   -> (Rational -> [SDoc] -> SDoc)-                   -> Rational -> BooleanFormula a -> SDoc+pprBooleanFormula'  :: (Rational -> LIdP (GhcPass p) -> SDoc)+                    -> (Rational -> [SDoc] -> SDoc)+                    -> (Rational -> [SDoc] -> SDoc)+                    -> Rational -> BooleanFormula (GhcPass p) -> SDoc pprBooleanFormula' pprVar pprAnd pprOr = go   where   go p (Var x)  = pprVar p x-  go p (And []) = cparen (p > 0) $ empty+  go p (And []) = cparen (p > 0) empty   go p (And xs) = pprAnd p (map (go 3 . unLoc) xs)   go _ (Or  []) = keyword $ text "FALSE"   go p (Or  xs) = pprOr p (map (go 2 . unLoc) xs)   go p (Parens x) = go p (unLoc x)  -- Pretty print in source syntax, "a | b | c,d,e"-pprBooleanFormula :: (Rational -> a -> SDoc) -> Rational -> BooleanFormula a -> SDoc+pprBooleanFormula :: (Rational -> LIdP (GhcPass p) -> SDoc)+                  -> Rational -> BooleanFormula (GhcPass p) -> SDoc pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr   where   pprAnd p = cparen (p > 3) . fsep . punctuate comma   pprOr  p = cparen (p > 2) . fsep . intersperse vbar  -- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"?-pprBooleanFormulaNice :: Outputable a => BooleanFormula a -> SDoc+pprBooleanFormulaNice :: Outputable (LIdP (GhcPass p)) => BooleanFormula (GhcPass p) -> SDoc pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0   where   pprVar _ = quotes . ppr@@ -230,14 +227,13 @@   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+instance OutputableBndrId p => Outputable (BooleanFormula (GhcPass p)) where   ppr = pprBooleanFormulaNormal -pprBooleanFormulaNormal :: (OutputableBndr a)-                        => BooleanFormula a -> SDoc+pprBooleanFormulaNormal :: OutputableBndrId p => BooleanFormula (GhcPass p) -> SDoc pprBooleanFormulaNormal = go   where-    go (Var x)    = pprPrefixOcc x+    go (Var x)    = pprPrefixOcc (unLoc x)     go (And xs)   = fsep $ punctuate comma (map (go . unLoc) xs)     go (Or [])    = keyword $ text "FALSE"     go (Or xs)    = fsep $ intersperse vbar (map (go . unLoc) xs)
compiler/GHC/Data/FastString.hs view
@@ -1,12 +1,20 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE CPP #-}  {-# OPTIONS_GHC -O2 -funbox-strict-fields #-}+#if MIN_VERSION_GLASGOW_HASKELL(9,8,0,0)+{-# OPTIONS_GHC -fno-unoptimized-core-for-interpreter #-}+#endif -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected+--+-- Also important, if you load this module into GHCi then the data representation of+-- FastString has to match that of the host compiler due to the shared FastString+-- table. Otherwise you will get segfaults when the table is consulted and the fields+-- from the FastString are in an incorrect order.  -- | -- There are two principal string types used internally by GHC:@@ -127,9 +135,6 @@ import qualified Data.ByteString.Char8    as BSC import qualified Data.ByteString.Unsafe   as BS import qualified Data.ByteString.Short    as SBS-#if !MIN_VERSION_bytestring(0,11,0)-import qualified Data.ByteString.Short.Internal as SBS-#endif import GHC.Data.ShortText (ShortText(..)) import Foreign.C import System.IO@@ -139,9 +144,7 @@  import Foreign -#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) import GHC.Conc.Sync    (sharedCAF)-#endif  import GHC.Exts import GHC.IO@@ -400,9 +403,6 @@    -- use the support wired into the RTS to share this CAF among all images of   -- libHSghc-#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)-  return tab-#else   sharedCAF tab getOrSetLibHSghcFastStringTable  -- from the 9.3 RTS; the previous RTS before might not have this symbol.  The@@ -410,7 +410,6 @@ -- or similar rather than use (odd parity) development versions. foreign import ccall unsafe "getOrSetLibHSghcFastStringTable"   getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a)-#endif  {- @@ -704,10 +703,6 @@ -- ----------------------------------------------------------------------------- -- under the carpet -#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-foreign import ccall unsafe "strlen"-  cstringLength# :: Addr# -> Int#-#endif  ptrStrLength :: Ptr Word8 -> Int {-# INLINE ptrStrLength #-}
compiler/GHC/Data/FastString/Env.hs view
@@ -82,7 +82,7 @@ filterFsEnv x y           = filterUFM x y mapMaybeFsEnv f x         = mapMaybeUFM f x -lookupFsEnv_NF env n = expectJust "lookupFsEnv_NF" (lookupFsEnv env n)+lookupFsEnv_NF env n = expectJust (lookupFsEnv env n)  strictMapFsEnv :: (a -> b) -> FastStringEnv a -> FastStringEnv b strictMapFsEnv = strictMapUFM
compiler/GHC/Data/FlatBag.hs view
@@ -8,13 +8,11 @@   , mappendFlatBag   -- * Construction   , fromList-  , fromSizedSeq+  , fromSmallArray   ) where  import GHC.Prelude -import GHC.Data.SizedSeq (SizedSeq, ssElts, sizeSS)- import Control.DeepSeq  import GHC.Data.SmallArray@@ -125,5 +123,10 @@ -- | Convert a 'SizedSeq' into its flattened representation. -- A 'FlatBag a' is more memory efficient than '[a]', if no further modification -- is necessary.-fromSizedSeq :: SizedSeq a -> FlatBag a-fromSizedSeq s = fromList (sizeSS s) (ssElts s)+fromSmallArray :: SmallArray a -> FlatBag a+fromSmallArray s = case sizeofSmallArray s of+                      0 -> EmptyFlatBag+                      1 -> UnitFlatBag (indexSmallArray s 0)+                      2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1)+                      _ -> FlatBag s+
compiler/GHC/Data/Graph/Directed.hs view
@@ -8,13 +8,14 @@  module GHC.Data.Graph.Directed (         Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,-        graphFromVerticesAndAdjacency,+        graphFromVerticesAndAdjacency, emptyGraph,          SCC(..), Node(..), G.flattenSCC, G.flattenSCCs,         stronglyConnCompG,         topologicalSortG,         verticesG, edgesG, hasVertexG,-        reachableG, reachablesG, transposeG, allReachable, allReachableCyclic, outgoingG,+        reachablesG,+        transposeG, outgoingG,         emptyG,          findCycle,@@ -43,7 +44,6 @@ -- removed them since they were not used anywhere in GHC. ------------------------------------------------------------------------------ - import GHC.Prelude  import GHC.Utils.Misc ( sortWith, count )@@ -60,14 +60,14 @@  import qualified Data.Graph as G import Data.Graph ( Vertex, Bounds, SCC(..) ) -- Used in the underlying representation-import Data.Tree import GHC.Types.Unique import GHC.Types.Unique.FM-import qualified Data.IntMap as IM-import qualified Data.IntSet as IS-import qualified Data.Map as M-import qualified Data.Set as S +-- The graph internals are defined in the .Internal module so they can be+-- imported by GHC.Data.Graph.Directed.Reachability while still allowing this+-- module to export it abstractly.+import GHC.Data.Graph.Directed.Internal+ {- ************************************************************************ *                                                                      *@@ -86,14 +86,6 @@         arranged densely in 0.n -} -data Graph node = Graph {-    gr_int_graph      :: IntGraph,-    gr_vertex_to_node :: Vertex -> node,-    gr_node_to_vertex :: node -> Maybe Vertex-  }--data Edge node = Edge node node- {-| Representation for nodes of the Graph.   * The @payload@ is user data, just carried around in this module@@ -357,51 +349,22 @@ topologicalSortG graph = map (gr_vertex_to_node graph) result   where result = {-# SCC "Digraph.topSort" #-} G.topSort (gr_int_graph graph) -reachableG :: Graph node -> node -> [node]-reachableG graph from = map (gr_vertex_to_node graph) result-  where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)-        result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex]- outgoingG :: Graph node -> node -> [node] outgoingG graph from = map (gr_vertex_to_node graph) result-  where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)+  where from_vertex = expectJust (gr_node_to_vertex graph from)         result = gr_int_graph graph ! from_vertex --- | Given a list of roots return all reachable nodes.+-- | Given a list of roots, return all reachable nodes in topological order.+-- Implemented using a depth-first traversal. reachablesG :: Graph node -> [node] -> [node] reachablesG graph froms = map (gr_vertex_to_node graph) result   where result = {-# SCC "Digraph.reachable" #-}                  reachable (gr_int_graph graph) vs         vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ] --- | Efficiently construct a map which maps each key to it's set of transitive--- dependencies. Only works on acyclic input.-allReachable :: Ord key => Graph node -> (node -> key) -> M.Map key (S.Set key)-allReachable = all_reachable reachableGraph---- | Efficiently construct a map which maps each key to it's set of transitive--- dependencies. Less efficient than @allReachable@, but works on cyclic input as well.-allReachableCyclic :: Ord key => Graph node -> (node -> key) -> M.Map key (S.Set key)-allReachableCyclic = all_reachable reachableGraphCyclic--all_reachable :: Ord key => (IntGraph -> IM.IntMap IS.IntSet) -> Graph node -> (node -> key) -> M.Map key (S.Set key)-all_reachable int_reachables (Graph g from _) keyOf =-  M.fromList [(k, IS.foldr (\v' vs -> keyOf (from v') `S.insert` vs) S.empty vs)-             | (v, vs) <- IM.toList int_graph-             , let k = keyOf (from v)]-  where-    int_graph = int_reachables g- hasVertexG :: Graph node -> node -> Bool hasVertexG graph node = isJust $ gr_node_to_vertex graph node -verticesG :: Graph node -> [node]-verticesG graph = map (gr_vertex_to_node graph) $ G.vertices (gr_int_graph graph)--edgesG :: Graph node -> [Edge node]-edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ G.edges (gr_int_graph graph)-  where v2n = gr_vertex_to_node graph- transposeG :: Graph node -> Graph node transposeG graph = Graph (G.transposeG (gr_int_graph graph))                          (gr_vertex_to_node graph)@@ -410,114 +373,12 @@ emptyG :: Graph node -> Bool emptyG g = graphEmpty (gr_int_graph g) -{--************************************************************************-*                                                                      *-*      Showing Graphs-*                                                                      *-************************************************************************--}--instance Outputable node => Outputable (Graph node) where-    ppr graph = vcat [-                  hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)),-                  hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph))-                ]--instance Outputable node => Outputable (Edge node) where-    ppr (Edge from to) = ppr from <+> text "->" <+> ppr to- graphEmpty :: G.Graph -> Bool graphEmpty g = lo > hi   where (lo, hi) = bounds g -{--************************************************************************-*                                                                      *-*      IntGraphs-*                                                                      *-************************************************************************--} -type IntGraph = G.Graph- {----------------------------------------------------------------- Depth first search numbering---------------------------------------------------------------}---- Data.Tree has flatten for Tree, but nothing for Forest-preorderF           :: Forest a -> [a]-preorderF ts         = concatMap flatten ts--{----------------------------------------------------------------- Finding reachable vertices---------------------------------------------------------------}---- This generalizes reachable which was found in Data.Graph-reachable    :: IntGraph -> [Vertex] -> [Vertex]-reachable g vs = preorderF (G.dfs g vs)--reachableGraph :: IntGraph -> IM.IntMap IS.IntSet-reachableGraph g = res-  where-    do_one v = IS.unions (IS.fromList (g ! v) : mapMaybe (flip IM.lookup res) (g ! v))-    res = IM.fromList [(v, do_one v) | v <- G.vertices g]--scc :: IntGraph -> [SCC Vertex]-scc graph = map decode forest-  where-    forest = {-# SCC "Digraph.scc" #-} G.scc graph--    decode (Node v []) | mentions_itself v = CyclicSCC [v]-                       | otherwise         = AcyclicSCC v-    decode other = CyclicSCC (dec other [])-      where dec (Node v ts) vs = v : foldr dec vs ts-    mentions_itself v = v `elem` (graph ! v)--reachableGraphCyclic :: IntGraph -> IM.IntMap IS.IntSet-reachableGraphCyclic g = foldl' add_one_comp mempty comps-  where-    neighboursOf v = g!v--    comps = scc g--    -- To avoid divergence on cyclic input, we build the result-    -- strongly connected component by component, in topological-    -- order. For each SCC, we know that:-    ---    --   * All vertices in the component can reach all other vertices-    --     in the component ("local" reachables)-    ---    --   * Other reachable vertices ("remote" reachables) must come-    --     from earlier components, either via direct neighbourhood, or-    --     transitively from earlier reachability map-    ---    -- This allows us to build the extension of the reachability map-    -- directly, without any self-reference, thereby avoiding a loop.-    add_one_comp :: IM.IntMap IS.IntSet -> SCC Vertex -> IM.IntMap IS.IntSet-    add_one_comp earlier (AcyclicSCC v) = IM.insert v all_remotes earlier-      where-        earlier_neighbours = neighboursOf v-        earlier_further = mapMaybe (flip IM.lookup earlier) earlier_neighbours-        all_remotes = IS.unions (IS.fromList earlier_neighbours : earlier_further)-    add_one_comp earlier (CyclicSCC vs) = IM.union (IM.fromList [(v, local v `IS.union` all_remotes) | v <- vs]) earlier-      where-        all_locals = IS.fromList vs-        local v = IS.delete v all_locals-            -- Arguably, for a cyclic SCC we should include each-            -- vertex in its own reachable set. However, this could-            -- lead to a lot of extra pain in client code to avoid-            -- looping when traversing the reachability map.-        all_neighbours = IS.fromList (concatMap neighboursOf vs)-        earlier_neighbours = all_neighbours IS.\\ all_locals-        earlier_further = mapMaybe (flip IM.lookup earlier) (IS.toList earlier_neighbours)-        all_remotes = IS.unions (earlier_neighbours : earlier_further)--{- ************************************************************************ *                                                                      * *                         Classify Edge Types@@ -619,7 +480,8 @@ graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vertex . key_extractor)   where key_extractor = node_key         (bounds, vertex_node, key_vertex, _) = reduceNodesIntoVerticesOrd vertices key_extractor-        key_vertex_pair (a, b) = (expectJust "graphFromVerticesAndAdjacency" $ key_vertex a,-                                  expectJust "graphFromVerticesAndAdjacency" $ key_vertex b)+        key_vertex_pair (a, b) = (expectJust $ key_vertex a,+                                  expectJust $ key_vertex b)         reduced_edges = map key_vertex_pair edges         graph = G.buildG bounds reduced_edges+
+ compiler/GHC/Data/Graph/Directed/Internal.hs view
@@ -0,0 +1,79 @@+module GHC.Data.Graph.Directed.Internal where++import GHC.Prelude+import GHC.Utils.Outputable++import Data.Array+import qualified Data.Graph as G+import Data.Graph ( Vertex, SCC(..) ) -- Used in the underlying representation+import Data.Tree++data Graph node = Graph {+    gr_int_graph      :: IntGraph,+    gr_vertex_to_node :: Vertex -> node,+    gr_node_to_vertex :: node -> Maybe Vertex+}++data Edge node = Edge node node++------------------------------------------------------------+-- Nodes and Edges+------------------------------------------------------------++verticesG :: Graph node -> [node]+verticesG graph = map (gr_vertex_to_node graph) $ G.vertices (gr_int_graph graph)++edgesG :: Graph node -> [Edge node]+edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ G.edges (gr_int_graph graph)+  where v2n = gr_vertex_to_node graph++------------------------------------------------------------+-- Showing Graphs+------------------------------------------------------------++instance Outputable node => Outputable (Graph node) where+    ppr graph = vcat [+                  hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)),+                  hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph))+                ]++instance Outputable node => Outputable (Edge node) where+    ppr (Edge from to) = ppr from <+> text "->" <+> ppr to++{-+************************************************************************+*                                                                      *+*      IntGraphs+*                                                                      *+************************************************************************+-}++type IntGraph = G.Graph++------------------------------------------------------------+-- Depth first search numbering+------------------------------------------------------------++-- Data.Tree has flatten for Tree, but nothing for Forest+preorderF           :: Forest a -> [a]+preorderF ts         = concatMap flatten ts++------------------------------------------------------------+-- Finding reachable vertices+------------------------------------------------------------++-- This generalizes reachable which was found in Data.Graph+reachable    :: IntGraph -> [Vertex] -> [Vertex]+reachable g vs = preorderF (G.dfs g vs)++scc :: IntGraph -> [SCC Vertex]+scc graph = map decode forest+  where+    forest = {-# SCC "Digraph.scc" #-} G.scc graph++    decode (Node v []) | mentions_itself v = CyclicSCC [v]+                       | otherwise         = AcyclicSCC v+    decode other = CyclicSCC (dec other [])+      where dec (Node v ts) vs = v : foldr dec vs ts+    mentions_itself v = v `elem` (graph ! v)+
+ compiler/GHC/Data/Graph/Directed/Reachability.hs view
@@ -0,0 +1,178 @@+-- | An abstract interface for a fast reachability data structure constructed+-- from a 'GHC.Data.Graph.Directed' graph.+module GHC.Data.Graph.Directed.Reachability+  ( ReachabilityIndex++  -- * Constructing a reachability index+  , graphReachability, cyclicGraphReachability++  -- * Reachability queries+  , allReachable, allReachableMany+  , isReachable, isReachableMany++  -- * Debugging+  , reachabilityIndexMembers++  )+  where++import GHC.Prelude+import GHC.Data.Maybe++import qualified Data.Graph as G+import Data.Graph ( Vertex, SCC(..) )++import Data.Array ((!))+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS++import GHC.Data.Graph.Directed.Internal++--------------------------------------------------------------------------------+-- * Reachability index+--------------------------------------------------------------------------------++-- | The abstract data structure for fast reachability queries+data ReachabilityIndex node = ReachabilityIndex {+    index :: IM.IntMap IS.IntSet,+    from_vertex :: Vertex -> node,+    to_vertex :: node -> Maybe Vertex+}++--+reachabilityIndexMembers :: ReachabilityIndex node -> [node]+reachabilityIndexMembers (ReachabilityIndex index from_vert _) = map from_vert (IM.keys index)++--------------------------------------------------------------------------------+-- * Construction+--------------------------------------------------------------------------------++-- | Construct a 'ReachabilityIndex' from an acyclic 'Graph'.+-- If the graph can have cycles, use 'cyclicGraphReachability'+graphReachability :: Graph node -> ReachabilityIndex node+graphReachability (Graph g from to) =+  ReachabilityIndex{index = reachableGraph, from_vertex = from, to_vertex = to}+    where+      reachableGraph :: IM.IntMap IS.IntSet+      reachableGraph = IM.fromList [(v, do_one v) | v <- G.vertices g]++      do_one v = IS.unions (IS.fromList (g ! v) : mapMaybe (flip IM.lookup reachableGraph) (g ! v))++-- | Construct a 'ReachabilityIndex' from a 'Graph' which may have cycles.+-- If this reachability index is just going to be used once, it may make sense+-- to use 'reachablesG' instead, which will traverse the reachable nodes without+-- constructing the index -- which may be faster.+cyclicGraphReachability :: Graph node -> ReachabilityIndex node+cyclicGraphReachability (Graph g from to) =+  ReachabilityIndex{index = reachableGraphCyclic, from_vertex = from, to_vertex = to}+    where+      reachableGraphCyclic :: IM.IntMap IS.IntSet+      reachableGraphCyclic = foldl' add_one_comp mempty comps++      neighboursOf v = g!v++      comps = scc g++      -- To avoid divergence on cyclic input, we build the result+      -- strongly connected component by component, in topological+      -- order. For each SCC, we know that:+      --+      --   * All vertices in the component can reach all other vertices+      --     in the component ("local" reachables)+      --+      --   * Other reachable vertices ("remote" reachables) must come+      --     from earlier components, either via direct neighbourhood, or+      --     transitively from earlier reachability map+      --+      -- This allows us to build the extension of the reachability map+      -- directly, without any self-reference, thereby avoiding a loop.+      add_one_comp :: IM.IntMap IS.IntSet -> SCC Vertex -> IM.IntMap IS.IntSet+      add_one_comp earlier (AcyclicSCC v) = IM.insert v all_remotes earlier+        where+          earlier_neighbours = neighboursOf v+          earlier_further = mapMaybe (flip IM.lookup earlier) earlier_neighbours+          all_remotes = IS.unions (IS.fromList earlier_neighbours : earlier_further)+      add_one_comp earlier (CyclicSCC vs) = IM.union (IM.fromList [(v, local v `IS.union` all_remotes) | v <- vs]) earlier+        where+          all_locals = IS.fromList vs+          local v = IS.delete v all_locals+              -- Arguably, for a cyclic SCC we should include each+              -- vertex in its own reachable set. However, this could+              -- lead to a lot of extra pain in client code to avoid+              -- looping when traversing the reachability map.+          all_neighbours = IS.fromList (concatMap neighboursOf vs)+          earlier_neighbours = all_neighbours IS.\\ all_locals+          earlier_further = mapMaybe (flip IM.lookup earlier) (IS.toList earlier_neighbours)+          all_remotes = IS.unions (earlier_neighbours : earlier_further)++--------------------------------------------------------------------------------+-- * Reachability queries+--------------------------------------------------------------------------------++-- | 'allReachable' returns the nodes reachable from the given @root@ node.+--+-- Properties:+--  * The list of nodes /does not/ include the @root@ node!+--  * The list of nodes is deterministically ordered, but according to an+--     internal order determined by the indices attributed to graph nodes.+--+-- If you need a topologically sorted list, consider using the functions exposed from 'GHC.Data.Graph.Directed' on 'Graph' instead.+allReachable :: ReachabilityIndex node -> node {-^ The @root@ node -} -> [node] {-^ All nodes reachable from @root@ -}+allReachable (ReachabilityIndex index from to) root = map from result+  where root_i = expectJust (to root)+        hits = {-# SCC "allReachable" #-} IM.lookup root_i index+        result = IS.toList $! expectJust hits++-- | 'allReachableMany' returns all nodes reachable from the many given @roots@.+--+-- Properties:+--  * The list of nodes /does not/ include the @roots@ node!+--  * The list of nodes is deterministically ordered, but according to an+--     internal order determined by the indices attributed to graph nodes.+--  * This function has $O(n)$ complexity where $n$ is the number of @roots@.+--+-- If you need a topologically sorted list, consider using the functions+-- exposed from 'GHC.Data.Graph.Directed' on 'Graph' instead ('reachableG').+allReachableMany :: ReachabilityIndex node -> [node] {-^ The @roots@ -} -> [node] {-^ All nodes reachable from all @roots@ -}+allReachableMany (ReachabilityIndex index from to) roots = map from (IS.toList hits)+  where roots_i = [ v | Just v <- map to roots ]+        hits = {-# SCC "allReachableMany" #-}+               IS.unions $ map (expectJust . flip IM.lookup index) roots_i++-- | Fast reachability query.+--+-- On graph @g@ with nodes @a@ and @b@, @isReachable g a b@+-- asks whether @b@ can be reached through @g@ starting from @a@.+--+-- Properties:+--  * No self loops, i.e. @isReachable _ a a == False@+isReachable :: ReachabilityIndex node {-^ @g@ -}+            -> node -- ^ @a@+            -> node -- ^ @b@+            -> Bool -- ^ @b@ is reachable from @a@+isReachable (ReachabilityIndex index _ to) a b =+    IS.member b_i $+    expectJust $ IM.lookup a_i index+  where a_i = expectJust $ to a+        b_i = expectJust $ to b++-- | Fast reachability query with many roots.+--+-- On graph @g@ with many nodes @roots@ and node @b@, @isReachableMany g as b@+-- asks whether @b@ can be reached through @g@ from any of the @roots@.+--+-- By partially applying this function to a set of roots, the resulting function can+-- be applied many times and share the initial work.+--+-- Properties:+--  * No self loops, i.e. @isReachableMany _ [a] a == False@+isReachableMany :: ReachabilityIndex node -- ^ @g@+                -> [node] -- ^ @roots@+                -> (node -> Bool) -- ^ @b@ is reachable from any of the @roots@+isReachableMany (ReachabilityIndex index _ to) roots =+  let roots_i = [ v | Just v <- map to roots ]+      unions =+          IS.unions $+            map (expectJust . flip IM.lookup index) roots_i+  in \b -> let b_i = expectJust $ to b+           in IS.member b_i unions
compiler/GHC/Data/IOEnv.hs view
@@ -22,7 +22,7 @@         IOEnvFailure(..),          -- Getting at the environment-        getEnv, setEnv, updEnv,+        getEnv, setEnv, updEnv, updEnvIO,          runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_,         tryM, tryAllM, tryMostM, fixM,@@ -253,3 +253,8 @@ updEnv :: (env -> env') -> IOEnv env' a -> IOEnv env a {-# INLINE updEnv #-} updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env))++-- | Perform a computation with an altered environment+updEnvIO :: (env -> IO env') -> IOEnv env' a -> IOEnv env a+{-# INLINE updEnvIO #-}+updEnvIO upd (IOEnv m) = IOEnv (\ env -> m =<< upd env)
+ compiler/GHC/Data/List.hs view
@@ -0,0 +1,25 @@+module GHC.Data.List where++mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])+mapAndUnzip _ [] = ([], [])+mapAndUnzip f (x:xs)+  = let (r1,  r2)  = f x+        (rs1, rs2) = mapAndUnzip f xs+    in+    (r1:rs1, r2:rs2)++mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])+mapAndUnzip3 _ [] = ([], [], [])+mapAndUnzip3 f (x:xs)+  = let (r1,  r2,  r3)  = f x+        (rs1, rs2, rs3) = mapAndUnzip3 f xs+    in+    (r1:rs1, r2:rs2, r3:rs3)++mapAndUnzip4 :: (a -> (b, c, d, e)) -> [a] -> ([b], [c], [d], [e])+mapAndUnzip4 _ [] = ([], [], [], [])+mapAndUnzip4 f (x:xs)+  = let (r1,  r2,  r3, r4)  = f x+        (rs1, rs2, rs3, rs4) = mapAndUnzip4 f xs+    in+    (r1:rs1, r2:rs2, r3:rs3, r4:rs4)
compiler/GHC/Data/List/Infinite.hs view
@@ -16,15 +16,18 @@   , allListsOf   , toList   , repeat+  , enumFrom   ) where -import Prelude ((-), Applicative (..), Bool (..), Foldable, Functor (..), Int, Maybe (..), Traversable (..), flip, otherwise)+import Prelude ((-), Applicative (..), Bool (..), Enum (succ), Foldable, Functor (..), Int, Maybe (..), Monad (..), Traversable (..), (<$>), flip, otherwise) import Control.Category (Category (..)) import Control.Monad (guard) import qualified Data.Foldable as F import Data.List.NonEmpty (NonEmpty (..)) import qualified GHC.Base as List (build) +infixr 5 `Inf`+ data Infinite a = Inf a (Infinite a)   deriving (Foldable, Functor, Traversable) @@ -44,6 +47,11 @@     pure = repeat     Inf f fs <*> Inf a as = Inf (f a) (fs <*> as) +instance Monad Infinite where+    x >>= f = join (f <$> x)+      where+        join (Inf a as) = head a `Inf` join (tail <$> as)+ mapMaybe :: (a -> Maybe b) -> Infinite a -> Infinite b mapMaybe f = go   where@@ -170,6 +178,10 @@ "repeat" [~1] forall a . repeat a = build \ c -> repeatFB c a "repeatFB" [1] repeatFB Inf = repeat   #-}++enumFrom :: Enum a => a -> Infinite a+enumFrom = iterate succ+{-# INLINE enumFrom #-}  {- Note [Fusion for `Infinite` lists]
+ compiler/GHC/Data/List/NonEmpty.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE LambdaCase #-}++module GHC.Data.List.NonEmpty (module Data.List.NonEmpty, module GHC.Data.List.NonEmpty, toList) where++import Prelude (Bool, (.))+import Control.Applicative+import qualified Control.Monad as List (zipWithM)+import Data.Foldable (Foldable (toList))+import Data.List.NonEmpty hiding (toList, unzip)+import qualified Data.List as List+import qualified GHC.Data.List as List++zipWithM :: Applicative f => (a -> b -> f c) -> NonEmpty a -> NonEmpty b -> f (NonEmpty c)+zipWithM f (a:|as) (b:|bs) = liftA2 (:|) (f a b) (List.zipWithM f as bs)+-- Inline to enable fusion of `List.zipWithM`+-- See Note [Fusion for zipN/zipWithN] in List.hs+{-# INLINE zipWithM #-}++unzip :: NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)+unzip ((a,b):|xs) = (a:|as, b:|bs)+  where+    (as, bs) = List.unzip xs++unzip3 :: NonEmpty (a, b, c) -> (NonEmpty a, NonEmpty b, NonEmpty c)+unzip3 ((a,b,c):|xs) = (a:|as, b:|bs, c:|cs)+  where+    (as, bs, cs) = List.unzip3 xs++mapAndUnzip :: (a -> (b, c)) -> NonEmpty a -> (NonEmpty b, NonEmpty c)+mapAndUnzip f (x:|xs) = (b:|bs, c:|cs)+  where+    (b, c) = f x+    (bs, cs) = List.mapAndUnzip f xs++mapAndUnzip3 :: (a -> (b, c, d)) -> NonEmpty a -> (NonEmpty b, NonEmpty c, NonEmpty d)+mapAndUnzip3 f (x:|xs) = (b:|bs, c:|cs, d:|ds)+  where+    (b, c, d) = f x+    (bs, cs, ds) = List.mapAndUnzip3 f xs++isSingleton :: NonEmpty a -> Bool+isSingleton = List.null . tail
compiler/GHC/Data/Maybe.hs view
@@ -33,7 +33,9 @@ import Control.Exception (SomeException(..)) import Data.Maybe import Data.Foldable ( foldlM, for_ )-import GHC.Utils.Misc (HasDebugCallStack)+import GHC.Utils.Misc (HasCallStack)+import GHC.Utils.Panic+import GHC.Utils.Outputable import Data.List.NonEmpty ( NonEmpty ) import Control.Applicative( Alternative( (<|>) ) ) @@ -66,10 +68,14 @@   go Nothing         action  = action   go result@(Just _) _action = return result -expectJust :: HasDebugCallStack => String -> Maybe a -> a+expectJust :: HasCallStack => Maybe a -> a+-- always enable the call stack to get the location even on non-debug builds {-# INLINE expectJust #-}-expectJust _   (Just x) = x-expectJust err Nothing  = error ("expectJust " ++ err)+expectJust = fromMaybe expectJustError++expectJustError :: HasCallStack => a+expectJustError = pprPanic "expectJust" empty+{-# NOINLINE expectJustError #-}  whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust = for_
compiler/GHC/Data/Pair.hs view
@@ -66,3 +66,6 @@     !(as,bs) = unzipPairs prs     -- This makes the unzip work eagerly, building no thunks at     -- the cost of doing all the work up-front.++instance Foldable1 Pair where+    foldMap1 f (Pair a b) = f a Semi.<> f b
compiler/GHC/Data/SmallArray.hs view
@@ -16,11 +16,18 @@   , mapSmallArray   , foldMapSmallArray   , rnfSmallArray++  -- * IO Operations+  , SmallMutableArrayIO+  , newSmallArrayIO+  , writeSmallArrayIO+  , unsafeFreezeSmallArrayIO   ) where  import GHC.Exts import GHC.Prelude+import GHC.IO import GHC.ST import Control.DeepSeq @@ -28,6 +35,8 @@  data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a) +type SmallMutableArrayIO a = SmallMutableArray RealWorld a+ newSmallArray   :: Int  -- ^ size   -> a    -- ^ initial contents@@ -37,6 +46,9 @@ newSmallArray (I# sz) x s = case newSmallArray# sz x s of   (# s', a #) -> (# s', SmallMutableArray a #) +newSmallArrayIO :: Int -> a -> IO (SmallMutableArrayIO a)+newSmallArrayIO sz x = IO $ \s -> newSmallArray sz x s+ writeSmallArray   :: SmallMutableArray s a -- ^ array   -> Int                   -- ^ index@@ -46,7 +58,13 @@ {-# INLINE writeSmallArray #-} writeSmallArray (SmallMutableArray a) (I# i) x = writeSmallArray# a i x +writeSmallArrayIO :: SmallMutableArrayIO a+                  -> Int+                  -> a+                  -> IO ()+writeSmallArrayIO a ix v = IO $ \s -> (# writeSmallArray a ix v s, () #) + -- | Copy and freeze a slice of a mutable array. freezeSmallArray   :: SmallMutableArray s a -- ^ source@@ -68,6 +86,9 @@ unsafeFreezeSmallArray (SmallMutableArray ma) s =   case unsafeFreezeSmallArray# ma s of     (# s', a #) -> (# s', SmallArray a #)++unsafeFreezeSmallArrayIO :: SmallMutableArrayIO a -> IO (SmallArray a)+unsafeFreezeSmallArrayIO arr = IO $ \s -> unsafeFreezeSmallArray arr s  -- | Get the size of a 'SmallArray' sizeofSmallArray
compiler/GHC/Data/Strict.hs view
@@ -22,9 +22,14 @@ import Control.Applicative import Data.Semigroup import Data.Data+import Control.DeepSeq  data Maybe a = Nothing | Just !a   deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)++instance NFData a => NFData (Maybe a) where+  rnf Nothing = ()+  rnf (Just x) = rnf x  fromMaybe :: a -> Maybe a -> a fromMaybe d Nothing = d
compiler/GHC/Data/StringBuffer.hs view
@@ -6,7 +6,6 @@ Buffers for scanning string input stored in external arrays. -} -{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE LambdaCase #-}@@ -77,12 +76,7 @@ import GHC.Exts  import Foreign-#if MIN_VERSION_base(4,15,0) import GHC.ForeignPtr (unsafeWithForeignPtr)-#else-unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b-unsafeWithForeignPtr = withForeignPtr-#endif  -- ----------------------------------------------------------------------------- -- The StringBuffer type
compiler/GHC/Data/TrieMap.hs view
@@ -69,7 +69,7 @@    lookupTM :: forall b. Key m -> m b -> Maybe b    alterTM  :: forall b. Key m -> XT b -> m b -> m b    filterTM :: (a -> Bool) -> m a -> m a-+   mapMaybeTM :: (a -> Maybe b) -> m a -> m b    foldTM   :: (a -> b -> b) -> m a -> b -> b       -- The unusual argument order here makes       -- it easy to compose calls to foldTM;@@ -146,6 +146,7 @@   alterTM = xtInt   foldTM k m z = IntMap.foldr k z m   filterTM f m = IntMap.filter f m+  mapMaybeTM f m = IntMap.mapMaybe f m  xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a xtInt k f m = IntMap.alter f k m@@ -157,6 +158,7 @@   alterTM k f m = Map.alter f k m   foldTM k m z = Map.foldr k z m   filterTM f m = Map.filter f m+  mapMaybeTM f m = Map.mapMaybe f m   {-@@ -233,6 +235,7 @@   alterTM k f m = alterUDFM f m k   foldTM k m z = foldUDFM k z m   filterTM f m = filterUDFM f m+  mapMaybeTM f m = mapMaybeUDFM f m  {- ************************************************************************@@ -259,6 +262,7 @@    alterTM  = xtMaybe alterTM    foldTM   = fdMaybe    filterTM = ftMaybe+   mapMaybeTM = mpMaybe  instance TrieMap m => Foldable (MaybeMap m) where   foldMap = foldMapTM@@ -281,6 +285,10 @@ ftMaybe f (MM { mm_nothing = mn, mm_just = mj })   = MM { mm_nothing = filterMaybe f mn, mm_just = filterTM f mj } +mpMaybe :: TrieMap m => (a -> Maybe b) -> MaybeMap m a -> MaybeMap m b+mpMaybe f (MM { mm_nothing = mn, mm_just = mj })+  = MM { mm_nothing = mn >>= f, mm_just = mapMaybeTM f mj }+ foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b foldMaybe _ Nothing  b = b foldMaybe k (Just a) b = k a b@@ -314,6 +322,7 @@    alterTM  = xtList alterTM    foldTM   = fdList    filterTM = ftList+   mapMaybeTM = mpList  instance TrieMap m => Foldable (ListMap m) where   foldMap = foldMapTM@@ -340,6 +349,10 @@ ftList f (LM { lm_nil = mnil, lm_cons = mcons })   = LM { lm_nil = filterMaybe f mnil, lm_cons = fmap (filterTM f) mcons } +mpList :: TrieMap m => (a -> Maybe b) -> ListMap m a -> ListMap m b+mpList f (LM { lm_nil = mnil, lm_cons = mcons })+  = LM { lm_nil = mnil >>= f, lm_cons = fmap (mapMaybeTM f) mcons }+ {- ************************************************************************ *                                                                      *@@ -395,6 +408,7 @@    alterTM  = xtG    foldTM   = fdG    filterTM = ftG+   mapMaybeTM = mpG  instance (Eq (Key m), TrieMap m) => Foldable (GenMap m) where   foldMap = foldMapTM@@ -457,3 +471,11 @@ ftG f (MultiMap m) = MultiMap (filterTM f m)   -- we don't have enough information to reconstruct the key to make   -- a SingletonMap++{-# INLINEABLE mpG #-}+mpG :: TrieMap m => (a -> Maybe b) -> GenMap m a -> GenMap m b+mpG _ EmptyMap = EmptyMap+mpG f (SingletonMap k v) = case f v of+                             Just v' -> SingletonMap k v'+                             Nothing -> EmptyMap+mpG f (MultiMap m) = MultiMap (mapMaybeTM f m)
compiler/GHC/Data/Unboxed.hs view
@@ -4,6 +4,13 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UnliftedNewtypes #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}+  -- If you use -fomit-interface-pragmas for your build, we won't+  -- inline the matcher for JustUB, and that turns out to have a+  -- catastropic effect on Lint, which uses unboxed Maybes.+  -- Simple fix: switch off -fomit-interface-pragmas for this tiny+  -- and very stable module.+ module GHC.Data.Unboxed (   MaybeUB(JustUB, NothingUB),   fmapMaybeUB, fromMaybeUB, apMaybeUB, maybeUB
compiler/GHC/Data/Word64Map/Internal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeFamilies #-} @@ -303,14 +302,12 @@ import GHC.Utils.Containers.Internal.BitUtil import GHC.Utils.Containers.Internal.StrictPair -#ifdef __GLASGOW_HASKELL__ import Data.Coerce import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix),                   DataType, mkDataType, gcast1) import GHC.Exts (build) import qualified GHC.Exts as GHCExts import Text.Read-#endif import qualified Control.Category as Category import Data.Word @@ -481,7 +478,6 @@     rnf (Tip _ v) = rnf v     rnf (Bin _ _ l r) = rnf l `seq` rnf r -#if __GLASGOW_HASKELL__  {--------------------------------------------------------------------   A Data instance@@ -505,7 +501,6 @@ intMapDataType :: DataType intMapDataType = mkDataType "Data.Word64Map.Internal.Word64Map" [fromListConstr] -#endif  {--------------------------------------------------------------------   Query@@ -2394,13 +2389,11 @@     go (Tip k x)     = Tip k (f x)     go Nil           = Nil -#ifdef __GLASGOW_HASKELL__ {-# NOINLINE [1] map #-} {-# RULES "map/map" forall f g xs . map f (map g xs) = map (f . g) xs "map/coerce" map coerce = coerce  #-}-#endif  -- | \(O(n)\). Map a function over all values in the map. --@@ -2414,7 +2407,6 @@       Tip k x     -> Tip k (f k x)       Nil         -> Nil -#ifdef __GLASGOW_HASKELL__ {-# NOINLINE [1] mapWithKey #-} {-# RULES "mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =@@ -2424,7 +2416,6 @@ "map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =   mapWithKey (\k a -> f (g k a)) xs  #-}-#endif  -- | \(O(n)\). -- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@@@ -3093,13 +3084,11 @@   Lists --------------------------------------------------------------------} -#ifdef __GLASGOW_HASKELL__ -- | @since 0.5.6.2 instance GHCExts.IsList (Word64Map a) where   type Item (Word64Map a) = (Key,a)   fromList = fromList   toList   = toList-#endif  -- | \(O(n)\). Convert the map to a list of key\/value pairs. Subject to list -- fusion.@@ -3127,7 +3116,6 @@ toDescList = foldlWithKey (\xs k x -> (k,x):xs) []  -- List fusion for the list generating functions.-#if __GLASGOW_HASKELL__ -- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion. -- They are important to convert unfused methods back, see mapFB in prelude. foldrFB :: (Key -> a -> b -> b) -> b -> Word64Map a -> b@@ -3159,7 +3147,6 @@ {-# RULES "Word64Map.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-} {-# RULES "Word64Map.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-} {-# RULES "Word64Map.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}-#endif   -- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs.@@ -3349,11 +3336,9 @@ instance Functor Word64Map where     fmap = map -#ifdef __GLASGOW_HASKELL__     a <$ Bin p m l r = Bin p m (a <$ l) (a <$ r)     a <$ Tip k _     = Tip k a     _ <$ Nil         = Nil-#endif  {--------------------------------------------------------------------   Show@@ -3375,19 +3360,12 @@   Read --------------------------------------------------------------------} instance (Read e) => Read (Word64Map e) where-#ifdef __GLASGOW_HASKELL__   readPrec = parens $ prec 10 $ do     Ident "fromList" <- lexP     xs <- readPrec     return (fromList xs)    readListPrec = readListPrecDefault-#else-  readsPrec p = readParen (p > 10) $ \ r -> do-    ("fromList",s) <- lex r-    (xs,t) <- reads s-    return (fromList xs,t)-#endif  -- | @since 0.5.9 instance Read1 Word64Map where
compiler/GHC/Data/Word64Map/Lazy.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-}  ----------------------------------------------------------------------------- -- |@@ -62,11 +61,7 @@  module GHC.Data.Word64Map.Lazy (     -- * Map type-#if !defined(TESTING)     Word64Map, Key          -- instance Eq,Show-#else-    Word64Map(..), Key          -- instance Eq,Show-#endif      -- * Construction     , empty
compiler/GHC/Data/Word64Map/Strict.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-}  ----------------------------------------------------------------------------- -- |@@ -80,11 +79,7 @@  module GHC.Data.Word64Map.Strict (     -- * Map type-#if !defined(TESTING)     Word64Map, Key          -- instance Eq,Show-#else-    Word64Map(..), Key          -- instance Eq,Show-#endif      -- * Construction     , empty
compiler/GHC/Data/Word64Map/Strict/Internal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-}  {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} @@ -82,11 +81,7 @@  module GHC.Data.Word64Map.Strict.Internal (     -- * Map type-#if !defined(TESTING)     Word64Map, Key          -- instance Eq,Show-#else-    Word64Map(..), Key          -- instance Eq,Show-#endif      -- * Construction     , empty@@ -823,13 +818,11 @@     go (Tip k x)     = Tip k $! f x     go Nil           = Nil -#ifdef __GLASGOW_HASKELL__ {-# NOINLINE [1] map #-} {-# RULES "map/map" forall f g xs . map f (map g xs) = map (\x -> f $! g x) xs "map/mapL" forall f g xs . map f (L.map g xs) = map (\x -> f (g x)) xs  #-}-#endif  -- | \(O(n)\). Map a function over all values in the map. --@@ -843,7 +836,6 @@       Tip k x     -> Tip k $! f k x       Nil         -> Nil -#ifdef __GLASGOW_HASKELL__ -- Pay close attention to strictness here. We need to force the -- intermediate result for map f . map g, and we need to refrain -- from forcing it for map f . L.map g, etc.@@ -871,7 +863,6 @@ "map/mapWithKeyL" forall f g xs . map f (L.mapWithKey g xs) =   mapWithKey (\k a -> f (g k a)) xs  #-}-#endif  -- | \(O(n)\). -- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@
compiler/GHC/Data/Word64Set.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-}  ----------------------------------------------------------------------------- -- |@@ -60,11 +59,7 @@             -- $strictness              -- * Set type-#if !defined(TESTING)               Word64Set          -- instance Eq,Show-#else-              Word64Set(..)      -- instance Eq,Show-#endif             , Key              -- * Construction@@ -150,10 +145,6 @@             , showTree             , showTreeWith -#if defined(TESTING)-            -- * Internals-            , match-#endif             ) where  import GHC.Data.Word64Set.Internal as WS
compiler/GHC/Data/Word64Set/Internal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeFamilies #-} @@ -195,15 +194,11 @@ import GHC.Utils.Containers.Internal.BitUtil import GHC.Utils.Containers.Internal.StrictPair -#if __GLASGOW_HASKELL__ import Data.Data (Data(..), Constr, mkConstr, constrIndex, DataType, mkDataType) import qualified Data.Data import Text.Read-#endif -#if __GLASGOW_HASKELL__ import qualified GHC.Exts-#endif  import Data.Functor.Identity (Identity(..)) @@ -268,7 +263,6 @@     (<>)    = union     stimes  = stimesIdempotentMonoid -#if __GLASGOW_HASKELL__  {--------------------------------------------------------------------   A Data instance@@ -291,7 +285,6 @@ intSetDataType :: DataType intSetDataType = mkDataType "Data.Word64Set.Internal.Word64Set" [fromListConstr] -#endif  {--------------------------------------------------------------------   Query@@ -502,15 +495,11 @@      choose True  = inserted     choose False = deleted-#ifndef __GLASGOW_HASKELL__-{-# INLINE alterF #-}-#else {-# INLINABLE [2] alterF #-}  {-# RULES "alterF/Const" forall k (f :: Bool -> Const a Bool) . alterF f k = \s -> Const . getConst . f $ member k s  #-}-#endif  {-# SPECIALIZE alterF :: (Bool -> Identity Bool) -> Key -> Word64Set -> Identity Word64Set #-} @@ -1128,13 +1117,11 @@   Lists --------------------------------------------------------------------} -#ifdef __GLASGOW_HASKELL__ -- | @since 0.5.6.2 instance GHC.Exts.IsList Word64Set where   type Item Word64Set = Key   fromList = fromList   toList   = toList-#endif  -- | \(O(n)\). Convert the set to a list of elements. Subject to list fusion. toList :: Word64Set -> [Key]@@ -1152,7 +1139,6 @@ toDescList = foldl (flip (:)) []  -- List fusion for the list generating functions.-#if __GLASGOW_HASKELL__ -- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion. -- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude. foldrFB :: (Key -> b -> b) -> b -> Word64Set -> b@@ -1178,7 +1164,6 @@ {-# RULES "Word64Set.toAscListBack" [1] foldrFB (:) [] = toAscList #-} {-# RULES "Word64Set.toDescList" [~1] forall s . toDescList s = GHC.Exts.build (\c n -> foldlFB (\xs x -> c x xs) n s) #-} {-# RULES "Word64Set.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-}-#endif   -- | \(O(n \min(n,W))\). Create a set from a list of integers.@@ -1302,19 +1287,12 @@   Read --------------------------------------------------------------------} instance Read Word64Set where-#ifdef __GLASGOW_HASKELL__   readPrec = parens $ prec 10 $ do     Ident "fromList" <- lexP     xs <- readPrec     return (fromList xs)    readListPrec = readListPrecDefault-#else-  readsPrec p = readParen (p > 10) $ \ r -> do-    ("fromList",s) <- lex r-    (xs,t) <- reads s-    return (fromList xs,t)-#endif  {--------------------------------------------------------------------   NFData@@ -1536,7 +1514,6 @@ {-# INLINE foldr'Bits #-} {-# INLINE takeWhileAntitoneBits #-} -#if defined(__GLASGOW_HASKELL__) indexOfTheOnlyBit :: Nat -> Word64 {-# INLINE indexOfTheOnlyBit #-} indexOfTheOnlyBit bitmask = fromIntegral $ countTrailingZeros bitmask@@ -1603,63 +1580,6 @@           else ((1 `shiftLL` b) - 1)   in bitmap .&. m -#else-{-----------------------------------------------------------------------  In general case we use logarithmic implementation of-  lowestBitSet and highestBitSet, which works up to bit sizes of 64.--  Folds are linear scans.-----------------------------------------------------------------------}--lowestBitSet n0 =-    let (n1,b1) = if n0 .&. 0xFFFFFFFF /= 0 then (n0,0)  else (n0 `shiftRL` 32, 32)-        (n2,b2) = if n1 .&. 0xFFFF /= 0     then (n1,b1) else (n1 `shiftRL` 16, 16+b1)-        (n3,b3) = if n2 .&. 0xFF /= 0       then (n2,b2) else (n2 `shiftRL` 8,  8+b2)-        (n4,b4) = if n3 .&. 0xF /= 0        then (n3,b3) else (n3 `shiftRL` 4,  4+b3)-        (n5,b5) = if n4 .&. 0x3 /= 0        then (n4,b4) else (n4 `shiftRL` 2,  2+b4)-        b6      = if n5 .&. 0x1 /= 0        then     b5  else                   1+b5-    in b6--highestBitSet n0 =-    let (n1,b1) = if n0 .&. 0xFFFFFFFF00000000 /= 0 then (n0 `shiftRL` 32, 32)    else (n0,0)-        (n2,b2) = if n1 .&. 0xFFFF0000 /= 0         then (n1 `shiftRL` 16, 16+b1) else (n1,b1)-        (n3,b3) = if n2 .&. 0xFF00 /= 0             then (n2 `shiftRL` 8,  8+b2)  else (n2,b2)-        (n4,b4) = if n3 .&. 0xF0 /= 0               then (n3 `shiftRL` 4,  4+b3)  else (n3,b3)-        (n5,b5) = if n4 .&. 0xC /= 0                then (n4 `shiftRL` 2,  2+b4)  else (n4,b4)-        b6      = if n5 .&. 0x2 /= 0                then                   1+b5   else     b5-    in b6--foldlBits prefix f z bm = let lb = lowestBitSet bm-                          in  go (prefix+lb) z (bm `shiftRL` lb)-  where go !_ acc 0 = acc-        go bi acc n | n `testBit` 0 = go (bi + 1) (f acc bi) (n `shiftRL` 1)-                    | otherwise     = go (bi + 1)    acc     (n `shiftRL` 1)--foldl'Bits prefix f z bm = let lb = lowestBitSet bm-                           in  go (prefix+lb) z (bm `shiftRL` lb)-  where go !_ !acc 0 = acc-        go bi acc n | n `testBit` 0 = go (bi + 1) (f acc bi) (n `shiftRL` 1)-                    | otherwise     = go (bi + 1)    acc     (n `shiftRL` 1)--foldrBits prefix f z bm = let lb = lowestBitSet bm-                          in  go (prefix+lb) (bm `shiftRL` lb)-  where go !_ 0 = z-        go bi n | n `testBit` 0 = f bi (go (bi + 1) (n `shiftRL` 1))-                | otherwise     =       go (bi + 1) (n `shiftRL` 1)--foldr'Bits prefix f z bm = let lb = lowestBitSet bm-                           in  go (prefix+lb) (bm `shiftRL` lb)-  where-        go !_ 0 = z-        go bi n | n `testBit` 0 = f bi $! go (bi + 1) (n `shiftRL` 1)-                | otherwise     =         go (bi + 1) (n `shiftRL` 1)--takeWhileAntitoneBits prefix predicate = foldl'Bits prefix f 0 -- Does not use antitone property-  where-    f acc bi | predicate bi = acc .|. bitmapOf bi-             | otherwise    = acc--#endif   {--------------------------------------------------------------------
compiler/GHC/Driver/Backend.hs view
@@ -214,6 +214,7 @@          ArchAArch64   -> True          ArchWasm32    -> True          ArchRISCV64   -> True+         ArchLoongArch64 -> True          _             -> False  -- | Is the platform supported by the JS backend?
compiler/GHC/Driver/Config.hs view
@@ -3,6 +3,7 @@    ( initOptCoercionOpts    , initSimpleOpts    , initEvalOpts+   , EvalStep(..)    ) where @@ -25,15 +26,32 @@    { so_uf_opts = unfoldingOpts dflags    , so_co_opts = initOptCoercionOpts dflags    , so_eta_red = gopt Opt_DoEtaReduction dflags+   , so_inline  = True    } +-- | Instruct the interpreter evaluation to break...+data EvalStep+  -- | ... at every breakpoint tick+  = EvalStepSingle+  -- | ... after any evaluation to WHNF+  -- (See Note [Debugger: Step-out])+  | EvalStepOut+  -- | ... only on explicit breakpoints+  | EvalStepNone+ -- | Extract GHCi options from DynFlags and step-initEvalOpts :: DynFlags -> Bool -> EvalOpts+initEvalOpts :: DynFlags -> EvalStep -> EvalOpts initEvalOpts dflags step =   EvalOpts     { useSandboxThread = gopt Opt_GhciSandbox dflags-    , singleStep       = step+    , singleStep       = singleStep+    , stepOut          = stepOut     , breakOnException = gopt Opt_BreakOnException dflags     , breakOnError     = gopt Opt_BreakOnError dflags     }+  where+    (singleStep, stepOut) = case step of+      EvalStepSingle -> (True,  False)+      EvalStepOut    -> (False, True)+      EvalStepNone   -> (False, False)
compiler/GHC/Driver/Config/Parser.hs view
@@ -1,5 +1,6 @@ module GHC.Driver.Config.Parser   ( initParserOpts+  , supportedLanguagePragmas   ) where @@ -17,9 +18,10 @@   mkParserOpts     <$> extensionFlags     <*> initDiagOpts-    <*> (supportedLanguagesAndExtensions . platformArchOS . targetPlatform)     <*> safeImportsOn     <*> gopt Opt_Haddock     <*> gopt Opt_KeepRawTokenStream     <*> const True -- use LINE/COLUMN to update the internal location +supportedLanguagePragmas :: DynFlags -> [String]+supportedLanguagePragmas = supportedLanguagesAndExtensions . platformArchOS . targetPlatform
compiler/GHC/Driver/DynFlags.hs view
@@ -62,6 +62,10 @@         versionedAppDir, versionedFilePath,         extraGccViaCFlags, globalPackageDatabasePath, +        --+        baseUnitId,++         -- * Include specifications         IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,         addImplicitQuoteInclude,@@ -71,6 +75,8 @@         initPromotionTickContext,          -- * Platform features+        isSse3Enabled,+        isSsse3Enabled,         isSse4_1Enabled,         isSse4_2Enabled,         isAvxEnabled,@@ -98,6 +104,7 @@ import GHC.Builtin.Names ( mAIN_NAME ) import GHC.Driver.Backend import GHC.Driver.Flags+import GHC.Driver.IncludeSpecs import GHC.Driver.Phases ( Phase(..), phaseInputExt ) import GHC.Driver.Plugins.External import GHC.Settings@@ -165,6 +172,8 @@   -- formerly Settings   ghcNameVersion    :: {-# UNPACK #-} !GhcNameVersion,   fileSettings      :: {-# UNPACK #-} !FileSettings,+  unitSettings      :: {-# UNPACK #-} !UnitSettings,+   targetPlatform    :: Platform,       -- Filled in by SysTools   toolSettings      :: {-# UNPACK #-} !ToolSettings,   platformMisc      :: {-# UNPACK #-} !PlatformMisc,@@ -399,6 +408,13 @@    ghciHistSize          :: Int, +  -- wasm ghci browser mode+  ghciBrowserHost                  :: !String,+  ghciBrowserPort                  :: !Int,+  ghciBrowserPuppeteerLaunchOpts   :: !(Maybe String),+  ghciBrowserPlaywrightBrowserType :: !(Maybe String),+  ghciBrowserPlaywrightLaunchOpts  :: !(Maybe String),+   flushOut              :: FlushOut,    ghcVersionFile        :: Maybe FilePath,@@ -634,6 +650,7 @@         splitInfo               = Nothing,          ghcNameVersion = sGhcNameVersion mySettings,+        unitSettings   = sUnitSettings mySettings,         fileSettings = sFileSettings mySettings,         toolSettings = sToolSettings mySettings,         targetPlatform = sTargetPlatform mySettings,@@ -683,6 +700,12 @@          ghciHistSize = 50, -- keep a log of length 50 by default +        ghciBrowserHost = "127.0.0.1",+        ghciBrowserPort = 0,+        ghciBrowserPuppeteerLaunchOpts = Nothing,+        ghciBrowserPlaywrightBrowserType = Nothing,+        ghciBrowserPlaywrightLaunchOpts = Nothing,+         flushOut = defaultFlushOut,         pprUserLength = 5,         pprCols = 100,@@ -729,16 +752,6 @@ defaultFlushOut :: FlushOut defaultFlushOut = FlushOut $ hFlush stdout ---data OnOff a = On a-             | Off a-  deriving (Eq, Show)--instance Outputable a => Outputable (OnOff a) where-  ppr (On x)  = text "On" <+> ppr x-  ppr (Off x) = text "Off" <+> ppr x- -- OnOffs accumulate in reverse order, so we use foldr in order to -- process them in the right order flattenExtensionFlags :: Maybe Language -> [OnOff LangExt.Extension] -> EnumSet LangExt.Extension@@ -925,46 +938,8 @@   | PkgDbPath FilePath   deriving Eq --- | Used to differentiate the scope an include needs to apply to.--- We have to split the include paths to avoid accidentally forcing recursive--- includes since -I overrides the system search paths. See #14312.-data IncludeSpecs-  = IncludeSpecs { includePathsQuote  :: [String]-                 , includePathsGlobal :: [String]-                 -- | See Note [Implicit include paths]-                 , includePathsQuoteImplicit :: [String]-                 }-  deriving Show --- | Append to the list of includes a path that shall be included using `-I`--- when the C compiler is called. These paths override system search paths.-addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs-addGlobalInclude spec paths  = let f = includePathsGlobal spec-                               in spec { includePathsGlobal = f ++ paths } --- | Append to the list of includes a path that shall be included using--- `-iquote` when the C compiler is called. These paths only apply when quoted--- includes are used. e.g. #include "foo.h"-addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs-addQuoteInclude spec paths  = let f = includePathsQuote spec-                              in spec { includePathsQuote = f ++ paths }---- | These includes are not considered while fingerprinting the flags for iface--- | See Note [Implicit include paths]-addImplicitQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs-addImplicitQuoteInclude spec paths  = let f = includePathsQuoteImplicit spec-                              in spec { includePathsQuoteImplicit = f ++ paths }----- | Concatenate and flatten the list of global and quoted includes returning--- just a flat list of paths.-flattenIncludes :: IncludeSpecs -> [String]-flattenIncludes specs =-    includePathsQuote specs ++-    includePathsQuoteImplicit specs ++-    includePathsGlobal specs-- -- An argument to --reexported-module which can optionally specify a module renaming. data ReexportedModule = ReexportedModule { reexportFrom :: ModuleName                                          , reexportTo   :: ModuleName@@ -1166,6 +1141,7 @@       Opt_GenManifest,       Opt_GhciHistory,       Opt_GhciSandbox,+      Opt_GhciDoLoadTargets,       Opt_HelpfulErrors,       Opt_KeepHiFiles,       Opt_KeepOFiles,@@ -1181,7 +1157,8 @@       Opt_ShowErrorContext,       Opt_SuppressStgReps,       Opt_UnoptimizedCoreForInterpreter,-      Opt_SpecialiseIncoherents+      Opt_SpecialiseIncoherents,+      Opt_WriteSelfRecompInfo     ]      ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]@@ -1290,7 +1267,7 @@ --  , ([2],     Opt_StaticArgumentTransformation) --   Static Argument Transformation needs investigation. See #9374     , ([0,1,2], Opt_SpecEval)-    , ([0,1,2], Opt_SpecEvalDictFun)+    , ([],      Opt_SpecEvalDictFun)     ]  @@ -1319,6 +1296,7 @@                                          -- always generate PIC. See                                          -- #10597 for more                                          -- information.+    (OSLinux,   ArchLoongArch64) -> [Opt_PIC, Opt_ExternalDynamicRefs]     _                      -> []  -- | The language extensions implied by the various language variants.@@ -1347,7 +1325,8 @@            -- default unless you specify another language.        LangExt.DeepSubsumption,        -- Non-standard but enabled for backwards compatability (see GHC proposal #511)-       LangExt.ListTuplePuns+       LangExt.ListTuplePuns,+       LangExt.ImplicitStagePersistence       ]  languageExtensions (Just Haskell2010)@@ -1365,7 +1344,9 @@        LangExt.FieldSelectors,        LangExt.RelaxedPolyRec,        LangExt.DeepSubsumption,-       LangExt.ListTuplePuns ]+       LangExt.ListTuplePuns,+       LangExt.ImplicitStagePersistence+       ]  languageExtensions (Just GHC2021)     = [LangExt.ImplicitPrelude,@@ -1416,7 +1397,9 @@        LangExt.TupleSections,        LangExt.TypeApplications,        LangExt.TypeOperators,-       LangExt.TypeSynonymInstances]+       LangExt.TypeSynonymInstances,+       LangExt.ImplicitStagePersistence+       ]  languageExtensions (Just GHC2024)     = languageExtensions (Just GHC2021) ++@@ -1485,6 +1468,11 @@ versionedFilePath :: ArchOS -> FilePath versionedFilePath platform = uniqueSubdir platform +-- | Access the unit-id of the version of `base` which we will automatically link+-- against.+baseUnitId :: DynFlags -> UnitId+baseUnitId dflags = unitSettings_baseUnitId (unitSettings dflags)+ -- SDoc ------------------------------------------- -- | Initialize the pretty-printing options@@ -1543,6 +1531,12 @@  -- ----------------------------------------------------------------------------- -- SSE, AVX, FMA++isSse3Enabled :: DynFlags -> Bool+isSse3Enabled dflags = sseVersion dflags >= Just SSE3++isSsse3Enabled :: DynFlags -> Bool+isSsse3Enabled dflags = sseVersion dflags >= Just SSSE3  isSse4_1Enabled :: DynFlags -> Bool isSse4_1Enabled dflags = sseVersion dflags >= Just SSE4
compiler/GHC/Driver/Env.hs view
@@ -1,7 +1,9 @@-+{-# LANGUAGE LambdaCase #-} module GHC.Driver.Env    ( Hsc(..)    , HscEnv (..)+   , hsc_mod_graph+   , setModuleGraph    , hscUpdateFlags    , hscSetFlags    , hsc_home_unit@@ -13,8 +15,7 @@    , hsc_all_home_unit_ids    , hscUpdateLoggerFlags    , hscUpdateHUG-   , hscUpdateHPT_lazy-   , hscUpdateHPT+   , hscInsertHPT    , hscSetActiveHomeUnit    , hscSetActiveUnitId    , hscActiveUnitId@@ -24,18 +25,20 @@    , runInteractiveHsc    , hscEPS    , hscInterp-   , hptCompleteSigs-   , hptAllInstances-   , hptInstancesBelow-   , hptAnns-   , hptAllThings-   , hptSomeThingsBelowUs-   , hptRules    , prepareAnnotations    , discardIC    , lookupType    , lookupIfaceByModule+   , lookupIfaceByModuleHsc    , mainModIs++   , hugRulesBelow+   , hugInstancesBelow+   , hugAnnsBelow+   , hugCompleteSigsBelow++    -- * Legacy API+   , hscUpdateHPT    ) where @@ -56,22 +59,18 @@ import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails import GHC.Unit.Home.ModInfo-import GHC.Unit.Env+import GHC.Unit.Home.PackageTable+import GHC.Unit.Home.Graph+import GHC.Unit.Module.Graph+import qualified GHC.Unit.Home.Graph as HUG+import GHC.Unit.Env as UnitEnv import GHC.Unit.External -import GHC.Core         ( CoreRule )-import GHC.Core.FamInstEnv-import GHC.Core.InstEnv--import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )-import GHC.Types.CompleteMatch import GHC.Types.Error ( emptyMessages, Messages ) import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.TyThing -import GHC.Builtin.Names ( gHC_PRIM )- import GHC.Data.Maybe  import GHC.Utils.Exception as Ex@@ -81,9 +80,15 @@ import GHC.Utils.Misc import GHC.Utils.Logger +import GHC.Core.Rules+import GHC.Types.Annotations+import GHC.Types.CompleteMatch+import GHC.Core.InstEnv+import GHC.Core.FamInstEnv+import GHC.Builtin.Names+ import Data.IORef import qualified Data.Set as Set-import GHC.Unit.Module.Graph  runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env hsc = do@@ -110,13 +115,13 @@ runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env)  hsc_home_unit :: HscEnv -> HomeUnit-hsc_home_unit = unsafeGetHomeUnit . hsc_unit_env+hsc_home_unit = ue_unsafeHomeUnit . hsc_unit_env  hsc_home_unit_maybe :: HscEnv -> Maybe HomeUnit hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env  hsc_units :: HasDebugCallStack => HscEnv -> UnitState-hsc_units = ue_units . hsc_unit_env+hsc_units = ue_homeUnitState . hsc_unit_env  hsc_HPT :: HscEnv -> HomePackageTable hsc_HPT = ue_hpt . hsc_unit_env@@ -127,22 +132,21 @@ hsc_HUG :: HscEnv -> HomeUnitGraph hsc_HUG = ue_home_unit_graph . hsc_unit_env -hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId-hsc_all_home_unit_ids = unitEnv_keys . hsc_HUG+hsc_mod_graph :: HscEnv -> ModuleGraph+hsc_mod_graph = ue_module_graph . hsc_unit_env -hscUpdateHPT_lazy :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv-hscUpdateHPT_lazy f hsc_env =-  let !res = updateHpt_lazy f (hsc_unit_env hsc_env)-  in hsc_env { hsc_unit_env = res }+hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId+hsc_all_home_unit_ids = HUG.allUnits . hsc_HUG -hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv-hscUpdateHPT f hsc_env =-  let !res = updateHpt f (hsc_unit_env hsc_env)-  in hsc_env { hsc_unit_env = res }+hscInsertHPT :: HomeModInfo -> HscEnv -> IO ()+hscInsertHPT hmi hsc_env = UnitEnv.insertHpt hmi (hsc_unit_env hsc_env)  hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv hscUpdateHUG f hsc_env = hsc_env { hsc_unit_env = updateHug f (hsc_unit_env hsc_env) } +setModuleGraph :: ModuleGraph -> HscEnv -> HscEnv+setModuleGraph mod_graph hsc_env = hsc_env { hsc_unit_env = (hsc_unit_env hsc_env) { ue_module_graph = mod_graph } }+ {-  Note [Target code interpreter]@@ -166,7 +170,7 @@ The target code interpreter to use can be selected per session via the `hsc_interp` field of `HscEnv`. There may be no interpreter available at all, in which case Template Haskell and GHCi will fail to run. The interpreter to use is-configured via command-line flags (in `GHC.setSessionDynFlags`).+configured via command-line flags (in `GHC.setTopSessionDynFlags`).   -}@@ -217,66 +221,68 @@ hscEPS :: HscEnv -> IO ExternalPackageState hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env))) -hptCompleteSigs :: HscEnv -> CompleteMatches-hptCompleteSigs = hptAllThings  (md_complete_matches . hm_details)---- | Find all the instance declarations (of classes and families) from--- the Home Package Table filtered by the provided predicate function.--- Used in @tcRnImports@, to select the instances that are in the--- transitive closure of imports from the currently compiled module.-hptAllInstances :: HscEnv -> (InstEnv, [FamInst])-hptAllInstances hsc_env-  = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do-                let details = hm_details mod_info-                return (md_insts details, md_fam_insts details)-    in (foldl' unionInstEnv emptyInstEnv insts, concat famInsts)---- | Find instances visible from the given set of imports-hptInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> (InstEnv, [FamInst])-hptInstancesBelow hsc_env uid mnwib =-  let-    mn = gwib_mod mnwib-    (insts, famInsts) =-        unzip $ hptSomeThingsBelowUs (\mod_info ->-                                     let details = hm_details mod_info-                                     -- Don't include instances for the current module-                                     in if moduleName (mi_module (hm_iface mod_info)) == mn-                                          then []-                                          else [(md_insts details, md_fam_insts details)])-                             True -- Include -hi-boot-                             hsc_env-                             uid-                             mnwib-  in (foldl' unionInstEnv emptyInstEnv insts, concat famInsts)---- | Get rules from modules "below" this one (in the dependency sense)-hptRules :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> [CoreRule]-hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False+--------------------------------------------------------------------------------+-- * Queries on Transitive Closure+-------------------------------------------------------------------------------- +-- | Find all rules in modules that are in the transitive closure of the given+-- module.+hugRulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO RuleBase+hugRulesBelow hsc_env uid mn = foldr (flip extendRuleBaseList) emptyRuleBase <$>+  hugSomeThingsBelowUs (md_rules . hm_details) False hsc_env uid mn --- | Get annotations from modules "below" this one (in the dependency sense)-hptAnns :: HscEnv -> Maybe (UnitId, ModuleNameWithIsBoot) -> [Annotation]-hptAnns hsc_env (Just (uid, mn)) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env uid mn-hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env+-- | Get annotations from all modules "below" this one (in the dependency+-- sense) within the home units. If the module is @Nothing@, returns /all/+-- annotations in the home units.+hugAnnsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO AnnEnv+hugAnnsBelow hsc_env uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$>+  hugSomeThingsBelowUs (md_anns . hm_details) False hsc_env uid mn -hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]-hptAllThings extract hsc_env = concatMap (concatHpt extract . homeUnitEnv_hpt . snd)-                                (hugElts (hsc_HUG hsc_env))+-- | Find all COMPLETE pragmas in modules that are in the transitive closure of the+-- given module.+hugCompleteSigsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO CompleteMatches+hugCompleteSigsBelow hsc uid mn = foldr (++) [] <$>+  hugSomeThingsBelowUs (md_complete_matches . hm_details) False hsc uid mn --- | Get things from modules "below" this one (in the dependency sense)--- C.f Inst.hptInstances-hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a]-hptSomeThingsBelowUs extract include_hi_boot hsc_env uid mn-  | isOneShot (ghcMode (hsc_dflags hsc_env)) = []+-- | Find instances visible from the given set of imports+hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst])+hugInstancesBelow hsc_env uid mnwib = do+ let mn = gwib_mod mnwib+ (insts, famInsts) <-+     unzip . concat <$>+       hugSomeThingsBelowUs (\mod_info ->+                                  let details = hm_details mod_info+                                  -- Don't include instances for the current module+                                  in if moduleName (mi_module (hm_iface mod_info)) == mn+                                       then []+                                       else [(md_insts details, md_fam_insts details)])+                          True -- Include -hi-boot+                          hsc_env+                          uid+                          mnwib+ return (foldl' unionInstEnv emptyInstEnv insts, concat famInsts) -  | otherwise+-- | Get things from modules in the transitive closure of the given module.+--+-- Note: Don't expose this function. This is a footgun if exposed!+hugSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]]+-- An explicit check to see if we are in one-shot mode to avoid poking the ModuleGraph thunk+-- These things are currently stored in the EPS for home packages. (See #25795 for+-- progress in removing these kind of checks; and making these functions of+-- `UnitEnv` rather than `HscEnv`)+-- See Note [Downsweep and the ModuleGraph]+hugSomeThingsBelowUs _ _ hsc_env _ _ | isOneShot (ghcMode (hsc_dflags hsc_env)) = return []+hugSomeThingsBelowUs extract include_hi_boot hsc_env uid mn   = let hug = hsc_HUG hsc_env         mg  = hsc_mod_graph hsc_env     in-    [ thing-    |-    -- Find each non-hi-boot module below me-      (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid) <- Set.toList (moduleGraphModulesBelow mg uid mn)+    sequence+    [ things+      -- "Finding each non-hi-boot module below me" maybe could be cached (well,+      -- the inverse) in the module graph to avoid filtering the boots out of+      -- the transitive closure out every time this is called+    | (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid)+          <- Set.toList (moduleGraphModulesBelow mg uid mn)     , include_hi_boot || (is_boot == NotBoot)          -- unsavoury: when compiling the base package with --make, we@@ -286,20 +292,17 @@     , mod /= moduleName gHC_PRIM     , not (mod == gwib_mod mn && uid == mod_uid) -        -- Look it up in the HPT-    , let things = case lookupHug hug mod_uid mod of-                    Just info -> extract info-                    Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg mempty+        -- Look it up in the HUG+    , let things = lookupHug hug mod_uid mod >>= \case+                    Just info -> return $ extract info+                    Nothing -> pprTrace "WARNING in hugSomeThingsBelowUs" msg mempty           msg = vcat [text "missing module" <+> ppr mod,                      text "When starting from"  <+> ppr mn,                      text "below:" <+> ppr (moduleGraphModulesBelow mg uid mn),                       text "Probable cause: out-of-date interface files"]                         -- This really shouldn't happen, but see #962-    , thing <- things     ] -- -- | Deal with gathering annotations in from all possible places --   and combining them into a single 'AnnEnv' prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv@@ -311,11 +314,13 @@         -- otherwise load annotations from all home package table         -- entries regardless of dependency ordering.         get_mod mg = (moduleUnitId (mg_module mg), GWIB (moduleName (mg_module mg)) NotBoot)-        home_pkg_anns  = (mkAnnEnv . hptAnns hsc_env) $ fmap get_mod mb_guts+    home_pkg_anns  <- fromMaybe (hugAllAnns (hsc_unit_env hsc_env))+                      $ uncurry (hugAnnsBelow hsc_env)+                      . get_mod <$> mb_guts+    let         other_pkg_anns = eps_ann_env eps-        ann_env        = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns,-                                                         Just home_pkg_anns,-                                                         Just other_pkg_anns]+        !ann_env       = maybe id plusAnnEnv mb_this_module_anns $!+            plusAnnEnv home_pkg_anns other_pkg_anns     return ann_env  -- | Find the 'TyThing' for the given 'Name' by using all the resources@@ -327,9 +332,9 @@ lookupType hsc_env name = do    eps <- liftIO $ hscEPS hsc_env    let pte = eps_PTE eps-   return $ lookupTypeInPTE hsc_env pte name+   lookupTypeInPTE hsc_env pte name -lookupTypeInPTE :: HscEnv -> PackageTypeEnv -> Name -> Maybe TyThing+lookupTypeInPTE :: HscEnv -> PackageTypeEnv -> Name -> IO (Maybe TyThing) lookupTypeInPTE hsc_env pte name = ty   where     hpt = hsc_HUG hsc_env@@ -338,12 +343,12 @@             then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name))             else nameModule name -    !ty = if isOneShot (ghcMode (hsc_dflags hsc_env))+    ty = if isOneShot (ghcMode (hsc_dflags hsc_env))             -- in one-shot, we don't use the HPT-            then lookupNameEnv pte name-            else case lookupHugByModule mod hpt of-             Just hm -> lookupNameEnv (md_types (hm_details hm)) name-             Nothing -> lookupNameEnv pte name+            then return $! lookupNameEnv pte name+            else HUG.lookupHugByModule mod hpt >>= \case+             Just hm -> pure $! lookupNameEnv (md_types (hm_details hm)) name+             Nothing -> pure $! lookupNameEnv pte name  -- | Find the 'ModIface' for a 'Module', searching in both the loaded home -- and external package module information@@ -351,9 +356,9 @@         :: HomeUnitGraph         -> PackageIfaceTable         -> Module-        -> Maybe ModIface+        -> IO (Maybe ModIface) lookupIfaceByModule hug pit mod-  = case lookupHugByModule mod hug of+  = HUG.lookupHugByModule mod hug >>= pure . \case        Just hm -> Just (hm_iface hm)        Nothing -> lookupModuleEnv pit mod    -- If the module does come from the home package, why do we look in the PIT as well?@@ -363,8 +368,13 @@    -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package    -- of its own, but it doesn't seem worth the bother. +lookupIfaceByModuleHsc :: HscEnv -> Module -> IO (Maybe ModIface)+lookupIfaceByModuleHsc hsc_env mod = do+  eps <- hscEPS hsc_env+  lookupIfaceByModule (hsc_HUG hsc_env) (eps_PIT eps) mod+ mainModIs :: HomeUnitEnv -> Module-mainModIs hue = mkHomeModule (expectJust "mainModIs" $ homeUnitEnv_home_unit  hue) (mainModuleNameIs (homeUnitEnv_dflags hue))+mainModIs hue = mkHomeModule (expectJust $ homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue))  -- | Retrieve the target code interpreter --@@ -425,3 +435,19 @@     where     home_unit = hsc_home_unit hsc_env     old_name = ic_name old_ic+++--------------------------------------------------------------------------------+-- * The Legacy API, should be removed after enough deprecation cycles+--------------------------------------------------------------------------------++{-# DEPRECATED hscUpdateHPT "Updating the HPT directly is no longer a supported \+   \ operation. Instead, the HPT is an insert-only data structure. If you want to \+   \ overwrite an existing entry, just use 'hscInsertHPT' to insert it again (it \+   \ will override the existing entry if there is one). See 'GHC.Unit.Home.PackageTable' for more details." #-}+hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv+hscUpdateHPT f hsc_env = hsc_env { hsc_unit_env = updateHug (HUG.unitEnv_adjust upd (ue_currentUnit $ hsc_unit_env hsc_env)) ue }+  where+    ue = hsc_unit_env hsc_env+    upd hue = hue { homeUnitEnv_hpt = f (homeUnitEnv_hpt hue) }+
compiler/GHC/Driver/Env/Types.hs view
@@ -18,7 +18,6 @@ import GHC.Types.Target import GHC.Types.TypeEnv import GHC.Unit.Finder.Types-import GHC.Unit.Module.Graph import GHC.Unit.Env import GHC.Utils.Logger import GHC.Utils.TmpFs@@ -65,9 +64,6 @@         hsc_targets :: [Target],                 -- ^ The targets (or roots) of the current session -        hsc_mod_graph :: ModuleGraph,-                -- ^ The module graph of the current session-         hsc_IC :: InteractiveContext,                 -- ^ The context for evaluating interactive statements @@ -112,3 +108,4 @@         , hsc_llvm_config :: !LlvmConfigCache                 -- ^ LLVM configuration cache.  }+
compiler/GHC/Driver/Errors.hs view
@@ -13,7 +13,7 @@ import GHC.Utils.Outputable (hang, ppr, ($$),  text, mkErrStyle, sdocStyle, updSDocContext ) import GHC.Utils.Logger -printMessages :: forall a . Diagnostic a => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()+printMessages :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO () printMessages logger msg_opts opts msgs   = sequence_ [ let style = mkErrStyle name_ppr_ctx                     ctx   = (diag_ppr_ctx opts) { sdocStyle = style }@@ -28,7 +28,7 @@                                   errMsgContext    = name_ppr_ctx }                   <- sortMsgBag (Just opts) (getMessages msgs) ]   where-    messageWithHints :: Diagnostic a => a -> SDoc+    messageWithHints :: a -> SDoc     messageWithHints e =       let main_msg = formatBulleted $ diagnosticMessage msg_opts e           in case diagnosticHints e of
compiler/GHC/Driver/Errors/Ppr.hs view
@@ -23,7 +23,6 @@ import GHC.Utils.Panic import GHC.Unit.Module import GHC.Unit.Module.Graph-import GHC.Unit.Module.ModSummary import GHC.Unit.State import GHC.Types.Hint import GHC.Types.SrcLoc@@ -63,7 +62,7 @@       -> diagnosticMessage (dsMessageOpts opts) m     GhcDriverMessage m       -> diagnosticMessage (driverMessageOpts opts) m-    GhcUnknownMessage (UnknownDiagnostic f m)+    GhcUnknownMessage (UnknownDiagnostic f _ m)       -> diagnosticMessage (f opts) m    diagnosticReason = \case@@ -90,7 +89,7 @@     GhcUnknownMessage m       -> diagnosticHints m -  diagnosticCode = constructorCode+  diagnosticCode = constructorCode @GHC  instance HasDefaultDiagnosticOpts DriverMessageOpts where   defaultOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) (defaultDiagnosticOpts @IfaceMessage)@@ -98,7 +97,7 @@ instance Diagnostic DriverMessage where   type DiagnosticOpts DriverMessage = DriverMessageOpts   diagnosticMessage opts = \case-    DriverUnknownMessage (UnknownDiagnostic f m)+    DriverUnknownMessage (UnknownDiagnostic f _ m)       -> diagnosticMessage (f opts) m     DriverPsHeaderMessage m       -> diagnosticMessage (psDiagnosticOpts opts) m@@ -156,7 +155,7 @@            text "module" <+> quotes (ppr mod) <+>            text "is defined in multiple files:" <+>            sep (map text files)-    DriverModuleNotFound mod+    DriverModuleNotFound _uid mod       -> mkSimpleDecorated (text "module" <+> quotes (ppr mod) <+> text "cannot be found locally")     DriverFileModuleNameMismatch actual expected       -> mkSimpleDecorated $@@ -261,10 +260,16 @@         ppr_node (ModuleNode _deps m) = text "module" <+> ppr_ms m         ppr_node (InstantiationNode _uid u) = text "instantiated unit" <+> ppr u         ppr_node (LinkNode uid _) = pprPanic "LinkNode should not be in a cycle" (ppr uid)+        ppr_node (UnitNode uid _) = pprPanic "UnitNode should not be in a cycle" (ppr uid) -        ppr_ms :: ModSummary -> SDoc-        ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>-                    (parens (text (msHsFilePath ms)))+        ppr_ms :: ModuleNodeInfo -> SDoc+        ppr_ms ms = quotes (ppr (moduleNodeInfoModule ms)) <+>+                    (parens (text (node_path ms)))++        node_path :: ModuleNodeInfo -> FilePath+        node_path ms = case ml_hs_file (moduleNodeInfoLocation ms) of+          Just f -> f+          Nothing -> ml_hi_file (moduleNodeInfoLocation ms)     DriverInstantiationNodeInDependencyGeneration node ->       mkSimpleDecorated $         vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:"@@ -422,4 +427,4 @@     DriverNoConfiguredLLVMToolchain       -> noHints -  diagnosticCode = constructorCode+  diagnosticCode = constructorCode @GHC
compiler/GHC/Driver/Errors/Types.hs view
@@ -4,6 +4,7 @@  module GHC.Driver.Errors.Types (     GhcMessage(..)+  , AnyGhcDiagnostic   , GhcMessageOpts(..)   , DriverMessage(..)   , DriverMessageOpts(..)@@ -94,10 +95,11 @@   -- 'Diagnostic' constraint ensures that worst case scenario we can still   -- render this into something which can be eventually converted into a   -- 'DecoratedSDoc'.-  GhcUnknownMessage :: (UnknownDiagnostic (DiagnosticOpts GhcMessage)) -> GhcMessage+  GhcUnknownMessage :: (UnknownDiagnosticFor GhcMessage) -> GhcMessage    deriving Generic +type AnyGhcDiagnostic = UnknownDiagnosticFor GhcMessage  data GhcMessageOpts = GhcMessageOpts { psMessageOpts :: DiagnosticOpts PsMessage                                      , tcMessageOpts :: DiagnosticOpts TcRnMessage@@ -111,7 +113,7 @@ -- conversion can happen gradually. This function should not be needed within -- GHC, as it would typically be used by plugin or library authors (see -- comment for the 'GhcUnknownMessage' type constructor)-ghcUnknownMessage :: (DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) => a -> GhcMessage+ghcUnknownMessage :: (DiagnosticOpts a ~ NoDiagnosticOpts, DiagnosticHint a ~ DiagnosticHint GhcMessage, Diagnostic a, Typeable a) => a -> GhcMessage ghcUnknownMessage = GhcUnknownMessage . mkSimpleUnknownDiagnostic  -- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on@@ -130,7 +132,7 @@ -- | A message from the driver. data DriverMessage where   -- | Simply wraps a generic 'Diagnostic' message @a@.-  DriverUnknownMessage :: UnknownDiagnostic (DiagnosticOpts DriverMessage) -> DriverMessage+  DriverUnknownMessage :: UnknownDiagnosticFor DriverMessage -> DriverMessage    -- | A parse error in parsing a Haskell file header during dependency   -- analysis@@ -185,7 +187,7 @@       Test cases: None.   -}-  DriverModuleNotFound :: !ModuleName -> DriverMessage+  DriverModuleNotFound :: !UnitId -> !ModuleName -> DriverMessage    {-| DriverFileModuleNameMismatch occurs if a module 'A' is defined in a file with a different name.       The first field is the name written in the source code; the second argument is the name extracted
compiler/GHC/Driver/Flags.hs view
@@ -29,6 +29,7 @@    , minusWcompatOpts    , unusedBindsFlags +   , OnOff(..)    , TurnOnFlag    , turnOn    , turnOff@@ -75,8 +76,19 @@   get bh = toEnum <$> get bh  instance NFData Language where-  rnf x = x `seq` ()+  rnf Haskell98 = ()+  rnf Haskell2010 = ()+  rnf GHC2021 = ()+  rnf GHC2024 = () +data OnOff a = On a+             | Off a+  deriving (Eq, Show)++instance Outputable a => Outputable (OnOff a) where+  ppr (On x)  = text "On" <+> ppr x+  ppr (Off x) = text "Off" <+> ppr x+ type TurnOnFlag = Bool   -- True  <=> we are turning the flag on                          -- False <=> we are turning the flag off turnOn  :: TurnOnFlag; turnOn  = True@@ -247,6 +259,8 @@   LangExt.ExtendedLiterals -> "ExtendedLiterals"   LangExt.ListTuplePuns -> "ListTuplePuns"   LangExt.MultilineStrings -> "MultilineStrings"+  LangExt.ExplicitLevelImports -> "ExplicitLevelImports"+  LangExt.ImplicitStagePersistence -> "ImplicitStagePersistence"  -- | Is this extension known by any other names? For example -- -XGeneralizedNewtypeDeriving is accepted@@ -269,78 +283,79 @@                   ++ mk (ExtensionDeprecatedFor [ext]) (extensionDeprecatedNames ext)   where mk depr = map (\name -> (depr, name)) --impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)]+impliedXFlags :: [(LangExt.Extension, OnOff LangExt.Extension)] impliedXFlags -- See Note [Updating flag description in the User's Guide]-  = [ (LangExt.RankNTypes,                turnOn, LangExt.ExplicitForAll)-    , (LangExt.QuantifiedConstraints,     turnOn, LangExt.ExplicitForAll)-    , (LangExt.ScopedTypeVariables,       turnOn, LangExt.ExplicitForAll)-    , (LangExt.LiberalTypeSynonyms,       turnOn, LangExt.ExplicitForAll)-    , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll)-    , (LangExt.FlexibleInstances,         turnOn, LangExt.TypeSynonymInstances)-    , (LangExt.FunctionalDependencies,    turnOn, LangExt.MultiParamTypeClasses)-    , (LangExt.MultiParamTypeClasses,     turnOn, LangExt.ConstrainedClassMethods)  -- c.f. #7854-    , (LangExt.TypeFamilyDependencies,    turnOn, LangExt.TypeFamilies)+  = [ (LangExt.RankNTypes,                On LangExt.ExplicitForAll)+    , (LangExt.QuantifiedConstraints,     On LangExt.ExplicitForAll)+    , (LangExt.ScopedTypeVariables,       On LangExt.ExplicitForAll)+    , (LangExt.LiberalTypeSynonyms,       On LangExt.ExplicitForAll)+    , (LangExt.ExistentialQuantification, On LangExt.ExplicitForAll)+    , (LangExt.FlexibleInstances,         On LangExt.TypeSynonymInstances)+    , (LangExt.FunctionalDependencies,    On LangExt.MultiParamTypeClasses)+    , (LangExt.MultiParamTypeClasses,     On LangExt.ConstrainedClassMethods)  -- c.f. #7854+    , (LangExt.TypeFamilyDependencies,    On LangExt.TypeFamilies) -    , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude)      -- NB: turn off!+    , (LangExt.RebindableSyntax, Off LangExt.ImplicitPrelude)      -- NB: turn off! -    , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies)+    , (LangExt.DerivingVia, On LangExt.DerivingStrategies) -    , (LangExt.GADTs,            turnOn, LangExt.GADTSyntax)-    , (LangExt.GADTs,            turnOn, LangExt.MonoLocalBinds)-    , (LangExt.TypeFamilies,     turnOn, LangExt.MonoLocalBinds)+    , (LangExt.GADTs,            On LangExt.GADTSyntax)+    , (LangExt.GADTs,            On LangExt.MonoLocalBinds)+    , (LangExt.TypeFamilies,     On LangExt.MonoLocalBinds) -    , (LangExt.TypeFamilies,     turnOn, LangExt.KindSignatures)  -- Type families use kind signatures-    , (LangExt.PolyKinds,        turnOn, LangExt.KindSignatures)  -- Ditto polymorphic kinds+    , (LangExt.TypeFamilies,     On LangExt.KindSignatures)  -- Type families use kind signatures+    , (LangExt.PolyKinds,        On LangExt.KindSignatures)  -- Ditto polymorphic kinds      -- TypeInType is now just a synonym for a couple of other extensions.-    , (LangExt.TypeInType,       turnOn, LangExt.DataKinds)-    , (LangExt.TypeInType,       turnOn, LangExt.PolyKinds)-    , (LangExt.TypeInType,       turnOn, LangExt.KindSignatures)+    , (LangExt.TypeInType,       On LangExt.DataKinds)+    , (LangExt.TypeInType,       On LangExt.PolyKinds)+    , (LangExt.TypeInType,       On LangExt.KindSignatures)      -- Standalone kind signatures are a replacement for CUSKs.-    , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs)+    , (LangExt.StandaloneKindSignatures, Off LangExt.CUSKs)      -- AutoDeriveTypeable is not very useful without DeriveDataTypeable-    , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable)+    , (LangExt.AutoDeriveTypeable, On LangExt.DeriveDataTypeable)      -- We turn this on so that we can export associated type     -- type synonyms in subordinates (e.g. MyClass(type AssocType))-    , (LangExt.TypeFamilies,     turnOn, LangExt.ExplicitNamespaces)-    , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces)+    , (LangExt.TypeFamilies,     On LangExt.ExplicitNamespaces)+    , (LangExt.TypeOperators, On LangExt.ExplicitNamespaces) -    , (LangExt.ImpredicativeTypes,  turnOn, LangExt.RankNTypes)+    , (LangExt.ImpredicativeTypes,  On LangExt.RankNTypes)          -- Record wild-cards implies field disambiguation         -- Otherwise if you write (C {..}) you may well get         -- stuff like " 'a' not in scope ", which is a bit silly         -- if the compiler has just filled in field 'a' of constructor 'C'-    , (LangExt.RecordWildCards,     turnOn, LangExt.DisambiguateRecordFields)--    , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp)+    , (LangExt.RecordWildCards,     On LangExt.DisambiguateRecordFields) -    , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI)+    , (LangExt.ParallelArrays, On LangExt.ParallelListComp)+    , (LangExt.MonadComprehensions, On LangExt.ParallelListComp)+    , (LangExt.JavaScriptFFI, On LangExt.InterruptibleFFI) -    , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor)-    , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable)+    , (LangExt.DeriveTraversable, On LangExt.DeriveFunctor)+    , (LangExt.DeriveTraversable, On LangExt.DeriveFoldable)      -- Duplicate record fields require field disambiguation-    , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields)+    , (LangExt.DuplicateRecordFields, On LangExt.DisambiguateRecordFields) -    , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes)-    , (LangExt.Strict, turnOn, LangExt.StrictData)+    , (LangExt.TemplateHaskell, On LangExt.TemplateHaskellQuotes)+    , (LangExt.Strict, On LangExt.StrictData)      -- Historically only UnboxedTuples was required for unboxed sums to work.     -- To avoid breaking code, we make UnboxedTuples imply UnboxedSums.-    , (LangExt.UnboxedTuples, turnOn, LangExt.UnboxedSums)+    , (LangExt.UnboxedTuples, On LangExt.UnboxedSums)      -- The extensions needed to declare an H98 unlifted data type-    , (LangExt.UnliftedDatatypes, turnOn, LangExt.DataKinds)-    , (LangExt.UnliftedDatatypes, turnOn, LangExt.StandaloneKindSignatures)+    , (LangExt.UnliftedDatatypes, On LangExt.DataKinds)+    , (LangExt.UnliftedDatatypes, On LangExt.StandaloneKindSignatures)      -- See (NVP3) in Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind-    , (LangExt.LinearTypes, turnOn, LangExt.MonoLocalBinds)+    , (LangExt.LinearTypes, On LangExt.MonoLocalBinds)++    , (LangExt.ExplicitLevelImports, Off LangExt.ImplicitStagePersistence)   ]  @@ -352,7 +367,7 @@     , (Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits)     , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits) ] --- General flags that are switched on/off when other general flags are switched+-- | General flags that are switched on/off when other general flags are switched -- on impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles)@@ -365,12 +380,12 @@                 ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithFallback)                 ] ++ validHoleFitsImpliedGFlags --- General flags that are switched on/off when other general flags are switched+-- | General flags that are switched on/off when other general flags are switched -- off impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)] --- Please keep what_glasgow_exts_does.rst up to date with this list+-- Please keep @docs/users_guide/what_glasgow_exts_does.rst@ up to date with this list. glasgowExtsFlags :: [LangExt.Extension] glasgowExtsFlags = [              LangExt.ConstrainedClassMethods@@ -418,7 +433,7 @@    -- enabled if you run -ddump-cmm-verbose-by-proc    -- Each flag corresponds to exact stage of Cmm pipeline.    | Opt_D_dump_cmm_verbose-   -- same as -ddump-cmm-verbose-by-proc but writes each stage+   -- ^ same as -ddump-cmm-verbose-by-proc but writes each stage    -- to a separate file (if used with -ddump-to-file)    | Opt_D_dump_cmm_cfg    | Opt_D_dump_cmm_cbe@@ -470,6 +485,7 @@    | Opt_D_dump_stg_cg        -- ^ STG (after stg2stg)    | Opt_D_dump_stg_tags      -- ^ Result of tag inference analysis.    | Opt_D_dump_stg_final     -- ^ Final STG (before cmm gen)+   | Opt_D_dump_stg_from_js_sinker -- ^ STG after JS sinker    | Opt_D_dump_call_arity    | Opt_D_dump_exitify    | Opt_D_dump_dmdanal@@ -491,9 +507,9 @@    | Opt_D_dump_rn_stats    | Opt_D_dump_opt_cmm    | Opt_D_dump_simpl_stats-   | Opt_D_dump_cs_trace -- Constraint solver in type checker+   | Opt_D_dump_cs_trace -- ^ Constraint solver in type checker    | Opt_D_dump_tc_trace-   | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker+   | Opt_D_dump_ec_trace -- ^ Pattern match exhaustiveness checker    | Opt_D_dump_if_trace    | Opt_D_dump_splices    | Opt_D_th_dec_file@@ -572,6 +588,7 @@    | Opt_DoAsmLinting    | Opt_DoAnnotationLinting    | Opt_DoBoundsChecking+   | Opt_AddBcoName    | Opt_NoLlvmMangler                  -- hidden flag    | Opt_FastLlvm                       -- hidden flag    | Opt_NoTypeableBinds@@ -581,9 +598,13 @@    | Opt_InfoTableMapWithFallback    | Opt_InfoTableMapWithStack -   | Opt_WarnIsError                    -- -Werror; makes warnings fatal-   | Opt_ShowWarnGroups                 -- Show the group a warning belongs to-   | Opt_HideSourcePaths                -- Hide module source/object paths+   | Opt_WarnIsError+   -- ^ @-Werror@; makes all warnings fatal.+   -- See 'wopt_set_fatal' for making individual warnings fatal as in @-Werror=foo@.+   | Opt_ShowWarnGroups+   -- ^ Show the group a warning belongs to.+   | Opt_HideSourcePaths+   -- ^ @-fhide-source-paths@; hide module source/object paths.     | Opt_PrintExplicitForalls    | Opt_PrintExplicitKinds@@ -631,15 +652,15 @@    | Opt_IgnoreAsserts    | Opt_DoEtaReduction    | Opt_CaseMerge-   | Opt_CaseFolding                    -- Constant folding through case-expressions+   | Opt_CaseFolding                    -- ^ Constant folding through case-expressions    | Opt_UnboxStrictFields    | Opt_UnboxSmallStrictFields    | Opt_DictsCheap-   | Opt_EnableRewriteRules             -- Apply rewrite rules during simplification-   | Opt_EnableThSpliceWarnings         -- Enable warnings for TH splices-   | Opt_RegsGraph                      -- do graph coloring register allocation-   | Opt_RegsIterative                  -- do iterative coalescing graph coloring register allocation-   | Opt_PedanticBottoms                -- Be picky about how we treat bottom+   | Opt_EnableRewriteRules             -- ^ Apply rewrite rules during simplification+   | Opt_EnableThSpliceWarnings         -- ^ Enable warnings for TH splices+   | Opt_RegsGraph                      -- ^ Do graph coloring register allocation+   | Opt_RegsIterative                  -- ^ Do iterative coalescing graph coloring register allocation+   | Opt_PedanticBottoms                -- ^ Be picky about how we treat bottom    | Opt_LlvmFillUndefWithGarbage       -- Testing for undef bugs (hidden flag)    | Opt_IrrefutableTuples    | Opt_CmmSink@@ -649,20 +670,20 @@    | Opt_AsmShortcutting    | Opt_InterModuleFarJumps    | Opt_OmitYields-   | Opt_FunToThunk               -- deprecated-   | Opt_DictsStrict                     -- be strict in argument dictionaries+   | Opt_FunToThunk                -- deprecated+   | Opt_DictsStrict               -- ^ Be strict in argument dictionaries    | Opt_DmdTxDictSel              -- ^ deprecated, no effect and behaviour is now default.                                    -- Allowed switching of a special demand transformer for dictionary selectors-   | Opt_Loopification                  -- See Note [Self-recursive tail calls]-   | Opt_CfgBlocklayout             -- ^ Use the cfg based block layout algorithm.-   | Opt_WeightlessBlocklayout         -- ^ Layout based on last instruction per block.+   | Opt_Loopification             -- See Note [Self-recursive tail calls]+   | Opt_CfgBlocklayout            -- ^ Use the cfg based block layout algorithm.+   | Opt_WeightlessBlocklayout     -- ^ Layout based on last instruction per block.    | Opt_CprAnal    | Opt_WorkerWrapper    | Opt_WorkerWrapperUnlift  -- ^ Do W/W split for unlifting even if we won't unbox anything.    | Opt_SolveConstantDicts    | Opt_AlignmentSanitisation    | Opt_CatchNonexhaustiveCases-   | Opt_NumConstantFolding+   | Opt_NumConstantFolding   -- ^ See Note [Constant folding through nested expressions] in GHC.Core.Opt.ConstantFold    | Opt_CoreConstantFolding    | Opt_FastPAPCalls                  -- #6084    | Opt_SpecEval@@ -672,7 +693,7 @@    -- Inference flags    | Opt_DoTagInferenceChecks -   -- PreInlining is on by default. The option is there just to see how+   -- | PreInlining is on by default. The option is there just to see how    -- bad things get if you turn it off!    | Opt_SimplPreInlining @@ -681,13 +702,15 @@    | Opt_OmitInterfacePragmas    | Opt_ExposeAllUnfoldings    | Opt_ExposeOverloadedUnfoldings-   | Opt_KeepAutoRules -- ^Keep auto-generated rules even if they seem to have become useless-   | Opt_WriteInterface -- forces .hi files to be written even with -fno-code-   | Opt_WriteHie -- generate .hie files+   | Opt_KeepAutoRules -- ^ Keep auto-generated rules even if they seem to have become useless+   | Opt_WriteInterface -- ^ Forces .hi files to be written even with -fno-code+   | Opt_WriteSelfRecompInfo+   | Opt_WriteSelfRecompFlags -- ^ Include detailed flag information for self-recompilation debugging+   | Opt_WriteHie -- ^ Generate .hie files     -- JavaScript opts-   | Opt_DisableJsMinifier -- ^ render JavaScript pretty-printed instead of minified (compacted)-   | Opt_DisableJsCsources -- ^ don't link C sources (compiled to JS) with Haskell code (compiled to JS)+   | Opt_DisableJsMinifier -- ^ Render JavaScript pretty-printed instead of minified (compacted)+   | Opt_DisableJsCsources -- ^ Don't link C sources (compiled to JS) with Haskell code (compiled to JS)     -- profiling opts    | Opt_AutoSccsOnIndividualCafs@@ -730,6 +753,14 @@    | Opt_ValidateHie    | Opt_LocalGhciHistory    | Opt_NoIt++   -- wasm ghci browser mode+   | Opt_GhciBrowser+   | Opt_GhciBrowserRedirectWasiConsole++   -- | Instruct GHCi to load all targets on startup+   | Opt_GhciDoLoadTargets+    | Opt_HelpfulErrors    | Opt_DeferTypeErrors             -- Since 7.6    | Opt_DeferTypedHoles             -- Since 7.10@@ -770,11 +801,11 @@    | Opt_LinkRts     -- output style opts-   | Opt_ErrorSpans -- Include full span info in error messages,+   | Opt_ErrorSpans -- ^ Include full span info in error messages,                     -- instead of just the start position.    | Opt_DeferDiagnostics    | Opt_DiagnosticsAsJSON  -- ^ Dump diagnostics as JSON-   | Opt_DiagnosticsShowCaret -- Show snippets of offending code+   | Opt_DiagnosticsShowCaret -- ^ Show snippets of offending code    | Opt_PprCaseAsLet    | Opt_PprShowTicks    | Opt_ShowHoleConstraints@@ -797,29 +828,29 @@    | Opt_ShowLoadedModules    | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals] -   -- Suppress a coercions inner structure, replacing it with '...'+   -- | Suppress a coercions inner structure, replacing it with '...'    | Opt_SuppressCoercions-   -- Suppress the type of a coercion as well+   -- | Suppress the type of a coercion as well    | Opt_SuppressCoercionTypes    | Opt_SuppressVarKinds-   -- Suppress module id prefixes on variables.+   -- | Suppress module id prefixes on variables.    | Opt_SuppressModulePrefixes-   -- Suppress type applications.+   -- | Suppress type applications.    | Opt_SuppressTypeApplications-   -- Suppress info such as arity and unfoldings on identifiers.+   -- | Suppress info such as arity and unfoldings on identifiers.    | Opt_SuppressIdInfo-   -- Suppress separate type signatures in core, but leave types on+   -- | Suppress separate type signatures in core, but leave types on    -- lambda bound vars    | Opt_SuppressUnfoldings-   -- Suppress the details of even stable unfoldings+   -- | Suppress the details of even stable unfoldings    | Opt_SuppressTypeSignatures-   -- Suppress unique ids on variables.+   -- | Suppress unique ids on variables.    -- Except for uniques, as some simplifier phases introduce new    -- variables that have otherwise identical names.    | Opt_SuppressUniques    | Opt_SuppressStgExts    | Opt_SuppressStgReps-   | Opt_SuppressTicks     -- Replaces Opt_PprShowTicks+   | Opt_SuppressTicks      -- ^ Replaces Opt_PprShowTicks    | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps    | Opt_SuppressCoreSizes  -- ^ Suppress per binding Core size stats in dumps @@ -1020,55 +1051,62 @@    | Opt_WarnDerivingTypeable    | Opt_WarnDeferredTypeErrors    | Opt_WarnDeferredOutOfScopeVariables-   | Opt_WarnNonCanonicalMonadInstances              -- since 8.0-   | Opt_WarnNonCanonicalMonadFailInstances          -- since 8.0, removed 8.8-   | Opt_WarnNonCanonicalMonoidInstances             -- since 8.0-   | Opt_WarnMissingPatternSynonymSignatures         -- since 8.0-   | Opt_WarnUnrecognisedWarningFlags                -- since 8.0-   | Opt_WarnSimplifiableClassConstraints            -- Since 8.2-   | Opt_WarnCPPUndef                                -- Since 8.2-   | Opt_WarnUnbangedStrictPatterns                  -- Since 8.2-   | Opt_WarnMissingHomeModules                      -- Since 8.2-   | Opt_WarnPartialFields                           -- Since 8.4+   | Opt_WarnNonCanonicalMonadInstances              -- ^ @since 8.0+   | Opt_WarnNonCanonicalMonadFailInstances          -- ^ @since 8.0, has no effect since 8.8+   | Opt_WarnNonCanonicalMonoidInstances             -- ^ @since 8.0+   | Opt_WarnMissingPatternSynonymSignatures         -- ^ @since 8.0+   | Opt_WarnUnrecognisedWarningFlags                -- ^ @since 8.0+   | Opt_WarnSimplifiableClassConstraints            -- ^ @since 8.2+   | Opt_WarnCPPUndef                                -- ^ @since 8.2+   | Opt_WarnUnbangedStrictPatterns                  -- ^ @since 8.2+   | Opt_WarnMissingHomeModules                      -- ^ @since 8.2+   | Opt_WarnPartialFields                           -- ^ @since 8.4    | Opt_WarnMissingExportList    | Opt_WarnInaccessibleCode-   | Opt_WarnStarIsType                              -- Since 8.6-   | Opt_WarnStarBinder                              -- Since 8.6-   | Opt_WarnImplicitKindVars                        -- Since 8.6+   | Opt_WarnStarIsType                              -- ^ @since 8.6+   | Opt_WarnStarBinder                              -- ^ @since 8.6+   | Opt_WarnImplicitKindVars                        -- ^ @since 8.6    | Opt_WarnSpaceAfterBang-   | Opt_WarnMissingDerivingStrategies               -- Since 8.8-   | Opt_WarnPrepositiveQualifiedModule              -- Since 8.10-   | Opt_WarnUnusedPackages                          -- Since 8.10-   | Opt_WarnInferredSafeImports                     -- Since 8.10-   | Opt_WarnMissingSafeHaskellMode                  -- Since 8.10-   | Opt_WarnCompatUnqualifiedImports                -- Since 8.10+   | Opt_WarnMissingDerivingStrategies               -- ^ @since 8.8+   | Opt_WarnPrepositiveQualifiedModule              -- ^ @since 8.10+   | Opt_WarnUnusedPackages                          -- ^ @since 8.10+   | Opt_WarnInferredSafeImports                     -- ^ @since 8.10+   | Opt_WarnMissingSafeHaskellMode                  -- ^ @since 8.10+   | Opt_WarnCompatUnqualifiedImports                -- ^ @since 8.10    | Opt_WarnDerivingDefaults-   | Opt_WarnInvalidHaddock                          -- Since 9.0-   | Opt_WarnOperatorWhitespaceExtConflict           -- Since 9.2-   | Opt_WarnOperatorWhitespace                      -- Since 9.2-   | Opt_WarnAmbiguousFields                         -- Since 9.2-   | Opt_WarnImplicitLift                            -- Since 9.2-   | Opt_WarnMissingKindSignatures                   -- Since 9.2-   | Opt_WarnMissingPolyKindSignatures               -- Since 9.8-   | Opt_WarnMissingExportedPatternSynonymSignatures -- since 9.2-   | Opt_WarnRedundantStrictnessFlags                -- Since 9.4-   | Opt_WarnForallIdentifier                        -- Since 9.4-   | Opt_WarnUnicodeBidirectionalFormatCharacters    -- Since 9.0.2-   | Opt_WarnGADTMonoLocalBinds                      -- Since 9.4-   | Opt_WarnTypeEqualityOutOfScope                  -- Since 9.4-   | Opt_WarnTypeEqualityRequiresOperators           -- Since 9.4-   | Opt_WarnLoopySuperclassSolve                    -- Since 9.6, has no effect since 9.10-   | Opt_WarnTermVariableCapture                     -- Since 9.8-   | Opt_WarnMissingRoleAnnotations                  -- Since 9.8-   | Opt_WarnImplicitRhsQuantification               -- Since 9.8-   | Opt_WarnIncompleteExportWarnings                -- Since 9.8-   | Opt_WarnIncompleteRecordSelectors               -- Since 9.10-   | Opt_WarnBadlyStagedTypes                        -- Since 9.10-   | Opt_WarnInconsistentFlags                       -- Since 9.8-   | Opt_WarnDataKindsTC                             -- Since 9.10-   | Opt_WarnDeprecatedTypeAbstractions              -- Since 9.10-   | Opt_WarnDefaultedExceptionContext               -- Since 9.10-   | Opt_WarnViewPatternSignatures                   -- Since 9.12+   | Opt_WarnInvalidHaddock                          -- ^ @since 9.0+   | Opt_WarnOperatorWhitespaceExtConflict           -- ^ @since 9.2+   | Opt_WarnOperatorWhitespace                      -- ^ @since 9.2+   | Opt_WarnAmbiguousFields                         -- ^ @since 9.2+   | Opt_WarnImplicitLift                            -- ^ @since 9.2+   | Opt_WarnMissingKindSignatures                   -- ^ @since 9.2+   | Opt_WarnMissingPolyKindSignatures               -- ^ @since 9.8+   | Opt_WarnMissingExportedPatternSynonymSignatures -- ^ @since 9.2+   | Opt_WarnRedundantStrictnessFlags                -- ^ @since 9.4+   | Opt_WarnForallIdentifier                        -- ^ @since 9.4+   | Opt_WarnUnicodeBidirectionalFormatCharacters    -- ^ @since 9.0.2+   | Opt_WarnGADTMonoLocalBinds                      -- ^ @since 9.4+   | Opt_WarnTypeEqualityOutOfScope                  -- ^ @since 9.4+   | Opt_WarnTypeEqualityRequiresOperators           -- ^ @since 9.4+   | Opt_WarnLoopySuperclassSolve                    -- ^ @since 9.6, has no effect since 9.10+   | Opt_WarnTermVariableCapture                     -- ^ @since 9.8+   | Opt_WarnMissingRoleAnnotations                  -- ^ @since 9.8+   | Opt_WarnImplicitRhsQuantification               -- ^ @since 9.8+   | Opt_WarnIncompleteExportWarnings                -- ^ @since 9.8+   | Opt_WarnIncompleteRecordSelectors               -- ^ @since 9.10+   | Opt_WarnBadlyLevelledTypes                      -- ^ @since 9.10+   | Opt_WarnInconsistentFlags                       -- ^ @since 9.8+   | Opt_WarnDataKindsTC                             -- ^ @since 9.10+   | Opt_WarnDefaultedExceptionContext               -- ^ @since 9.10+   | Opt_WarnViewPatternSignatures                   -- ^ @since 9.12+   | Opt_WarnUselessSpecialisations                  -- ^ @since 9.14+   | Opt_WarnDeprecatedPragmas                       -- ^ @since 9.14+   | Opt_WarnRuleLhsEqualities+       -- ^ @since 9.14, scheduled to be removed in 9.18+       --+       -- See Note [Quantifying over equalities in RULES] in GHC.Tc.Gen.Sig+   | Opt_WarnUnusableUnpackPragmas                   -- Since 9.14+   | Opt_WarnPatternNamespaceSpecifier               -- Since 9.14    deriving (Eq, Ord, Show, Enum, Bounded)  -- | Return the names of a WarningFlag@@ -1180,12 +1218,16 @@   Opt_WarnImplicitRhsQuantification               -> "implicit-rhs-quantification" :| []   Opt_WarnIncompleteExportWarnings                -> "incomplete-export-warnings" :| []   Opt_WarnIncompleteRecordSelectors               -> "incomplete-record-selectors" :| []-  Opt_WarnBadlyStagedTypes                        -> "badly-staged-types" :| []+  Opt_WarnBadlyLevelledTypes                      -> "badly-levelled-types" :| []   Opt_WarnInconsistentFlags                       -> "inconsistent-flags" :| []   Opt_WarnDataKindsTC                             -> "data-kinds-tc" :| []-  Opt_WarnDeprecatedTypeAbstractions              -> "deprecated-type-abstractions" :| []   Opt_WarnDefaultedExceptionContext               -> "defaulted-exception-context" :| []   Opt_WarnViewPatternSignatures                   -> "view-pattern-signatures" :| []+  Opt_WarnUselessSpecialisations                  -> "useless-specialisations" :| ["useless-specializations"]+  Opt_WarnDeprecatedPragmas                       -> "deprecated-pragmas" :| []+  Opt_WarnRuleLhsEqualities                       -> "rule-lhs-equalities" :| []+  Opt_WarnUnusableUnpackPragmas                   -> "unusable-unpack-pragmas" :| []+  Opt_WarnPatternNamespaceSpecifier               -> "pattern-namespace-specifier" :| []  -- ----------------------------------------------------------------------------- -- Standard sets of warning options@@ -1245,7 +1287,7 @@  -- | Warning groups. ----- As all warnings are in the Weverything set, it is ignored when+-- As all warnings are in the 'W_everything' set, it is ignored when -- displaying to the user which group a warning is in. warningGroups :: [WarningGroup] warningGroups = [minBound..maxBound]@@ -1260,7 +1302,7 @@ -- Separating this from 'warningGroups' allows for multiple -- hierarchies with no inherent relation to be defined. ----- The special-case Weverything group is not included.+-- The special-case 'W_everything' group is not included. warningHierarchies :: [[WarningGroup]] warningHierarchies = hierarchies ++ map (:[]) rest   where@@ -1322,15 +1364,19 @@         Opt_WarnOperatorWhitespaceExtConflict,         Opt_WarnUnicodeBidirectionalFormatCharacters,         Opt_WarnGADTMonoLocalBinds,-        Opt_WarnBadlyStagedTypes,+        Opt_WarnBadlyLevelledTypes,         Opt_WarnTypeEqualityRequiresOperators,         Opt_WarnInconsistentFlags,-        Opt_WarnDataKindsTC,         Opt_WarnTypeEqualityOutOfScope,-        Opt_WarnViewPatternSignatures+        Opt_WarnImplicitRhsQuantification, -- was in -Wcompat since 9.8, enabled by default since 9.14, to turn into a hard error in 9.16+        Opt_WarnViewPatternSignatures,+        Opt_WarnUselessSpecialisations,+        Opt_WarnDeprecatedPragmas,+        Opt_WarnRuleLhsEqualities,+        Opt_WarnUnusableUnpackPragmas       ] --- | Things you get with -W+-- | Things you get with @-W@. minusWOpts :: [WarningFlag] minusWOpts     = standardWarnings ++@@ -1346,7 +1392,7 @@         Opt_WarnUnbangedStrictPatterns       ] --- | Things you get with -Wall+-- | Things you get with @-Wall@. minusWallOpts :: [WarningFlag] minusWallOpts     = minusWOpts ++@@ -1363,25 +1409,25 @@         Opt_WarnIncompleteUniPatterns,         Opt_WarnIncompletePatternsRecUpd,         Opt_WarnIncompleteExportWarnings,+        Opt_WarnIncompleteRecordSelectors,         Opt_WarnDerivingTypeable       ] --- | Things you get with -Weverything, i.e. *all* known warnings flags+-- | Things you get with @-Weverything@, i.e. *all* known warnings flags. minusWeverythingOpts :: [WarningFlag] minusWeverythingOpts = [ toEnum 0 .. ] --- | Things you get with -Wcompat.+-- | Things you get with @-Wcompat@. -- -- This is intended to group together warnings that will be enabled by default -- at some point in the future, so that library authors eager to make their -- code future compatible to fix issues before they even generate warnings. minusWcompatOpts :: [WarningFlag] minusWcompatOpts-    = [ Opt_WarnImplicitRhsQuantification-      , Opt_WarnDeprecatedTypeAbstractions+    = [ Opt_WarnPatternNamespaceSpecifier       ] --- | Things you get with -Wunused-binds+-- | Things you get with @-Wunused-binds@. unusedBindsFlags :: [WarningFlag] unusedBindsFlags = [ Opt_WarnUnusedTopBinds                    , Opt_WarnUnusedLocalBinds
compiler/GHC/Driver/Hooks.hs view
@@ -52,7 +52,7 @@ import GHC.Unit.Module import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface-import GHC.Unit.Home.ModInfo+import GHC.Unit.Home.PackageTable  import GHC.Core import GHC.Core.TyCon
+ compiler/GHC/Driver/IncludeSpecs.hs view
@@ -0,0 +1,48 @@+module GHC.Driver.IncludeSpecs+  ( IncludeSpecs(..)+  , addGlobalInclude+  , addQuoteInclude+  , addImplicitQuoteInclude+  , flattenIncludes+  ) where++import GHC.Prelude++-- | Used to differentiate the scope an include needs to apply to.+-- We have to split the include paths to avoid accidentally forcing recursive+-- includes since -I overrides the system search paths. See #14312.+data IncludeSpecs+  = IncludeSpecs { includePathsQuote  :: [String]+                 , includePathsGlobal :: [String]+                 -- | See Note [Implicit include paths]+                 , includePathsQuoteImplicit :: [String]+                 }+  deriving Show++-- | Append to the list of includes a path that shall be included using `-I`+-- when the C compiler is called. These paths override system search paths.+addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs+addGlobalInclude spec paths  = let f = includePathsGlobal spec+                               in spec { includePathsGlobal = f ++ paths }++-- | Append to the list of includes a path that shall be included using+-- `-iquote` when the C compiler is called. These paths only apply when quoted+-- includes are used. e.g. #include "foo.h"+addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs+addQuoteInclude spec paths  = let f = includePathsQuote spec+                              in spec { includePathsQuote = f ++ paths }++-- | These includes are not considered while fingerprinting the flags for iface+-- | See Note [Implicit include paths]+addImplicitQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs+addImplicitQuoteInclude spec paths  = let f = includePathsQuoteImplicit spec+                              in spec { includePathsQuoteImplicit = f ++ paths }+++-- | Concatenate and flatten the list of global and quoted includes returning+-- just a flat list of paths.+flattenIncludes :: IncludeSpecs -> [String]+flattenIncludes specs =+    includePathsQuote specs +++    includePathsQuoteImplicit specs +++    includePathsGlobal specs
compiler/GHC/Driver/Phases.hs view
@@ -23,6 +23,7 @@    isDynLibSuffix,    isHaskellUserSrcSuffix,    isHaskellSigSuffix,+   isHaskellBootSuffix,    isSourceSuffix,     isHaskellishTarget,@@ -234,7 +235,7 @@ phaseInputExt StopLn              = "o"  haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes,-    js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes+    js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes, haskellish_boot_suffixes  :: [String] -- When a file with an extension in the haskellish_src_suffixes group is -- loaded in --make mode, its imports will be loaded too.@@ -247,7 +248,8 @@  -- Will not be deleted as temp files: haskellish_user_src_suffixes =-  haskellish_sig_suffixes ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ]+  haskellish_sig_suffixes ++ haskellish_boot_suffixes ++ [ "hs", "lhs" ]+haskellish_boot_suffixes     = [ "hs-boot", "lhs-boot" ] haskellish_sig_suffixes      = [ "hsig", "lhsig" ] backpackish_suffixes         = [ "bkp" ] @@ -265,11 +267,12 @@   _         -> ["so"]  isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix,-    isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix+    isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix, isHaskellBootSuffix  :: String -> Bool isHaskellishSuffix     s = s `elem` haskellish_suffixes isBackpackishSuffix    s = s `elem` backpackish_suffixes isHaskellSigSuffix     s = s `elem` haskellish_sig_suffixes+isHaskellBootSuffix    s = s `elem` haskellish_boot_suffixes isHaskellSrcSuffix     s = s `elem` haskellish_src_suffixes isCishSuffix           s = s `elem` cish_suffixes isJsSuffix             s = s `elem` js_suffixes
compiler/GHC/Driver/Ppr.hs view
@@ -6,6 +6,7 @@    , showPpr    , showPprUnsafe    , printForUser+   , printForUserColoured    ) where @@ -34,6 +35,13 @@       doc' = pprWithUnitState unit_state doc  printForUser :: DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO ()-printForUser dflags handle name_ppr_ctx depth doc+printForUser = printForUser' False++printForUserColoured :: DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO ()+printForUserColoured = printForUser' True++printForUser' :: Bool -> DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO ()+printForUser' colour dflags handle name_ppr_ctx depth doc   = printSDocLn ctx (PageMode False) handle doc-    where ctx = initSDocContext dflags (mkUserStyle name_ppr_ctx depth)+    where ctx = initSDocContext dflags (setStyleColoured colour $ mkUserStyle name_ppr_ctx depth)+
compiler/GHC/Driver/Session.hs view
@@ -18,8 +18,6 @@ -- ------------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.Driver.Session (         -- * Dynamic flags and associated configuration types         DumpFlag(..),@@ -81,6 +79,9 @@         safeDirectImpsReq, safeImplicitImpsReq,         unsafeFlags, unsafeFlagsForInfer, +        -- ** base+        baseUnitId,+         -- ** System tool settings and locations         Settings(..),         sProgramName,@@ -162,6 +163,7 @@         updOptLevel,         setTmpDir,         setUnitId,+        setHomeUnitId,          TurnOnFlag,         turnOn,@@ -205,6 +207,9 @@         setUnsafeGlobalDynFlags,          -- * SSE and AVX+        isSse3Enabled,+        isSsse3Enabled,+        isSse4_1Enabled,         isSse4_2Enabled,         isBmiEnabled,         isBmi2Enabled,@@ -233,6 +238,7 @@ import GHC.Platform import GHC.Platform.Ways import GHC.Platform.Profile+import GHC.Platform.ArchOS  import GHC.Unit.Types import GHC.Unit.Parser@@ -247,6 +253,7 @@ import GHC.Settings.Config import GHC.Core.Unfold import GHC.Driver.CmdLine+import GHC.Utils.Logger import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Constants (debugIsOn)@@ -265,7 +272,7 @@ import GHC.Utils.TmpFs import GHC.Utils.Fingerprint import GHC.Utils.Outputable-import GHC.Utils.Error (emptyDiagOpts)+import GHC.Utils.Error (emptyDiagOpts, logInfo) import GHC.Settings import GHC.CmmToAsm.CFG.Weight import GHC.Core.Opt.CallerCC@@ -283,6 +290,7 @@ import Data.Ord import Data.Char import Data.List (intercalate, sortBy, partition)+import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set@@ -391,6 +399,7 @@ settings dflags = Settings   { sGhcNameVersion = ghcNameVersion dflags   , sFileSettings = fileSettings dflags+  , sUnitSettings = unitSettings dflags   , sTargetPlatform = targetPlatform dflags   , sToolSettings = toolSettings dflags   , sPlatformMisc = platformMisc dflags@@ -489,6 +498,10 @@ opt_i                 :: DynFlags -> [String] opt_i dflags= toolSettings_opt_i $ toolSettings dflags ++setBaseUnitId :: String -> DynP ()+setBaseUnitId s = upd $ \d -> d { unitSettings = UnitSettings (stringToUnitId s) }+ -----------------------------------------------------------------------------  {-@@ -700,15 +713,15 @@ -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] -- Config.hs should really use Option. setPgmP   f = alterToolSettings (\s -> s { toolSettings_pgm_P   = (pgm, map Option args)})-  where (pgm:args) = words f+  where pgm:|args = expectNonEmpty $ words f -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] -- Config.hs should really use Option. setPgmJSP   f = alterToolSettings (\s -> s { toolSettings_pgm_JSP   = (pgm, map Option args)})-  where (pgm:args) = words f+  where pgm:|args = expectNonEmpty $ words f -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] -- Config.hs should really use Option. setPgmCmmP f = alterToolSettings (\s -> s { toolSettings_pgm_CmmP = (pgm, map Option args)})-  where (pgm:args) = words f+  where pgm:|args = expectNonEmpty $ words f addOptl   f = alterToolSettings (\s -> s { toolSettings_opt_l   = f : toolSettings_opt_l s}) addOptc   f = alterToolSettings (\s -> s { toolSettings_opt_c   = f : toolSettings_opt_c s}) addOptcxx f = alterToolSettings (\s -> s { toolSettings_opt_cxx = f : toolSettings_opt_cxx s})@@ -800,7 +813,7 @@ -- the parsed 'DynFlags', the left-over arguments, and a list of warnings. -- Throws a 'UsageError' if errors occurred during parsing (such as unknown -- flags or missing arguments).-parseDynamicFlagsCmdLine :: MonadIO m => DynFlags -> [Located String]+parseDynamicFlagsCmdLine :: MonadIO m => Logger -> DynFlags -> [Located String]                          -> m (DynFlags, [Located String], Messages DriverMessage)                             -- ^ Updated 'DynFlags', left-over arguments, and                             -- list of warnings.@@ -810,7 +823,7 @@ -- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags -- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db). -- Used to parse flags set in a modules pragma.-parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String]+parseDynamicFilePragma :: MonadIO m => Logger -> DynFlags -> [Located String]                        -> m (DynFlags, [Located String], Messages DriverMessage)                           -- ^ Updated 'DynFlags', left-over arguments, and                           -- list of warnings.@@ -859,10 +872,11 @@     :: forall m. MonadIO m     => [Flag (CmdLineP DynFlags)]    -- ^ valid flags to match against     -> Bool                          -- ^ are the arguments from the command line?+    -> Logger                        -- ^ logger     -> DynFlags                      -- ^ current dynamic flags     -> [Located String]              -- ^ arguments to parse     -> m (DynFlags, [Located String], Messages DriverMessage)-parseDynamicFlagsFull activeFlags cmdline dflags0 args = do+parseDynamicFlagsFull activeFlags cmdline logger dflags0 args = do   ((leftover, errs, cli_warns), dflags1) <- processCmdLineP activeFlags dflags0 args    -- See Note [Handling errors when parsing command-line flags]@@ -878,7 +892,7 @@       throwGhcExceptionIO (CmdLineError ("combination not supported: " ++                                intercalate "/" (map wayDesc (Set.toAscList theWays)))) -  let (dflags3, consistency_warnings) = makeDynFlagsConsistent dflags2+  let (dflags3, consistency_warnings, infoverb) = makeDynFlagsConsistent dflags2    -- Set timer stats & heap size   when (enableTimeStats dflags3) $ liftIO enableTimingStats@@ -892,6 +906,9 @@   let diag_opts = initDiagOpts dflags3       warns = warnsToMessages diag_opts $ mconcat [consistency_warnings, sh_warns, cli_warns] +  when (logVerbAtLeast logger 3) $+    mapM_ (\(L _loc m) -> liftIO $ logInfo logger m) infoverb+   return (dflags3, leftover, warns)  -- | Check (and potentially disable) any extensions that aren't allowed@@ -1517,6 +1534,8 @@         "Use `-ddump-stg-from-core` or `-ddump-stg-final` instead"   , make_ord_flag defGhcFlag "ddump-stg-tags"         (setDumpFlag Opt_D_dump_stg_tags)+  , make_ord_flag defGhcFlag "ddump-stg-from-js-sinker"+        (setDumpFlag Opt_D_dump_stg_from_js_sinker)   , make_ord_flag defGhcFlag "ddump-call-arity"         (setDumpFlag Opt_D_dump_call_arity)   , make_ord_flag defGhcFlag "ddump-exitify"@@ -1659,6 +1678,8 @@                                                   d { sseVersion = Just SSE2 }))   , make_ord_flag defGhcFlag "msse3"        (noArg (\d ->                                                   d { sseVersion = Just SSE3 }))+  , make_ord_flag defGhcFlag "mssse3"       (noArg (\d ->+                                                  d { sseVersion = Just SSSE3 }))   , make_ord_flag defGhcFlag "msse4"        (noArg (\d ->                                                   d { sseVersion = Just SSE4 }))   , make_ord_flag defGhcFlag "msse4.2"      (noArg (\d ->@@ -1826,6 +1847,19 @@       (intSuffix (\n d -> d {maxForcedSpecArgs = n}))   , make_ord_flag defGhciFlag "fghci-hist-size"       (intSuffix (\n d -> d {ghciHistSize = n}))++  -- wasm ghci browser mode+  , make_ord_flag defGhciFlag "fghci-browser-host"+      $ hasArg $ \f d -> d { ghciBrowserHost = f }+  , make_ord_flag defGhciFlag "fghci-browser-port"+      $ intSuffix $ \n d -> d { ghciBrowserPort = n }+  , make_ord_flag defGhciFlag "fghci-browser-puppeteer-launch-opts"+      $ hasArg $ \f d -> d { ghciBrowserPuppeteerLaunchOpts = Just f }+  , make_ord_flag defGhciFlag "fghci-browser-playwright-browser-type"+      $ hasArg $ \f d -> d { ghciBrowserPlaywrightBrowserType = Just f }+  , make_ord_flag defGhciFlag "fghci-browser-playwright-launch-opts"+      $ hasArg $ \f d -> d { ghciBrowserPlaywrightLaunchOpts = Just f }+   , make_ord_flag defGhcFlag "fmax-inline-alloc-size"       (intSuffix (\n d -> d { maxInlineAllocSize = n }))   , make_ord_flag defGhcFlag "fmax-inline-memcpy-insns"@@ -2052,6 +2086,7 @@       (NoArg (setGeneralFlag Opt_DistrustAllPackages))   , make_ord_flag defFlag "trust"                 (HasArg trustPackage)   , make_ord_flag defFlag "distrust"              (HasArg distrustPackage)+  , make_ord_flag defFlag "base-unit-id"          (HasArg setBaseUnitId)   ]   where     setPackageEnv env = upd $ \s -> s { packageEnv = Just env }@@ -2232,7 +2267,9 @@   Opt_WarnAmbiguousFields -> warnSpec x   Opt_WarnAutoOrphans -> depWarnSpec x "it has no effect"   Opt_WarnCPPUndef -> warnSpec x-  Opt_WarnBadlyStagedTypes -> warnSpec x+  Opt_WarnBadlyLevelledTypes ->+    warnSpec x +++    subWarnSpec "badly-staged-types" x "it is renamed to -Wbadly-levelled-types"   Opt_WarnUnbangedStrictPatterns -> warnSpec x   Opt_WarnDeferredTypeErrors -> warnSpec x   Opt_WarnDeferredOutOfScopeVariables -> warnSpec x@@ -2346,10 +2383,15 @@   Opt_WarnImplicitRhsQuantification -> warnSpec x   Opt_WarnIncompleteExportWarnings -> warnSpec x   Opt_WarnIncompleteRecordSelectors -> warnSpec x-  Opt_WarnDataKindsTC -> warnSpec x-  Opt_WarnDeprecatedTypeAbstractions -> warnSpec x+  Opt_WarnDataKindsTC+    -> depWarnSpec x "DataKinds violations are now always an error"   Opt_WarnDefaultedExceptionContext -> warnSpec x   Opt_WarnViewPatternSignatures -> warnSpec x+  Opt_WarnUselessSpecialisations -> warnSpec x+  Opt_WarnDeprecatedPragmas -> warnSpec x+  Opt_WarnRuleLhsEqualities -> warnSpec x+  Opt_WarnUnusableUnpackPragmas -> warnSpec x+  Opt_WarnPatternNamespaceSpecifier -> warnSpec x  warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)] warningGroupsDeps = map mk warningGroups@@ -2459,6 +2501,14 @@   flagGhciSpec "local-ghci-history"           Opt_LocalGhciHistory,   flagGhciSpec "no-it"                        Opt_NoIt,   flagSpec "ghci-sandbox"                     Opt_GhciSandbox,++  -- wasm ghci browser mode+  flagGhciSpec "ghci-browser"                 Opt_GhciBrowser,+  flagGhciSpec "ghci-browser-redirect-wasi-console" Opt_GhciBrowserRedirectWasiConsole,++  -- load all targets on GHCi startup+  flagGhciSpec "load-initial-targets"         Opt_GhciDoLoadTargets,+   flagSpec "helpful-errors"                   Opt_HelpfulErrors,   flagSpec "hpc"                              Opt_Hpc,   flagSpec "ignore-asserts"                   Opt_IgnoreAsserts,@@ -2521,6 +2571,8 @@   flagSpec "use-rpaths"                       Opt_RPath,   flagSpec "write-interface"                  Opt_WriteInterface,   flagSpec "write-if-simplified-core"         Opt_WriteIfSimplifiedCore,+  flagSpec "write-if-self-recomp"             Opt_WriteSelfRecompInfo,+  flagSpec "write-if-self-recomp-flags"       Opt_WriteSelfRecompFlags,   flagSpec "write-ide-info"                   Opt_WriteHie,   flagSpec "unbox-small-strict-fields"        Opt_UnboxSmallStrictFields,   flagSpec "unbox-strict-fields"              Opt_UnboxStrictFields,@@ -2532,6 +2584,7 @@   flagSpec "catch-nonexhaustive-cases"        Opt_CatchNonexhaustiveCases,   flagSpec "alignment-sanitisation"           Opt_AlignmentSanitisation,   flagSpec "check-prim-bounds"                Opt_DoBoundsChecking,+  flagSpec "add-bco-name"                     Opt_AddBcoName,   flagSpec "num-constant-folding"             Opt_NumConstantFolding,   flagSpec "core-constant-folding"            Opt_CoreConstantFolding,   flagSpec "fast-pap-calls"                   Opt_FastPAPCalls,@@ -2927,13 +2980,18 @@ setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps   where-    deps = [ if turn_on then setExtensionFlag'   d-                        else unSetExtensionFlag' d-           | (f', turn_on, d) <- impliedXFlags, f' == f ]+    deps :: [DynFlags -> DynFlags]+    deps = [ setExtension d+           | (f', d) <- impliedXFlags, f' == f ]         -- When you set f, set the ones it implies         -- NB: use setExtensionFlag recursively, in case the implied flags         --     implies further flags +    setExtension :: OnOff LangExt.Extension -> DynFlags -> DynFlags+    setExtension = \ case+      On extension -> setExtensionFlag' extension+      Off extension -> unSetExtensionFlag' extension+ unSetExtensionFlag' f dflags = xopt_unset dflags f    -- When you un-set f, however, we don't un-set the things it implies    --      (except for -fno-glasgow-exts, which is treated specially)@@ -3063,6 +3121,9 @@ setUnitId :: String -> DynFlags -> DynFlags setUnitId p d = d { homeUnitId_ = stringToUnitId p } +setHomeUnitId :: UnitId -> DynFlags -> DynFlags+setHomeUnitId p d = d { homeUnitId_ = p }+ setWorkingDirectory :: String -> DynFlags -> DynFlags setWorkingDirectory p d = d { workingDirectory =  Just p } @@ -3155,7 +3216,7 @@      -- dummy parser state.     p_state str = initParserState-              (mkParserOpts mempty emptyDiagOpts [] False False False True)+              (mkParserOpts mempty emptyDiagOpts False False False True)               (stringToStringBuffer str)               (mkRealSrcLoc (mkFastString []) 1 1) @@ -3403,11 +3464,15 @@        ("Project Patch Level1",        cProjectPatchLevel1),        ("Project Patch Level2",        cProjectPatchLevel2),        ("Project Unit Id",             cProjectUnitId),+       ("ghc-internal Unit Id",        cGhcInternalUnitId), -- See Note [Special unit-ids]        ("Booter version",              cBooterVersion),        ("Stage",                       cStage),        ("Build platform",              cBuildPlatformString),        ("Host platform",               cHostPlatformString),        ("Target platform",             platformMisc_targetPlatformString $ platformMisc dflags),+       ("target os string",            stringEncodeOS (platformOS (targetPlatform dflags))),+       ("target arch string",          stringEncodeArch (platformArch (targetPlatform dflags))),+       ("target word size in bits",    show (platformWordSizeInBits (targetPlatform dflags))),        ("Have interpreter",            showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags),        ("Object splitting supported",  showBool False),        ("Have native code generator",  showBool $ platformNcgSupported platform),@@ -3453,6 +3518,26 @@     expandDirectories :: FilePath -> Maybe FilePath -> String -> String     expandDirectories topd mtoold = expandToolDir useInplaceMinGW mtoold . expandTopDir topd +-- Note [Special unit-ids]+-- ~~~~~~~~~~~~~~~~~~~~~~~+-- Certain units are special to the compiler:+-- - Wired-in identifiers reference a specific unit-id of `ghc-internal`.+-- - GHC plugins must be linked against a specific unit-id of `ghc`,+--   namely the same one as the compiler.+-- - When using Template Haskell, the result of executing splices refer to+--   the Template Haskell ASTs created using constructors from `ghc-internal`,+--   and must be linked against the same `ghc-internal` unit-id as the compiler.+--+-- We therefore expose the unit-id of `ghc-internal` ("ghc-internal Unit Id") and+-- ghc ("Project Unit Id") through `ghc --info`.+--+-- This allows build tools to act accordingly, eg, if a user wishes to build a+-- GHC plugin, `cabal-install` might force them to use the exact `ghc` unit+-- that the compiler was linked against.+-- See:+--  - https://github.com/haskell/cabal/issues/10087+--  - https://github.com/commercialhaskell/stack/issues/6749+ {- ----------------------------------------------------------------------------- Note [DynFlags consistency] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -3477,12 +3562,35 @@ the flags; this is because API clients may parse flags but update the DynFlags afterwords, before finally running code inside a session (see T10052 and #10052).++Host ways vs Build ways mismatch+--------------------------------+Many consistency checks aim to fix the situation where the wanted build ways+are not compatible with the ways the compiler is built in. This happens when+using the interpreter, TH, and the runtime linker, where the compiler cannot+load objects compiled for ways not matching its own.++For instance, a profiled-dynamic object can only be loaded by a+profiled-dynamic compiler (and not any other kind of compiler).++This incompatibility is traditionally solved in either of two ways:++(1) Force the "wanted" build ways to match the compiler ways exactly,+    guaranteeing they match.++(2) Force the use of the external interpreter. When interpreting is offloaded+    to the external interpreter it no longer matters what are the host compiler ways.++In the checks and fixes performed by `makeDynFlagsConsistent`, the choice+between the two does not seem uniform. TODO: Make this choice more evident and uniform. -}  -- | Resolve any internal inconsistencies in a set of 'DynFlags'. -- Returns the consistent 'DynFlags' as well as a list of warnings--- to report to the user.-makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Warn])+-- to report to the user, and a list of verbose info msgs.+--+-- See Note [DynFlags consistency]+makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Warn], [Located SDoc]) -- Whenever makeDynFlagsConsistent does anything, it starts over, to -- ensure that a later change doesn't invalidate an earlier check. -- Be careful not to introduce potential loops!@@ -3573,13 +3681,49 @@   | LinkMergedObj <- ghcLink dflags  , Nothing <- outputFile dflags- = pgmError "--output must be specified when using --merge-objs"+    = pgmError "--output must be specified when using --merge-objs" - | otherwise = (dflags, mempty)+ | platformTablesNextToCode platform+   && os == OSMinGW32+   && arch == ArchAArch64+    = case backendCodeOutput (backend dflags) of+        LlvmCodeOutput -> pgmError "-fllvm is incompatible with enabled TablesNextToCode at Windows Aarch64"+        NcgCodeOutput -> pgmError "-fasm is incompatible with enabled TablesNextToCode at Windows Aarch64"+        _ -> (dflags, mempty, mempty)++  -- When we do ghci, force using dyn ways if the target RTS linker+  -- only supports dynamic code+ | LinkInMemory <- ghcLink dflags+ , sTargetRTSLinkerOnlySupportsSharedLibs $ settings dflags+ , not (ways dflags `hasWay` WayDyn && gopt Opt_ExternalInterpreter dflags)+    = flip loopNoWarn "Forcing dynamic way because target RTS linker only supports dynamic code" $+        -- See checkOptions, -fexternal-interpreter is+        -- required when using --interactive with a non-standard+        -- way (-prof, -static, or -dynamic).+        setGeneralFlag' Opt_ExternalInterpreter $+        addWay' WayDyn dflags++ | LinkInMemory <- ghcLink dflags+ , not (gopt Opt_ExternalInterpreter dflags)+ , targetWays_ dflags /= hostFullWays+    = flip loopNoWarn "Forcing build ways to match the compiler ways because we're using the internal interpreter" $+        let dflags_a = dflags { targetWays_ = hostFullWays }+            dflags_b = foldl gopt_set dflags_a+                     $ concatMap (wayGeneralFlags platform)+                                 hostFullWays+            dflags_c = foldl gopt_unset dflags_b+                     $ concatMap (wayUnsetGeneralFlags platform)+                                 hostFullWays+        in dflags_c++ | otherwise = (dflags, mempty, mempty)     where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")           loop updated_dflags warning               = case makeDynFlagsConsistent updated_dflags of-                (dflags', ws) -> (dflags', L loc (DriverInconsistentDynFlags warning) : ws)+                (dflags', ws, is) -> (dflags', L loc (DriverInconsistentDynFlags warning) : ws, is)+          loopNoWarn updated_dflags doc+              = case makeDynFlagsConsistent updated_dflags of+                (dflags', ws, is) -> (dflags', ws, L loc (text doc):is)           platform = targetPlatform dflags           arch = platformArch platform           os   = platformOS   platform
compiler/GHC/Hs/Binds.hs view
@@ -26,16 +26,19 @@ module GHC.Hs.Binds   ( module Language.Haskell.Syntax.Binds   , module GHC.Hs.Binds+  , HsRuleBndrsAnn(..)   ) where  import GHC.Prelude  import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Binds+import Language.Haskell.Syntax.Expr( LHsExpr ) -import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprFunBind, pprPatBind )+import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprLExpr, pprFunBind, pprPatBind ) import {-# SOURCE #-} GHC.Hs.Pat  (pprLPat ) +import GHC.Data.BooleanFormula ( LBooleanFormula, pprBooleanFormulaNormal ) import GHC.Types.Tickish import GHC.Hs.Extension import GHC.Parser.Annotation@@ -47,7 +50,6 @@ import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Var-import GHC.Data.BooleanFormula (LBooleanFormula) import GHC.Types.Name  import GHC.Utils.Outputable@@ -138,20 +140,6 @@  type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = DataConCantHappen -type instance XNoMultAnn GhcPs = NoExtField-type instance XNoMultAnn GhcRn = NoExtField-type instance XNoMultAnn GhcTc = Mult--type instance XPct1Ann   GhcPs = EpToken "%1"-type instance XPct1Ann   GhcRn = NoExtField-type instance XPct1Ann   GhcTc = Mult--type instance XMultAnn   GhcPs = EpToken "%"-type instance XMultAnn   GhcRn = NoExtField-type instance XMultAnn   GhcTc = Mult--type instance XXMultAnn  (GhcPass _) = DataConCantHappen- data AnnPSB   = AnnPSB {       ap_pattern :: EpToken "pattern",@@ -165,14 +153,14 @@   noAnn = AnnPSB noAnn noAnn noAnn noAnn noAnn  setTcMultAnn :: Mult -> HsMultAnn GhcRn -> HsMultAnn GhcTc-setTcMultAnn mult (HsPct1Ann _)   = HsPct1Ann mult-setTcMultAnn mult (HsMultAnn _ p) = HsMultAnn mult p-setTcMultAnn mult (HsNoMultAnn _) = HsNoMultAnn mult+setTcMultAnn mult (HsLinearAnn _)   = HsLinearAnn mult+setTcMultAnn mult (HsExplicitMult _ p) = HsExplicitMult mult p+setTcMultAnn mult (HsUnannotated _) = HsUnannotated mult  getTcMultAnn :: HsMultAnn GhcTc -> Mult-getTcMultAnn (HsPct1Ann mult)   = mult-getTcMultAnn (HsMultAnn mult _) = mult-getTcMultAnn (HsNoMultAnn mult) = mult+getTcMultAnn (HsLinearAnn mult)   = mult+getTcMultAnn (HsExplicitMult mult _) = mult+getTcMultAnn (HsUnannotated mult) = mult  -- --------------------------------------------------------------------- @@ -544,13 +532,6 @@ plusHsValBinds _ _   = panic "HsBinds.plusHsValBinds" --- Used to print, for instance, let bindings:---   let %1 x = …-pprHsMultAnn :: forall id. OutputableBndrId id => HsMultAnn (GhcPass id) -> SDoc-pprHsMultAnn (HsNoMultAnn _) = empty-pprHsMultAnn (HsPct1Ann _) = text "%1"-pprHsMultAnn (HsMultAnn _ p) = text "%" <> ppr p- instance (OutputableBndrId pl, OutputableBndrId pr)          => Outputable (HsBindLR (GhcPass pl) (GhcPass pr)) where     ppr mbind = ppr_monobind mbind@@ -631,7 +612,7 @@                     GhcPs -> ppr v                     GhcRn -> ppr v                     GhcTc -> ppr v-          PrefixCon _ vs -> hsep (pprPrefixOcc psyn : map ppr_v vs)+          PrefixCon vs   -> hsep (pprPrefixOcc psyn : map ppr_v vs)             where                 ppr_v v = case ghcPass @r of                     GhcPs -> ppr v@@ -646,9 +627,9 @@                     GhcTc -> ppr v        ppr_rhs = case dir of-          Unidirectional           -> ppr_simple (text "<-")+          Unidirectional           -> ppr_simple larrow           ImplicitBidirectional    -> ppr_simple equals-          ExplicitBidirectional mg -> ppr_simple (text "<-") <+> text "where" $$+          ExplicitBidirectional mg -> ppr_simple larrow <+> text "where" $$                                       (nest 2 $ pprFunBind mg)  pprTicks :: SDoc -> SDoc -> SDoc@@ -663,10 +644,9 @@          then pp_when_debug          else pp_no_debug -instance Outputable (XRec pass (IdP pass)) => Outputable (RecordPatSynField pass) where+instance Outputable (XRecGhc (IdGhcP p)) => Outputable (RecordPatSynField (GhcPass p)) where     ppr (RecordPatSynField { recordPatSynField = v }) = ppr v - {- ************************************************************************ *                                                                      *@@ -725,6 +705,11 @@ type instance XMinimalSig       (GhcPass p) = ((EpaLocation, EpToken "#-}"), SourceText) type instance XSCCFunSig        (GhcPass p) = ((EpaLocation, EpToken "#-}"), SourceText) type instance XCompleteMatchSig (GhcPass p) = ((EpaLocation, Maybe TokDcolon, EpToken "#-}"), SourceText)++type instance XSpecSigE         GhcPs = AnnSpecSig+type instance XSpecSigE         GhcRn = Name+type instance XSpecSigE         GhcTc = NoExtField+     -- SourceText: See Note [Pragma source text] in "GHC.Types.SourceText" type instance XXSig             GhcPs = DataConCantHappen type instance XXSig             GhcRn = IdSig@@ -739,7 +724,7 @@   = AnnSpecSig {       ass_open   :: EpaLocation,       ass_close  :: EpToken "#-}",-      ass_dcolon :: TokDcolon,+      ass_dcolon :: Maybe TokDcolon, -- Only for old SpecSig, remove when it goes       ass_act    :: ActivationAnn     } deriving Data @@ -818,26 +803,48 @@  -- | Type checker Specialisation Pragmas ----- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer+-- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker+-- to the desugarer data TcSpecPrags   = IsDefaultMethod     -- ^ Super-specialised: a default method should                         -- be macro-expanded at every call site   | SpecPrags [LTcSpecPrag]-  deriving Data --- | Located Type checker Specification Pragmas+-- | Located Type checker Specialisation Pragmas type LTcSpecPrag = Located TcSpecPrag --- | Type checker Specification Pragma+-- | Type checker Specialisation Pragma+--+-- This data type is used to communicate between the typechecker and+-- the desugarer. data TcSpecPrag+  -- | Old-form specialise pragma   = SpecPrag-        Id-        HsWrapper-        InlinePragma-  -- ^ The Id to be specialised, a wrapper that specialises the-  -- polymorphic function, and inlining spec for the specialised function-  deriving Data+      Id+      -- ^ 'Id' to be specialised+      HsWrapper+      -- ^ wrapper that specialises the polymorphic function+      InlinePragma+      -- ^ inlining spec for the specialised function+   -- | New-form specialise pragma+   | SpecPragE+     { spe_fn_nm :: Name+       -- ^ 'Name' of the 'Id' being specialised+     , spe_fn_id :: Id+        -- ^ 'Id' being specialised+        --+        -- Note that 'spe_fn_nm' may differ from @'idName' 'spe_fn_id'@+        -- in the case of instance methods, where the 'Name' is the+        -- class-op selector but the 'spe_fn_id' is that for the local method+     , spe_inl   :: InlinePragma+        -- ^ (optional) INLINE annotation and activation phase annotation +     , spe_bndrs :: [Var]+        -- ^ TyVars, EvVars, and Ids+     , spe_call  :: LHsExpr GhcTc+        -- ^ The type-checked specialise expression+     }+ noSpecPrags :: TcSpecPrags noSpecPrags = SpecPrags [] @@ -859,19 +866,34 @@   | is_deflt                 = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)   | otherwise                = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (FixSig _ fix_sig)   = ppr fix_sig-ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec }))-  = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc (pprSpec (unLoc var)-                                             (interpp'SP ty) inl)++ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_src = src, inl_inline = spec }))+  = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc $+    pprSpec (unLoc var) (interpp'SP ty) inl     where       pragmaSrc = case spec of-        NoUserInlinePrag -> "{-# " ++ extractSpecPragName (inl_src inl)-        _                -> "{-# " ++ extractSpecPragName (inl_src inl)  ++ "_INLINE"+        NoUserInlinePrag -> "{-# " ++ extractSpecPragName src+        _                -> "{-# " ++ extractSpecPragName src  ++ "_INLINE"++ppr_sig (SpecSigE _ bndrs spec_e inl@(InlinePragma { inl_src = src, inl_inline = spec }))+  = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc $+    pp_inl <+> hang (ppr bndrs) 2 (pprLExpr spec_e)+  where+    -- SPECIALISE or SPECIALISE_INLINE+    pragmaSrc = case spec of+      NoUserInlinePrag -> "{-# " ++ extractSpecPragName src+      _                -> "{-# " ++ extractSpecPragName src  ++ "_INLINE"++    pp_inl | isDefaultInlinePragma inl = empty+           | otherwise = pprInline inl+ ppr_sig (InlineSig _ var inl)   = ppr_pfx <+> pprInline inl <+> pprPrefixOcc (unLoc var) <+> text "#-}"     where       ppr_pfx = case inlinePragmaSource inl of         SourceText src -> ftext src         NoSourceText   -> text "{-#" <+> inlinePragmaName (inl_inline inl)+ ppr_sig (SpecInstSig (_, src) ty)   = pragSrcBrackets src "{-# pragma" (text "instance" <+> ppr ty) ppr_sig (MinimalSig (_, src) bf)@@ -906,6 +928,7 @@  | is_deflt                     = text "default type signature"  | otherwise                    = text "class method signature" hsSigDoc (SpecSig _ _ _ inl)    = (inlinePragmaName . inl_inline $ inl) <+> text "pragma"+hsSigDoc (SpecSigE _ _ _ inl)   = (inlinePragmaName . inl_inline $ inl) <+> text "pragma" hsSigDoc (InlineSig _ _ prag)   = (inlinePragmaName . inl_inline $ prag) <+> text "pragma" -- Using the 'inlinePragmaName' function ensures that the pragma name for any -- one of the INLINE/INLINABLE/NOINLINE pragmas are printed after being extracted@@ -968,11 +991,58 @@ instance Outputable TcSpecPrag where   ppr (SpecPrag var _ inl)     = text (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "<type>") inl+  ppr (SpecPragE { spe_bndrs = bndrs, spe_call = spec_e, spe_inl = inl })+    = text (extractSpecPragName $ inl_src inl)+       <+> hang (ppr bndrs) 2 (pprLExpr spec_e) -pprMinimalSig :: (OutputableBndr name)-              => LBooleanFormula (GenLocated l name) -> SDoc-pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)+pprMinimalSig :: OutputableBndrId p  => LBooleanFormula (GhcPass p) -> SDoc+pprMinimalSig (L _ bf) = pprBooleanFormulaNormal bf ++{- *********************************************************************+*                                                                      *+                  RuleBndrs+*                                                                      *+********************************************************************* -}++data HsRuleBndrsAnn+  = HsRuleBndrsAnn+       { rb_tyanns :: Maybe (TokForall, EpToken ".")+                 -- ^ The locations of 'forall' and '.' for forall'd type vars+                 -- Using AddEpAnn to capture possible unicode variants+       , rb_tmanns :: Maybe (TokForall, EpToken ".")+                 -- ^ The locations of 'forall' and '.' for forall'd term vars+                 -- Using AddEpAnn to capture possible unicode variants+       } deriving (Data, Eq)++instance NoAnn HsRuleBndrsAnn where+  noAnn = HsRuleBndrsAnn Nothing Nothing++++type instance XXRuleBndrs   (GhcPass _) = DataConCantHappen+type instance XCRuleBndrs   GhcPs = HsRuleBndrsAnn+type instance XCRuleBndrs   GhcRn = NoExtField+type instance XCRuleBndrs   GhcTc = [Var]   -- Binders of the rule, not+                                            -- necessarily in dependency order++type instance XRuleBndrSig  (GhcPass _) = AnnTyVarBndr+type instance XCRuleBndr    (GhcPass _) = AnnTyVarBndr+type instance XXRuleBndr    (GhcPass _) = DataConCantHappen++instance (OutputableBndrId p) => Outputable (RuleBndrs (GhcPass p)) where+   ppr (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = tmvs })+     = pp_forall_ty tyvs <+> pp_forall_tm tyvs+     where+       pp_forall_ty Nothing     = empty+       pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot+       pp_forall_tm Nothing | null tmvs = empty+       pp_forall_tm _ = forAllLit <+> fsep (map ppr tmvs) <> dot++instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where+   ppr (RuleBndr _ name) = ppr name+   ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty)+ {- ************************************************************************ *                                                                      *@@ -984,6 +1054,7 @@ type instance Anno (HsBindLR (GhcPass idL) (GhcPass idR)) = SrcSpanAnnA type instance Anno (IPBind (GhcPass p)) = SrcSpanAnnA type instance Anno (Sig (GhcPass p)) = SrcSpanAnnA+type instance Anno (RuleBndr (GhcPass p)) = EpAnnCO  type instance Anno (FixitySig (GhcPass p)) = SrcSpanAnnA
compiler/GHC/Hs/Decls.hs view
@@ -43,7 +43,7 @@   isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,   isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,   tyFamInstDeclName, tyFamInstDeclLName,-  countTyClDecls, pprTyClDeclFlavour,+  countTyClDecls, tyClDeclFlavour,   tyClDeclLName, tyClDeclTyVars,   hsDeclHasCusk, famResultKindSignature,   FamilyDecl(..), LFamilyDecl,@@ -67,7 +67,7 @@   XViaStrategyPs(..),   -- ** @RULE@ declarations   LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..),-  HsRuleAnn(..), ActivationAnn(..),+  HsRuleAnn(..),   RuleBndr(..),LRuleBndr,   collectRuleBndrSigTys,   flattenRuleDecls, pprFullRuleName,@@ -110,6 +110,7 @@ import GHC.Prelude  import Language.Haskell.Syntax.Decls+import Language.Haskell.Syntax.Extension  import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprUntypedSplice )         -- Because Expr imports Decls via HsBracket@@ -119,7 +120,7 @@ import GHC.Hs.Doc import GHC.Types.Basic import GHC.Core.Coercion-import Language.Haskell.Syntax.Extension+ import GHC.Hs.Extension import GHC.Parser.Annotation import GHC.Types.Name@@ -138,6 +139,7 @@  import GHC.Data.Maybe import Data.Data (Data)+import Data.List (concatMap) import Data.Foldable (toList)  {-@@ -229,6 +231,20 @@                 , L loc (FixSig _ sig) <- sigs                 ] +hsGroupInstDecls :: HsGroup (GhcPass p) -> [LInstDecl (GhcPass p)]+hsGroupInstDecls = (=<<) group_instds . hs_tyclds++-- Helpers to flatten TyClGroups.+-- See (TCDEP1) in Note [Dependency analysis of type and class decls] in GHC.Rename.Module+tyClGroupTyClDecls :: [TyClGroup (GhcPass p)] -> [LTyClDecl (GhcPass p)]+tyClGroupInstDecls :: [TyClGroup (GhcPass p)] -> [LInstDecl (GhcPass p)]+tyClGroupRoleDecls :: [TyClGroup (GhcPass p)] -> [LRoleAnnotDecl (GhcPass p)]+tyClGroupKindSigs  :: [TyClGroup (GhcPass p)] -> [LStandaloneKindSig (GhcPass p)]+tyClGroupTyClDecls = Data.List.concatMap group_tyclds+tyClGroupInstDecls = Data.List.concatMap group_instds+tyClGroupRoleDecls = Data.List.concatMap group_roles+tyClGroupKindSigs  = Data.List.concatMap group_kisigs+ appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p)              -> HsGroup (GhcPass p) appendGroups@@ -444,6 +460,10 @@ tyClDeclLName (DataDecl { tcdLName = ln })  = ln tyClDeclLName (ClassDecl { tcdLName = ln }) = ln +tyClDeclTyVars :: TyClDecl (GhcPass p) -> LHsQTyVars (GhcPass p)+tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs+tyClDeclTyVars d = tcdTyVars d+ countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int)         -- class, synonym decls, data, newtype, family decls countTyClDecls decls@@ -530,7 +550,7 @@       ppr instds  pp_vanilla_decl_head :: (OutputableBndrId p)-   => XRec (GhcPass p) (IdP (GhcPass p))+   => XRecGhc (IdGhcP p)    -> LHsQTyVars (GhcPass p)    -> LexicalFixity    -> Maybe (LHsContext (GhcPass p))@@ -551,13 +571,18 @@                   , hsep (map (ppr.unLoc) (varl:varsr))]     pp_tyvars [] = pprPrefixOcc (unLoc thing) -pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc-pprTyClDeclFlavour (ClassDecl {})   = text "class"-pprTyClDeclFlavour (SynDecl {})     = text "type"-pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})-  = pprFlavour info <+> text "family"-pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = nd } })-  = ppr (dataDefnConsNewOrData nd)+tyClDeclFlavour :: TyClDecl (GhcPass p) -> TyConFlavour tc+tyClDeclFlavour (ClassDecl {})   = ClassFlavour+tyClDeclFlavour (SynDecl {})     = TypeSynonymFlavour+tyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})+  = case info of+      DataFamily          -> OpenFamilyFlavour (IAmData DataType) Nothing+      OpenTypeFamily      -> OpenFamilyFlavour IAmType Nothing+      ClosedTypeFamily {} -> ClosedTypeFamilyFlavour+tyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = nd } })+  = case dataDefnConsNewOrData nd of+      NewType  -> NewtypeFlavour+      DataType -> DataTypeFlavour  instance OutputableBndrId p => Outputable (FunDep (GhcPass p)) where   ppr = pprFunDep@@ -580,7 +605,14 @@ *                                                                      * ********************************************************************* -} -type instance XCTyClGroup (GhcPass _) = NoExtField+type instance XCTyClGroup GhcPs = NoExtField++type instance XCTyClGroup GhcRn = NameSet     -- Lexical dependencies of an SCC+  -- What names exactly are in this NameSet? See Note [Prepare TyClGroup FVs] in GHC.Rename.Module+  -- How is this NameSet used? See Note [Retrying TyClGroups] in GHC.Tc.TyCl++type instance XCTyClGroup GhcTc = DataConCantHappen+ type instance XXTyClGroup (GhcPass _) = DataConCantHappen  @@ -620,7 +652,7 @@  ------------- Functions over FamilyDecls ----------- -familyDeclLName :: FamilyDecl (GhcPass p) -> XRec (GhcPass p) (IdP (GhcPass p))+familyDeclLName :: FamilyDecl (GhcPass p) -> XRecGhc (IdGhcP p) familyDeclLName (FamilyDecl { fdLName = n }) = n  familyDeclName :: FamilyDecl (GhcPass p) -> IdP (GhcPass p)@@ -667,7 +699,7 @@                   TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr       pp_inj = case mb_inj of                  Just (L _ (InjectivityAnn _ lhs rhs)) ->-                   hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]+                   hsep [ vbar, ppr lhs, arrow, hsep (map ppr rhs) ]                  Nothing -> empty       (pp_where, pp_eqns) = case info of         ClosedTypeFamily mb_eqns ->@@ -779,7 +811,7 @@ -- | Return @'Just' fields@ if a data constructor declaration uses record -- syntax (i.e., 'RecCon'), where @fields@ are the field selectors. -- Otherwise, return 'Nothing'.-getRecConArgs_maybe :: ConDecl GhcRn -> Maybe (LocatedL [LConDeclField GhcRn])+getRecConArgs_maybe :: ConDecl GhcRn -> Maybe (LocatedL [LHsConDeclRecField GhcRn]) getRecConArgs_maybe (ConDeclH98{con_args = args}) = case args of   PrefixCon{} -> Nothing   RecCon flds -> Just flds@@ -836,7 +868,7 @@ instance OutputableBndrId p        => Outputable (StandaloneKindSig (GhcPass p)) where   ppr (StandaloneKindSig _ v ki)-    = text "type" <+> pprPrefixOcc (unLoc v) <+> text "::" <+> ppr ki+    = text "type" <+> pprPrefixOcc (unLoc v) <+> dcolon <+> ppr ki  pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc pp_condecls cs@@ -860,27 +892,31 @@   where     -- In ppr_details: let's not print the multiplicities (they are always 1, by     -- definition) as they do not appear in an actual declaration.-    ppr_details (InfixCon t1 t2) = hsep [ppr (hsScaledThing t1),+    ppr_details (InfixCon t1 t2) = hsep [pprHsConDeclFieldNoMult t1,                                          pprInfixOcc con,-                                         ppr (hsScaledThing t2)]-    ppr_details (PrefixCon _ tys) = hsep (pprPrefixOcc con-                                    : map (pprHsType . unLoc . hsScaledThing) tys)+                                         pprHsConDeclFieldNoMult t2]+    ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc con+                                    : map pprHsConDeclFieldNoMult tys)     ppr_details (RecCon fields)  = pprPrefixOcc con-                                 <+> pprConDeclFields (unLoc fields)+                                    <+> pprHsConDeclRecFields (unLoc fields) -pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs+pprConDecl (ConDeclGADT { con_names = cons+                        , con_outer_bndrs = L _ outer_bndrs+                        , con_inner_bndrs = inner_bndrs                         , con_mb_cxt = mcxt, con_g_args = args                         , con_res_ty = res_ty, con_doc = doc })   = pprMaybeWithDoc doc $ ppr_con_names (toList cons) <+> dcolon-    <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt,+    <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs+                <+> hsep (map pprHsForAllTelescope inner_bndrs)+                <+> pprLHsContext mcxt,               sep (ppr_args args ++ [ppr res_ty]) ])   where-    ppr_args (PrefixConGADT _ args) = map (\(HsScaled arr t) -> ppr t <+> ppr_arr arr) args-    ppr_args (RecConGADT _ fields) = [pprConDeclFields (unLoc fields) <+> arrow]+    ppr_args (PrefixConGADT _ args) = map (pprHsConDeclFieldWith (\arr tyDoc -> tyDoc <+> ppr_arr arr)) args+    ppr_args (RecConGADT _ fields) = [pprHsConDeclRecFields (unLoc fields) <+> arrow]      -- Display linear arrows as unrestricted with -XNoLinearTypes     -- (cf. dataConDisplayType in Note [Displaying linear fields] in GHC.Core.DataCon)-    ppr_arr (HsLinearArrow _) = sdocOption sdocLinearTypes $ \show_linear_types ->+    ppr_arr (HsLinearAnn _) = sdocOption sdocLinearTypes $ \show_linear_types ->                                   if show_linear_types then lollipop else arrow     ppr_arr arr = pprHsArrow arr @@ -1077,10 +1113,6 @@ newOrDataToFlavour NewType  = NewtypeFlavour newOrDataToFlavour DataType = DataTypeFlavour -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@@ -1295,15 +1327,13 @@  type instance XXRuleDecls    (GhcPass _) = DataConCantHappen -type instance XHsRule       GhcPs = (HsRuleAnn, SourceText)+type instance XHsRule       GhcPs = ((ActivationAnn, EpToken "="), SourceText) type instance XHsRule       GhcRn = (HsRuleRn, SourceText) type instance XHsRule       GhcTc = (HsRuleRn, SourceText)  data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS   deriving Data -type instance XXRuleDecl    (GhcPass _) = DataConCantHappen- data HsRuleAnn   = HsRuleAnn        { ra_tyanns :: Maybe (TokForall, EpToken ".")@@ -1315,13 +1345,11 @@ instance NoAnn HsRuleAnn where   noAnn = HsRuleAnn Nothing Nothing noAnn noAnn +type instance XXRuleDecl    (GhcPass _) = DataConCantHappen+ flattenRuleDecls :: [LRuleDecls (GhcPass p)] -> [LRuleDecl (GhcPass p)] flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls -type instance XCRuleBndr    (GhcPass _) = AnnTyVarBndr-type instance XRuleBndrSig  (GhcPass _) = AnnTyVarBndr-type instance XXRuleBndr    (GhcPass _) = DataConCantHappen- instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where   ppr (HsRules { rds_ext = ext                , rds_rules = rules })@@ -1336,28 +1364,18 @@   ppr (HsRule { rd_ext  = ext               , rd_name = name               , rd_act  = act-              , rd_tyvs = tys-              , rd_tmvs = tms+              , rd_bndrs = bndrs               , rd_lhs  = lhs               , rd_rhs  = rhs })         = sep [pprFullRuleName st name <+> ppr act,-               nest 4 (pp_forall_ty tys <+> pp_forall_tm tys-                                        <+> pprExpr (unLoc lhs)),+               nest 4 (ppr bndrs <+> pprExpr (unLoc lhs)),                nest 6 (equals <+> pprExpr (unLoc rhs)) ]         where-          pp_forall_ty Nothing     = empty-          pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot-          pp_forall_tm Nothing | null tms = empty-          pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot           st = case ghcPass @p of                  GhcPs | (_, st) <- ext -> st                  GhcRn | (_, st) <- ext -> st                  GhcTc | (_, st) <- ext -> st -instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where-   ppr (RuleBndr _ name) = ppr name-   ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty)- pprFullRuleName :: SourceText -> GenLocated a (RuleName) -> SDoc pprFullRuleName st (L _ n) = pprWithSourceText st (doubleQuotes $ ftext n) @@ -1471,7 +1489,7 @@ type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA type instance Anno (ConDecl (GhcPass p)) = SrcSpanAnnA type instance Anno Bool = EpAnnCO-type instance Anno [LocatedA (ConDeclField (GhcPass _))] = SrcSpanAnnL+type instance Anno [LocatedA (HsConDeclRecField (GhcPass _))] = SrcSpanAnnL type instance Anno (FamEqn p (LocatedA (HsType p))) = SrcSpanAnnA type instance Anno (TyFamInstDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (DataFamInstDecl (GhcPass p)) = SrcSpanAnnA@@ -1487,7 +1505,6 @@ type instance Anno (RuleDecls (GhcPass p)) = SrcSpanAnnA type instance Anno (RuleDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (SourceText, RuleName) = EpAnnCO-type instance Anno (RuleBndr (GhcPass p)) = EpAnnCO type instance Anno (WarnDecls (GhcPass p)) = SrcSpanAnnA type instance Anno (WarnDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA
+ compiler/GHC/Hs/Doc.hs-boot view
@@ -0,0 +1,19 @@+{-# LANGUAGE RoleAnnotations #-}+module GHC.Hs.Doc where++-- See #21592 for progress on removing this boot file.++import GHC.Types.SrcLoc+import GHC.Hs.DocString+import Data.Kind++type role WithHsDocIdentifiers representational nominal+type WithHsDocIdentifiers :: Type -> Type -> Type+data WithHsDocIdentifiers a pass++type HsDoc :: Type -> Type+type HsDoc = WithHsDocIdentifiers HsDocString++type LHsDoc :: Type -> Type+type LHsDoc pass = Located (HsDoc pass)+
compiler/GHC/Hs/Dump.hs view
@@ -6,6 +6,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -fno-specialise #-}+   -- Don't do type-class specialisation; it goes mad in this module+   -- See #25463+ -- | Contains a debug function to dump parts of the GHC.Hs AST. It uses a syb -- traversal which falls back to displaying based on the constructor name, so -- can be used to dump anything having a @Data.Data@ instance.
compiler/GHC/Hs/Expr.hs view
@@ -55,6 +55,7 @@ import GHC.Types.SrcLoc import GHC.Types.Tickish (CoreTickish) import GHC.Types.Unique.Set (UniqSet)+import GHC.Types.ThLevelIndex import GHC.Core.ConLike ( conLikeName, ConLike ) import GHC.Unit.Module (ModuleName) import GHC.Utils.Misc@@ -75,9 +76,10 @@ import qualified Data.Kind import Data.Maybe (isJust) import Data.Foldable ( toList )-import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE import Data.Void (Void)-+import qualified Data.Set as S {- ********************************************************************* *                                                                      *                 Expressions proper@@ -146,11 +148,6 @@ mkSyntaxExpr :: HsExpr GhcRn -> SyntaxExprRn mkSyntaxExpr = SyntaxExprRn --- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the--- renamer).-mkRnSyntaxExpr :: Name -> SyntaxExprRn-mkRnSyntaxExpr name = SyntaxExprRn $ HsVar noExtField $ noLocA name- instance Outputable SyntaxExprRn where   ppr (SyntaxExprRn expr) = ppr expr   ppr NoSyntaxExprRn      = text "<no syntax expr>"@@ -225,11 +222,6 @@ instance NoAnn EpAnnLam where   noAnn = EpAnnLam noAnn noAnn -data EpAnnUnboundVar = EpAnnUnboundVar-     { hsUnboundBackquotes :: (EpToken "`", EpToken "`")-     , hsUnboundHole       :: EpToken "_"-     } deriving Data- -- Record selectors at parse time are HsVar; they convert to HsRecSel -- on renaming. type instance XRecSel              GhcPs = DataConCantHappen@@ -246,14 +238,6 @@  type instance XVar           (GhcPass _) = NoExtField -type instance XUnboundVar    GhcPs = Maybe EpAnnUnboundVar-type instance XUnboundVar    GhcRn = NoExtField-type instance XUnboundVar    GhcTc = HoleExprRef-  -- We really don't need the whole HoleExprRef; just the IORef EvTerm-  -- would be enough. But then deriving a Data instance becomes impossible.-  -- Much, much easier just to define HoleExprRef with a Data instance and-  -- store the whole structure.- type instance XIPVar         GhcPs = NoExtField type instance XIPVar         GhcRn = NoExtField type instance XIPVar         GhcTc = DataConCantHappen@@ -399,6 +383,148 @@   -- A free-standing HsEmbTy is an error.   -- Valid usages are immediately desugared into Type. ++{-+Note [Holes in expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note explains how GHC uses the `HsHole` constructor.++`HsHole` is used to represent:++  - anonymous ("_") and named ("_x") holes in expressions,+  - unbound variables,+  - and parse errors.++A `HsHole` can be thought of as any thing which is not necessarily a valid or+fully defined program fragment, but for which a type can be derived.++Note that holes (wildcards) in types, and partial type signatures, are not+handled using the mechanisms described here. Instead, see+Note [The wildcard story for types] for the relevant information.+++* User-facing behavior++  While GHC uses the same internal mechanism to derive the type for any+  `HsHole`, it gives different feedback to the user depending on the type of+  hole. For example, an anonymous hole of the form++    foo x = x && _++  gives the diagnostic++    Foo.hs:5:14: error: [GHC-88464]+      • Found hole: _ :: Bool+      • In the second argument of ‘(&&)’, namely ‘_’+        In the expression: x && _++  while an expression containing an unbound variable++    foo x = x && y++  gives++    Foo.hs:5:14: error: [GHC-88464]+      Variable not in scope: y :: Bool+++* HsHole during parsing, renaming, and type checking++  The usage of `HsHole` during the three phases is listed below.++  - Anynomous holes, i.e. the user wrote "_":++      Parser        HsHole (HoleVar "_")+      Renamer       HsHole (HoleVar "_")+      Typechecker   HsHole (HoleVar "_", ref :: HoleExprRef)++  - Unbound variables and named holes; i.e. the user wrote "x" or "_x", where+    `x` or `_x` is not in scope. A variable with a leading underscore has no+    special meaning to the parser.++      Parser        HsVar "_x"+      Renamer       HsHole (HoleVar "_x")+      Typechecker   HsHole (HoleVar "_x", ref :: HoleExprRef)++  - Parse errors currently do not survive beyond the parser because an error is+    thrown after parsing. However, in the future GHC is intended to be tolerant+    of parse errors until the type checking phase to provide diagnostics similar+    to holes. This current singular case looks like this:++      Parser        HsHole HoleError++  Note that between anonymous holes, named holes, and unbound variables only the+  parsing phase is distinct, while during the renaming and type checking phases+  the cases are handled identically. The distinction that the user can observe+  is only introduced during final error reporting. There the `RdrName` is+  examined to see whether it starts with an underscore or not to determine+  whether the `HsHole` came from a hole or an out of scope variable.+++* Contents of HoleExprRef++  The HoleExprRef type used in the type checking phase is a data structure+  containing:++   - The type of the hole.+   - A ref-cell that is filled in (by the typechecker) with an+     error thunk.   With -fdefer-type errors we use this as the+     value of the hole.+   - A Unique (see Note [Uniques and tags]).++* Typechecking holes++  When the typechecker encounters a `HsHole`, it returns one with the+  HoleExprRef, but also emits a `DelayedError` into the `WantedConstraints`.+  This DelayedError later triggers the error reporting, and the filling-in of+  the error thunk, in GHC.Tc.Errors.++  The user has the option of deferring errors until runtime with+  `-fdefer-type-errors`. In this case, the hole carries evidence in its+  `HoleExprRef`. This evidence is an erroring expression that prints an error+  and crashes at runtime.++* Desugaring holes++  During desugaring, the `(HsHole (HoleVar "x", ref))` is desugared by+  reading the ref-cell to find the error thunk evidence term, put there by the+  constraint solver.++* Wrinkles:++  - Prior to fixing #17812, we used to invent an Id to hold the erroring+    expression, and then bind it during type-checking. But this does not support+    representation-polymorphic out-of-scope identifiers. See+    typecheck/should_compile/T17812. We thus use the mutable-CoreExpr approach+    described above.++  - You might think that the type in the HoleExprRef is the same as the type of+    the hole. However, because the hole type (hole_ty) is rewritten with respect+    to givens, this might not be the case. That is, the hole_ty is always (~) to+    the type of the HoleExprRef, but they might not be `eqType`. We need the+    type of the generated evidence to match what is expected in the context of+    the hole, and so we must store these types separately.++  - We really don't need the whole HoleExprRef; just the IORef EvTerm would be+    enough. But then deriving a Data instance becomes impossible. Much, much+    easier just to define HoleExprRef with a Data instance and store the whole+    structure.+-}+-- | Expression Hole. See Note [Holes in expressions].+type instance XHole GhcPs = HoleKind+type instance XHole GhcRn = HoleKind+type instance XHole GhcTc = (HoleKind, HoleExprRef)++data HoleKind+  = HoleVar (LIdP GhcPs)+  | HoleError+  deriving Data++-- | The RdrName for an unnamed hole ("_").+unnamedHoleRdrName :: RdrName+unnamedHoleRdrName = mkUnqual varName (fsLit "_")++ type instance XForAll        GhcPs = NoExtField type instance XForAll        GhcRn = NoExtField type instance XForAll        GhcTc = DataConCantHappen@@ -418,9 +544,23 @@ type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnLW type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA -arrowToHsExpr :: HsArrowOf (LocatedA (HsExpr GhcRn)) GhcRn -> LocatedA (HsExpr GhcRn)-arrowToHsExpr = expandHsArrow (HsVar noExtField)+multAnnToHsExpr :: HsMultAnnOf (LocatedA (HsExpr GhcRn)) GhcRn -> Maybe (LocatedA (HsExpr GhcRn))+multAnnToHsExpr = expandHsMultAnnOf mkHsVar +mkHsVar :: forall p. IsPass p => LIdP (GhcPass p) -> HsExpr (GhcPass p)+mkHsVar n = HsVar noExtField $+  case ghcPass @p of+    GhcPs -> n+    GhcRn -> fmap (WithUserRdr $ nameRdrName $ unLoc n) n+    GhcTc -> n++mkHsVarWithUserRdr :: forall p. IsPass p => RdrName -> LIdP (GhcPass p) -> HsExpr (GhcPass p)+mkHsVarWithUserRdr rdr n = HsVar noExtField $+  case ghcPass @p of+    GhcPs -> n+    GhcRn -> fmap (WithUserRdr rdr) n+    GhcTc -> n+ data AnnExplicitSum   = AnnExplicitSum {       aesOpen       :: EpaLocation,@@ -703,7 +843,13 @@ ppr_expr :: forall p. (OutputableBndrId p)          => HsExpr (GhcPass p) -> SDoc ppr_expr (HsVar _ (L _ v))   = pprPrefixOcc v-ppr_expr (HsUnboundVar _ uv) = pprPrefixOcc uv+ppr_expr (HsHole x) = case (ghcPass @p, x) of+  (GhcPs, HoleVar (L _ v)) -> pprPrefixOcc v+  (GhcRn, HoleVar (L _ v)) -> pprPrefixOcc v+  (GhcTc, (HoleVar (L _ v), _)) -> pprPrefixOcc v+  (GhcPs, HoleError) -> pprPrefixOcc unnamedHoleRdrName+  (GhcRn, HoleError) -> pprPrefixOcc unnamedHoleRdrName+  (GhcTc, (HoleError, _)) -> pprPrefixOcc unnamedHoleRdrName ppr_expr (HsIPVar _ v)       = ppr v ppr_expr (HsOverLabel s l) = case ghcPass @p of                GhcPs -> helper s@@ -809,14 +955,9 @@          nest 4 (ppr e3)]  ppr_expr (HsMultiIf _ alts)-  = hang (text "if") 3  (vcat (map ppr_alt alts))+  = hang (text "if") 3  (vcat $ toList $ NE.map ppr_alt alts)   where ppr_alt (L _ (GRHS _ guards expr)) =-          hang vbar 2 (ppr_one one_alt)-          where-            ppr_one [] = panic "ppr_exp HsMultiIf"-            ppr_one (h:t) = hang h 2 (sep t)-            one_alt = [ interpp'SP guards-                      , text "->" <+> pprDeeper (ppr expr) ]+          hang vbar 2 (hang (interpp'SP guards) 2 (arrow <+> pprDeeper (ppr expr)))         ppr_alt (L _ (XGRHS x)) = ppr x  -- special case: let ... in let ...@@ -864,7 +1005,10 @@ ppr_expr (HsTypedSplice ext e)   =     case ghcPass @p of       GhcPs -> pprTypedSplice Nothing e-      GhcRn -> pprTypedSplice (Just ext) e+      GhcRn ->+        case ext of+          HsTypedSpliceNested n -> pprTypedSplice (Just n) e+          HsTypedSpliceTop {}   -> pprTypedSplice Nothing e       GhcTc -> pprTypedSplice Nothing e ppr_expr (HsUntypedSplice ext s) =     case ghcPass @p of@@ -884,12 +1028,14 @@     GhcPs -> ppr q     GhcRn -> case b of       [] -> ppr q-      ps -> ppr q $$ text "pending(rn)" <+> ppr ps+      ps -> ppr q $$ whenPprDebug (text "pending(rn)" <+> ppr (map ppr_nested_splice ps))     GhcTc | HsBracketTc rnq  _ty _wrap ps <- b ->       ppr rnq `ppr_with_pending_tc_splices` ps+  where+    ppr_nested_splice (PendingRnSplice splice_name expr) = pprUntypedSplice False (Just splice_name) expr  ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))-  = hsep [text "proc", ppr pat, text "->", ppr cmd]+  = hsep [text "proc", ppr pat, arrow, ppr cmd]  ppr_expr (HsStatic _ e)   = hsep [text "static", ppr e]@@ -959,10 +1105,13 @@             ppr exp, text ")"]   ppr (HsRecSelTc f)      = pprPrefixOcc f - ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc ppr_infix_expr (HsVar _ (L _ v))    = Just (pprInfixOcc v)-ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ)+ppr_infix_expr (HsHole x) = Just $ pprInfixOcc $ case (ghcPass @p, x) of+  (GhcPs, HoleVar (L _ v)) -> v+  (GhcRn, HoleVar (L _ v)) -> v+  (GhcTc, (HoleVar (L _ v), _)) -> v+  _ -> unnamedHoleRdrName -- TODO: this is the HoleError case; this should print the source text instead of "_". ppr_infix_expr (XExpr x)            = case ghcPass @p of                                         GhcRn -> ppr_infix_expr_rn x                                         GhcTc -> ppr_infix_expr_tc x@@ -981,7 +1130,6 @@ ppr_infix_expr_tc (HsBinTick {})             = Nothing ppr_infix_expr_tc (HsRecSelTc f)            = Just (pprInfixOcc f) - ppr_infix_hs_expansion :: HsThingRn -> Maybe SDoc ppr_infix_hs_expansion (OrigExpr e) = ppr_infix_expr e ppr_infix_hs_expansion _            = Nothing@@ -1028,7 +1176,6 @@   where     go :: HsExpr (GhcPass p) -> Bool     go (HsVar{})                      = False-    go (HsUnboundVar{})               = False     go (HsIPVar{})                    = False     go (HsOverLabel{})                = False     go (HsLit _ l)                    = hsLitNeedsParens prec l@@ -1070,6 +1217,7 @@     go (HsProjection{})               = True     go (HsGetField{})                 = False     go (HsEmbTy{})                    = prec > topPrec+    go (HsHole{})                     = False     go (HsForAll{})                   = prec >= funPrec     go (HsQual{})                     = prec >= funPrec     go (HsFunArr{})                   = prec >= funPrec@@ -1125,7 +1273,7 @@ isAtomicHsExpr (HsOverLit {})    = True isAtomicHsExpr (HsIPVar {})      = True isAtomicHsExpr (HsOverLabel {})  = True-isAtomicHsExpr (HsUnboundVar {}) = True+isAtomicHsExpr (HsHole{})        = True isAtomicHsExpr (XExpr x)   | GhcTc <- ghcPass @p          = go_x_tc x   | GhcRn <- ghcPass @p          = go_x_rn x@@ -1574,22 +1722,24 @@ isSingletonMatchGroup :: [LMatch (GhcPass p) body] -> Bool isSingletonMatchGroup matches   | [L _ match] <- matches-  , Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match+  , Match { m_grhss = GRHSs { grhssGRHSs = _ :| [] } } <- match   = True   | otherwise   = False  matchGroupArity :: MatchGroup (GhcPass id) body -> Arity--- Precondition: MatchGroup is non-empty -- This is called before type checking, when mg_arg_tys is not set-matchGroupArity (MG { mg_alts = alts })-  | L _ (alt1:_) <- alts = count (isVisArgPat . unLoc) (hsLMatchPats alt1)-  | otherwise            = panic "matchGroupArity"-+matchGroupArity MG { mg_alts = L _ [] } = 1 -- See Note [Empty mg_alts]+matchGroupArity MG { mg_alts = L _ (alt1 : _) } = count isVisArgLPat (hsLMatchPats alt1)  hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)] hsLMatchPats (L _ (Match { m_pats = L _ pats })) = pats +isInfixMatch :: Match (GhcPass p) body -> Bool+isInfixMatch match = case m_ctxt match of+  FunRhs {mc_fixity = Infix} -> True+  _                          -> False+ -- We keep the type checker happy by providing EpAnnComments.  They -- can only be used if they follow a `where` keyword with no binds, -- but in that case the comment is attached to the following parsed@@ -1681,7 +1831,7 @@ pprGRHSs :: (OutputableBndrId idR, Outputable body)          => HsMatchContext fn -> GRHSs (GhcPass idR) body -> SDoc pprGRHSs ctxt (GRHSs _ grhss binds)-  = vcat (map (pprGRHS ctxt . unLoc) grhss)+  = vcat (toList $ NE.map (pprGRHS ctxt . unLoc) grhss)   -- Print the "where" even if the contents of the binds is empty. Only   -- EmptyLocalBinds means no "where" keyword  $$ ppUnless (eqEmptyLocalBinds binds)@@ -1700,10 +1850,10 @@  matchSeparator :: HsMatchContext fn -> SDoc matchSeparator FunRhs{}         = text "="-matchSeparator CaseAlt          = text "->"-matchSeparator LamAlt{}         = text "->"-matchSeparator IfAlt            = text "->"-matchSeparator ArrowMatchCtxt{} = text "->"+matchSeparator CaseAlt          = arrow+matchSeparator LamAlt{}         = arrow+matchSeparator IfAlt            = arrow+matchSeparator ArrowMatchCtxt{} = arrow matchSeparator PatBindRhs       = text "=" matchSeparator PatBindGuards    = text "=" matchSeparator StmtCtxt{}       = text "<-"@@ -1890,7 +2040,7 @@ pprStmt (BindStmt _ pat expr)  = pprBindStmt pat expr pprStmt (LetStmt _ binds)      = hsep [text "let", pprBinds binds] pprStmt (BodyStmt _ expr _ _)  = ppr expr-pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss))+pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr $ toList stmtss))  pprStmt (TransStmt { trS_stmts = stmts, trS_by = by                    , trS_using = using, trS_form = form })@@ -2065,8 +2215,14 @@       }   | HsUntypedSpliceNested SplicePointName -- A unique name to identify this splice point -type instance XTypedSplice   GhcPs = EpToken "$$"-type instance XTypedSplice   GhcRn = SplicePointName+-- See Note [Lifecycle of an untyped splice, and PendingRnSplice]+-- for an explanation of the Template Haskell extension points.+data HsTypedSpliceResult+  = HsTypedSpliceTop+  | HsTypedSpliceNested SplicePointName++type instance XTypedSplice   GhcPs = NoExtField+type instance XTypedSplice   GhcRn = HsTypedSpliceResult type instance XTypedSplice   GhcTc = DelayedSplice  type instance XUntypedSplice GhcPs = NoExtField@@ -2075,13 +2231,26 @@  -- HsUntypedSplice type instance XUntypedSpliceExpr GhcPs = EpToken "$"-type instance XUntypedSpliceExpr GhcRn = EpToken "$"+type instance XUntypedSpliceExpr GhcRn = HsUserSpliceExt type instance XUntypedSpliceExpr GhcTc = DataConCantHappen -type instance XQuasiQuote        p = NoExtField+type instance XTypedSpliceExpr GhcPs = EpToken "$$"+type instance XTypedSpliceExpr GhcRn = NoExtField+type instance XTypedSpliceExpr GhcTc = NoExtField -type instance XXUntypedSplice    p = DataConCantHappen+type instance XQuasiQuote        GhcPs = NoExtField+type instance XQuasiQuote        GhcRn = HsQuasiQuoteExt+type instance XQuasiQuote        GhcTc = DataConCantHappen ++type instance XXUntypedSplice    GhcPs = DataConCantHappen+type instance XXUntypedSplice    GhcRn = HsImplicitLiftSplice+type instance XXUntypedSplice    GhcTc = DataConCantHappen++type instance XXTypedSplice    GhcPs = DataConCantHappen+type instance XXTypedSplice    GhcRn = HsImplicitLiftSplice+type instance XXTypedSplice    GhcTc = DataConCantHappen+ -- See Note [Running typed splices in the zonker] -- These are the arguments that are passed to `GHC.Tc.Gen.Splice.runTopSplice` data DelayedSplice =@@ -2107,22 +2276,52 @@   | UntypedDeclSplice   deriving Data --- | Pending Renamer Splice-data PendingRnSplice-  = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn) +-- See Note [Lifecycle of an untyped splice, and PendingRnSplice]+-- A 'PendingRnSplice' is lifted from an untyped quotation and then typechecked.+data PendingRnSplice = PendingRnSplice SplicePointName (HsUntypedSplice GhcRn)++instance Outputable PendingRnSplice where+  ppr (PendingRnSplice sp expr) =+    angleBrackets (ppr sp <> comma <+> pprUntypedSplice False Nothing expr)+ -- | Pending Type-checker Splice+-- See Note [Lifecycle of an untyped splice, and PendingRnSplice] data PendingTcSplice   = PendingTcSplice SplicePointName (LHsExpr GhcTc) +-- | Information about an implicit lift, discovered by the renamer+-- See Note [Lifecycle of an untyped splice, and PendingRnSplice]+data HsImplicitLiftSplice =+        HsImplicitLiftSplice+          { implicit_lift_bind_lvl :: S.Set ThLevelIndex+          , implicit_lift_used_lvl :: ThLevelIndex+          , implicit_lift_gre :: Maybe GlobalRdrElt+          , implicit_lift_lid :: LIdOccP GhcRn+          } -pprPendingSplice :: (OutputableBndrId p)-                 => SplicePointName -> LHsExpr (GhcPass p) -> SDoc-pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr (stripParensLHsExpr e))+-- | Information about a user-written splice, discovered by the renamer+-- See Note [Lifecycle of an untyped splice, and PendingRnSplice]+data HsUserSpliceExt =+  HsUserSpliceExt+    { user_splice_flavour :: UntypedSpliceFlavour+    } -pprTypedSplice :: (OutputableBndrId p) => Maybe SplicePointName -> LHsExpr (GhcPass p) -> SDoc-pprTypedSplice n e = ppr_splice (text "$$") n e+-- | Information about a quasi-quoter, discovered by the renamer+-- See Note [Lifecycle of an untyped splice, and PendingRnSplice]+data HsQuasiQuoteExt =+  HsQuasiQuoteExt+    { quasi_quote_flavour :: UntypedSpliceFlavour+    } ++pprTypedSplice :: forall p . (OutputableBndrId p) => Maybe SplicePointName -> HsTypedSplice (GhcPass p) -> SDoc+pprTypedSplice n (HsTypedSpliceExpr _ e) = ppr_splice (text "$$") n e+pprTypedSplice n (XTypedSplice p) =+  case ghcPass @p of+    GhcRn -> case p of+              HsImplicitLiftSplice _ _ _ lid -> ppr lid <+> whenPprDebug (maybe empty (brackets . ppr) n)+ pprUntypedSplice :: forall p. (OutputableBndrId p)                  => Bool -- Whether to precede the splice with "$"                  -> Maybe SplicePointName -- Used for pretty printing when exists@@ -2130,7 +2329,11 @@                  -> SDoc pprUntypedSplice True  n (HsUntypedSpliceExpr _ e) = ppr_splice (text "$") n e pprUntypedSplice False n (HsUntypedSpliceExpr _ e) = ppr_splice empty n e-pprUntypedSplice _     _ (HsQuasiQuote _ q s)      = ppr_quasi q (unLoc s)+pprUntypedSplice _     _ (HsQuasiQuote _ q s)      = ppr_quasi (unLoc q) (unLoc s)+pprUntypedSplice _     _ (XUntypedSplice x) =+  case ghcPass @p of+    GhcRn -> case x of+              HsImplicitLiftSplice _ _ _ lid -> ppr lid  ppr_quasi :: OutputableBndr p => p -> FastString -> SDoc ppr_quasi quoter quote = char '[' <> ppr quoter <> vbar <>@@ -2200,15 +2403,12 @@ thTyBrackets :: SDoc -> SDoc thTyBrackets pp_body = text "[||" <+> pp_body <+> text "||]" -instance Outputable PendingRnSplice where-  ppr (PendingRnSplice _ n e) = pprPendingSplice n e- instance Outputable PendingTcSplice where-  ppr (PendingTcSplice n e) = pprPendingSplice n e+  ppr (PendingTcSplice n e) = angleBrackets (ppr n <> comma <+> ppr (stripParensLHsExpr e))  ppr_with_pending_tc_splices :: SDoc -> [PendingTcSplice] -> SDoc ppr_with_pending_tc_splices x [] = x-ppr_with_pending_tc_splices x ps = x $$ text "pending(tc)" <+> ppr ps+ppr_with_pending_tc_splices x ps = x $$ whenPprDebug (text "pending(tc)" <+> ppr ps)  {- ************************************************************************@@ -2346,7 +2546,8 @@                         , trS_form = form }) = pprTransStmt by using form     ppr_stmt stmt = pprStmt stmt -pprMatchContext :: Outputable fn => HsMatchContext fn -> SDoc++pprMatchContext :: Outputable p => HsMatchContext p -> SDoc pprMatchContext ctxt   | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt   | otherwise    = text "a"  <+> pprMatchContextNoun ctxt@@ -2458,7 +2659,7 @@  instance (UnXRec p, Outputable (XRec p FieldLabelString)) => Outputable (FieldLabelStrings p) where   ppr (FieldLabelStrings flds) =-    hcat (punctuate dot (map (ppr . unXRec @p) flds))+    hcat (punctuate dot (toList $ NE.map (ppr . unXRec @p) flds))  instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (FieldLabelStrings p) where   pprInfixOcc = pprFieldLabelStrings@@ -2470,7 +2671,7 @@  pprFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) => FieldLabelStrings p -> SDoc pprFieldLabelStrings (FieldLabelStrings flds) =-    hcat (punctuate dot (map (ppr . unXRec @p) flds))+    hcat (punctuate dot (toList $ NE.map (ppr . unXRec @p) flds))  pprPrefixFastString :: FastString -> SDoc pprPrefixFastString fs = pprPrefixOcc (mkVarUnqual fs)
compiler/GHC/Hs/Expr.hs-boot view
@@ -18,6 +18,7 @@   , MatchGroup   , GRHSs   , HsUntypedSplice+  , HsTypedSplice   ) import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) import GHC.Types.Name   ( Name )@@ -33,7 +34,7 @@  pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc -pprTypedSplice   :: (OutputableBndrId p) => Maybe SplicePointName -> LHsExpr (GhcPass p) -> SDoc+pprTypedSplice   :: (OutputableBndrId p) => Maybe SplicePointName -> HsTypedSplice (GhcPass p) -> SDoc pprUntypedSplice :: (OutputableBndrId p) => Bool -> Maybe SplicePointName -> HsUntypedSplice (GhcPass p) -> SDoc  pprPatBind :: forall bndr p . (OutputableBndrId bndr,
compiler/GHC/Hs/Extension.hs view
@@ -98,13 +98,20 @@ -}  -- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation-type instance XRec (GhcPass p) a = GenLocated (Anno a) a+type instance XRec (GhcPass p) a = XRecGhc a +-- (XRecGhc tree) wraps `tree` in a GHC-specific,+-- but pass-independent, source location+type XRecGhc a = GenLocated (Anno a) a+ type instance Anno RdrName = SrcSpanAnnN type instance Anno Name    = SrcSpanAnnN type instance Anno Id      = SrcSpanAnnN +type instance Anno (WithUserRdr a) = Anno a+ type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ EpAnn a,+                          Anno (IdOccGhcP p) ~ EpAnn a,                           NoAnn a,                           IsPass p) @@ -203,6 +210,16 @@   IdGhcP 'Renamed     = Name   IdGhcP 'Typechecked = Id +type LIdGhcP p = XRecGhc (IdGhcP p)++type instance IdOccP (GhcPass p) = IdOccGhcP p++type family IdOccGhcP pass where+  IdOccGhcP 'Parsed      = RdrName+  IdOccGhcP 'Renamed     = WithUserRdr Name+  IdOccGhcP 'Typechecked = Id+type LIdOccGhcP p = XRecGhc (IdOccGhcP p)+ -- | Marks that a field uses the GhcRn variant even when the pass -- parameter is GhcTc. Useful for storing HsTypes in GHC.Hs.Exprs, say, because -- HsType GhcTc should never occur.@@ -219,9 +236,13 @@ -- the @id@ and the 'NoGhcTc' of it. See Note [NoGhcTc]. type OutputableBndrId pass =   ( OutputableBndr (IdGhcP pass)+  , OutputableBndr (IdOccGhcP pass)   , OutputableBndr (IdGhcP (NoGhcTcPass pass))-  , Outputable (GenLocated (Anno (IdGhcP pass)) (IdGhcP pass))-  , Outputable (GenLocated (Anno (IdGhcP (NoGhcTcPass pass))) (IdGhcP (NoGhcTcPass pass)))+  , OutputableBndr (IdOccGhcP (NoGhcTcPass pass))+  , Outputable (LIdGhcP pass)+  , Outputable (LIdOccGhcP pass)+  , Outputable (LIdGhcP (NoGhcTcPass pass))+  , Outputable (LIdOccGhcP (NoGhcTcPass pass))   , IsPass pass   )
compiler/GHC/Hs/ImpExp.hs view
@@ -8,6 +8,8 @@ {-# LANGUAGE TypeFamilies         #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]                                       -- in module Language.Haskell.Syntax.Extension+{-# LANGUAGE MultiWayIf           #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -57,16 +59,8 @@  type instance Anno (ImportDecl (GhcPass p)) = SrcSpanAnnA --- | Given two possible located 'qualified' tokens, compute a style--- (in a conforming Haskell program only one of the two can be not--- 'Nothing'). This is called from "GHC.Parser".-importDeclQualifiedStyle :: Maybe (EpToken "qualified")-                         -> Maybe (EpToken "qualified")-                         -> (Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)-importDeclQualifiedStyle mPre mPost =-  if isJust mPre then (mPre, QualifiedPre)-  else if isJust mPost then (mPost,QualifiedPost) else (Nothing, NotQualified) + -- | Convenience function to answer the question if an import decl. is -- qualified. isImportDeclQualified :: ImportDeclQualifiedStyle -> Bool@@ -74,6 +68,7 @@ isImportDeclQualified _ = True  + type instance ImportDeclPkgQual GhcPs = RawPkgQual type instance ImportDeclPkgQual GhcRn = PkgQual type instance ImportDeclPkgQual GhcTc = PkgQual@@ -114,13 +109,24 @@   { importDeclAnnImport    :: EpToken "import" -- ^ The location of the @import@ keyword   , importDeclAnnPragma    :: Maybe (EpaLocation, EpToken "#-}") -- ^ The locations of @{-# SOURCE@ and @#-}@ respectively   , importDeclAnnSafe      :: Maybe (EpToken "safe") -- ^ The location of the @safe@ keyword+  , importDeclAnnLevel     :: Maybe EpAnnLevel -- ^ The location of the @splice@ or @quote@ keyword   , importDeclAnnQualified :: Maybe (EpToken "qualified") -- ^ The location of the @qualified@ keyword   , importDeclAnnPackage   :: Maybe EpaLocation -- ^ The location of the package name (when using @-XPackageImports@)   , importDeclAnnAs        :: Maybe (EpToken "as") -- ^ The location of the @as@ keyword   } deriving (Data) + instance NoAnn EpAnnImportDecl where-  noAnn = EpAnnImportDecl noAnn  Nothing  Nothing  Nothing  Nothing  Nothing+  noAnn = EpAnnImportDecl noAnn  Nothing Nothing  noAnn  Nothing  Nothing  Nothing++data EpAnnLevel = EpAnnLevelSplice (EpToken "splice")+                | EpAnnLevelQuote (EpToken "quote")+                deriving Data++instance HasLoc EpAnnLevel where+  getHasLoc (EpAnnLevelSplice tok) = getEpTokenSrcSpan tok+  getHasLoc (EpAnnLevelQuote tok) = getEpTokenSrcSpan tok+ -- ---------------------------------------------------------------------  simpleImportDecl :: ModuleName -> ImportDecl GhcPs@@ -130,6 +136,7 @@       ideclPkgQual    = NoRawPkgQual,       ideclSource     = NotBoot,       ideclSafe       = False,+      ideclLevelSpec  = NotLevelled,       ideclQualified  = NotQualified,       ideclAs         = Nothing,       ideclImportList = Nothing@@ -197,6 +204,7 @@ type instance XIEDefault (GhcPass _) = EpToken "default" type instance XIEPattern (GhcPass _) = EpToken "pattern" type instance XIEType    (GhcPass _) = EpToken "type"+type instance XIEData    (GhcPass _) = EpToken "data" type instance XXIEWrappedName (GhcPass _) = DataConCantHappen  type instance Anno (IEWrappedName (GhcPass _)) = SrcSpanAnnA@@ -247,12 +255,15 @@  type instance Anno (LocatedA (IE (GhcPass p))) = SrcSpanAnnA +ieLIEWrappedName :: IE (GhcPass p) -> LIEWrappedName (GhcPass p)+ieLIEWrappedName (IEVar _ n _)           = n+ieLIEWrappedName (IEThingAbs  _ n _)     = n+ieLIEWrappedName (IEThingWith _ n _ _ _) = n+ieLIEWrappedName (IEThingAll  _ n _)     = n+ieLIEWrappedName _ = panic "ieLIEWrappedName failed pattern match!"+ ieName :: IE (GhcPass p) -> IdP (GhcPass p)-ieName (IEVar _ (L _ n) _)           = ieWrappedName n-ieName (IEThingAbs  _ (L _ n) _)     = ieWrappedName n-ieName (IEThingWith _ (L _ n) _ _ _) = ieWrappedName n-ieName (IEThingAll  _ (L _ n) _)     = ieWrappedName n-ieName _ = panic "ieName failed pattern match!"+ieName = lieWrappedName . ieLIEWrappedName  ieNames :: IE (GhcPass p) -> [IdP (GhcPass p)] ieNames (IEVar       _ (L _ n) _)      = [ieWrappedName n]@@ -285,6 +296,7 @@ ieWrappedLName (IEName    _ (L l n)) = L l n ieWrappedLName (IEPattern _ (L l n)) = L l n ieWrappedLName (IEType    _ (L l n)) = L l n+ieWrappedLName (IEData    _ (L l n)) = L l n  ieWrappedName :: IEWrappedName (GhcPass p) -> IdP (GhcPass p) ieWrappedName = unLoc . ieWrappedLName@@ -301,6 +313,7 @@ replaceWrappedName (IEName    x (L l _)) n = IEName    x (L l n) replaceWrappedName (IEPattern r (L l _)) n = IEPattern r (L l n) replaceWrappedName (IEType    r (L l _)) n = IEType    r (L l n)+replaceWrappedName (IEData    r (L l _)) n = IEData    r (L l n)  replaceLWrappedName :: LIEWrappedName GhcPs -> IdP GhcRn -> LIEWrappedName GhcRn replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n')@@ -357,6 +370,7 @@   ppr (IEName    _ (L _ n)) = pprPrefixOcc n   ppr (IEPattern _ (L _ n)) = text "pattern" <+> pprPrefixOcc n   ppr (IEType    _ (L _ n)) = text "type"    <+> pprPrefixOcc n+  ppr (IEData    _ (L _ n)) = text "data"    <+> pprPrefixOcc n  pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc pprImpExp name = type_pref <+> pprPrefixOcc name
compiler/GHC/Hs/Instances.hs view
@@ -33,6 +33,9 @@ import GHC.Hs.Pat import GHC.Hs.ImpExp import GHC.Parser.Annotation+import GHC.Types.Name.Reader (WithUserRdr(..))+import GHC.Data.BooleanFormula (BooleanFormula(..))+import Language.Haskell.Syntax.Extension (Anno)  -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs-----------------------------------------@@ -108,9 +111,6 @@ deriving instance Data (HsPatSynDir GhcRn) deriving instance Data (HsPatSynDir GhcTc) -deriving instance Data (HsMultAnn GhcPs)-deriving instance Data (HsMultAnn GhcRn)-deriving instance Data (HsMultAnn GhcTc) -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Decls ---------------------------------- @@ -259,6 +259,13 @@ deriving instance Data (RuleBndr GhcRn) deriving instance Data (RuleBndr GhcTc) +deriving instance Data (RuleBndrs GhcPs)+deriving instance Data (RuleBndrs GhcRn)+deriving instance Data (RuleBndrs GhcTc)++deriving instance Data TcSpecPrags+deriving instance Data TcSpecPrag+ -- deriving instance (DataId p)     => Data (WarnDecls p) deriving instance Data (WarnDecls GhcPs) deriving instance Data (WarnDecls GhcRn)@@ -403,7 +410,16 @@ deriving instance Data (HsUntypedSplice GhcRn) deriving instance Data (HsUntypedSplice GhcTc) +deriving instance Data (HsTypedSplice GhcPs)+deriving instance Data (HsTypedSplice GhcRn)+deriving instance Data (HsTypedSplice GhcTc)++deriving instance Data HsImplicitLiftSplice+deriving instance Data HsUserSpliceExt+deriving instance Data HsQuasiQuoteExt+ deriving instance Data a => Data (HsUntypedSpliceResult a)+deriving instance Data HsTypedSpliceResult  -- deriving instance (DataIdLR p p) => Data (HsQuote p) deriving instance Data (HsQuote GhcPs)@@ -432,6 +448,8 @@ -- deriving instance (DataId p) => Data (HsLit p) deriving instance Data (HsLit GhcPs) deriving instance Data (HsLit GhcRn)++deriving instance Data HsLitTc deriving instance Data (HsLit GhcTc)  -- deriving instance (DataIdLR p p) => Data (HsOverLit p)@@ -452,10 +470,6 @@  deriving instance Data ConPatTc -deriving instance Data (HsConPatTyArg GhcPs)-deriving instance Data (HsConPatTyArg GhcRn)-deriving instance Data (HsConPatTyArg GhcTc)- deriving instance (Data a, Data b) => Data (HsFieldBind a b)  deriving instance (Data body) => Data (HsRecFields GhcPs body)@@ -525,34 +539,36 @@ deriving instance Data (HsType GhcRn) deriving instance Data (HsType GhcTc) +deriving instance Data HsTypeGhcPsExt+ -- deriving instance (DataIdLR p p) => Data (HsTyLit p) deriving instance Data (HsTyLit GhcPs) deriving instance Data (HsTyLit GhcRn) deriving instance Data (HsTyLit GhcTc) --- deriving instance (Data mult, DataIdLR p p) => Data (HsArrowOf mult p)-deriving instance Data (HsArrowOf (LocatedA (HsType GhcPs)) GhcPs)-deriving instance Data (HsArrowOf (LocatedA (HsType GhcRn)) GhcRn)-deriving instance Data (HsArrowOf (LocatedA (HsType GhcTc)) GhcTc)-deriving instance Data (HsArrowOf (LocatedA (HsExpr GhcPs)) GhcPs)-deriving instance Data (HsArrowOf (LocatedA (HsExpr GhcRn)) GhcRn)-deriving instance Data (HsArrowOf (LocatedA (HsExpr GhcTc)) GhcTc)---- deriving instance (DataIdLR p p) => Data (HsScaled p a)-deriving instance Data thing => Data (HsScaled GhcPs thing)-deriving instance Data thing => Data (HsScaled GhcRn thing)-deriving instance Data thing => Data (HsScaled GhcTc thing)+-- deriving instance (Data mult, DataIdLR p p) => Data (HsMultAnnOf mult p)+deriving instance Data (HsMultAnnOf (LocatedA (HsType GhcPs)) GhcPs)+deriving instance Data (HsMultAnnOf (LocatedA (HsType GhcRn)) GhcRn)+deriving instance Data (HsMultAnnOf (LocatedA (HsType GhcRn)) GhcTc)+deriving instance Data (HsMultAnnOf (LocatedA (HsExpr GhcPs)) GhcPs)+deriving instance Data (HsMultAnnOf (LocatedA (HsExpr GhcRn)) GhcRn)+deriving instance Data (HsMultAnnOf (LocatedA (HsExpr GhcTc)) GhcTc)  -- deriving instance (Data a, Data b) => Data (HsArg p a b) deriving instance (Data a, Data b) => Data (HsArg GhcPs a b) deriving instance (Data a, Data b) => Data (HsArg GhcRn a b) deriving instance (Data a, Data b) => Data (HsArg GhcTc a b) --- deriving instance (DataIdLR p p) => Data (ConDeclField p)-deriving instance Data (ConDeclField GhcPs)-deriving instance Data (ConDeclField GhcRn)-deriving instance Data (ConDeclField GhcTc)+-- deriving instance (DataIdLR p p) => Data (HsConDeclRecField p)+deriving instance Data (HsConDeclRecField GhcPs)+deriving instance Data (HsConDeclRecField GhcRn)+deriving instance Data (HsConDeclRecField GhcTc) +-- deriving instance (DataIdLR p p, Typeable on) => Data (HsConDeclField on p)+deriving instance Data (HsConDeclField GhcPs)+deriving instance Data (HsConDeclField GhcRn)+deriving instance Data (HsConDeclField GhcTc)+ -- deriving instance (DataId p)     => Data (FieldOcc p) deriving instance Data (FieldOcc GhcPs) deriving instance Data (FieldOcc GhcRn)@@ -577,6 +593,7 @@  deriving instance Data HsThingRn deriving instance Data XXExprGhcRn+deriving instance Data a => Data (WithUserRdr a)  -- --------------------------------------------------------------------- @@ -588,3 +605,6 @@ deriving instance Data XViaStrategyPs  -- ---------------------------------------------------------------------++deriving instance (Typeable p, Data (Anno (IdGhcP p)), Data (IdGhcP p)) => Data (BooleanFormula (GhcPass p))+---------------------------------------------------------------------
compiler/GHC/Hs/Lit.hs view
@@ -62,12 +62,27 @@ type instance XHsWord16Prim (GhcPass _) = SourceText type instance XHsWord32Prim (GhcPass _) = SourceText type instance XHsWord64Prim (GhcPass _) = SourceText-type instance XHsInteger    (GhcPass _) = SourceText-type instance XHsRat        (GhcPass _) = NoExtField type instance XHsFloatPrim  (GhcPass _) = NoExtField type instance XHsDoublePrim (GhcPass _) = NoExtField-type instance XXLit         (GhcPass _) = DataConCantHappen +type instance XXLit         GhcPs = DataConCantHappen+type instance XXLit         GhcRn = DataConCantHappen+type instance XXLit         GhcTc = HsLitTc++data HsLitTc+  = HsInteger SourceText Integer Type+      -- ^ Genuinely an integer; arises only+      -- from TRANSLATION (overloaded+      -- literals are done with HsOverLit)+  | HsRat FractionalLit Type+      -- ^ Genuinely a rational; arises only from+      -- TRANSLATION (overloaded literals are+      -- done with HsOverLit)+instance Eq HsLitTc where+  (HsInteger _ x _) == (HsInteger _ y _) = x==y+  (HsRat x _)       == (HsRat y _)       = x==y+  _                 == _                 = False+ data OverLitRn   = OverLitRn {         ol_rebindable :: Bool,         -- Note [ol_rebindable]@@ -130,7 +145,7 @@ -- -- See Note [Printing of literals in Core] in GHC.Types.Literal -- for the reasoning.-hsLitNeedsParens :: PprPrec -> HsLit x -> Bool+hsLitNeedsParens :: forall x. IsPass x => PprPrec -> HsLit (GhcPass x) -> Bool hsLitNeedsParens p = go   where     go (HsChar {})        = False@@ -139,8 +154,6 @@     go (HsMultilineString {}) = False     go (HsStringPrim {})  = False     go (HsInt _ x)        = p > topPrec && il_neg x-    go (HsInteger _ x _)  = p > topPrec && x < 0-    go (HsRat _ x _)      = p > topPrec && fl_neg x     go (HsFloatPrim {})   = False     go (HsDoublePrim {})  = False     go (HsIntPrim {})     = False@@ -153,10 +166,18 @@     go (HsWord16Prim {})  = False     go (HsWord64Prim {})  = False     go (HsWord32Prim {})  = False-    go (XLit _)           = False+    go (XLit x)           = case ghcPass @x of+      GhcTc -> case x of+         (HsInteger _ x _) -> p > topPrec && x < 0+         (HsRat  x _)      -> p > topPrec && fl_neg x --- | Convert a literal from one index type to another-convertLit :: HsLit (GhcPass p1) -> HsLit (GhcPass p2)++-- | Convert a literal from one index type to another.+-- The constraint XXLit (GhcPass p)~DataConCantHappen means that once the+-- XLit constructor is inhabited, we can no longer go back to the case where+-- its not. In practice it just means you can't just convertLit to go from+-- (HsLit GhcTc) -> (HsLit GhcPs/GhcRn), while all other conversions are fine.+convertLit :: XXLit (GhcPass p)~DataConCantHappen => HsLit (GhcPass p) -> HsLit (GhcPass p') convertLit (HsChar a x)       = HsChar a x convertLit (HsCharPrim a x)   = HsCharPrim a x convertLit (HsString a x)     = HsString a x@@ -173,8 +194,6 @@ convertLit (HsWord16Prim a x) = HsWord16Prim a x convertLit (HsWord32Prim a x) = HsWord32Prim a x convertLit (HsWord64Prim a x) = HsWord64Prim a x-convertLit (HsInteger a x b)  = HsInteger a x b-convertLit (HsRat a x b)      = HsRat a x b convertLit (HsFloatPrim a x)  = HsFloatPrim a x convertLit (HsDoublePrim a x) = HsDoublePrim a x @@ -194,7 +213,7 @@ -}  -- Instance specific to GhcPs, need the SourceText-instance Outputable (HsLit (GhcPass p)) where+instance IsPass p => Outputable (HsLit (GhcPass p)) where     ppr (HsChar st c)       = pprWithSourceText st (pprHsChar c)     ppr (HsCharPrim st c)   = pprWithSourceText st (pprPrimChar c)     ppr (HsString st s)     = pprWithSourceText st (pprHsString s)@@ -205,8 +224,6 @@     ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s)     ppr (HsInt _ i)       = pprWithSourceText (il_text i) (integer (il_value i))-    ppr (HsInteger st i _)  = pprWithSourceText st (integer i)-    ppr (HsRat _ f _)       = ppr f     ppr (HsFloatPrim _ f)   = ppr f <> primFloatSuffix     ppr (HsDoublePrim _ d)  = ppr d <> primDoubleSuffix     ppr (HsIntPrim st i)    = pprWithSourceText st (pprPrimInt i)@@ -219,6 +236,10 @@     ppr (HsWord16Prim st w) = pprWithSourceText st (pprPrimWord16 w)     ppr (HsWord32Prim st w) = pprWithSourceText st (pprPrimWord32 w)     ppr (HsWord64Prim st w) = pprWithSourceText st (pprPrimWord64 w)+    ppr (XLit x)            = case ghcPass @p of+      GhcTc -> case x of+         (HsInteger st i _) -> pprWithSourceText st (integer i)+         (HsRat  f _)       -> ppr f  -- in debug mode, print the expression that it's resolved to, too instance OutputableBndrId p@@ -237,7 +258,7 @@ -- mainly for too reasons: --  * We do not want to expose their internal representation --  * The warnings become too messy-pmPprHsLit :: HsLit (GhcPass x) -> SDoc+pmPprHsLit :: forall p. IsPass p => HsLit (GhcPass p) -> SDoc pmPprHsLit (HsChar _ c)       = pprHsChar c pmPprHsLit (HsCharPrim _ c)   = pprHsChar c pmPprHsLit (HsString st s)    = pprWithSourceText st (pprHsString s)@@ -254,10 +275,12 @@ pmPprHsLit (HsWord16Prim _ w) = integer w pmPprHsLit (HsWord32Prim _ w) = integer w pmPprHsLit (HsWord64Prim _ w) = integer w-pmPprHsLit (HsInteger _ i _)  = integer i-pmPprHsLit (HsRat _ f _)      = ppr f pmPprHsLit (HsFloatPrim _ f)  = ppr f pmPprHsLit (HsDoublePrim _ d) = ppr d+pmPprHsLit (XLit x)           = case ghcPass @p of+  GhcTc -> case x of+   (HsInteger _ i _)  -> integer i+   (HsRat f _)        -> ppr f  negateOverLitVal :: OverLitVal -> OverLitVal negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i)
compiler/GHC/Hs/Pat.hs view
@@ -24,15 +24,15 @@  module GHC.Hs.Pat (         Pat(..), LPat,-        isInvisArgPat, isVisArgPat,+        isInvisArgPat, isInvisArgLPat,+        isVisArgPat, isVisArgLPat,         EpAnnSumPat(..),         ConPatTc (..),         ConLikeP,         HsPatExpansion(..),         XXPatGhcTc(..), -        HsConPatDetails, hsConPatArgs, hsConPatTyArgs,-        HsConPatTyArg(..),+        HsConPatDetails, hsConPatArgs,         HsRecFields(..), HsFieldBind(..), LHsFieldBind,         HsRecField, LHsRecField,         HsRecUpdField, LHsRecUpdField,@@ -84,7 +84,9 @@ import GHC.Types.SrcLoc import GHC.Data.Bag -- collect ev vars from pats import GHC.Types.Name+ import Data.Data+import qualified Data.List( map )  import qualified Data.List.NonEmpty as NE @@ -177,17 +179,13 @@   -- XXExprGhcRn allows us to handle RebindableSyntax in pattern position:   -- see "XXExpr GhcTc" for the counterpart in expressions. -type instance ConLikeP GhcPs = RdrName -- IdP GhcPs-type instance ConLikeP GhcRn = Name    -- IdP GhcRn+type instance ConLikeP GhcPs = RdrName          -- IdOccP GhcPs+type instance ConLikeP GhcRn = WithUserRdr Name -- IdOccP GhcRn type instance ConLikeP GhcTc = ConLike -type instance XConPatTyArg GhcPs = EpToken "@"-type instance XConPatTyArg GhcRn = NoExtField-type instance XConPatTyArg GhcTc = NoExtField- type instance XHsRecFields GhcPs = NoExtField type instance XHsRecFields GhcRn = NoExtField-type instance XHsRecFields GhcTc = MultiplicityCheckCoercions+type instance XHsRecFields GhcTc = NoExtField  type instance XHsFieldBind _ = Maybe (EpToken "=") @@ -337,6 +335,16 @@       cpt_wrap  :: HsWrapper     } ++hsRecFields :: HsRecFields (GhcPass p) arg -> [IdGhcP p]+hsRecFields rbinds = Data.List.map (hsRecFieldSel . unLoc) (rec_flds rbinds)++hsRecFieldsArgs :: HsRecFields (GhcPass p) arg -> [arg]+hsRecFieldsArgs rbinds = Data.List.map (hfbRHS . unLoc) (rec_flds rbinds)++hsRecFieldSel :: HsRecField (GhcPass p) arg -> IdGhcP p+hsRecFieldSel = unLoc . foLabel . unLoc . hfbLHS+ hsRecFieldId :: HsRecField GhcTc arg -> Id hsRecFieldId = hsRecFieldSel @@ -348,9 +356,6 @@ ************************************************************************ -} -instance Outputable (HsTyPat p) => Outputable (HsConPatTyArg p) where-  ppr (HsConPatTyArg _ ty) = char '@' <> ppr ty- instance (Outputable arg, Outputable (XRec p (HsRecField p arg)), XRec p RecFieldsDotDot ~ LocatedE RecFieldsDotDot)       => Outputable (HsRecFields p arg) where   ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })@@ -498,8 +503,7 @@ pprConArgs :: (OutputableBndrId p,                      Outputable (Anno (IdGhcP p)))            => HsConPatDetails (GhcPass p) -> SDoc-pprConArgs (PrefixCon ts pats) = fsep (pprTyArgs ts : map (pprParendLPat appPrec) pats)-  where pprTyArgs tyargs = fsep (map ppr tyargs)+pprConArgs (PrefixCon pats)    = fsep (map (pprParendLPat appPrec) pats) pprConArgs (InfixCon p1 p2)    = sep [ pprParendLPat appPrec p1                                      , pprParendLPat appPrec p2 ] pprConArgs (RecCon rpats)      = ppr rpats@@ -517,7 +521,7 @@ -- Make a vanilla Prefix constructor pattern mkPrefixConPat dc pats tys   = noLocA $ ConPat { pat_con = noLocA (RealDataCon dc)-                    , pat_args = PrefixCon [] pats+                    , pat_args = PrefixCon pats                     , pat_con_ext = ConPatTc                       { cpt_tvs = []                       , cpt_dicts = []@@ -1091,12 +1095,12 @@  -- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@ -- needs parentheses under precedence @p@.-conPatNeedsParens :: PprPrec -> HsConDetails t a b -> Bool+conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool conPatNeedsParens p = go   where-    go (PrefixCon ts args) = p >= appPrec && (not (null args) || not (null ts))-    go (InfixCon {})       = p >= opPrec -- type args should be empty in this case-    go (RecCon {})         = False+    go (PrefixCon args) = p >= appPrec && not (null args)+    go (InfixCon {})    = p >= opPrec -- type args should be empty in this case+    go (RecCon {})      = False   -- | Parenthesize a pattern without token information
compiler/GHC/Hs/Specificity.hs view
@@ -49,4 +49,3 @@   rnf (Invisible spec) = rnf spec   rnf Required = () -
compiler/GHC/Hs/Type.hs view
@@ -23,14 +23,14 @@ -}  module GHC.Hs.Type (-        Mult, HsScaled(..),-        hsMult, hsScaledThing,-        HsArrow, HsArrowOf(..), arrowToHsType, expandHsArrow,-        EpLinearArrow(..),-        hsLinear, hsUnrestricted, isUnrestricted,-        pprHsArrow,+        Mult,+        HsMultAnn, HsMultAnnOf(..),+        multAnnToHsType, expandHsMultAnnOf,+        EpLinear(..), EpArrowOrColon(..),+        pprHsArrow, pprHsMultAnn,          HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,+        HsTypeGhcPsExt(..),         HsForAllTelescope(..), EpAnnForallVis, EpAnnForallInvis,         HsTyVarBndr(..), LHsTyVarBndr, AnnTyVarBndr(..),         HsBndrKind(..),@@ -51,14 +51,14 @@         LHsTypeArg, lhsTypeArgSrcSpan,         OutputableBndrFlag, -        LBangType, BangType,         HsSrcBang(..), HsImplBang(..),         SrcStrictness(..), SrcUnpackedness(..),-        getBangType, getBangStrictness, -        ConDeclField(..), LConDeclField, pprConDeclFields,+        HsConDeclRecField(..), LHsConDeclRecField, pprHsConDeclRecFields, -        HsConDetails(..), noTypeArgs,+        HsConDetails(..),+        HsConDeclField(..), pprHsConDeclFieldWith, pprHsConDeclFieldNoMult,+        hsPlainTypeField, mkConDeclField,         FieldOcc(..), LFieldOcc, mkFieldOcc,         fieldOccRdrName, fieldOccLRdrName, @@ -77,7 +77,9 @@         hsScopedTvs, hsScopedKvs, hsWcScopedTvs, dropWildCards,         hsTyVarLName, hsTyVarName,         hsAllLTyVarNames, hsLTyVarLocNames,-        hsLTyVarName, hsLTyVarNames, hsForAllTelescopeNames,+        hsLTyVarName, hsLTyVarNames,+        hsForAllTelescopeBndrs,+        hsForAllTelescopeNames,         hsLTyVarLocName, hsExplicitLTyVarNames,         splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,         splitLHsPatSynTy,@@ -90,7 +92,7 @@         setHsTyVarBndrFlag, hsTyVarBndrFlag, updateHsTyVarBndrFlag,          -- Printing-        pprHsType, pprHsForAll,+        pprHsType, pprHsForAll, pprHsForAllTelescope,         pprHsOuterFamEqnTyVarBndrs, pprHsOuterSigTyVarBndrs,         pprLHsContext,         hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext@@ -105,7 +107,6 @@ import Language.Haskell.Syntax.Extension import GHC.Core.DataCon ( SrcStrictness(..), SrcUnpackedness(..)                         , HsSrcBang(..), HsImplBang(..)-                        , mkHsSrcBang                         ) import GHC.Hs.Extension import GHC.Parser.Annotation@@ -113,11 +114,11 @@ import GHC.Types.Fixity ( LexicalFixity(..) ) import GHC.Types.SourceText import GHC.Types.Name-import GHC.Types.Name.Reader ( RdrName )+import GHC.Types.Name.Reader ( RdrName, WithUserRdr(..), noUserRdr ) import GHC.Types.Var ( VarBndr, visArgTypeLike ) import GHC.Core.TyCo.Rep ( Type(..) ) import GHC.Builtin.Names ( negateName )-import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr )+import GHC.Builtin.Types( oneDataConName, mkTupleStr ) import GHC.Core.Ppr ( pprOccWithTick) import GHC.Core.Type import GHC.Core.Multiplicity( pprArrowWithMultiplicity )@@ -136,25 +137,6 @@ {- ************************************************************************ *                                                                      *-\subsection{Bang annotations}-*                                                                      *-************************************************************************--}--getBangType :: LHsType (GhcPass p) -> LHsType (GhcPass p)-getBangType                 (L _ (HsBangTy _ _ lty))       = lty-getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) =-  addCLocA lty lds (HsDocTy x lty lds)-getBangType lty                                            = lty--getBangStrictness :: LHsType (GhcPass p) -> HsSrcBang-getBangStrictness                 (L _ (HsBangTy (_, s) b _))     = HsSrcBang s b-getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy (_, s) b _)) _)) = HsSrcBang s b-getBangStrictness _ = (mkHsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)--{--************************************************************************-*                                                                      * \subsection{Data types} *                                                                      * ************************************************************************@@ -299,10 +281,14 @@ type instance XHsSig (GhcPass _) = NoExtField type instance XXHsSigType (GhcPass _) = DataConCantHappen -hsSigWcType :: forall p. UnXRec p => LHsSigWcType p -> LHsType p-hsSigWcType = sig_body . unXRec @p . hswc_body -dropWildCards :: LHsSigWcType pass -> LHsSigType pass+hsPatSigType :: HsPatSigType (GhcPass p) -> LHsType (GhcPass p)+hsPatSigType (HsPS { hsps_body = ty }) = ty++hsSigWcType :: LHsSigWcType (GhcPass p) -> LHsType (GhcPass p)+hsSigWcType = sig_body . unLoc . hswc_body++dropWildCards :: LHsSigWcType (GhcPass p) -> LHsSigType (GhcPass p) -- Drop the wildcard part of a LHsSigWcType dropWildCards sig_ty = hswc_body sig_ty @@ -475,11 +461,8 @@ type instance XSpliceTy        GhcTc = Kind  type instance XDocTy           (GhcPass _) = NoExtField-type instance XBangTy          (GhcPass _) = ((EpaLocation, EpToken "#-}", EpaLocation), SourceText)--type instance XRecTy           GhcPs = AnnList ()-type instance XRecTy           GhcRn = NoExtField-type instance XRecTy           GhcTc = NoExtField+type instance XConDeclField    (GhcPass _) = ((EpaLocation, EpToken "#-}", EpaLocation), SourceText)+type instance XXConDeclRecField   (GhcPass _) = DataConCantHappen  type instance XExplicitListTy  GhcPs = (EpToken "'", EpToken "[", EpToken "]") type instance XExplicitListTy  GhcRn = NoExtField@@ -495,92 +478,123 @@ type instance XWildCardTy      GhcRn = NoExtField type instance XWildCardTy      GhcTc = NoExtField -type instance XXType         (GhcPass _) = HsCoreTy---- An escape hatch for tunnelling a Core 'Type' through 'HsType'.--- For more details on how this works, see:------ * @Note [Renaming HsCoreTys]@ in "GHC.Rename.HsType"------ * @Note [Typechecking HsCoreTys]@ in "GHC.Tc.Gen.HsType"-type HsCoreTy = Type+type instance XXType           GhcPs = HsTypeGhcPsExt+type instance XXType           GhcRn = HsCoreTy+type instance XXType           GhcTc = DataConCantHappen  type instance XNumTy         (GhcPass _) = SourceText type instance XStrTy         (GhcPass _) = SourceText type instance XCharTy        (GhcPass _) = SourceText type instance XXTyLit        (GhcPass _) = DataConCantHappen -data EpLinearArrow-  = EpPct1 !(EpToken "%1") !(TokRarrow)-  | EpLolly !(EpToken "⊸")-  deriving Data+type HsCoreTy = Type -instance NoAnn EpLinearArrow where-  noAnn = EpPct1 noAnn noAnn+-- Extension of HsType during parsing.+-- see Note [Trees That Grow] in Language.Haskell.Syntax.Extension+data HsTypeGhcPsExt+  = HsCoreTy    HsCoreTy+    -- An escape hatch for tunnelling a Core 'Type' through 'HsType'.+    -- For more details on how this works, see:+    --+    -- @Note [Renaming HsCoreTys]@ in "GHC.Rename.HsType"+    --+    -- @Note [Typechecking HsCoreTys]@ in "GHC.Tc.Gen.HsType" -type instance XUnrestrictedArrow _ GhcPs = TokRarrow-type instance XUnrestrictedArrow _ GhcRn = NoExtField-type instance XUnrestrictedArrow _ GhcTc = NoExtField+  | HsBangTy    (EpaLocation, EpToken "#-}", EpaLocation)+                HsSrcBang+                (LHsType GhcPs)+    -- See Note [Parsing data type declarations] -type instance XLinearArrow       _ GhcPs = EpLinearArrow-type instance XLinearArrow       _ GhcRn = NoExtField-type instance XLinearArrow       _ GhcTc = NoExtField+  | HsRecTy     (AnnList ())+                [LHsConDeclRecField GhcPs]+    -- See Note [Parsing data type declarations] -type instance XExplicitMult      _ GhcPs = (EpToken "%", TokRarrow)-type instance XExplicitMult      _ GhcRn = NoExtField-type instance XExplicitMult      _ GhcTc = NoExtField+{- Note [Parsing data type declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When parsing it is not always clear if we're parsing a constructor field type+or not. So during parsing we extend the type syntax to support bang annotations+and record braces. We do this through the extension constructor of (HsType GhcPs),+namely `HsTypeGhcPsExt`, adding data constructors for `HsBangTy` and `HsRecTy`.+Once parsing is done (i.e. (HsType GhcRn) and (HsType GhcTc)) these constructors+are not needed; instead the data is stored in `HsConDeclField`. It is an error+if it turns out the extensions were used outside of a constructor field type.+-} -type instance XXArrow            _ (GhcPass _) = DataConCantHappen+data EpArrowOrColon+  = EpArrow !TokRarrow+  | EpColon !TokDcolon+  | EpPatBind+  deriving Data -hsLinear :: forall p a. IsPass p => a -> HsScaled (GhcPass p) a-hsLinear = HsScaled (HsLinearArrow x)-  where-    x = case ghcPass @p of-      GhcPs -> noAnn-      GhcRn -> noExtField-      GhcTc -> noExtField+data EpLinear+  = EpPct1 !(EpToken "%1") !EpArrowOrColon+  | EpLolly !(EpToken "⊸")+  deriving Data -hsUnrestricted :: forall p a. IsPass p => a -> HsScaled (GhcPass p) a-hsUnrestricted = HsScaled (HsUnrestrictedArrow x)-  where-    x = case ghcPass @p of-      GhcPs -> noAnn-      GhcRn -> noExtField-      GhcTc -> noExtField+instance NoAnn EpLinear where+  noAnn = EpPct1 noAnn (EpArrow noAnn) -isUnrestricted :: HsArrow GhcRn -> Bool-isUnrestricted (arrowToHsType -> L _ (HsTyVar _ _ (L _ n))) = n == manyDataConName-isUnrestricted _ = False+type instance XUnannotated  _ GhcPs = EpArrowOrColon+type instance XUnannotated  _ GhcRn = NoExtField+type instance XUnannotated  _ GhcTc = Mult -arrowToHsType :: HsArrow GhcRn -> LHsType GhcRn-arrowToHsType = expandHsArrow (HsTyVar noAnn NotPromoted)+type instance XLinearAnn    _ GhcPs = EpLinear+type instance XLinearAnn    _ GhcRn = NoExtField+type instance XLinearAnn    _ GhcTc = Mult --- | Convert an arrow into its corresponding multiplicity. In essence this--- erases the information of whether the programmer wrote an explicit--- multiplicity or a shorthand.-expandHsArrow :: (LocatedN Name -> t GhcRn) -> HsArrowOf (LocatedA (t GhcRn)) GhcRn -> LocatedA (t GhcRn)-expandHsArrow mk_var (HsUnrestrictedArrow _) = noLocA (mk_var (noLocA manyDataConName))-expandHsArrow mk_var (HsLinearArrow _) = noLocA (mk_var (noLocA oneDataConName))-expandHsArrow _mk_var (HsExplicitMult _ p) = p+type instance XExplicitMult _ GhcPs = (EpToken "%", EpArrowOrColon)+type instance XExplicitMult _ GhcRn = NoExtField+type instance XExplicitMult _ GhcTc = Mult +type instance XXMultAnnOf   _ (GhcPass _) = DataConCantHappen++multAnnToHsType :: HsMultAnn GhcRn -> Maybe (LHsType GhcRn)+multAnnToHsType = expandHsMultAnnOf (HsTyVar noAnn NotPromoted . fmap noUserRdr)++-- | Convert an multiplicity annotation into its corresponding multiplicity.+-- If no annotation was written, `Nothing` is returned.+-- In this polymorphic function, `t` can be `HsType` or `HsExpr`+expandHsMultAnnOf :: (LocatedN Name -> t GhcRn)+                  -> HsMultAnnOf (LocatedA (t GhcRn)) GhcRn+                  -> Maybe (LocatedA (t GhcRn))+expandHsMultAnnOf _mk_var HsUnannotated{} = Nothing+expandHsMultAnnOf mk_var (HsLinearAnn _) = Just (noLocA (mk_var (noLocA oneDataConName)))+expandHsMultAnnOf _mk_var (HsExplicitMult _ p) = Just p+ instance       (Outputable mult, OutputableBndrId pass) =>-      Outputable (HsArrowOf mult (GhcPass pass)) where+      Outputable (HsMultAnnOf mult (GhcPass pass)) where   ppr arr = parens (pprHsArrow arr)  -- See #18846-pprHsArrow :: (Outputable mult, OutputableBndrId pass) => HsArrowOf mult (GhcPass pass) -> SDoc-pprHsArrow (HsUnrestrictedArrow _) = pprArrowWithMultiplicity visArgTypeLike (Left False)-pprHsArrow (HsLinearArrow _)       = pprArrowWithMultiplicity visArgTypeLike (Left True)-pprHsArrow (HsExplicitMult _ p)    = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p))+pprHsArrow :: (Outputable mult, OutputableBndrId pass) => HsMultAnnOf mult (GhcPass pass) -> SDoc+pprHsArrow (HsUnannotated _)    = pprArrowWithMultiplicity visArgTypeLike (Left False)+pprHsArrow (HsLinearAnn _)      = pprArrowWithMultiplicity visArgTypeLike (Left True)+pprHsArrow (HsExplicitMult _ p) = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p)) -type instance XConDeclField  (GhcPass _) = TokDcolon-type instance XXConDeclField (GhcPass _) = DataConCantHappen+-- Used to print, for instance, let bindings:+--   let %1 x = …+-- and record field declarations:+--   { x %1 :: … }+pprHsMultAnn :: forall id. OutputableBndrId id => HsMultAnn (GhcPass id) -> SDoc+pprHsMultAnn (HsUnannotated _) = empty+pprHsMultAnn (HsLinearAnn _) = text "%1"+pprHsMultAnn (HsExplicitMult _ p) = text "%" <> ppr p +type instance XConDeclRecField  (GhcPass _) = NoExtField+type instance XXConDeclRecField (GhcPass _) = DataConCantHappen+ instance OutputableBndrId p-       => Outputable (ConDeclField (GhcPass p)) where-  ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty+       => Outputable (HsConDeclRecField (GhcPass p)) where+  ppr (HsConDeclRecField _ fld_n cfs) = pprMaybeWithDoc (cdf_doc cfs) (ppr_names fld_n <+> pprHsConDeclFieldWith ppr_mult cfs { cdf_doc = Nothing })+    where+      ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc+      ppr_names [n] = pprPrefixOcc n+      ppr_names ns = sep (punctuate comma (map pprPrefixOcc ns)) +      ppr_mult :: HsMultAnn (GhcPass p) -> SDoc -> SDoc+      ppr_mult mult tyDoc = pprHsMultAnn mult <+> dcolon <+> tyDoc+ --------------------- hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name] -- Get the lexically-scoped type variables of an LHsSigWcType:@@ -623,6 +637,10 @@ hsLTyVarNames :: [LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)] hsLTyVarNames = mapMaybe hsLTyVarName +hsForAllTelescopeBndrs :: HsForAllTelescope (GhcPass p) -> [LHsTyVarBndr ForAllTyFlag (GhcPass p)]+hsForAllTelescopeBndrs (HsForAllVis   _ bndrs) = map (fmap (setHsTyVarBndrFlag Required)) bndrs+hsForAllTelescopeBndrs (HsForAllInvis _ bndrs) = map (fmap (updateHsTyVarBndrFlag Invisible)) bndrs+ hsForAllTelescopeNames :: HsForAllTelescope (GhcPass p) -> [IdP (GhcPass p)] hsForAllTelescopeNames (HsForAllVis _ bndrs) = hsLTyVarNames bndrs hsForAllTelescopeNames (HsForAllInvis _ bndrs) = hsLTyVarNames bndrs@@ -679,9 +697,9 @@ mkAnonWildCardTy :: EpToken "_" -> HsType GhcPs mkAnonWildCardTy tok = HsWildCardTy tok -mkHsOpTy :: (Anno (IdGhcP p) ~ SrcSpanAnnN)+mkHsOpTy :: (Anno (IdOccGhcP p) ~ SrcSpanAnnN)          => PromotionFlag-         -> LHsType (GhcPass p) -> LocatedN (IdP (GhcPass p))+         -> LHsType (GhcPass p) -> LocatedN (IdOccP (GhcPass p))          -> LHsType (GhcPass p) -> HsType (GhcPass p) mkHsOpTy prom ty1 op ty2 = HsOpTy noExtField prom ty1 op ty2 @@ -711,10 +729,10 @@ --      splitHsFunType (a -> (b -> c)) = ([a,b], c) -- It returns API Annotations for any parens removed splitHsFunType ::-     LHsType (GhcPass p)+     LHsType GhcPs   -> ( ([EpToken "("], [EpToken ")"]) , EpAnnComments -- The locations of any parens and                                   -- comments discarded-     , [HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p))+     , [HsConDeclField GhcPs], LHsType GhcPs) splitHsFunType ty = go ty   where     go (L l (HsParTy (op,cp) ty))@@ -725,7 +743,7 @@      go (L ll (HsFunTy _ mult x y))       | (anns, csy, args, res) <- splitHsFunType y-      = (anns, csy S.<> epAnnComments ll, HsScaled mult x:args, res)+      = (anns, csy S.<> epAnnComments ll, mkConDeclField mult x:args, res)      go other = (noAnn, emptyComments, [], other) @@ -733,18 +751,18 @@ -- This is somewhat like @GHC.Tc.Gen.HsType.splitHsAppTys@, but a little more -- thorough. The purpose of this function is to examine instance heads, so it -- doesn't handle *all* cases (like lists, tuples, @(~)@, etc.).-hsTyGetAppHead_maybe :: (Anno (IdGhcP p) ~ SrcSpanAnnN)+hsTyGetAppHead_maybe :: (Anno (IdOccGhcP p) ~ SrcSpanAnnN)                      => LHsType (GhcPass p)-                     -> Maybe (LocatedN (IdP (GhcPass p)))+                     -> Maybe (LocatedN (IdOccP (GhcPass p))) hsTyGetAppHead_maybe = go   where-    go (L _ (HsTyVar _ _ ln))          = Just ln-    go (L _ (HsAppTy _ l _))           = go l-    go (L _ (HsAppKindTy _ t _))       = go t-    go (L _ (HsOpTy _ _ _ ln _))       = Just ln-    go (L _ (HsParTy _ t))             = go t-    go (L _ (HsKindSig _ t _))         = go t-    go _                               = Nothing+    go (L _ (HsTyVar _ _ ln))    = Just ln+    go (L _ (HsAppTy _ l _))     = go l+    go (L _ (HsAppKindTy _ t _)) = go t+    go (L _ (HsOpTy _ _ _ ln _)) = Just ln+    go (L _ (HsParTy _ t))       = go t+    go (L _ (HsKindSig _ t _))   = go t+    go _                         = Nothing  ------------------------------------------------------------ @@ -895,16 +913,29 @@ -- "GHC.Hs.Decls" for why this is important. splitLHsGadtTy ::      LHsSigType GhcPs-  -> (HsOuterSigTyVarBndrs GhcPs, Maybe (LHsContext GhcPs), LHsType GhcPs)+  -> (HsOuterSigTyVarBndrs GhcPs, [HsForAllTelescope GhcPs], Maybe (LHsContext GhcPs), LHsType GhcPs) splitLHsGadtTy (L _ sig_ty)-  | (outer_bndrs, rho_ty) <- split_bndrs sig_ty-  , (mb_ctxt, tau_ty)     <- splitLHsQualTy_KP rho_ty-  = (outer_bndrs, mb_ctxt, tau_ty)+  | (outer_bndrs, sigma_ty) <- split_outer_bndrs sig_ty+  , (inner_bndrs, phi_ty)   <- split_inner_bndrs sigma_ty+  , (mb_ctxt, rho_ty)       <- splitLHsQualTy_KP phi_ty+  = case rho_ty of+      L _ (HsFunTy _ _ (L _ (XHsType HsRecTy{})) _) | not (null inner_bndrs)+        -- Bad! Record GADTs are not allowed to have inner_bndrs,+        -- undo the split to get a proper error message later+        -> (outer_bndrs, [], Nothing, sigma_ty)+      _ -> (outer_bndrs, inner_bndrs, mb_ctxt, rho_ty)   where-    split_bndrs :: HsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)-    split_bndrs (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty}) =+    split_outer_bndrs :: HsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)+    split_outer_bndrs (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty}) =       (outer_bndrs, body_ty) +    split_inner_bndrs :: LHsType GhcPs -> ([HsForAllTelescope GhcPs], LHsType GhcPs)+    split_inner_bndrs (L _ HsForAllTy { hst_tele = tele+                                      , hst_body = body })+      = let ~(teles, t) = split_inner_bndrs body+        in (tele:teles, t)+    split_inner_bndrs t = ([], t)+ -- | Decompose a type of the form @forall <tvs>. body@ into its constituent -- parts. Only splits type variable binders that -- were quantified invisibly (e.g., @forall a.@, with a dot).@@ -999,9 +1030,9 @@ -- | Decompose a type class instance type (of the form -- @forall <tvs>. context => instance_head@) into the @instance_head@ and -- retrieve the underlying class type constructor (if it exists).-getLHsInstDeclClass_maybe :: (Anno (IdGhcP p) ~ SrcSpanAnnN)+getLHsInstDeclClass_maybe :: (Anno (IdOccGhcP p) ~ SrcSpanAnnN)                           => LHsSigType (GhcPass p)-                          -> Maybe (LocatedN (IdP (GhcPass p)))+                          -> Maybe (LocatedN (IdOccP (GhcPass p))) -- Works on (LHsSigType GhcPs) getLHsInstDeclClass_maybe inst_ty   = do { let head_ty = getLHsInstDeclHead inst_ty@@ -1128,9 +1159,7 @@ type instance XCFieldOcc GhcRn = RdrName type instance XCFieldOcc GhcTc = RdrName -type instance XXFieldOcc GhcPs = DataConCantHappen-type instance XXFieldOcc GhcRn = DataConCantHappen-type instance XXFieldOcc GhcTc = DataConCantHappen+type instance XXFieldOcc (GhcPass p) = DataConCantHappen  -------------------------------------------------------------------------------- @@ -1143,6 +1172,10 @@   GhcRn -> foExt fo   GhcTc -> foExt fo +-- ToDo SPJ: remove+--fieldOccExt :: FieldOcc (GhcPass p) -> XCFieldOcc (GhcPass p)+--fieldOccExt (FieldOcc { foExt = ext }) = ext+ fieldOccLRdrName :: forall p. IsPass p => FieldOcc (GhcPass p) -> LocatedN RdrName fieldOccLRdrName fo = case ghcPass @p of   GhcPs -> foLabel fo@@ -1164,10 +1197,10 @@ -}  -- | Name of an operator in an operator application or section-data OpName = NormalOp Name             -- ^ A normal identifier-            | NegateOp                  -- ^ Prefix negation-            | UnboundOp RdrName         -- ^ An unbound identifier-            | RecFldOp (FieldOcc GhcRn) -- ^ A record field occurrence+data OpName = NormalOp (WithUserRdr Name) -- ^ A normal identifier+            | NegateOp                    -- ^ Prefix negation+            | UnboundOp RdrName           -- ^ An unbound identifier+            | RecFldOp (FieldOcc GhcRn)   -- ^ A record field occurrence  instance Outputable OpName where   ppr (NormalOp n)   = ppr n@@ -1209,6 +1242,15 @@             HsBndrRequired  _ -> parens_if_kind bkind d             HsBndrInvisible _ -> char '@' <> parens_if_kind bkind d +instance OutputableBndrFlag ForAllTyFlag p where+  pprTyVarBndr (HsTvb _ spec bvar bkind) =+      text "forall" <+> decorate (ppr_hs_tvb bvar bkind)+    where decorate :: SDoc -> SDoc+          decorate d = case spec of+            Inferred  -> braces d <> dot+            Specified -> parens_if_kind bkind d <> dot+            Required  -> parens_if_kind bkind d <+> text "->"+ ppr_hs_tvb :: OutputableBndrId p => HsBndrVar (GhcPass p) -> HsBndrKind (GhcPass p) -> SDoc ppr_hs_tvb bvar (HsBndrNoKind _) = ppr bvar ppr_hs_tvb bvar (HsBndrKind _ k) = hsep [ppr bvar, dcolon, ppr k]@@ -1277,13 +1319,31 @@     pprInfixOcc  n = ppr n     pprPrefixOcc n = ppr n -instance (Outputable tyarg, Outputable arg, Outputable rec)-         => Outputable (HsConDetails tyarg arg rec) where-  ppr (PrefixCon tyargs args) = text "PrefixCon:" <+> hsep (map (\t -> text "@" <> ppr t) tyargs) <+> ppr args-  ppr (RecCon rec)            = text "RecCon:" <+> ppr rec-  ppr (InfixCon l r)          = text "InfixCon:" <+> ppr [l, r]+instance (Outputable arg, Outputable rec)+         => Outputable (HsConDetails arg rec) where+  ppr (PrefixCon args) = text "PrefixCon:" <+> ppr args+  ppr (RecCon rec)     = text "RecCon:" <+> ppr rec+  ppr (InfixCon l r)   = text "InfixCon:" <+> ppr [l, r] -instance Outputable (XRec pass (IdP pass)) => Outputable (FieldOcc pass) where+pprHsConDeclFieldWith :: (OutputableBndrId p)+                      => (HsMultAnn (GhcPass p) -> SDoc -> SDoc)+                      -> HsConDeclField (GhcPass p) -> SDoc+pprHsConDeclFieldWith ppr_mult (CDF _ prag mark mult ty doc) =+  pprMaybeWithDoc doc (ppr_mult mult (ppr prag <+> ppr mark <> ppr ty))++pprHsConDeclFieldNoMult :: (OutputableBndrId p) => HsConDeclField (GhcPass p) -> SDoc+pprHsConDeclFieldNoMult = pprHsConDeclFieldWith (\_ d -> d)++hsPlainTypeField :: LHsType GhcPs -> HsConDeclField GhcPs+hsPlainTypeField = mkConDeclField (HsUnannotated (EpColon noAnn))++mkConDeclField :: HsMultAnn GhcPs -> LHsType GhcPs -> HsConDeclField GhcPs+mkConDeclField mult (L _ (HsDocTy _ ty lds)) = (mkConDeclField mult ty) { cdf_doc = Just lds }+mkConDeclField mult (L _ (XHsType (HsBangTy ann (HsSrcBang srcTxt unp str) t))) = CDF (ann, srcTxt) unp str mult t Nothing+mkConDeclField mult t = CDF noAnn NoSrcUnpack NoSrcStrict mult t Nothing++instance Outputable (XRecGhc (IdGhcP p)) =>+       Outputable (FieldOcc (GhcPass p)) where   ppr = ppr . foLabel  instance (OutputableBndrId pass) => OutputableBndr (FieldOcc (GhcPass pass)) where@@ -1294,8 +1354,6 @@   pprInfixOcc  = pprInfixOcc . unLoc   pprPrefixOcc = pprPrefixOcc . unLoc -- ppr_tylit :: (HsTyLit (GhcPass p)) -> SDoc ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i) ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s))@@ -1318,7 +1376,7 @@                         => HsOuterSigTyVarBndrs (GhcPass p) -> SDoc pprHsOuterSigTyVarBndrs (HsOuterImplicit{}) = empty pprHsOuterSigTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) =-  pprHsForAll (mkHsForAllInvisTele noAnn bndrs) Nothing+  pprHsForAllTelescope (mkHsForAllInvisTele noAnn bndrs)  -- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@ -- only when @-dppr-debug@ is enabled.@@ -1326,13 +1384,16 @@             => HsForAllTelescope (GhcPass p)             -> Maybe (LHsContext (GhcPass p)) -> SDoc pprHsForAll tele cxt-  = pp_tele tele <+> pprLHsContext cxt-  where-    pp_tele :: HsForAllTelescope (GhcPass p) -> SDoc-    pp_tele tele = case tele of+  = pprHsForAllTelescope tele <+> pprLHsContext cxt++pprHsForAllTelescope :: forall p. OutputableBndrId p+                     => HsForAllTelescope (GhcPass p)+                     -> SDoc+pprHsForAllTelescope tele =+  case tele of       HsForAllVis   { hsf_vis_bndrs   = qtvs } -> pp_forall (space <> arrow) qtvs       HsForAllInvis { hsf_invis_bndrs = qtvs } -> pp_forall dot qtvs-+  where     pp_forall :: forall flag p. (OutputableBndrId p, OutputableBndrFlag flag p)               => SDoc -> [LHsTyVarBndr flag (GhcPass p)] -> SDoc     pp_forall separator qtvs@@ -1356,17 +1417,9 @@       [L _ ty] -> ppr_mono_ty ty           <+> darrow       _        -> parens (interpp'SP ctxt) <+> darrow -pprConDeclFields :: forall p. OutputableBndrId p-                 => [LConDeclField (GhcPass p)] -> SDoc-pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))-  where-    ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,-                                 cd_fld_doc = doc }))-        = pprMaybeWithDoc doc (ppr_names ns <+> dcolon <+> ppr ty)--    ppr_names :: forall p. OutputableBndrId p => [LFieldOcc (GhcPass p)] -> SDoc-    ppr_names [n] = pprPrefixOcc n-    ppr_names ns = sep (punctuate comma (map pprPrefixOcc ns))+pprHsConDeclRecFields :: forall p. OutputableBndrId p+                 => [LHsConDeclRecField (GhcPass p)] -> SDoc+pprHsConDeclRecFields fields = braces (sep (punctuate comma (map ppr fields)))  -- Printing works more-or-less as for Types @@ -1384,8 +1437,6 @@ ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty })   = sep [pprLHsContextAlways ctxt, ppr_mono_lty ty] -ppr_mono_ty (HsBangTy _ b ty)           = ppr b <> ppr_mono_lty ty-ppr_mono_ty (HsRecTy _ flds)            = pprConDeclFields flds ppr_mono_ty (HsTyVar _ prom (L _ name)) = pprOccWithTick Prefix prom name ppr_mono_ty (HsFunTy _ mult ty1 ty2)    = ppr_fun_ty mult ty1 ty2 ppr_mono_ty (HsTupleTy _ con tys)@@ -1442,11 +1493,16 @@ ppr_mono_ty (HsDocTy _ ty doc)   = pprWithDoc doc $ ppr_mono_lty ty -ppr_mono_ty (XHsType t) = ppr t+ppr_mono_ty (XHsType t) = case ghcPass @p of+  GhcPs -> case t of+    HsCoreTy ty     -> ppr ty+    HsBangTy _ b ty -> ppr b <> ppr_mono_lty ty+    HsRecTy _ flds  -> pprHsConDeclRecFields flds+  GhcRn -> ppr t  -------------------------- ppr_fun_ty :: (OutputableBndrId p)-           => HsArrow (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc+           => HsMultAnn (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc ppr_fun_ty mult ty1 ty2   = let p1 = ppr_mono_lty ty1         p2 = ppr_mono_lty ty2@@ -1461,13 +1517,11 @@ -------------------------- -- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses -- under precedence @p@.-hsTypeNeedsParens :: PprPrec -> HsType (GhcPass p) -> Bool+hsTypeNeedsParens :: forall p. IsPass p => PprPrec -> HsType (GhcPass p) -> Bool hsTypeNeedsParens p = go_hs_ty   where     go_hs_ty (HsForAllTy{})           = p >= funPrec     go_hs_ty (HsQualTy{})             = p >= funPrec-    go_hs_ty (HsBangTy{})             = p > topPrec-    go_hs_ty (HsRecTy{})              = False     go_hs_ty (HsTyVar{})              = False     go_hs_ty (HsFunTy{})              = p >= funPrec     -- Special-case unary boxed tuple applications so that they are@@ -1498,7 +1552,12 @@     go_hs_ty (HsOpTy{})               = p >= opPrec     go_hs_ty (HsParTy{})              = False     go_hs_ty (HsDocTy _ (L _ t) _)    = go_hs_ty t-    go_hs_ty (XHsType ty)             = go_core_ty ty+    go_hs_ty (XHsType t)             = case ghcPass @p of+      GhcPs -> case t of+        HsCoreTy ty -> go_core_ty ty+        HsBangTy{}  -> p > topPrec+        HsRecTy{}   -> False+      GhcRn -> go_core_ty t      go_core_ty (TyVarTy{})    = False     go_core_ty (AppTy{})      = p >= appPrec@@ -1530,8 +1589,6 @@     go (HsQualTy{ hst_ctxt = ctxt, hst_body = body})       | (L _ (c:_)) <- ctxt = goL c       | otherwise            = goL body-    go (HsBangTy{})          = False-    go (HsRecTy{})           = False     go (HsTyVar _ p _)       = isPromoted p     go (HsFunTy _ _ arg _)   = goL arg     go (HsListTy{})          = False@@ -1555,7 +1612,7 @@ -- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is -- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply -- returns @ty@.-parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)+parenthesizeHsType :: IsPass p => PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p) parenthesizeHsType p lty@(L loc ty)   | hsTypeNeedsParens p ty = L loc (HsParTy noAnn lty)   | otherwise              = lty@@ -1564,8 +1621,7 @@ -- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@ -- with an 'HsParTy' to form a parenthesized @ctxt@. Otherwise, it simply -- returns @ctxt@ unchanged.-parenthesizeHsContext :: PprPrec-                      -> LHsContext (GhcPass p) -> LHsContext (GhcPass p)+parenthesizeHsContext :: IsPass p => PprPrec -> LHsContext (GhcPass p) -> LHsContext (GhcPass p) parenthesizeHsContext p lctxt@(L loc ctxt) =   case ctxt of     [c] -> L loc [parenthesizeHsType p c]@@ -1579,7 +1635,6 @@ ************************************************************************ -} -type instance Anno (BangType (GhcPass p)) = SrcSpanAnnA type instance Anno [LocatedA (HsType (GhcPass p))] = SrcSpanAnnC type instance Anno (HsType (GhcPass p)) = SrcSpanAnnA type instance Anno (HsSigType (GhcPass p)) = SrcSpanAnnA@@ -1593,6 +1648,6 @@  type instance Anno (HsOuterTyVarBndrs _ (GhcPass _)) = SrcSpanAnnA type instance Anno HsIPName = EpAnnCO-type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA+type instance Anno (HsConDeclRecField (GhcPass p)) = SrcSpanAnnA  type instance Anno (FieldOcc (GhcPass p)) = SrcSpanAnnA
compiler/GHC/Hs/Utils.hs view
@@ -53,13 +53,15 @@   mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,   mkHsCmdIf, mkConLikeTc, -  nlHsTyApp, nlHsTyApps, nlHsVar, nl_HsVar, nlHsDataCon,+  nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon,   nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,   nlHsIntLit, nlHsVarApps,   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,   mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,   mkLocatedList, nlAscribe, +  forgetUserRdr, noUserRdr,+   -- * Bindings   mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind,   mkPatSynBind,@@ -135,7 +137,7 @@ import GHC.Core.Make   ( mkChunkified ) import GHC.Core.Type   ( Type, isUnliftedType ) -import GHC.Builtin.Types ( unitTy )+import GHC.Builtin.Types ( unitTy, manyDataConTy )  import GHC.Types.Id import GHC.Types.Name@@ -157,7 +159,7 @@ import Control.Arrow ( first ) import Data.Foldable ( toList ) import Data.List ( partition )-import Data.List.NonEmpty ( nonEmpty )+import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) import qualified Data.List.NonEmpty as NE  import Data.IntMap ( IntMap )@@ -207,8 +209,8 @@ unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))                      ~ EpAnn NoEpAnns              => EpAnn GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p))-             -> [LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))]-unguardedRHS an loc rhs = [L (noAnnSrcSpan loc) (GRHS an [] rhs)]+             -> NonEmpty (LGRHS (GhcPass p) (LocatedA (body (GhcPass p))))+unguardedRHS an loc rhs = NE.singleton $ L (noAnnSrcSpan loc) (GRHS an [] rhs)  type AnnoBody p body   = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ Origin@@ -287,8 +289,7 @@ mkHsSyntaxApps ann (SyntaxExprTc { syn_expr      = fun                                  , syn_arg_wraps = arg_wraps                                  , syn_res_wrap  = res_wrap }) args-  = mkLHsWrap res_wrap (foldl' mkHsApp (L ann fun) (zipWithEqual "mkHsSyntaxApps"-                                                     mkLHsWrap arg_wraps args))+  = mkLHsWrap res_wrap (foldl' mkHsApp (L ann fun) (zipWithEqual mkLHsWrap arg_wraps args)) mkHsSyntaxApps _ NoSyntaxExprTc args = pprPanic "mkHsSyntaxApps" (ppr args)   -- this function should never be called in scenarios where there is no   -- syntax expr@@ -306,7 +307,7 @@  nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc nlHsTyApp fun_id tys-  = noLocA (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLocA fun_id)))+  = noLocA (mkHsWrap (mkWpTyApps tys) (mkHsVar (noLocA fun_id)))  nlHsTyApps :: Id -> [Type] -> [LHsExpr GhcTc] -> LHsExpr GhcTc nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs@@ -475,7 +476,7 @@ -- | A useful function for building @OpApps@.  The operator is always a -- variable, and we don't know the fixity yet. mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs-mkHsOpApp e1 op e2 = OpApp noExtField e1 (noLocA (HsVar noExtField (noLocA op))) e2+mkHsOpApp e1 op e2 = OpApp noExtField e1 (noLocA (mkHsVar (noLocA op))) e2  mkHsString :: String -> HsLit (GhcPass p) mkHsString s = HsString NoSourceText (mkFastString s)@@ -502,11 +503,7 @@  nlHsVar :: IsSrcSpanAnn p a         => IdP (GhcPass p) -> LHsExpr (GhcPass p)-nlHsVar n = noLocA (HsVar noExtField (noLocA n))--nl_HsVar :: IsSrcSpanAnn p a-        => IdP (GhcPass p) -> HsExpr (GhcPass p)-nl_HsVar n = HsVar noExtField (noLocA n)+nlHsVar n = noLocA (mkHsVar (noLocA n))  -- | NB: Only for 'LHsExpr' 'Id'. nlHsDataCon :: DataCon -> LHsExpr GhcTc@@ -538,8 +535,8 @@  nlHsVarApps :: IsSrcSpanAnn p a             => IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)-nlHsVarApps f xs = noLocA (foldl' mk (HsVar noExtField (noLocA f))-                                         (map ((HsVar noExtField) . noLocA) xs))+nlHsVarApps f xs = noLocA (foldl' mk (mkHsVar (noLocA f))+                                         (map (mkHsVar . noLocA) xs))                  where                    mk f a = HsApp noExtField (noLocA f) (noLocA a) @@ -561,28 +558,28 @@ nlConPat con pats = noLocA $ ConPat   { pat_con_ext = noAnn   , pat_con = noLocA con-  , pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats)+  , pat_args = PrefixCon (map (parenthesizePat appPrec) pats)   }  nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn nlConPatName con pats = noLocA $ ConPat   { pat_con_ext = noExtField-  , pat_con = noLocA con-  , pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats)+  , pat_con = noLocA (noUserRdr con)+  , pat_args = PrefixCon (map (parenthesizePat appPrec) pats)   }  nlNullaryConPat :: RdrName -> LPat GhcPs nlNullaryConPat con = noLocA $ ConPat   { pat_con_ext = noAnn   , pat_con = noLocA con-  , pat_args = PrefixCon [] []+  , pat_args = PrefixCon []   }  nlWildConPat :: DataCon -> LPat GhcPs nlWildConPat con = noLocA $ ConPat   { pat_con_ext = noAnn   , pat_con = noLocA $ getRdrName con-  , pat_args = PrefixCon [] $+  , pat_args = PrefixCon $      replicate (dataConSourceArity con)                nlWildPat   }@@ -608,7 +605,6 @@          -> LHsExpr GhcPs nlList   :: [LHsExpr GhcPs] -> LHsExpr GhcPs --- AZ:Is this used? nlHsLam match = noLocA $ HsLam noAnn LamSingle                   $ mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA [match]) @@ -624,32 +620,32 @@ nlList exprs          = noLocA (ExplicitList noAnn exprs)  nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)-nlHsTyVar :: IsSrcSpanAnn p a+nlHsTyVar :: forall p a. IsSrcSpanAnn p a           => PromotionFlag -> IdP (GhcPass p)           -> LHsType (GhcPass p) nlHsFunTy :: forall p. IsPass p           => LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsParTy :: LHsType (GhcPass p)                        -> LHsType (GhcPass p)  nlHsAppTy f t = noLocA (HsAppTy noExtField f t)-nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocA x))-nlHsFunTy a b = noLocA (HsFunTy noExtField (HsUnrestrictedArrow x) a b)+nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocA $ noUserRdrP @p x))+nlHsFunTy a b = noLocA (HsFunTy noExtField (HsUnannotated x) a b)   where     x = case ghcPass @p of-      GhcPs -> noAnn+      GhcPs -> EpArrow noAnn       GhcRn -> noExtField-      GhcTc -> noExtField+      GhcTc -> manyDataConTy nlHsParTy t   = noLocA (HsParTy noAnn t)  nlHsTyConApp :: forall p a. IsSrcSpanAnn p a              => PromotionFlag-             -> LexicalFixity -> IdP (GhcPass p)+             -> LexicalFixity -> IdOccP (GhcPass p)              -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p) nlHsTyConApp prom fixity tycon tys   | Infix <- fixity   , HsValArg _ ty1 : HsValArg _ ty2 : rest <- tys   = foldl' mk_app (noLocA $ HsOpTy noExtField prom ty1 (noLocA tycon) ty2) rest   | otherwise-  = foldl' mk_app (nlHsTyVar prom tycon) tys+  = foldl' mk_app (nlHsTyVar prom $ forgetUserRdr @p tycon) tys   where     mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p)     mk_app fun@(L _ (HsOpTy {})) arg = mk_app (nlHsParTy fun) arg@@ -658,6 +654,22 @@     mk_app fun (HsTypeArg _ ki) = nlHsAppKindTy fun ki     mk_app fun (HsArgPar _) = nlHsParTy fun +-- | Turn an 'IdP' into an 'IdOccP', with no user-written 'RdrName' information.+noUserRdrP :: forall p. IsPass p => IdP (GhcPass p) -> IdOccP (GhcPass p)+noUserRdrP =+  case ghcPass @p of+    GhcPs -> id+    GhcRn -> noUserRdr+    GhcTc -> id++-- | Turn an 'IdOccP' into an 'IdP', discarding the user-written 'RdrName'.+forgetUserRdr :: forall p. IsPass p => IdOccP (GhcPass p) -> IdP (GhcPass p)+forgetUserRdr =+  case ghcPass @p of+    GhcPs -> id+    GhcRn -> \ (WithUserRdr _rdr n) -> n+    GhcTc -> id+ nlHsAppKindTy :: forall p. IsPass p =>   LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p) nlHsAppKindTy f k = noLocA (HsAppKindTy x f k)@@ -868,9 +880,9 @@  -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is -- considered infix.-isInfixFunBind :: forall id1 id2. UnXRec id2 => HsBindLR id1 id2 -> Bool+isInfixFunBind :: HsBindLR (GhcPass p1) (GhcPass p2) -> Bool isInfixFunBind (FunBind { fun_matches = MG _ matches })-  = any (isInfixMatch . unXRec @id2) (unXRec @id2 matches)+  = any (isInfixMatch . unLoc) (unLoc matches) isInfixFunBind _ = False  -- |Return the 'SrcSpan' encompassing the contents of any enclosed binds@@ -1190,7 +1202,7 @@     LetStmt _  binds -> collectLocalBinders flag binds     BodyStmt {}      -> []     LastStmt {}      -> []-    ParStmt _ xs _ _ -> collectLStmtsBinders flag [s | ParStmtBlock _ ss _ _ <- xs, s <- ss]+    ParStmt _ xs _ _ -> collectLStmtsBinders flag [s | ParStmtBlock _ ss _ _ <- toList xs, s <- ss]     TransStmt { trS_stmts = stmts } -> collectLStmtsBinders flag stmts     RecStmt { recS_stmts = L _ ss } -> collectLStmtsBinders flag ss     XStmtLR x -> case ghcPass :: GhcPass idR of@@ -1288,15 +1300,11 @@     CollWithDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)                            ++ collectEvBinders (cpt_binds (pat_con_ext pat))     CollVarTyVarBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)-                           ++ concatMap collectConPatTyArgBndrs (hsConPatTyArgs ps)  collectEvBinders :: TcEvBinds -> [Id] collectEvBinders (EvBinds bs)   = foldr add_ev_bndr [] bs collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders" -collectConPatTyArgBndrs :: HsConPatTyArg GhcRn -> [Name]-collectConPatTyArgBndrs (HsConPatTyArg _ tp) = collectTyPatBndrs tp- collect_ty_pat_bndrs :: CollectFlag p -> HsTyPat (NoGhcTc p) -> [IdP p] -> [IdP p] collect_ty_pat_bndrs CollNoDictBinders _ bndrs = bndrs collect_ty_pat_bndrs CollWithDictBinders _ bndrs = bndrs@@ -1342,7 +1350,6 @@       GhcTc -> case ext of         AbsBinds { abs_exports = dbinds } -> (map abe_poly dbinds ++)         -- I don't think we want the binders from the abe_binds-         -- binding (hence see AbsBinds) is in zonking in GHC.Tc.Zonk.Type    collectXSplicePat flag ext =@@ -1647,7 +1654,7 @@     get_flds_h98 :: FieldIndices p -> HsConDeclH98Details (GhcPass p)                  -> (Maybe [Located Int], FieldIndices p)     get_flds_h98 seen (RecCon flds) = first Just $ get_flds seen flds-    get_flds_h98 seen (PrefixCon _ []) = (Just [], seen)+    get_flds_h98 seen (PrefixCon []) = (Just [], seen)     get_flds_h98 seen _ = (Nothing, seen)      get_flds_gadt :: FieldIndices p -> HsConDeclGADTDetails (GhcPass p)@@ -1656,7 +1663,7 @@     get_flds_gadt seen (PrefixConGADT _ []) = (Just [], seen)     get_flds_gadt seen _ = (Nothing, seen) -    get_flds :: FieldIndices p -> LocatedL [LConDeclField (GhcPass p)]+    get_flds :: FieldIndices p -> LocatedL [LHsConDeclRecField (GhcPass p)]              -> ([Located Int], FieldIndices p)     get_flds seen flds =       foldr add_fld ([], seen) fld_names@@ -1664,7 +1671,7 @@         add_fld fld (is, ixs) =           let (i, ixs') = insertField fld ixs           in  (i:is, ixs')-        fld_names = concatMap (cd_fld_names . unLoc) (unLoc flds)+        fld_names = concatMap (cdrf_names . unLoc) (unLoc flds)  -- | A bijection between record fields of a datatype and integers, -- used to implement Note [Collecting record fields in data declarations].@@ -1792,7 +1799,7 @@     hs_stmt (LetStmt _ binds)     = hs_local_binds binds     hs_stmt (BodyStmt {})         = []     hs_stmt (LastStmt {})         = []-    hs_stmt (ParStmt _ xs _ _)    = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs , s <- ss]+    hs_stmt (ParStmt _ xs _ _)    = hs_lstmts [s | ParStmtBlock _ ss _ _ <- toList xs , s <- ss]     hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts     hs_stmt (RecStmt { recS_stmts = L _ ss }) = hs_lstmts ss @@ -1844,7 +1851,7 @@     hs_pat _ = []      details :: HsConPatDetails GhcRn -> [(SrcSpan, [ImplicitFieldBinders])]-    details (PrefixCon _ ps) = hs_lpats ps+    details (PrefixCon ps) = hs_lpats ps     details (RecCon (HsRecFields { rec_dotdot = Nothing, rec_flds }))       = hs_lpats $ map (hfbRHS . unLoc) rec_flds     details (RecCon (HsRecFields { rec_dotdot = Just (L err_loc rec_dotdot), rec_flds }))@@ -1871,5 +1878,5 @@   where (explicit_binds, implicit_binds) = splitAt unRecFieldsDotDot rec_flds         implicit_field_binders (L _ (HsFieldBind { hfbLHS = L _ fld, hfbRHS = rhs }))           = ImplicitFieldBinders-              { implFlBndr_field   = unLoc $ foLabel fld+              { implFlBndr_field   = unLoc $ foLabel (fld :: FieldOcc GhcRn)               , implFlBndr_binders = collectPatBinders CollNoDictBinders rhs }
+ compiler/GHC/HsToCore/Breakpoints.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE RecordWildCards #-}++-- | Information attached to Breakpoints generated from Ticks+--+-- The breakpoint information stored in 'ModBreaks' is generated during+-- desugaring from the ticks annotating the source expressions.+--+-- This information can be queried per-breakpoint using the 'BreakpointId'+-- datatype, which indexes tick-level breakpoint information.+--+-- 'ModBreaks' and 'BreakpointId's are not to be confused with+-- 'InternalModBreaks' and 'InternalBreakId's. The latter are constructed+-- during bytecode generation and can be found in 'GHC.ByteCode.Breakpoints'.+--+-- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers]+module GHC.HsToCore.Breakpoints+  ( -- * ModBreaks+    mkModBreaks, ModBreaks(..)++    -- ** Re-exports BreakpointId+  , BreakpointId(..), BreakTickIndex+  ) where++import GHC.Prelude+import Data.Array++import GHC.HsToCore.Ticks (Tick (..))+import GHC.Data.SizedSeq+import GHC.Types.SrcLoc (SrcSpan)+import GHC.Types.Name (OccName)+import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..))+import GHC.Unit.Module (Module)+import GHC.Utils.Outputable+import Data.List (intersperse)++--------------------------------------------------------------------------------+-- ModBreaks+--------------------------------------------------------------------------------++-- | All the information about the source-relevant breakpoints for a module+--+-- This information is constructed once during desugaring (with `mkModBreaks`)+-- from breakpoint ticks and fixed/unchanged from there on forward. It could be+-- exported as an abstract datatype because it should never be updated after+-- construction, only queried.+--+-- The arrays can be indexed using the int in the corresponding 'BreakpointId'+-- (i.e. the 'BreakpointId' whose 'Module' matches the 'Module' corresponding+-- to these 'ModBreaks') with the accessors 'modBreaks_locs', 'modBreaks_vars',+-- and 'modBreaks_decls'.+data ModBreaks+   = ModBreaks+   { modBreaks_locs   :: !(Array BreakTickIndex SrcSpan)+        -- ^ An array giving the source span of each breakpoint.+   , modBreaks_vars   :: !(Array BreakTickIndex [OccName])+        -- ^ An array giving the names of the free variables at each breakpoint.+   , modBreaks_decls  :: !(Array BreakTickIndex [String])+        -- ^ An array giving the names of the declarations enclosing each breakpoint.+        -- See Note [Field modBreaks_decls]+   , modBreaks_ccs    :: !(Array BreakTickIndex (String, String))+        -- ^ Array pointing to cost centre info for each breakpoint;+        -- actual 'CostCentre' allocation is done at link-time.+   , modBreaks_module :: !Module+        -- ^ The module to which this ModBreaks is associated.+        -- We also cache this here for internal sanity checks.+   }++-- | Initialize memory for breakpoint data that is shared between the bytecode+-- generator and the interpreter.+--+-- Since GHCi and the RTS need to interact with breakpoint data and the bytecode+-- generator needs to encode this information for each expression, the data is+-- allocated remotely in GHCi's address space and passed to the codegen as+-- foreign pointers.+mkModBreaks :: Bool {-^ Whether the interpreter is profiled and thus if we should include store a CCS array -}+            -> Module -> SizedSeq Tick -> ModBreaks+mkModBreaks interpreterProfiled modl extendedMixEntries+  = let count = fromIntegral $ sizeSS extendedMixEntries+        entries = ssElts extendedMixEntries+        locsTicks  = listArray (0,count-1) [ tick_loc  t | t <- entries ]+        varsTicks  = listArray (0,count-1) [ tick_ids  t | t <- entries ]+        declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ]+        ccs+          | interpreterProfiled =+              listArray+                (0, count - 1)+                [ ( concat $ intersperse "." $ tick_path t,+                    renderWithContext defaultSDocContext $ ppr $ tick_loc t+                  )+                | t <- entries+                ]+          | otherwise = listArray (0, -1) []+     in ModBreaks+      { modBreaks_locs   = locsTicks+      , modBreaks_vars   = varsTicks+      , modBreaks_decls  = declsTicks+      , modBreaks_ccs    = ccs+      , modBreaks_module = modl+      }++{-+Note [Field modBreaks_decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A value of eg ["foo", "bar", "baz"] in a `modBreaks_decls` field means:+The breakpoint is in the function called "baz" that is declared in a `let`+or `where` clause of a declaration called "bar", which itself is declared+in a `let` or `where` clause of the top-level function called "foo".+-}
compiler/GHC/HsToCore/Errors/Ppr.hs view
@@ -7,7 +7,7 @@  module GHC.HsToCore.Errors.Ppr where -import GHC.Core.Predicate (isEvVar)+import GHC.Core.Predicate (isEvId) import GHC.Core.Type import GHC.Driver.Flags import GHC.Hs@@ -27,7 +27,7 @@ instance Diagnostic DsMessage where   type DiagnosticOpts DsMessage = NoDiagnosticOpts   diagnosticMessage opts = \case-    DsUnknownMessage (UnknownDiagnostic f m)+    DsUnknownMessage (UnknownDiagnostic f _ m)       -> diagnosticMessage (f opts) m     DsEmptyEnumeration       -> mkSimpleDecorated $ text "Enumeration is empty"@@ -83,14 +83,46 @@                StrictBinds       -> "strict bindings"          in mkSimpleDecorated $               hang (text "Top-level" <+> text desc <+> text "aren't allowed:") 2 (ppr bind)-    DsUselessSpecialiseForClassMethodSelector poly_id-      -> mkSimpleDecorated $-           text "Ignoring useless SPECIALISE pragma for class selector:" <+> quotes (ppr poly_id)-    DsUselessSpecialiseForNoInlineFunction poly_id-      -> mkSimpleDecorated $-          text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id)-    DsMultiplicityCoercionsNotSupported-      -> mkSimpleDecorated $ text "GHC bug #19517: GHC currently does not support programs using GADTs or type families to witness equality of multiplicities"+    DsUselessSpecialisePragma poly_nm is_dfun rea ->+      mkSimpleDecorated $+        vcat [ what <+> pragma <+> text "pragma" <> why+             , additional ]+      where+        quoted_nm = quotes (ppr poly_nm)+        what+          | uselessSpecialisePragmaKeepAnyway rea+          = text "Dubious"+          | otherwise+          = text "Ignoring useless"+        pragma = if is_dfun+                 then text "SPECIALISE instance"+                 else text "SPECIALISE"+        why = case rea of+          UselessSpecialiseForClassMethodSelector ->+            text " for class selector:" <+> quoted_nm+          UselessSpecialiseForNoInlineFunction ->+            text " for NOINLINE function:" <+> quoted_nm+          UselessSpecialiseNoSpecialisation ->+            -- Omit the Name for a DFunId, as it will be internal and not+            -- very illuminating to users who don't know what a DFunId is.+            (if is_dfun then empty else text " for" <+> quoted_nm) <> dot++        additional+          | uselessSpecialisePragmaKeepAnyway rea+          = -- No specialisation happening, but the pragma may still be useful.+            -- For example (#25389):+            --+            --   data G a where { G1 :: G Int, G2 :: G Bool }+            --   f :: G a -> a+            --   f G1 = <branch1>; f G2 = <branch2>+            --   {-# SPECIALISE f :: G Int -> Int #-}+            --     -- In $sf, we get rid of dead code in <branch2>+            vcat+              [ text "The pragma does not specialise away any class dictionaries,"+              , text "and neither is there any value specialisation."+              ]+          | otherwise+          = empty     DsOrphanRule rule       -> mkSimpleDecorated $ text "Orphan rule:" <+> ppr rule     DsRuleLhsTooComplicated orig_lhs lhs2@@ -111,11 +143,11 @@                        , text "is not bound in RULE lhs"])                 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs                         , text "Orig lhs:" <+> ppr orig_lhs-                        , text "optimised lhs:" <+> ppr lhs2 ])+                        , text "Optimised lhs:" <+> ppr lhs2 ])             pp_bndr b             | isTyVar b = text "type variable" <+> quotes (ppr b)-            | isEvVar b = text "constraint"    <+> quotes (ppr (varType b))+            | isEvId  b = text "constraint"    <+> quotes (ppr (varType b))             | otherwise = text "variable"      <+> quotes (ppr b)     DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs       -> mkSimpleDecorated $@@ -167,6 +199,8 @@                -> mkMsg "Splices within declaration brackets" empty              ThNonLinearDataCon                -> mkMsg "Non-linear fields in data constructors" empty+             ThDataConVisibleForall+               -> mkMsg "Visible forall in data constructors" empty          where            mkMsg what doc =              mkSimpleDecorated $@@ -207,10 +241,12 @@                           <+> text "for"<+> quotes (ppr lhs_id)                           <+> text "might fire first")                 ]-    DsIncompleteRecordSelector name cons_wo_field not_full_examples -> mkSimpleDecorated $-      text "The application of the record field" <+> quotes (ppr name)-      <+> text "may fail for the following constructors:"-      <+> vcat (map ppr cons_wo_field ++ [text "..." | not_full_examples])+    DsIncompleteRecordSelector name cons maxCons -> mkSimpleDecorated $+      hang (text "Selecting the record field" <+> quotes (ppr name)+              <+> text "may fail for the following constructors:")+           2+           (hsep $ punctuate comma $+            map ppr (take maxCons cons) ++ [ text "..." | lengthExceeds cons maxCons ])    diagnosticReason = \case     DsUnknownMessage m          -> diagnosticReason m@@ -224,9 +260,7 @@     DsNonExhaustivePatterns _ (ExhaustivityCheckType mb_flag) _ _ _       -> maybe WarningWithoutFlag WarningWithFlag mb_flag     DsTopLevelBindsNotAllowed{}                 -> ErrorWithoutFlag-    DsUselessSpecialiseForClassMethodSelector{} -> WarningWithoutFlag-    DsUselessSpecialiseForNoInlineFunction{}    -> WarningWithoutFlag-    DsMultiplicityCoercionsNotSupported{}       -> ErrorWithoutFlag+    DsUselessSpecialisePragma{}                 -> WarningWithFlag Opt_WarnUselessSpecialisations     DsOrphanRule{}                              -> WarningWithFlag Opt_WarnOrphans     DsRuleLhsTooComplicated{}                   -> WarningWithoutFlag     DsRuleIgnoredDueToConstructor{}             -> WarningWithoutFlag@@ -261,9 +295,7 @@     DsMaxPmCheckModelsReached{}                 -> [SuggestIncreaseMaxPmCheckModels]     DsNonExhaustivePatterns{}                   -> noHints     DsTopLevelBindsNotAllowed{}                 -> noHints-    DsUselessSpecialiseForClassMethodSelector{} -> noHints-    DsUselessSpecialiseForNoInlineFunction{}    -> noHints-    DsMultiplicityCoercionsNotSupported         -> noHints+    DsUselessSpecialisePragma{}                 -> noHints     DsOrphanRule{}                              -> noHints     DsRuleLhsTooComplicated{}                   -> noHints     DsRuleIgnoredDueToConstructor{}             -> noHints@@ -280,7 +312,7 @@     DsAnotherRuleMightFireFirst _ bad_rule _    -> [SuggestAddPhaseToCompetingRule bad_rule]     DsIncompleteRecordSelector{}                -> noHints -  diagnosticCode = constructorCode+  diagnosticCode = constructorCode @GHC  {- Note [Suggest NegativeLiterals]
compiler/GHC/HsToCore/Errors/Types.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-}  module GHC.HsToCore.Errors.Types where@@ -31,7 +32,7 @@ -- | Diagnostics messages emitted during desugaring. data DsMessage   -- | Simply wraps a generic 'Diagnostic' message.-  = DsUnknownMessage (UnknownDiagnostic (DiagnosticOpts DsMessage))+  = DsUnknownMessage (UnknownDiagnosticFor DsMessage)      {-| DsEmptyEnumeration is a warning (controlled by the -Wempty-enumerations flag) that is         emitted if an enumeration is empty.@@ -105,11 +106,18 @@    | DsTopLevelBindsNotAllowed !BindsType !(HsBindLR GhcTc GhcTc) -  | DsUselessSpecialiseForClassMethodSelector !Id+    {-| DsUselessSpecialisePragma is a warning (controlled by the -Wuseless-specialisations flag)+        that is emitted for SPECIALISE pragmas that (most likely) don't do anything. -  | DsUselessSpecialiseForNoInlineFunction !Id+        Examples: -  | DsMultiplicityCoercionsNotSupported+          foo :: forall a. a -> a+          {-# SPECIALISE foo :: Int -> Int #-}+    -}+  | DsUselessSpecialisePragma+      !Name+      !Bool -- ^ is this a @SPECIALISE instance@ pragma?+      !UselessSpecialisePragmaReason    | DsOrphanRule !CoreRule @@ -163,7 +171,9 @@        DsIncompleteRecSel2        DsIncompleteRecSel3   -}-  | DsIncompleteRecordSelector !Name ![ConLike] !Bool+  | DsIncompleteRecordSelector !Name       -- ^ The selector+                               ![ConLike]  -- ^ The partial constructors+                               !Int        -- ^ The max number of constructors reported    deriving Generic @@ -194,6 +204,26 @@   | ThWarningAndDeprecationPragmas [LIdP GhcRn]   | ThSplicesWithinDeclBrackets   | ThNonLinearDataCon+  | ThDataConVisibleForall++-- | Why is a @SPECIALISE@ pragmas useless?+data UselessSpecialisePragmaReason+  -- | Useless @SPECIALISE@ pragma for a class method+  = UselessSpecialiseForClassMethodSelector+  -- | Useless @SPECIALISE@ pragma for a function with NOINLINE+  | UselessSpecialiseForNoInlineFunction+  -- | Useless @SPECIALISE@ pragma which generates a specialised function+  -- which is identical to the original function at runtime.+  | UselessSpecialiseNoSpecialisation+  deriving Generic++uselessSpecialisePragmaKeepAnyway :: UselessSpecialisePragmaReason -> Bool+uselessSpecialisePragmaKeepAnyway = \case+  UselessSpecialiseForClassMethodSelector -> False+  UselessSpecialiseForNoInlineFunction    -> False+  UselessSpecialiseNoSpecialisation       -> True+    -- See #25389/T25389 for why we might want to keep this specialisation+    -- around even if it seemingly does nothing.  data NegLiteralExtEnabled   = YesUsingNegLiterals
compiler/GHC/HsToCore/Pmc/Solver/Types.hs view
@@ -63,8 +63,8 @@ import GHC.Builtin.Names import GHC.Builtin.Types import GHC.Builtin.Types.Prim-import GHC.Tc.Solver.InertSet (InertSet, emptyInert)-import GHC.Tc.Utils.TcType (isStringTy)+import GHC.Tc.Solver.InertSet (InertSet, emptyInertSet)+import GHC.Tc.Utils.TcType (isStringTy, topTcLevel) import GHC.Types.CompleteMatch import GHC.Types.SourceText (SourceText(..), mkFractionalLit, FractionalLit                             , fractionalLitFromRational@@ -129,7 +129,7 @@   ppr (TySt n inert) = ppr n <+> ppr inert  initTyState :: TyState-initTyState = TySt 0 emptyInert+initTyState = TySt 0 (emptyInertSet topTcLevel)  -- | The term oracle state. Stores 'VarInfo' for encountered 'Id's. These -- entries are possibly shared when we figure out that two variables must be
+ compiler/GHC/HsToCore/Ticks.hs view
@@ -0,0 +1,1451 @@+{-# LANGUAGE NondecreasingIndentation #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++{-+(c) Galois, 2006+(c) University of Glasgow, 2007+(c) Florian Ragwitz, 2025+-}++module GHC.HsToCore.Ticks+  ( TicksConfig (..)+  , Tick (..)+  , TickishType (..)+  , addTicksToBinds+  , isGoodSrcSpan'+  , stripTicksTopHsExpr+  ) where++import GHC.Prelude as Prelude++import GHC.Hs+import GHC.Unit++import GHC.Core.Type+import GHC.Core.TyCon++import GHC.Data.Maybe+import GHC.Data.FastString+import GHC.Data.SizedSeq++import GHC.Driver.Flags (DumpFlag(..))++import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic+import GHC.Utils.Logger+import GHC.Types.SrcLoc+import GHC.Types.Basic+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Name.Set hiding (FreeVars)+import GHC.Types.Name+import GHC.Types.CostCentre+import GHC.Types.CostCentre.State+import GHC.Types.Tickish+import GHC.Types.ProfAuto++import Control.Monad+import Data.List (isSuffixOf, intersperse)+import Data.Foldable (toList)++import Trace.Hpc.Mix++import Data.Bifunctor (second)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Set (Set)+import qualified Data.Set as Set++{-+************************************************************************+*                                                                      *+*              The main function: addTicksToBinds+*                                                                      *+************************************************************************+-}++-- | Configuration for compilation pass to add tick for instrumentation+-- to binding sites.+data TicksConfig = TicksConfig+  { ticks_passes       :: ![TickishType]+  -- ^ What purposes do we need ticks for++  , ticks_profAuto     :: !ProfAuto+  -- ^ What kind of {-# SCC #-} to add automatically++  , ticks_countEntries :: !Bool+  -- ^ Whether to count the entries to functions+  --+  -- Requires extra synchronization which can vastly degrade+  -- performance.+  }++data Tick = Tick+  { tick_loc   :: SrcSpan   -- ^ Tick source span+  , tick_path  :: [String]  -- ^ Path to the declaration+  , tick_ids   :: [OccName] -- ^ Identifiers being bound+  , tick_label :: BoxLabel  -- ^ Label for the tick counter+  }++addTicksToBinds+        :: Logger+        -> TicksConfig+        -> Module+        -> ModLocation          -- ^ location of the current module+        -> NameSet              -- ^ Exported Ids.  When we call addTicksToBinds,+                                -- isExportedId doesn't work yet (the desugarer+                                -- hasn't set it), so we have to work from this set.+        -> [TyCon]              -- ^ Type constructors in this module+        -> LHsBinds GhcTc+        -> IO (LHsBinds GhcTc, Maybe (FilePath, SizedSeq Tick))++addTicksToBinds logger cfg+                mod mod_loc exports tyCons binds+  | let passes = ticks_passes cfg+  , not (null passes)+  , Just orig_file <- ml_hs_file mod_loc = do++     let  orig_file2 = guessSourceFile binds orig_file++          tickPass tickish (binds,st) =+            let env = TTE+                      { fileName     = mkFastString orig_file2+                      , declPath     = []+                      , tte_countEntries = ticks_countEntries cfg+                      , exports      = exports+                      , inlines      = emptyVarSet+                      , inScope      = emptyVarSet+                      , blackList    = Set.fromList $+                                       mapMaybe (\tyCon -> case getSrcSpan (tyConName tyCon) of+                                                             RealSrcSpan l _ -> Just l+                                                             UnhelpfulSpan _ -> Nothing)+                                                tyCons+                      , density      = mkDensity tickish $ ticks_profAuto cfg+                      , this_mod     = mod+                      , tickishType  = tickish+                      , recSelBinds  = emptyVarEnv+                      }+                (binds',_,st') = unTM (addTickLHsBinds binds) env st+            in (binds', st')++          (binds1,st) = foldr tickPass (binds, initTTState) passes++          extendedMixEntries = ticks st++     putDumpFileMaybe logger Opt_D_dump_ticked "HPC" FormatHaskell+       (pprLHsBinds binds1)++     return (binds1, Just (orig_file2, extendedMixEntries))++  | otherwise = return (binds, Nothing)++guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath+guessSourceFile binds orig_file =+     -- Try look for a file generated from a .hsc file to a+     -- .hs file, by peeking ahead.+     let top_pos = catMaybes $ foldr (\ (L pos _) rest ->+                               srcSpanFileName_maybe (locA pos) : rest) [] binds+     in+     case top_pos of+        (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name+                      -> unpackFS file_name+        _ -> orig_file+++-- -----------------------------------------------------------------------------+-- TickDensity++-- | Where to insert ticks+data TickDensity+  = TickForCoverage       -- ^ for Hpc+  | TickForBreakPoints    -- ^ for GHCi+  | TickAllFunctions      -- ^ for -prof-auto-all+  | TickTopFunctions      -- ^ for -prof-auto-top+  | TickExportedFunctions -- ^ for -prof-auto-exported+  | TickCallSites         -- ^ for stack tracing+  deriving Eq++mkDensity :: TickishType -> ProfAuto -> TickDensity+mkDensity tickish pa = case tickish of+  HpcTicks             -> TickForCoverage+  SourceNotes          -> TickForCoverage+  Breakpoints          -> TickForBreakPoints+  ProfNotes ->+    case pa of+      ProfAutoAll      -> TickAllFunctions+      ProfAutoTop      -> TickTopFunctions+      ProfAutoExports  -> TickExportedFunctions+      ProfAutoCalls    -> TickCallSites+      _other           -> panic "mkDensity"++-- | Decide whether to add a tick to a binding or not.+shouldTickBind  :: TickDensity+                -> Bool         -- ^ top level?+                -> Bool         -- ^ exported?+                -> Bool         -- ^ simple pat bind?+                -> Bool         -- ^ INLINE pragma?+                -> Bool++shouldTickBind density top_lev exported _simple_pat inline+ = case density of+      TickForBreakPoints    -> False+        -- we never add breakpoints to simple pattern bindings+        -- (there's always a tick on the rhs anyway).+      TickAllFunctions      -> not inline+      TickTopFunctions      -> top_lev && not inline+      TickExportedFunctions -> exported && not inline+      TickForCoverage       -> True+      TickCallSites         -> False++shouldTickPatBind :: TickDensity -> Bool -> Bool+shouldTickPatBind density top_lev+  = case density of+      TickForBreakPoints    -> False+      TickAllFunctions      -> True+      TickTopFunctions      -> top_lev+      TickExportedFunctions -> False+      TickForCoverage       -> False+      TickCallSites         -> False++-- Strip ticks HsExpr++-- | Strip CoreTicks from an HsExpr+stripTicksTopHsExpr :: HsExpr GhcTc -> ([CoreTickish], HsExpr GhcTc)+stripTicksTopHsExpr (XExpr (HsTick t e)) = let (ts, body) = stripTicksTopHsExpr (unLoc e)+                                            in (t:ts, body)+stripTicksTopHsExpr e = ([], e)++-- -----------------------------------------------------------------------------+-- Adding ticks to bindings++addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)+addTickLHsBinds = mapM addTickLHsBind++addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)+addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds+                                                 , abs_exports = abs_exports+                                                 }))) =+  withEnv (add_rec_sels . add_inlines . add_exports) $ do+      binds' <- addTickLHsBinds binds+      return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' }+  where+   -- in AbsBinds, the Id on each binding is not the actual top-level+   -- Id that we are defining, they are related by the abs_exports+   -- field of AbsBinds.  So if we're doing TickExportedFunctions we need+   -- to add the local Ids to the set of exported Names so that we know to+   -- tick the right bindings.+   add_exports env =+     env{ exports = exports env `extendNameSetList`+                      [ idName mid+                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports+                      , idName pid `elemNameSet` (exports env) ] }++   -- See Note [inline sccs]+   add_inlines env =+     env{ inlines = inlines env `extendVarSetList`+                      [ mid+                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports+                      , isInlinePragma (idInlinePragma pid) ] }++   add_rec_sels env =+     env{ recSelBinds = recSelBinds env `extendVarEnvList`+                          [ (abe_mono, abe_poly)+                          | ABE{ abe_poly, abe_mono } <- abs_exports+                          , RecSelId{} <- [idDetails abe_poly] ] }++addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches }))) = do+  let name = getOccString id+  decl_path <- getPathEntry+  density <- getDensity++  inline_ids <- liftM inlines getEnv+  -- See Note [inline sccs]+  let inline   = isInlinePragma (idInlinePragma id)+                 || id `elemVarSet` inline_ids++  -- See Note [inline sccs]+  tickish <- tickishType `liftM` getEnv+  case tickish of { ProfNotes | inline -> return (L pos funBind); _ -> do++  -- See Note [Record-selector ticks]+  selTick <- recSelTick id+  case selTick of { Just tick -> tick_rec_sel tick; _ -> do++  (fvs, mg) <-+        getFreeVars $+        addPathEntry name $+        addTickMatchGroup False matches++  blackListed <- isBlackListed (locA pos)+  exported_names <- liftM exports getEnv++  -- We don't want to generate code for blacklisted positions+  -- We don't want redundant ticks on simple pattern bindings+  -- We don't want to tick non-exported bindings in TickExportedFunctions+  let simple = matchGroupArity matches == 0+                  -- A binding is a "simple pattern binding" if it is a+                  -- funbind with zero patterns+      toplev = null decl_path+      exported = idName id `elemNameSet` exported_names++  tick <- if not blackListed &&+               shouldTickBind density toplev exported simple inline+             then+                bindTick density name (locA pos) fvs+             else+                return Nothing++  let mbCons = maybe Prelude.id (:)+  return $ L pos $ funBind { fun_matches = mg+                           , fun_ext = second (tick `mbCons`) (fun_ext funBind) }+  } }+  where+    -- See Note [Record-selector ticks]+    tick_rec_sel tick =+      pure $ L pos $ funBind { fun_ext = second (tick :) (fun_ext funBind) }+++-- Note [Record-selector ticks]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Users expect (see #17834) that accessing a record field by its name using+-- NamedFieldPuns or RecordWildCards will mark it as covered. This is very+-- reasonable, because otherwise the use of those two language features will+-- produce unnecessary noise in coverage reports, distracting from real+-- coverage problems.+--+-- Because of that, GHC chooses to treat record selectors specially for+-- coverage purposes to improve the developer experience.+--+-- This is done by keeping track of which 'Id's are effectively bound to+-- record fields (using NamedFieldPuns or RecordWildCards) in 'TickTransEnv's+-- 'recSelBinds', and making 'HsVar's corresponding to those fields tick the+-- appropriate box when executed.+--+-- To enable that, we also treat 'FunBind's for record selector functions+-- specially. We only create a TopLevelBox for the record selector function,+-- skipping the ExpBox that'd normally be created. This simplifies the re-use+-- of ticks for the same record selector, and is done by not recursing into+-- the fun_matches match group for record selector functions.+--+-- This scheme could be extended further in the future, making coverage for+-- constructor fields (named or even positional) mean that the field was+-- accessed at run-time. For the time being, we only cover NamedFieldPuns and+-- RecordWildCards binds to cover most practical use-cases while keeping it+-- simple.++-- TODO: Revisit this+addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs+                                    , pat_rhs = rhs+                                    , pat_ext = (grhs_ty, initial_ticks)}))) = do++  let simplePatId = isSimplePat lhs++  -- TODO: better name for rhs's for non-simple patterns?+  let name = maybe "(...)" getOccString simplePatId++  (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False False rhs+  let pat' = pat { pat_rhs = rhs'}++  -- Should create ticks here?+  density <- getDensity+  decl_path <- getPathEntry+  let top_lev = null decl_path+  if not (shouldTickPatBind density top_lev)+    then return (L pos pat')+    else do++    -- Allocate the ticks+    rhs_tick <- bindTick density name (locA pos) fvs++    let mbCons = maybe id (:)+        (initial_rhs_ticks, initial_patvar_tickss) = initial_ticks+        rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks++    patvar_tickss <- case simplePatId of+      Just{} -> return initial_patvar_tickss+      Nothing -> do+        let patvars = map getOccString (collectPatBinders CollNoDictBinders lhs)+        patvar_ticks <- mapM (\v -> bindTick density v (locA pos) fvs) patvars+        return+          (zipWith mbCons patvar_ticks+                          (initial_patvar_tickss ++ repeat []))++    return $ L pos $ pat' { pat_ext = (grhs_ty, (rhs_ticks, patvar_tickss)) }++-- Only internal stuff, not from source, uses VarBind, so we ignore it.+addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind+addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind++bindTick+  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish)+bindTick density name pos fvs = do+  decl_path <- getPathEntry+  let+      toplev        = null decl_path+      count_entries = toplev || density == TickAllFunctions+      top_only      = density /= TickAllFunctions+      box_label     = if toplev then TopLevelBox [name]+                                else LocalBox (decl_path ++ [name])+  --+  allocATickBox box_label count_entries top_only pos fvs+++-- Note [inline sccs]+-- ~~~~~~~~~~~~~~~~~~+-- The reason not to add ticks to INLINE functions is that this is+-- sometimes handy for avoiding adding a tick to a particular function+-- (see #6131)+--+-- So for now we do not add any ticks to INLINE functions at all.+--+-- We used to use isAnyInlinePragma to figure out whether to avoid adding+-- ticks for this purpose. However, #12962 indicates that this contradicts+-- the documentation on profiling (which only mentions INLINE pragmas).+-- So now we're more careful about what we avoid adding ticks to.++-- -----------------------------------------------------------------------------+-- Decorate an LHsExpr with ticks++-- selectively add ticks to interesting expressions+addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickLHsExpr e@(L pos e0) = do+  d <- getDensity+  case d of+    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it+    TickForCoverage    | XExpr (ExpandedThingTc OrigStmt{} _) <- e0 -- expansion ticks are handled separately+                       -> dont_tick_it+                       | otherwise -> tick_it+    TickCallSites      | isCallSite e0      -> tick_it+    _other             -> dont_tick_it+ where+   tick_it      = allocTickBox (ExpBox False) False False (locA pos)+                  $ addTickHsExpr e0+   dont_tick_it = addTickLHsExprNever e++-- Add a tick to an expression which is the RHS of an equation or a binding.+-- We always consider these to be breakpoints, unless the expression is a 'let'+-- (because the body will definitely have a tick somewhere).  ToDo: perhaps+-- we should treat 'case' and 'if' the same way?+addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickLHsExprRHS e@(L pos e0) = do+  d <- getDensity+  case d of+     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it+                        | otherwise     -> tick_it+     TickForCoverage -> tick_it+     TickCallSites   | isCallSite e0 -> tick_it+     _other          -> dont_tick_it+ where+   tick_it      = allocTickBox (ExpBox False) False False (locA pos)+                  $ addTickHsExpr e0+   dont_tick_it = addTickLHsExprNever e++-- The inner expression of an evaluation context:+--    let binds in [], ( [] )+-- we never tick these if we're doing HPC, but otherwise+-- we treat it like an ordinary expression.+addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickLHsExprEvalInner e = do+   d <- getDensity+   case d of+     TickForCoverage -> addTickLHsExprNever e+     _otherwise      -> addTickLHsExpr e++-- | A let body is treated differently from addTickLHsExprEvalInner+-- above with TickForBreakPoints, because for breakpoints we always+-- want to tick the body, even if it is not a redex.  See test+-- break012.  This gives the user the opportunity to inspect the+-- values of the let-bound variables.+addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickLHsExprLetBody e@(L pos e0) = do+  d <- getDensity+  case d of+     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it+                        | otherwise     -> tick_it+     _other -> addTickLHsExprEvalInner e+ where+   tick_it      = allocTickBox (ExpBox False) False False (locA pos)+                  -- don't allow duplicates of this forced bp+                  $ withBlackListed (locA pos)+                  $ addTickHsExpr e0+   dont_tick_it = addTickLHsExprNever e++-- version of addTick that does not actually add a tick,+-- because the scope of this tick is completely subsumed by+-- another.+addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickLHsExprNever (L pos e0) = do+    e1 <- addTickHsExpr e0+    return $ L pos e1++-- General heuristic: expressions which are calls (do not denote+-- values) are good break points.+isGoodBreakExpr :: HsExpr GhcTc -> Bool+isGoodBreakExpr (XExpr (ExpandedThingTc (OrigStmt{}) _)) = False+isGoodBreakExpr e = isCallSite e++isCallSite :: HsExpr GhcTc -> Bool+isCallSite HsApp{}     = True+isCallSite HsAppType{} = True+isCallSite HsCase{}    = True+isCallSite (XExpr (ExpandedThingTc _ e))+  = isCallSite e++-- NB: OpApp, SectionL, SectionR are all expanded out+isCallSite _           = False++addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickLHsExprOptAlt oneOfMany e@(L pos e0)+  = ifDensity TickForCoverage+        (allocTickBox (ExpBox oneOfMany) False False (locA pos)+                           $ addTickHsExpr e0)+        (addTickLHsExpr e)++addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addBinTickLHsExpr boxLabel e@(L pos e0)+  = ifDensity TickForCoverage+        (allocBinTickBox boxLabel (locA pos) $ addTickHsExpr e0)+        (addTickLHsExpr e)+++-- -----------------------------------------------------------------------------+-- Decorate the body of an HsExpr with ticks.+-- (Whether to put a tick around the whole expression was already decided,+-- in the addTickLHsExpr family of functions.)++addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)+-- See Note [Record-selector ticks]+addTickHsExpr e@(HsVar _ (L _ id)) =+    freeVar id >> recSelTick id >>= pure . maybe e wrap+  where wrap tick = XExpr . HsTick tick . noLocA $ e+addTickHsExpr e@(HsIPVar {})            = return e+addTickHsExpr e@(HsOverLit {})          = return e+addTickHsExpr e@(HsOverLabel{})         = return e+addTickHsExpr e@(HsLit {})              = return e+addTickHsExpr e@(HsEmbTy {})            = return e+addTickHsExpr e@(HsHole {})             = return e+addTickHsExpr e@(HsQual {})             = return e+addTickHsExpr e@(HsForAll {})           = return e+addTickHsExpr e@(HsFunArr {})           = return e+addTickHsExpr (HsLam x v mg)            = liftM (HsLam x v)+                                                (addTickMatchGroup True mg)+addTickHsExpr (HsApp x e1 e2)          = liftM2 (HsApp x) (addTickLHsExprNever e1)+                                                          (addTickLHsExpr      e2)+addTickHsExpr (HsAppType x e ty) = do+        e' <- addTickLHsExprNever e+        return (HsAppType x e' ty)+addTickHsExpr (OpApp fix e1 e2 e3) =+        liftM4 OpApp+                (return fix)+                (addTickLHsExpr e1)+                (addTickLHsExprNever e2)+                (addTickLHsExpr e3)+addTickHsExpr (NegApp x e neg) =+        liftM2 (NegApp x)+                (addTickLHsExpr e)+                (addTickSyntaxExpr hpcSrcSpan neg)+addTickHsExpr (HsPar x e) = do+        e' <- addTickLHsExprEvalInner e+        return (HsPar x e')+addTickHsExpr (SectionL x e1 e2) =+        liftM2 (SectionL x)+                (addTickLHsExpr e1)+                (addTickLHsExprNever e2)+addTickHsExpr (SectionR x e1 e2) =+        liftM2 (SectionR x)+                (addTickLHsExprNever e1)+                (addTickLHsExpr e2)+addTickHsExpr (ExplicitTuple x es boxity) =+        liftM2 (ExplicitTuple x)+                (mapM addTickTupArg es)+                (return boxity)+addTickHsExpr (ExplicitSum ty tag arity e) = do+        e' <- addTickLHsExpr e+        return (ExplicitSum ty tag arity e')+addTickHsExpr (HsCase x e mgs) =+        liftM2 (HsCase x)+                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily+                                   -- be evaluated.+                (addTickMatchGroup False mgs)++addTickHsExpr (HsIf x e1 e2 e3) =+        liftM3 (HsIf x)+                (addBinTickLHsExpr (BinBox CondBinBox) e1)+                (addTickLHsExprOptAlt True e2)+                (addTickLHsExprOptAlt True e3)+addTickHsExpr (HsMultiIf ty alts)+  = do { let isOneOfMany = case alts of { (_ :| []) -> False; _ -> True; }+       ; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False False) alts+       ; return $ HsMultiIf ty alts' }+addTickHsExpr (HsLet x binds e) =+        bindLocals binds $ do+          binds' <- addTickHsLocalBinds binds -- to think about: !patterns.+          e' <- addTickLHsExprLetBody e+          return (HsLet x binds' e')+addTickHsExpr (ExplicitList ty es)+  = liftM2 ExplicitList (return ty) (mapM (addTickLHsExpr) es)++addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e++addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })+  = do { rec_binds' <- addTickHsRecordBinds rec_binds+       ; return (expr { rcon_flds = rec_binds' }) }++addTickHsExpr expr@(RecordUpd { rupd_expr = e+                              , rupd_flds = upd@(RegularRecUpdFields { recUpdFields = flds }) })+  = do { e' <- addTickLHsExpr e+       ; flds' <- mapM addTickHsRecField flds+       ; return (expr { rupd_expr = e', rupd_flds = upd { recUpdFields = flds' } }) }+addTickHsExpr expr@(RecordUpd { rupd_expr = e+                              , rupd_flds = upd@(OverloadedRecUpdFields { olRecUpdFields = flds } ) })+  = do { e' <- addTickLHsExpr e+       ; flds' <- mapM addTickHsRecField flds+       ; return (expr { rupd_expr = e', rupd_flds = upd { olRecUpdFields = flds' } }) }++addTickHsExpr (ExprWithTySig x e ty) =+        liftM3 ExprWithTySig+                (return x)+                (addTickLHsExprNever e) -- No need to tick the inner expression+                                        -- for expressions with signatures+                (return ty)+addTickHsExpr (ArithSeq ty wit arith_seq) =+        liftM3 ArithSeq+                (return ty)+                (addTickWit wit)+                (addTickArithSeqInfo arith_seq)+             where addTickWit Nothing = return Nothing+                   addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl+                                             return (Just fl')++addTickHsExpr (HsPragE x p e) =+        liftM (HsPragE x p) (addTickLHsExpr e)+addTickHsExpr e@(HsTypedBracket {})  = return e+addTickHsExpr e@(HsUntypedBracket{}) = return e+addTickHsExpr e@(HsTypedSplice{})    = return e+addTickHsExpr e@(HsUntypedSplice{})  = return e+addTickHsExpr e@(HsGetField {})      = return e+addTickHsExpr e@(HsProjection {})    = return e+addTickHsExpr (HsProc x pat cmdtop) =+      bindLocals pat $+        liftM2 (HsProc x)+                (addTickLPat pat)+                (traverse (addTickHsCmdTop) cmdtop)+addTickHsExpr (XExpr (WrapExpr w e)) =+        liftM (XExpr . WrapExpr w) $+              (addTickHsExpr e)        -- Explicitly no tick on inside+addTickHsExpr (XExpr (ExpandedThingTc o e)) = addTickHsExpanded o e++addTickHsExpr e@(XExpr (ConLikeTc {})) = return e+  -- We used to do a freeVar on a pat-syn builder, but actually+  -- such builders are never in the inScope env, which+  -- doesn't include top level bindings++-- We might encounter existing ticks (multiple Coverage passes)+addTickHsExpr (XExpr (HsTick t e)) =+        liftM (XExpr . HsTick t) (addTickLHsExprNever e)+addTickHsExpr (XExpr (HsBinTick t0 t1 e)) =+        liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e)++addTickHsExpr e@(XExpr (HsRecSelTc (FieldOcc _ id)))   = do freeVar (unLoc id); return e++addTickHsExpr (HsDo srcloc cxt (L l stmts))+  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())+       ; return (HsDo srcloc cxt (L l stmts')) }+  where+        forQual = case cxt of+                    ListComp -> Just $ BinBox QualBinBox+                    _        -> Nothing++addTickHsExpanded :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc)+addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ case o of+  -- We always want statements to get a tick, so we can step over each one.+  -- To avoid duplicates we blacklist SrcSpans we already inserted here.+  OrigStmt (L pos _) -> do_tick_black pos+  _                  -> skip+  where+    skip = addTickHsExpr e+    do_tick_black pos = do+      d <- getDensity+      case d of+         TickForCoverage    -> tick_it_black pos+         TickForBreakPoints -> tick_it_black pos+         _                  -> skip+    tick_it_black pos =+      unLoc <$> allocTickBox (ExpBox False) False False (locA pos)+                             (withBlackListed (locA pos) $+                               addTickHsExpr e)++addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)+addTickTupArg (Present x e)  = do { e' <- addTickLHsExpr e+                                  ; return (Present x e') }+addTickTupArg (Missing ty) = return (Missing ty)+++addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)+                  -> TM (MatchGroup GhcTc (LHsExpr GhcTc))+addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches, mg_ext = ctxt }) = do+  let isOneOfMany = matchesOneOfMany matches+      isDoExp     = isDoExpansionGenerated $ mg_origin ctxt+  matches' <- mapM (traverse (addTickMatch isOneOfMany is_lam isDoExp)) matches+  return $ mg { mg_alts = L l matches' }++addTickMatch :: Bool -> Bool -> Bool {-Is this Do Expansion-} ->  Match GhcTc (LHsExpr GhcTc)+             -> TM (Match GhcTc (LHsExpr GhcTc))+addTickMatch isOneOfMany isLambda isDoExp match@(Match { m_pats = L _ pats+                                                       , m_grhss = gRHSs }) =+  bindLocals pats $ do+    gRHSs' <- addTickGRHSs isOneOfMany isLambda isDoExp gRHSs+    return $ match { m_grhss = gRHSs' }++addTickGRHSs :: Bool -> Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)+             -> TM (GRHSs GhcTc (LHsExpr GhcTc))+addTickGRHSs isOneOfMany isLambda isDoExp (GRHSs x guarded local_binds) =+  bindLocals local_binds $ do+    local_binds' <- addTickHsLocalBinds local_binds+    guarded' <- mapM (traverse (addTickGRHS isOneOfMany isLambda isDoExp)) guarded+    return $ GRHSs x guarded' local_binds'++addTickGRHS :: Bool -> Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)+            -> TM (GRHS GhcTc (LHsExpr GhcTc))+addTickGRHS isOneOfMany isLambda isDoExp (GRHS x stmts expr) = do+  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts+                        (addTickGRHSBody isOneOfMany isLambda isDoExp expr)+  return $ GRHS x stmts' expr'++addTickGRHSBody :: Bool -> Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickGRHSBody isOneOfMany isLambda isDoExp expr@(L pos e0) = do+  d <- getDensity+  case d of+    TickForBreakPoints+      | isDoExp       -- ticks for do-expansions are handled by `addTickHsExpanded`+      -> addTickLHsExprNever expr+      | otherwise+      -> addTickLHsExprRHS expr+    TickForCoverage+      | isDoExp       -- ticks for do-expansions are handled by `addTickHsExpanded`+      -> addTickLHsExprNever expr+      | otherwise+      -> addTickLHsExprOptAlt isOneOfMany expr+    TickAllFunctions | isLambda ->+       addPathEntry "\\" $+         allocTickBox (ExpBox False) True{-count-} False{-not top-} (locA pos) $+           addTickHsExpr e0+    _otherwise ->+       addTickLHsExprRHS expr++addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc]+              -> TM [ExprLStmt GhcTc]+addTickLStmts isGuard stmts = do+  (stmts, _) <- addTickLStmts' isGuard stmts (return ())+  return stmts++addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a+               -> TM ([ExprLStmt GhcTc], a)+addTickLStmts' isGuard lstmts res+  = bindLocals lstmts $+    do { lstmts' <- mapM (traverse (addTickStmt isGuard)) lstmts+       ; a <- res+       ; return (lstmts', a) }++addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)+            -> TM (Stmt GhcTc (LHsExpr GhcTc))+addTickStmt _isGuard (LastStmt x e noret ret) =+        liftM3 (LastStmt x)+                (addTickLHsExpr e)+                (pure noret)+                (addTickSyntaxExpr hpcSrcSpan ret)+addTickStmt _isGuard (BindStmt xbs pat e) =+      bindLocals pat $+        liftM4 (\b f -> BindStmt $ XBindStmtTc+                    { xbstc_bindOp = b+                    , xbstc_boundResultType = xbstc_boundResultType xbs+                    , xbstc_boundResultMult = xbstc_boundResultMult xbs+                    , xbstc_failOp = f+                    })+                (addTickSyntaxExpr hpcSrcSpan (xbstc_bindOp xbs))+                (mapM (addTickSyntaxExpr hpcSrcSpan) (xbstc_failOp xbs))+                (addTickLPat pat)+                (addTickLHsExprRHS e)+addTickStmt isGuard (BodyStmt x e bind' guard') =+        liftM3 (BodyStmt x)+                (addTick isGuard e)+                (addTickSyntaxExpr hpcSrcSpan bind')+                (addTickSyntaxExpr hpcSrcSpan guard')+addTickStmt _isGuard (LetStmt x binds) =+        liftM (LetStmt x)+                (addTickHsLocalBinds binds)+addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) =+    liftM3 (ParStmt x)+        (mapM (addTickStmtAndBinders isGuard) pairs)+        (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) mzipExpr))+        (addTickSyntaxExpr hpcSrcSpan bindExpr)++addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts+                                    , trS_by = by, trS_using = using+                                    , trS_ret = returnExpr, trS_bind = bindExpr+                                    , trS_fmap = liftMExpr }) = do+    t_s <- addTickLStmts isGuard stmts+    t_y <- traverse  addTickLHsExprRHS by+    t_u <- addTickLHsExprRHS using+    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr+    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr+    t_m <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) liftMExpr))+    return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u+                  , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }++addTickStmt isGuard stmt@(RecStmt {})+  = do { stmts' <- addTickLStmts isGuard (unLoc $ recS_stmts stmt)+       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)+       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)+       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)+       ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'+                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }++addTickStmt isGuard (XStmtLR (ApplicativeStmt body_ty args mb_join)) = do+    args' <- mapM (addTickApplicativeArg isGuard) args+    return (XStmtLR (ApplicativeStmt body_ty args' mb_join))++addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e+                  | otherwise          = addTickLHsExprRHS e++addTickApplicativeArg+  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)+  -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)+addTickApplicativeArg isGuard (op, arg) =+  liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)+ where+  addTickArg (ApplicativeArgOne m_fail pat expr isBody) =+    bindLocals pat $+      ApplicativeArgOne+        <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail+        <*> addTickLPat pat+        <*> addTickLHsExpr expr+        <*> pure isBody+  addTickArg (ApplicativeArgMany x stmts ret pat ctxt) =+    bindLocals pat $+      ApplicativeArgMany x+        <$> addTickLStmts isGuard stmts+        <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret))+        <*> addTickLPat pat+        <*> pure ctxt++addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc+                      -> TM (ParStmtBlock GhcTc GhcTc)+addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =+    liftM3 (ParStmtBlock x)+        (addTickLStmts isGuard stmts)+        (return ids)+        (addTickSyntaxExpr hpcSrcSpan returnExpr)++addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)+addTickHsLocalBinds (HsValBinds x binds) =+        liftM (HsValBinds x)+                (addTickHsValBinds binds)+addTickHsLocalBinds (HsIPBinds x binds)  =+        liftM (HsIPBinds x)+                (addTickHsIPBinds binds)+addTickHsLocalBinds (EmptyLocalBinds x)  = return (EmptyLocalBinds x)++addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)+                  -> TM (HsValBindsLR GhcTc (GhcPass b))+addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do+        b <- liftM2 NValBinds+                (mapM (\ (rec,binds') ->+                                liftM2 (,)+                                        (return rec)+                                        (addTickLHsBinds binds'))+                        binds)+                (return sigs)+        return $ XValBindsLR b+addTickHsValBinds _ = panic "addTickHsValBinds"++addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)+addTickHsIPBinds (IPBinds dictbinds ipbinds) =+        liftM2 IPBinds+                (return dictbinds)+                (mapM (traverse (addTickIPBind)) ipbinds)++addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)+addTickIPBind (IPBind x nm e) =+        liftM (IPBind x nm)+               (addTickLHsExpr e)++-- There is no location here, so we might need to use a context location??+addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)+addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do+        x' <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan pos) x))+        return $ syn { syn_expr = x' }+addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc++-- we do not walk into patterns.+addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)+addTickLPat pat = return pat++addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)+addTickHsCmdTop (HsCmdTop x cmd) =+        liftM2 HsCmdTop+                (return x)+                (addTickLHsCmd cmd)++addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc)+addTickLHsCmd (L pos c0) = do+        c1 <- addTickHsCmd c0+        return $ L pos c1++addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)+addTickHsCmd (HsCmdLam x lam_variant mgs) =+        liftM (HsCmdLam x lam_variant) (addTickCmdMatchGroup mgs)+addTickHsCmd (HsCmdApp x c e) =+        liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)+{-+addTickHsCmd (OpApp e1 c2 fix c3) =+        liftM4 OpApp+                (addTickLHsExpr e1)+                (addTickLHsCmd c2)+                (return fix)+                (addTickLHsCmd c3)+-}+addTickHsCmd (HsCmdPar x e) = do+        e' <- addTickLHsCmd e+        return (HsCmdPar x e')+addTickHsCmd (HsCmdCase x e mgs) =+        liftM2 (HsCmdCase x)+                (addTickLHsExpr e)+                (addTickCmdMatchGroup mgs)+addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =+        liftM3 (HsCmdIf x cnd)+                (addBinTickLHsExpr (BinBox CondBinBox) e1)+                (addTickLHsCmd c2)+                (addTickLHsCmd c3)+addTickHsCmd (HsCmdLet x binds c) =+        bindLocals binds $ do+          binds' <- addTickHsLocalBinds binds -- to think about: !patterns.+          c' <- addTickLHsCmd c+          return (HsCmdLet x binds' c')+addTickHsCmd (HsCmdDo srcloc (L l stmts))+  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())+       ; return (HsCmdDo srcloc (L l stmts')) }++addTickHsCmd (HsCmdArrApp  arr_ty e1 e2 ty1 lr) =+        liftM5 HsCmdArrApp+               (return arr_ty)+               (addTickLHsExpr e1)+               (addTickLHsExpr e2)+               (return ty1)+               (return lr)+addTickHsCmd (HsCmdArrForm x e f cmdtop) =+        liftM3 (HsCmdArrForm x)+               (addTickLHsExpr e)+               (return f)+               (mapM (traverse (addTickHsCmdTop)) cmdtop)++addTickHsCmd (XCmd (HsWrap w cmd)) =+  liftM XCmd $+  liftM (HsWrap w) (addTickHsCmd cmd)++-- Others should never happen in a command context.+--addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)++addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)+                     -> TM (MatchGroup GhcTc (LHsCmd GhcTc))+addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do+  matches' <- mapM (traverse addTickCmdMatch) matches+  return $ mg { mg_alts = L l matches' }++addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))+addTickCmdMatch match@(Match { m_pats = L _ pats, m_grhss = gRHSs }) =+  bindLocals pats $ do+    gRHSs' <- addTickCmdGRHSs gRHSs+    return $ match { m_grhss = gRHSs' }++addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))+addTickCmdGRHSs (GRHSs x guarded local_binds) =+  bindLocals local_binds $ do+    local_binds' <- addTickHsLocalBinds local_binds+    guarded' <- mapM (traverse addTickCmdGRHS) guarded+    return $ GRHSs x guarded' local_binds'++addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))+-- The *guards* are *not* Cmds, although the body is+-- C.f. addTickGRHS for the BinBox stuff+addTickCmdGRHS (GRHS x stmts cmd)+  = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)+                                   stmts (addTickLHsCmd cmd)+       ; return $ GRHS x stmts' expr' }++addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]+                 -> TM [LStmt GhcTc (LHsCmd GhcTc)]+addTickLCmdStmts stmts = do+  (stmts, _) <- addTickLCmdStmts' stmts (return ())+  return stmts++addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a+                  -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a)+addTickLCmdStmts' lstmts res+  = bindLocals lstmts $ do+        lstmts' <- mapM (traverse addTickCmdStmt) lstmts+        a <- res+        return (lstmts', a)++addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))+addTickCmdStmt (BindStmt x pat c) =+      bindLocals pat $+        liftM2 (BindStmt x)+                (addTickLPat pat)+                (addTickLHsCmd c)+addTickCmdStmt (LastStmt x c noret ret) =+        liftM3 (LastStmt x)+                (addTickLHsCmd c)+                (pure noret)+                (addTickSyntaxExpr hpcSrcSpan ret)+addTickCmdStmt (BodyStmt x c bind' guard') =+        liftM3 (BodyStmt x)+                (addTickLHsCmd c)+                (addTickSyntaxExpr hpcSrcSpan bind')+                (addTickSyntaxExpr hpcSrcSpan guard')+addTickCmdStmt (LetStmt x binds) =+        liftM (LetStmt x)+                (addTickHsLocalBinds binds)+addTickCmdStmt stmt@(RecStmt {})+  = do { stmts' <- addTickLCmdStmts (unLoc $ recS_stmts stmt)+       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)+       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)+       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)+       ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'+                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }+addTickCmdStmt (XStmtLR (ApplicativeStmt{})) =+  panic "ToDo: addTickCmdStmt ApplicativeLastStmt"++-- Others should never happen in a command context.+addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)++addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)+addTickHsRecordBinds (HsRecFields x fields dd)+  = do  { fields' <- mapM addTickHsRecField fields+        ; return (HsRecFields x fields' dd) }++addTickHsRecField :: LHsFieldBind GhcTc id (LHsExpr GhcTc)+                  -> TM (LHsFieldBind GhcTc id (LHsExpr GhcTc))+addTickHsRecField (L l (HsFieldBind x id expr pun))+        = do { expr' <- addTickLHsExpr expr+             ; return (L l (HsFieldBind x id expr' pun)) }++addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)+addTickArithSeqInfo (From e1) =+        liftM From+                (addTickLHsExpr e1)+addTickArithSeqInfo (FromThen e1 e2) =+        liftM2 FromThen+                (addTickLHsExpr e1)+                (addTickLHsExpr e2)+addTickArithSeqInfo (FromTo e1 e2) =+        liftM2 FromTo+                (addTickLHsExpr e1)+                (addTickLHsExpr e2)+addTickArithSeqInfo (FromThenTo e1 e2 e3) =+        liftM3 FromThenTo+                (addTickLHsExpr e1)+                (addTickLHsExpr e2)+                (addTickLHsExpr e3)++data TickTransState = TT { ticks       :: !(SizedSeq Tick)+                         , ccIndices   :: !CostCentreState+                         , recSelTicks :: !(IdEnv CoreTickish)+                         }++initTTState :: TickTransState+initTTState = TT { ticks        = emptySS+                 , ccIndices    = newCostCentreState+                 , recSelTicks  = emptyVarEnv+                 }++addMixEntry :: Tick -> TM Int+addMixEntry ent = do+  c <- fromIntegral . sizeSS . ticks <$> getState+  setState $ \st ->+    st { ticks = addToSS (ticks st) ent+       }+  return c++addRecSelTick :: Id -> CoreTickish -> TM ()+addRecSelTick sel tick =+  setState $ \s -> s{ recSelTicks = extendVarEnv (recSelTicks s) sel tick }++data TickTransEnv = TTE { fileName     :: FastString+                        , density      :: TickDensity+                        , tte_countEntries :: !Bool+                          -- ^ Whether the number of times functions are+                          -- entered should be counted.+                        , exports      :: NameSet+                        , inlines      :: VarSet+                        , declPath     :: [String]+                        , inScope      :: VarSet+                        , blackList    :: Set RealSrcSpan+                        , this_mod     :: Module+                        , tickishType  :: TickishType+                        , recSelBinds  :: IdEnv Id+                        }++--      deriving Show++-- | Reasons why we need ticks,+data TickishType+  -- | For profiling+  = ProfNotes+  -- | For Haskell Program Coverage+  | HpcTicks+  -- | For ByteCode interpreter break points+  | Breakpoints+  -- | For source notes+  | SourceNotes+  deriving (Eq)++-- | Tickishs that only make sense when their source code location+-- refers to the current file. This might not always be true due to+-- LINE pragmas in the code - which would confuse at least HPC.+tickSameFileOnly :: TickishType -> Bool+tickSameFileOnly HpcTicks = True+tickSameFileOnly _other   = False++type FreeVars = OccEnv Id+noFVs :: FreeVars+noFVs = emptyOccEnv++-- Note [freevars]+-- ~~~~~~~~~~~~~~~+--   For breakpoints we want to collect the free variables of an+--   expression for pinning on the HsTick.  We don't want to collect+--   *all* free variables though: in particular there's no point pinning+--   on free variables that are will otherwise be in scope at the GHCi+--   prompt, which means all top-level bindings.  Unfortunately detecting+--   top-level bindings isn't easy (collectHsBindsBinders on the top-level+--   bindings doesn't do it), so we keep track of a set of "in-scope"+--   variables in addition to the free variables, and the former is used+--   to filter additions to the latter.  This gives us complete control+--   over what free variables we track.++newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }+    deriving (Functor)+        -- a combination of a state monad (TickTransState) and a writer+        -- monad (FreeVars).++instance Applicative TM where+    pure a = TM $ \ _env st -> (a,noFVs,st)+    (<*>) = ap++instance Monad TM where+  (TM m) >>= k = TM $ \ env st ->+                                case m env st of+                                  (r1,fv1,st1) ->+                                     case unTM (k r1) env st1 of+                                       (r2,fv2,st2) ->+                                          (r2, fv1 `plusOccEnv` fv2, st2)+++-- | Get the next HPC cost centre index for a given centre name+getCCIndexM :: FastString -> TM CostCentreIndex+getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $+                                                 ccIndices st+                              in (idx, noFVs, st { ccIndices = is' })++getState :: TM TickTransState+getState = TM $ \ _ st -> (st, noFVs, st)++setState :: (TickTransState -> TickTransState) -> TM ()+setState f = TM $ \ _ st -> ((), noFVs, f st)++getEnv :: TM TickTransEnv+getEnv = TM $ \ env st -> (env, noFVs, st)++withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a+withEnv f (TM m) = TM $ \ env st ->+                                 case m (f env) st of+                                   (a, fvs, st') -> (a, fvs, st')++getDensity :: TM TickDensity+getDensity = TM $ \env st -> (density env, noFVs, st)++ifDensity :: TickDensity -> TM a -> TM a -> TM a+ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el++getFreeVars :: TM a -> TM (FreeVars, a)+getFreeVars (TM m)+  = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')++freeVar :: Id -> TM ()+freeVar id = TM $ \ env st ->+                if id `elemVarSet` inScope env+                   then ((), unitOccEnv (nameOccName (idName id)) id, st)+                   else ((), noFVs, st)++addPathEntry :: String -> TM a -> TM a+addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })++getPathEntry :: TM [String]+getPathEntry = declPath `liftM` getEnv++getFileName :: TM FastString+getFileName = fileName `liftM` getEnv++isGoodSrcSpan' :: SrcSpan -> Bool+isGoodSrcSpan' pos@(RealSrcSpan _ _) = srcSpanStart pos /= srcSpanEnd pos+isGoodSrcSpan' (UnhelpfulSpan _) = False++isGoodTickSrcSpan :: SrcSpan -> TM Bool+isGoodTickSrcSpan pos = do+  file_name <- getFileName+  tickish <- tickishType `liftM` getEnv+  let need_same_file = tickSameFileOnly tickish+      same_file      = Just file_name == srcSpanFileName_maybe pos+  isBL <- isBlackListed pos+  return (isGoodSrcSpan' pos && not isBL && (not need_same_file || same_file))++ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a+ifGoodTickSrcSpan pos then_code else_code = do+  good <- isGoodTickSrcSpan pos+  if good then then_code else else_code++bindLocals :: (CollectBinders bndr, CollectFldBinders bndr) => bndr -> TM a -> TM a+bindLocals from (TM m) = TM $ \env st ->+  case m (with_bnds env) st of+    (r, fv, st') -> (r, fv `delListFromOccEnv` (map (nameOccName . idName) new_bnds), st')+  where with_bnds e = e{ inScope = inScope e `extendVarSetList` new_bnds+                       , recSelBinds = recSelBinds e `plusVarEnv` collectFldBinds from }+        new_bnds = collectBinds from++withBlackListed :: SrcSpan -> TM a -> TM a+withBlackListed (RealSrcSpan ss _) = withEnv (\ env -> env { blackList = Set.insert ss (blackList env) })+withBlackListed (UnhelpfulSpan _)  = id++isBlackListed :: SrcSpan -> TM Bool+isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList env), noFVs, st)+isBlackListed (UnhelpfulSpan _) = return False++-- the tick application inherits the source position of its+-- expression argument to support nested box allocations+allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc)+             -> TM (LHsExpr GhcTc)+allocTickBox boxLabel countEntries topOnly pos m+  = ifGoodTickSrcSpan pos good_case skip_case+  where+    this_loc = L (noAnnSrcSpan pos)+    skip_case = do+      e <- m+      return (this_loc e)+    good_case = do+      (fvs, e) <- getFreeVars m+      env <- getEnv+      tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)+      return (this_loc (XExpr $ HsTick tickish $ this_loc e))++recSelTick :: Id -> TM (Maybe CoreTickish)+recSelTick id = ifDensity TickForCoverage maybe_tick (pure Nothing)+  where+    maybe_tick = getEnv >>=+      maybe (pure Nothing) tick . (`lookupVarEnv` id) . recSelBinds+    tick sel = getState >>=+      maybe (alloc sel) (pure . Just) . (`lookupVarEnv` sel) . recSelTicks+    alloc sel = allocATickBox (box sel) False False (getSrcSpan sel) noFVs+                  >>= traverse (\t -> t <$ addRecSelTick sel t)+    box sel = TopLevelBox [getOccString sel]++-- the tick application inherits the source position of its+-- expression argument to support nested box allocations+allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars+              -> TM (Maybe CoreTickish)+allocATickBox boxLabel countEntries topOnly  pos fvs =+  ifGoodTickSrcSpan pos (do+    let+      mydecl_path = case boxLabel of+                      TopLevelBox x -> x+                      LocalBox xs  -> xs+                      _ -> panic "allocATickBox"+    tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path+    return (Just tickish)+  ) (return Nothing)+++mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]+          -> TM CoreTickish+mkTickish boxLabel countEntries topOnly pos fvs decl_path = do++  let ids = filter (not . mightBeUnliftedType . idType) $ nonDetOccEnvElts fvs+          -- unlifted types cause two problems here:+          --   * we can't bind them  at the GHCi prompt+          --     (bindLocalsAtBreakpoint already filters them out),+          --   * the simplifier might try to substitute a literal for+          --     the Id, and we can't handle that.++      me = Tick+        { tick_loc   = pos+        , tick_path  = decl_path+        , tick_ids   = map (nameOccName.idName) ids+        , tick_label = boxLabel+        }++      cc_name | topOnly   = mkFastString $ head decl_path+              | otherwise = mkFastString $ concat (intersperse "." decl_path)++  env <- getEnv+  case tickishType env of+    HpcTicks -> HpcTick (this_mod env) <$> addMixEntry me++    ProfNotes -> do+      flavour <- mkHpcCCFlavour <$> getCCIndexM cc_name+      let cc = mkUserCC cc_name (this_mod env) pos flavour+          count = countEntries && tte_countEntries env+      return $ ProfNote cc count True{-scopes-}++    Breakpoints -> do+      i <- addMixEntry me+      pure (Breakpoint noExtField (BreakpointId (this_mod env) i) ids)++    SourceNotes | RealSrcSpan pos' _ <- pos ->+      return $ SourceNote pos' $ LexicalFastString cc_name++    _otherwise -> panic "mkTickish: bad source span!"+++allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc)+                -> TM (LHsExpr GhcTc)+allocBinTickBox boxLabel pos m = do+  env <- getEnv+  case tickishType env of+    HpcTicks -> do e <- liftM (L (noAnnSrcSpan pos)) m+                   ifGoodTickSrcSpan pos+                     (mkBinTickBoxHpc boxLabel pos e)+                     (return e)+    _other   -> allocTickBox (ExpBox False) False False pos m++mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc+                -> TM (LHsExpr GhcTc)+mkBinTickBoxHpc boxLabel pos e = do+  env <- getEnv+  binTick <- HsBinTick+    <$> addMixEntry (Tick { tick_loc = pos+                          , tick_path = declPath env+                          , tick_ids = []+                          , tick_label = boxLabel True+                          })+    <*> addMixEntry (Tick { tick_loc = pos+                          , tick_path = declPath env+                          , tick_ids = []+                          , tick_label = boxLabel False+                          })+    <*> pure e+  tick <- HpcTick (this_mod env)+    <$> addMixEntry (Tick { tick_loc = pos+                          , tick_path = declPath env+                          , tick_ids = []+                          , tick_label = ExpBox False+                          })+  let pos' = noAnnSrcSpan pos+  return $ L pos' $ XExpr $ HsTick tick (L pos' (XExpr binTick))++hpcSrcSpan :: SrcSpan+hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")++matchesOneOfMany :: [LMatch GhcTc body] -> Bool+matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1+  where+        matchCount :: LMatch GhcTc body -> Int+        matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ }))+          = length grhss++-- | Convenience class used by 'bindLocals' to collect new bindings from+-- various parts of he AST. Just delegates to+-- 'collect{Pat,Pats,Local,LStmts}Binders' from 'GHC.Hs.Utils' as appropriate.+class CollectBinders a where+  collectBinds :: a -> [Id]++-- | Variant of 'CollectBinders' which collects information on which locals+-- are bound to record fields (currently only via 'RecordWildCards' or+-- 'NamedFieldPuns') to enable better coverage support for record selectors.+--+-- See Note [Record-selector ticks].+class CollectFldBinders a where+  collectFldBinds :: a -> IdEnv Id++instance CollectBinders (LocatedA (Pat GhcTc)) where+  collectBinds = collectPatBinders CollNoDictBinders+instance CollectBinders [LocatedA (Pat GhcTc)] where+  collectBinds = collectPatsBinders CollNoDictBinders+instance CollectBinders (HsLocalBinds GhcTc) where+  collectBinds = collectLocalBinders CollNoDictBinders+instance CollectBinders [LocatedA (Stmt GhcTc (LocatedA (HsExpr GhcTc)))] where+  collectBinds = collectLStmtsBinders CollNoDictBinders+instance CollectBinders [LocatedA (Stmt GhcTc (LocatedA (HsCmd GhcTc)))] where+  collectBinds = collectLStmtsBinders CollNoDictBinders++instance (CollectFldBinders a) => CollectFldBinders [a] where+  collectFldBinds = foldr (flip plusVarEnv . collectFldBinds) emptyVarEnv+instance (CollectFldBinders e) => CollectFldBinders (GenLocated l e) where+  collectFldBinds = collectFldBinds . unLoc+instance CollectFldBinders (Pat GhcTc) where+  collectFldBinds ConPat{ pat_args = RecCon HsRecFields{ rec_flds, rec_dotdot } } =+    collectFldBinds rec_flds `plusVarEnv` plusVarEnvList (zipWith fld_bnds [0..] rec_flds)+    where n_explicit | Just (L _ (RecFieldsDotDot n)) <- rec_dotdot = n+                     | otherwise = length rec_flds+          fld_bnds n (L _ HsFieldBind{ hfbLHS = L _ FieldOcc{ foLabel = L _ sel }+                                     , hfbRHS = L _ (VarPat _ (L _ var))+                                     , hfbPun })+            | hfbPun || n >= n_explicit = unitVarEnv var sel+          fld_bnds _ _ = emptyVarEnv+  collectFldBinds ConPat{ pat_args = PrefixCon pats } = collectFldBinds pats+  collectFldBinds ConPat{ pat_args = InfixCon p1 p2 } = collectFldBinds [p1, p2]+  collectFldBinds (LazyPat _ pat) = collectFldBinds pat+  collectFldBinds (BangPat _ pat) = collectFldBinds pat+  collectFldBinds (AsPat _ _ pat) = collectFldBinds pat+  collectFldBinds (ViewPat _ _ pat) = collectFldBinds pat+  collectFldBinds (ParPat _ pat) = collectFldBinds pat+  collectFldBinds (ListPat _ pats) = collectFldBinds pats+  collectFldBinds (TuplePat _ pats _) = collectFldBinds pats+  collectFldBinds (SumPat _ pats _ _) = collectFldBinds pats+  collectFldBinds (SigPat _ pat _) = collectFldBinds pat+  collectFldBinds (XPat exp) = collectFldBinds exp+  collectFldBinds VarPat{} = emptyVarEnv+  collectFldBinds WildPat{} = emptyVarEnv+  collectFldBinds OrPat{} = emptyVarEnv+  collectFldBinds LitPat{} = emptyVarEnv+  collectFldBinds NPat{} = emptyVarEnv+  collectFldBinds NPlusKPat{} = emptyVarEnv+  collectFldBinds SplicePat{} = emptyVarEnv+  collectFldBinds EmbTyPat{} = emptyVarEnv+  collectFldBinds InvisPat{} = emptyVarEnv+instance (CollectFldBinders r) => CollectFldBinders (HsFieldBind l r) where+  collectFldBinds = collectFldBinds . hfbRHS+instance CollectFldBinders XXPatGhcTc where+  collectFldBinds (CoPat _ pat _) = collectFldBinds pat+  collectFldBinds (ExpansionPat _ pat) = collectFldBinds pat+instance CollectFldBinders (HsLocalBinds GhcTc) where+  collectFldBinds (HsValBinds _ bnds) = collectFldBinds bnds+  collectFldBinds HsIPBinds{} = emptyVarEnv+  collectFldBinds EmptyLocalBinds{} = emptyVarEnv+instance CollectFldBinders (HsValBinds GhcTc) where+  collectFldBinds (ValBinds _ bnds _) = collectFldBinds bnds+  collectFldBinds (XValBindsLR (NValBinds bnds _)) = collectFldBinds (map snd bnds)+instance CollectFldBinders (HsBind GhcTc) where+  collectFldBinds PatBind{ pat_lhs } = collectFldBinds pat_lhs+  collectFldBinds (XHsBindsLR AbsBinds{ abs_exports, abs_binds }) =+    mkVarEnv [ (abe_poly, sel)+             | ABE{ abe_poly, abe_mono } <- abs_exports+             , Just sel <- [lookupVarEnv monos abe_mono] ]+    where monos = collectFldBinds abs_binds+  collectFldBinds VarBind{} = emptyVarEnv+  collectFldBinds FunBind{} = emptyVarEnv+  collectFldBinds PatSynBind{} = emptyVarEnv+instance CollectFldBinders (Stmt GhcTc e) where+  collectFldBinds (BindStmt _ pat _) = collectFldBinds pat+  collectFldBinds (LetStmt _ bnds) = collectFldBinds bnds+  collectFldBinds (ParStmt _ xs _ _) = collectFldBinds [s | ParStmtBlock _ ss _ _ <- toList xs, s <- ss]+  collectFldBinds TransStmt{ trS_stmts } = collectFldBinds trS_stmts+  collectFldBinds RecStmt{ recS_stmts } = collectFldBinds recS_stmts+  collectFldBinds (XStmtLR (ApplicativeStmt _ args _)) = collectFldBinds (map snd args)+  collectFldBinds LastStmt{} = emptyVarEnv+  collectFldBinds BodyStmt{} = emptyVarEnv+instance CollectFldBinders (ApplicativeArg GhcTc) where+  collectFldBinds ApplicativeArgOne{ app_arg_pattern } = collectFldBinds app_arg_pattern+  collectFldBinds ApplicativeArgMany{ bv_pattern } = collectFldBinds bv_pattern
compiler/GHC/Iface/Decl.hs view
@@ -13,7 +13,6 @@ module GHC.Iface.Decl    ( coAxiomToIfaceDecl    , tyThingToIfaceDecl -- Converting things to their Iface equivalents-   , toIfaceBooleanFormula    ) where @@ -32,7 +31,7 @@ import GHC.Core.DataCon import GHC.Core.Type import GHC.Core.Multiplicity-+import GHC.Core.TyCo.Tidy  import GHC.Types.Id import GHC.Types.Var.Env@@ -40,14 +39,11 @@ import GHC.Types.Name import GHC.Types.Basic import GHC.Types.TyThing-import GHC.Types.SrcLoc  import GHC.Utils.Panic.Plain import GHC.Utils.Misc  import GHC.Data.Maybe-import GHC.Data.BooleanFormula- import Data.List ( findIndex, mapAccumL )  {-@@ -120,7 +116,7 @@                   , ifaxbRHS     = toIfaceType rhs                   , ifaxbIncomps = iface_incomps }   where-    iface_incomps = map (expectJust "iface_incomps"+    iface_incomps = map (expectJust                         . flip findIndex lhs_s                         . eqTypes                         . coAxBranchLHS) incomps@@ -209,18 +205,20 @@             ibr  = map (coAxBranchToIfaceBranch tycon lhss) defs             axn  = coAxiomName ax -    ifaceConDecls (NewTyCon { data_con = con })    = IfNewTyCon  (ifaceConDecl con)     ifaceConDecls (DataTyCon { data_cons = cons, is_type_data = type_data })       = IfDataTyCon type_data (map ifaceConDecl cons)-    ifaceConDecls (TupleTyCon { data_con = con })  = IfDataTyCon False [ifaceConDecl con]-    ifaceConDecls (SumTyCon { data_cons = cons })  = IfDataTyCon False (map ifaceConDecl cons)-    ifaceConDecls AbstractTyCon                    = IfAbstractTyCon-        -- The AbstractTyCon case happens when a TyCon has been trimmed-        -- during tidying.-        -- Furthermore, tyThingToIfaceDecl is also used in GHC.Tc.Module-        -- for GHCi, when browsing a module, in which case the-        -- AbstractTyCon and TupleTyCon cases are perfectly sensible.-        -- (Tuple declarations are not serialised into interface files.)+    ifaceConDecls (NewTyCon { data_con = con })        = IfNewTyCon        (ifaceConDecl con)+    ifaceConDecls (UnaryClassTyCon { data_con = con})  = IfDataTyCon False [ifaceConDecl con]+    ifaceConDecls (TupleTyCon { data_con = con })      = IfDataTyCon False [ifaceConDecl con]+    ifaceConDecls (SumTyCon { data_cons = cons })      = IfDataTyCon False (map ifaceConDecl cons)+    ifaceConDecls AbstractTyCon                        = IfAbstractTyCon+        -- The AbstractTyCon case happens when a TyCon has been trimmed during tidying.+        --+        -- NB: TupleTyCon/SumTyCon/UnaryClassTyCon are never serialised into interface files+        --     But tyThingToIfaceDecl is also used in GHC.Tc.Module+        --     for GHCi, when browsing a module, in which case the+        --     AbstractTyCon, TupleTyCon, SumTyCon are perfectly sensible.+        --     (Not sure about UnaryClassTyCon, but easier to treat it uniformly.)      ifaceConDecl data_con         = IfCon   { ifConName    = dataConName data_con,@@ -250,7 +248,7 @@           --     we know that the type variables will line up           -- The latter (b) is important because we pretty-print type constructors           -- by converting to Iface syntax and pretty-printing that-          con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))+          con_env1 = (fst tc_env1, mkVarEnv (zipEqual univ_tvs tc_tyvars))                      -- A bit grimy, perhaps, but it's simple!            (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs@@ -264,7 +262,7 @@           -- tidying produced. Therefore, tidying the user-written tyvars is a           -- simple matter of looking up each variable in the substitution,           -- which tidyTyCoVarOcc accomplishes.-          tidyUserForAllTyBinder :: TidyEnv -> InvisTVBinder -> InvisTVBinder+          tidyUserForAllTyBinder :: TidyEnv -> TyVarBinder -> TyVarBinder           tidyUserForAllTyBinder env (Bndr tv vis) =             Bndr (tidyTyCoVarOcc env tv) vis @@ -287,7 +285,8 @@                 ifClassCtxt   = tidyToIfaceContext env1 sc_theta,                 ifATs    = map toIfaceAT clas_ats,                 ifSigs   = map toIfaceClassOp op_stuff,-                ifMinDef = toIfaceBooleanFormula $ fmap (mkIfLclName . getOccFS) (classMinimalDef clas)+                ifMinDef = toIfaceBooleanFormula (classMinimalDef clas),+                ifUnary  = isUnaryClassTyCon tycon             }      (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)@@ -335,10 +334,3 @@  tidyTyVar :: TidyEnv -> TyVar -> IfLclName tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)--toIfaceBooleanFormula :: BooleanFormula IfLclName -> IfaceBooleanFormula-toIfaceBooleanFormula = \case-    Var nm    -> IfVar    nm-    And bfs   -> IfAnd    (map (toIfaceBooleanFormula . unLoc) bfs)-    Or bfs    -> IfOr     (map (toIfaceBooleanFormula . unLoc) bfs)-    Parens bf -> IfParens (toIfaceBooleanFormula . unLoc $ bf)
compiler/GHC/Iface/Errors/Ppr.hs view
@@ -59,7 +59,7 @@    diagnosticHints = interfaceErrorHints -  diagnosticCode = constructorCode+  diagnosticCode = constructorCode @GHC  interfaceErrorHints :: IfaceMessage -> [GhcHint] interfaceErrorHints = \ case@@ -336,8 +336,9 @@             ]         ]  | otherwise =-  -- ToDo: This will fail to have enough qualification when the package IDs-  -- are the same+  -- Display fully qualified unit names. Otherwise we may not have enough+  -- qualification and the printed names could look exactly the same.+  pprRawUnitIds $   withPprStyle (mkUserStyle alwaysQualify AllTheWay) $     -- we want the Modules below to be qualified with package names,     -- so reset the NamePprCtx setting.@@ -345,7 +346,6 @@          , ppr requested_mod          , text "differs from name found in the interface file"          , ppr read_mod-         , parens (text "if these names look the same, try again with -dppr-debug")          ]  dynamicHashMismatchError :: Module -> ModLocation -> SDoc
+ compiler/GHC/Iface/Flags.hs view
@@ -0,0 +1,194 @@+-- | Datatype definitions for the flag representation stored in interface files+module GHC.Iface.Flags (+     IfaceDynFlags(..)+   , IfaceGeneralFlag(..)+   , IfaceProfAuto(..)+   , IfaceExtension(..)+   , IfaceLanguage(..)+   , IfaceCppOptions(..)+   , pprIfaceDynFlags+   , missingExtraFlagInfo+   ) where++import GHC.Prelude++import GHC.Utils.Outputable+import Control.DeepSeq+import GHC.Utils.Fingerprint+import GHC.Utils.Binary++import GHC.Driver.DynFlags+import GHC.Types.SafeHaskell+import GHC.Core.Opt.CallerCC.Types++import qualified GHC.LanguageExtensions as LangExt++-- The part of DynFlags which recompilation information needs+data IfaceDynFlags = IfaceDynFlags+        { ifaceMainIs :: Maybe (Maybe String)+        , ifaceSafeMode :: IfaceTrustInfo+        , ifaceLang :: Maybe IfaceLanguage+        , ifaceExts :: [IfaceExtension]+        , ifaceCppOptions :: IfaceCppOptions+        , ifaceJsOptions  :: IfaceCppOptions+        , ifaceCmmOptions :: IfaceCppOptions+        , ifacePaths :: [String]+        , ifaceProf  :: Maybe IfaceProfAuto+        , ifaceTicky :: [IfaceGeneralFlag]+        , ifaceCodeGen :: [IfaceGeneralFlag]+        , ifaceFatIface :: Bool+        , ifaceDebugLevel :: Int+        , ifaceCallerCCFilters :: [CallerCcFilter]+        }++pprIfaceDynFlags :: IfaceDynFlags -> SDoc+pprIfaceDynFlags (IfaceDynFlags a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) =+  vcat [ text "main-is:" <+> (ppr $ fmap (fmap (text @SDoc)) a1)+       , text "safe-mode:" <+> ppr a2+       , text "lang:" <+> ppr a3+       , text "exts:" <+> ppr a4+       , text "cpp-options:"+       , nest 2 $ ppr a5+       , text "js-options:"+       , nest 2 $ ppr a6+       , text "cmm-options:"+       , nest 2 $ ppr a7+       , text "paths:" <+> hcat (map text a8)+       , text "prof:"  <+> ppr a9+       , text "ticky:"+       , nest 2 $ vcat (map ppr a10)+       , text "codegen:"+       , nest 2 $ vcat (map ppr a11)+       , text "fat-iface:" <+> ppr a12+       , text "debug-level:" <+> ppr a13+       , text "caller-cc-filters:" <+> ppr a14+       ]++missingExtraFlagInfo :: SDoc+missingExtraFlagInfo = text "flags: no detailed info, recompile with -fwrite-if-self-recomp-flags"+  where+    -- If you modify the name of this flag, you have to modify this string.+    _placeholder = Opt_WriteSelfRecompFlags++instance Binary IfaceDynFlags where+  put_ bh (IfaceDynFlags a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) = do+    put_ bh a1+    put_ bh a2+    put_ bh a3+    put_ bh a4+    put_ bh a5+    put_ bh a6+    put_ bh a7+    put_ bh a8+    put_ bh a9+    put_ bh a10+    put_ bh a11+    put_ bh a12+    put_ bh a13+    put_ bh a14+  get bh = IfaceDynFlags <$> get bh+                         <*> get bh+                         <*> get bh+                         <*> get bh+                         <*> get bh+                         <*> get bh+                         <*> get bh+                         <*> get bh+                         <*> get bh+                         <*> get bh+                         <*> get bh+                         <*> get bh+                         <*> get bh+                         <*> get bh++instance NFData IfaceDynFlags where+  rnf (IfaceDynFlags a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) =+          rnf a1+    `seq` rnf a2+    `seq` rnf a3+    `seq` rnf a4+    `seq` rnf a5+    `seq` rnf a6+    `seq` rnf a7+    `seq` rnf a8+    `seq` rnf a9+    `seq` rnf a10+    `seq` rnf a11+    `seq` rnf a12+    `seq` rnf a13+    `seq` rnf a14++newtype IfaceGeneralFlag = IfaceGeneralFlag GeneralFlag++instance NFData IfaceGeneralFlag where+  rnf (IfaceGeneralFlag !_) = ()++instance Binary IfaceGeneralFlag where+  put_ bh (IfaceGeneralFlag f) = put_ bh (fromEnum f)+  get bh = IfaceGeneralFlag . toEnum <$> get bh++instance Outputable IfaceGeneralFlag where+  ppr (IfaceGeneralFlag f) = text (show f)++newtype IfaceProfAuto = IfaceProfAuto ProfAuto++instance NFData IfaceProfAuto where+  rnf (IfaceProfAuto !_) = ()++instance Binary IfaceProfAuto where+  put_ bh (IfaceProfAuto f) = put_ bh (fromEnum f)+  get bh = IfaceProfAuto . toEnum <$> get bh++instance Outputable IfaceProfAuto where+  ppr (IfaceProfAuto f) = text (show f)+++newtype IfaceExtension = IfaceExtension LangExt.Extension++instance NFData IfaceExtension where+  rnf (IfaceExtension !_) = ()++instance Binary IfaceExtension where+  put_ bh (IfaceExtension f) = put_ bh (fromEnum f)+  get bh = IfaceExtension . toEnum <$> get bh++instance Outputable IfaceExtension where+  ppr (IfaceExtension f) = text (show f)++newtype IfaceLanguage = IfaceLanguage Language++instance NFData IfaceLanguage where+  rnf (IfaceLanguage !_) = ()++instance Binary IfaceLanguage where+  put_ bh (IfaceLanguage f) = put_ bh (fromEnum f)+  get bh = IfaceLanguage . toEnum <$> get bh++instance Outputable IfaceLanguage where+  ppr (IfaceLanguage f) = text (show f)++data IfaceCppOptions = IfaceCppOptions { ifaceCppIncludes :: [FilePath]+                                       , ifaceCppOpts :: [String]+                                       , ifaceCppSig :: ([String], Fingerprint)+                                       }++instance NFData IfaceCppOptions where+  rnf (IfaceCppOptions is os s) = rnf is `seq` rnf os `seq` rnf s++instance Binary IfaceCppOptions where+  put_ bh (IfaceCppOptions is os s) = do+     put_ bh is+     put_ bh os+     put_ bh s+  get bh = IfaceCppOptions <$> get bh <*> get bh <*> get bh++instance Outputable IfaceCppOptions where+  ppr (IfaceCppOptions is os (wos, fp)) =+        vcat [text "includes:"+             , nest 2 $ hcat (map text is)+             , text "opts:"+             , nest 2 $ hcat (map text os)+             , text "signature:"+             , nest 2 $ parens (ppr fp) <+> ppr (map (text @SDoc) wos)++             ]
compiler/GHC/Iface/Recomp/Binary.hs view
@@ -15,6 +15,7 @@ import GHC.Types.Name import GHC.Utils.Panic.Plain import GHC.Iface.Type (putIfaceType)+import System.IO.Unsafe (unsafePerformIO)  fingerprintBinMem :: WriteBinHandle -> IO Fingerprint fingerprintBinMem bh = withBinBuffer bh f@@ -29,8 +30,8 @@ computeFingerprint :: (Binary a)                    => (WriteBinHandle -> Name -> IO ())                    -> a-                   -> IO Fingerprint-computeFingerprint put_nonbinding_name a = do+                   -> Fingerprint+computeFingerprint put_nonbinding_name a = unsafePerformIO $ do     bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block     put_ bh a     fingerprintBinMem bh
+ compiler/GHC/Iface/Recomp/Types.hs view
@@ -0,0 +1,156 @@+module GHC.Iface.Recomp.Types (+  IfaceSelfRecomp(..),+  IfaceDynFlags(..),+  pprIfaceDynFlags,+  missingExtraFlagInfo,+) where++import GHC.Prelude+import GHC.Fingerprint+import GHC.Utils.Outputable+import GHC.Iface.Flags+import GHC.Types.SafeHaskell+import GHC.Unit.Module.Deps+import GHC.Unit.Module++import GHC.Utils.Binary++import Control.DeepSeq++{-+Note [Self recompilation information in interface files]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The flag -fwrite-if-self-recomp controls whether+interface files contain the information necessary to answer the+question:++  Is the interface file up-to-date, relative to:+    * the source file it corresponds to,+    * the flags passed to the GHC invocation to compile it,+    * its dependencies (e.g. imported items, watched files added by addDependentFile, ...)++If there is no self-recompilation information stored, then we always re-generate+the interface file from scratch.++Why? Most packages are only built once either by a distribution or cabal+and then placed into an immutable store, after which we will never ask+this question. Therefore we can derive two benefits from omitting this+information.++* Primary motivation: It vastly reduces the surface area for creating+  non-deterministic interface files. See issue #10424 which motivated a+  proper fix to that issue. Distributions have long contained versions+  of GHC which just have broken self-recompilation checking (in order to+  get deterministic interface files).++* Secondary motivation: This reduces the size of interface files+  slightly.. the `mi_usages` field can be quite big but probably this+  isn't such a great benefit.++* Third motivation: Conceptually clarity about which parts of an+  interface file are used in order to **communicate** with subsequent+  packages about the **interface** for a module. And which parts are+  used to self-communicate during recompilation checking.++The main tracking issue is #22188 but fixes issues such as #10424 in a+proper way.++-}++-- | The information for a module which is only used when deciding whether to recompile+-- itself.+--+-- See Note [Self recompilation information in interface files]+data IfaceSelfRecomp =+    IfaceSelfRecomp { mi_sr_src_hash :: !Fingerprint+                       -- ^ Hash of the .hs source, used for recompilation checking.+                       , mi_sr_usages   :: [Usage]+                       -- ^ Usages; kept sorted so that it's easy to decide+                       -- whether to write a new iface file (changing usages+                       -- doesn't affect the hash of this module)+                       -- NOT STRICT!  we read this field lazily from the interface file+                       -- It is *only* consulted by the recompilation checker++                       , mi_sr_flag_hash :: !(FingerprintWithValue IfaceDynFlags)+                       -- ^ Hash of the important flags used when compiling the module, excluding+                       -- optimisation flags+                       , mi_sr_opt_hash :: !Fingerprint+                       -- ^ Hash of optimisation flags+                       , mi_sr_hpc_hash :: !Fingerprint+                       -- ^ Hash of hpc flags+                       , mi_sr_plugin_hash :: !Fingerprint+                       -- ^ Hash of plugins+                       }+++instance Binary IfaceSelfRecomp where+  put_ bh (IfaceSelfRecomp{mi_sr_src_hash, mi_sr_usages, mi_sr_flag_hash, mi_sr_opt_hash, mi_sr_hpc_hash, mi_sr_plugin_hash}) = do+    put_ bh mi_sr_src_hash+    lazyPut bh mi_sr_usages+    put_ bh mi_sr_flag_hash+    put_ bh mi_sr_opt_hash+    put_ bh mi_sr_hpc_hash+    put_ bh mi_sr_plugin_hash++  get bh = do+    src_hash    <- get bh+    usages      <- lazyGet bh+    flag_hash   <- get bh+    opt_hash    <- get bh+    hpc_hash    <- get bh+    plugin_hash <- get bh+    return $ IfaceSelfRecomp { mi_sr_src_hash = src_hash, mi_sr_usages = usages, mi_sr_flag_hash = flag_hash, mi_sr_opt_hash = opt_hash, mi_sr_hpc_hash = hpc_hash, mi_sr_plugin_hash = plugin_hash }++instance Outputable IfaceSelfRecomp where+  ppr (IfaceSelfRecomp{mi_sr_src_hash, mi_sr_usages, mi_sr_flag_hash, mi_sr_opt_hash, mi_sr_hpc_hash, mi_sr_plugin_hash})+    = vcat [text "Self-Recomp"+            , nest 2 (vcat [ text "src hash:" <+> ppr mi_sr_src_hash+                           , text "flags:" <+> pprFingerprintWithValue missingExtraFlagInfo (fmap pprIfaceDynFlags mi_sr_flag_hash)+                           , text "opt hash:" <+> ppr mi_sr_opt_hash+                           , text "hpc hash:" <+> ppr mi_sr_hpc_hash+                           , text "plugin hash:" <+> ppr mi_sr_plugin_hash+                           , text "usages:" <+> ppr (map pprUsage mi_sr_usages)+                           ])]++instance NFData IfaceSelfRecomp where+  rnf (IfaceSelfRecomp src_hash usages flag_hash opt_hash hpc_hash plugin_hash)+    = rnf src_hash `seq` rnf usages `seq` rnf flag_hash `seq` rnf opt_hash `seq` rnf hpc_hash `seq` rnf plugin_hash `seq` ()++pprFingerprintWithValue :: SDoc -> FingerprintWithValue SDoc -> SDoc+pprFingerprintWithValue missingInfo (FingerprintWithValue fp mflags)+  = vcat $+    [ text "fingerprint:" <+> (ppr fp)+    ]+    ++ case mflags of+        Nothing -> [missingInfo]+        Just doc -> [doc]++pprUsage :: Usage -> SDoc+pprUsage UsagePackageModule{ usg_mod = mod, usg_mod_hash = hash, usg_safe = safe }+  = pprUsageImport mod hash safe+pprUsage UsageHomeModule{ usg_unit_id = unit_id, usg_mod_name = mod_name+                              , usg_mod_hash = hash, usg_safe = safe+                              , usg_exports = exports, usg_entities = entities }+  = pprUsageImport (mkModule unit_id mod_name) hash safe $$+    nest 2 (+        maybe empty (\v -> text "exports: " <> ppr v) exports $$+        vcat [ ppr n <+> ppr v | (n,v) <- entities ]+        )+pprUsage usage@UsageFile{}+  = hsep [text "addDependentFile",+          doubleQuotes (ftext (usg_file_path usage)),+          ppr (usg_file_hash usage)]+pprUsage usage@UsageMergedRequirement{}+  = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]+pprUsage usage@UsageHomeModuleInterface{}+  = hsep [text "implementation", ppr (usg_mod_name usage)+                               , ppr (usg_unit_id usage)+                               , ppr (usg_iface_hash usage)]++pprUsageImport :: Outputable mod => mod -> Fingerprint -> IsSafeImport -> SDoc+pprUsageImport mod hash safe+  = hsep [ text "import", pp_safe, ppr mod+         , ppr hash ]+    where+        pp_safe | safe      = text "safe"+                | otherwise = text " -/ "
compiler/GHC/Iface/Syntax.hs view
@@ -26,7 +26,8 @@         IfaceCompleteMatch(..),         IfaceLFInfo(..), IfaceTopBndrInfo(..),         IfaceImport(..),-        ImpIfaceList(..),+        ifImpModule,+        ImpIfaceList(..), IfaceExport,          -- * Binding names         IfaceTopBndr,@@ -35,10 +36,8 @@         -- Misc         ifaceDeclImplicitBndrs, visibleIfConDecls,         ifaceDeclFingerprints,-        fromIfaceBooleanFormula,         fromIfaceWarnings,         fromIfaceWarningTxt,-         -- Free Names         freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,         freeNamesIfConDecls,@@ -51,7 +50,10 @@  import GHC.Prelude +import GHC.Builtin.Names(mkUnboundName) import GHC.Data.FastString+import GHC.Data.BooleanFormula (pprBooleanFormula, isTrue)+ import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey,                            constraintKindTyConKey ) import GHC.Types.Unique ( hasKey )@@ -62,25 +64,26 @@ import GHC.Types.Cpr import GHC.Core.Class import GHC.Types.FieldLabel-import GHC.Types.Name.Set import GHC.Core.Coercion.Axiom ( BranchIndex ) import GHC.Types.Name+import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Types.CostCentre import GHC.Types.Literal+import GHC.Types.Avail import GHC.Types.ForeignCall import GHC.Types.Annotations( AnnPayload, AnnTarget ) import GHC.Types.Basic+import GHC.Types.Tickish import GHC.Unit.Module import GHC.Unit.Module.Warnings import GHC.Types.SrcLoc import GHC.Types.SourceText-import GHC.Data.BooleanFormula ( BooleanFormula(..), pprBooleanFormula, isTrue ) import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders, visArgTypeLike ) import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag ) import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import GHC.Builtin.Types ( constraintKindTyConName )-import GHC.Stg.InferTags.TagSig+import GHC.Stg.EnforceEpt.TagSig import GHC.Parser.Annotation (noLocA) import GHC.Hs.Extension ( GhcRn ) import GHC.Hs.Doc ( WithHsDocIdentifiers(..) )@@ -92,12 +95,14 @@ import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith,-                       seqList, zipWithEqual )+                       zipWithEqual ) +import Language.Haskell.Syntax.BooleanFormula(BooleanFormula(..))+ import Control.Monad-import System.IO.Unsafe import Control.DeepSeq import Data.Proxy+import qualified Data.Set as Set  infixl 3 &&& @@ -109,13 +114,53 @@ ************************************************************************ -} +type IfaceExport = AvailInfo+ data IfaceImport = IfaceImport ImpDeclSpec ImpIfaceList  data ImpIfaceList   = ImpIfaceAll -- ^ no user import list-  | ImpIfaceExplicit !IfGlobalRdrEnv-  | ImpIfaceEverythingBut !NameSet+  | ImpIfaceExplicit+    { iil_avails :: !DetOrdAvails+    , iil_non_explicit_parents :: ![Name]+    }+  | ImpIfaceEverythingBut ![Name] +-- | Extract the imported module from an IfaceImport+ifImpModule :: IfaceImport -> Module+ifImpModule (IfaceImport declSpec _) = is_mod declSpec++instance Binary IfaceImport where+  put_ bh (IfaceImport declSpec ifaceList) = do+    put_ bh declSpec+    put_ bh ifaceList+  get bh = do+    declSpec <- get bh+    ifaceList <- get bh+    return (IfaceImport declSpec ifaceList)++instance Binary ImpIfaceList where+  put_ bh ImpIfaceAll = putByte bh 0+  put_ bh (ImpIfaceExplicit env implicit_parents) = do+    putByte bh 1+    put_ bh env+    put_ bh implicit_parents+  put_ bh (ImpIfaceEverythingBut ns) = do+    putByte bh 2+    put_ @[Name] bh ns+  get bh = do+    tag <- getByte bh+    case tag of+      0 -> return ImpIfaceAll+      1 -> do+        env <- get bh+        implicit_parents <- get bh+        return $ ImpIfaceExplicit env implicit_parents+      2 -> do+        ns <- get @[Name] bh+        return $ ImpIfaceEverythingBut ns+      _ -> fail $ "instance Binary ImpIfaceList: Invalid tag " ++ show tag+ -- | A binding top-level 'Name' in an interface file (e.g. the name of an -- 'IfaceDecl'). type IfaceTopBndr = Name@@ -210,21 +255,24 @@      ifClassCtxt :: IfaceContext,             -- Super classes      ifATs       :: [IfaceAT],                -- Associated type families      ifSigs      :: [IfaceClassOp],           -- Method signatures-     ifMinDef    :: IfaceBooleanFormula       -- Minimal complete definition+     ifMinDef    :: IfaceBooleanFormula,      -- Minimal complete definition+     ifUnary     :: Bool                      -- This is a unary class+       -- NB: in principle ifUnary is redundant; it can be deduced from+       --     the number and types of class ops.  In practice, in interface+       --     files those types are knot tied, and it's very easy to get a+       --     black hole.  Easiest thing: let the definition module decide if+       --     it is a unary class, and communicate that through IfaceClassBody+       --     See (UCM12) in Note [Unary class magic] in GHC.Core.TyCon     } +-- See also 'BooleanFormula' data IfaceBooleanFormula   = IfVar IfLclName   | IfAnd [IfaceBooleanFormula]   | IfOr [IfaceBooleanFormula]   | IfParens IfaceBooleanFormula+  deriving Eq -fromIfaceBooleanFormula :: IfaceBooleanFormula -> BooleanFormula IfLclName-fromIfaceBooleanFormula = \case-    IfVar nm     -> Var    nm-    IfAnd ibfs   -> And    (map (noLocA . fromIfaceBooleanFormula) ibfs)-    IfOr ibfs    -> Or     (map (noLocA . fromIfaceBooleanFormula) ibfs)-    IfParens ibf -> Parens (noLocA . fromIfaceBooleanFormula $ ibf)  data IfaceTyConParent   = IfNoParent@@ -293,7 +341,7 @@         -- So this guarantee holds for IfaceConDecl, but *not* for DataCon          ifConExTCvs   :: [IfaceBndr],  -- Existential ty/covars-        ifConUserTvBinders :: [IfaceForAllSpecBndr],+        ifConUserTvBinders :: [IfaceForAllBndr],           -- The tyvars, in the order the user wrote them           -- INVARIANT: the set of tyvars in ifConUserTvBinders is exactly the           --            set of tyvars (*not* covars) of ifConExTCvs, unioned@@ -502,6 +550,14 @@             4 -> pure IfLFUnlifted             _ -> panic "Invalid byte" +instance NFData IfaceLFInfo where+  rnf = \case+    IfLFReEntrant arity -> rnf arity+    IfLFThunk updatable mb_fun -> rnf updatable `seq` rnf mb_fun+    IfLFCon con -> rnf con+    IfLFUnknown fun_flag -> rnf fun_flag+    IfLFUnlifted -> ()+ {- Note [Versioning of instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -553,9 +609,7 @@                                         ifSigs      = sigs,                                         ifATs       = ats                                      }})-  = --   (possibly) newtype coercion-    co_occs ++-    --    data constructor (DataCon namespace)+  = --    data constructor (DataCon namespace)     --    data worker (Id namespace)     --    no wrapper (class dictionaries never have a wrapper)     [dc_occ, dcww_occ] ++@@ -568,12 +622,8 @@   where     cls_tc_occ = occName cls_tc_name     n_ctxt = length sc_ctxt-    n_sigs = length sigs-    co_occs | is_newtype = [mkNewTyCoOcc cls_tc_occ]-            | otherwise  = []     dcww_occ = mkDataConWorkerOcc dc_occ     dc_occ = mkClassDataConOcc cls_tc_occ-    is_newtype = n_sigs + n_ctxt == 1 -- Sigh (keep this synced with buildClass)  ifaceDeclImplicitBndrs _ = [] @@ -600,9 +650,7 @@     [ (occ, computeFingerprint' (hash,occ))     | occ <- ifaceDeclImplicitBndrs decl ]   where-     computeFingerprint' =-       unsafeDupablePerformIO-        . computeFingerprint (panic "ifaceDeclFingerprints")+    computeFingerprint' = computeFingerprint (panic "ifaceDeclFingerprints")  fromIfaceWarnings :: IfaceWarnings -> Warnings GhcRn fromIfaceWarnings = \case@@ -653,7 +701,7 @@   = IfaceHpcTick    Module Int               -- from HpcTick x   | IfaceSCC        CostCentre Bool Bool     -- from ProfNote   | IfaceSource  RealSrcSpan FastString      -- from SourceNote-  | IfaceBreakpoint Int [IfaceExpr] Module   -- from Breakpoint+  | IfaceBreakpoint BreakpointId [IfaceExpr] -- from Breakpoint  data IfaceAlt = IfaceAlt IfaceConAlt [IfLclName] IfaceExpr         -- Note: IfLclName, not IfaceBndr (and same with the case binder)@@ -914,15 +962,226 @@ constraintIfaceKind =   IfaceTyConApp (IfaceTyCon constraintKindTyConName (mkIfaceTyConInfo NotPromoted IfaceNormalTyCon)) IA_Nil +{- Note [Print invisible binders in interface declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Starting from GHC 9.8 it is possible to write invisible @-binders+in type-level declarations. That feature introduced several challenges+in interface declaration pretty printing (e.g. using the :info command+inside GHCi) to overcome.++Consider this example with a redundant type variable `a`:++  type Id :: forall a b. b -> b+  type Id x = x++GHC will create system binders for kinds there to meet typechecking+and compilation needs and that will turn that declaration into a less+straightforward form with multiple @-binders:++  type Id :: forall {k} (a :: k) b. b -> b+  type Id @{k} @a @b x = x :: b++This information isn't required for understanding in most cases,+so GHC will hide it unless -fprint-explicit-kinds flag is supplied by the user.+And here is what we get:++  type Id :: forall {k} (a :: k) b. b -> b+  type Id x = x++However, there are several cases involving user-written @-binders+when it is cruicial to show them to provide understanding of what's going on.+First of all it can plainly appear on the right-hand side:++  type T :: forall (a :: Type). Type+  type T @x = Tuple2 x x++Not only that, an invisible binder can be unused by itself, but have an+impact on invisible binder positioning, e.g.:++  type T :: forall (a :: Type) (b :: Type). Type+  type T           @x          @y        = Tuple2 y y++Here `x` is unused, but it is required to display, as `y` corresponds+to `b` in the standalone kind signature.++The last problem is related to non-generative type declarations (type+synonyms and type families) only. It is not possible to partially+apply them, hence it's important to understand what parts of a declaration's+kind are related to the declaration itself. Here is a simple example:++  type T1 :: forall k. k -> Maybe k+  type T1 = Just++  type T2 :: forall k. k -> Maybe k+  type T2 @k = Just++Both these type synonyms have the same kind signature, but they aren't+the same! `T1` can be used in strictly more cases, for example, as+an argument for a higher-order type:++  type F :: (forall k. k -> Maybe k) -> Type++  type R1 = F T1 -- Yes!+  type R2 = F T2 -- No, that will not compile :(++User-written invisible binders and "system" binders introduced by GHC+are indistinguishable at this stage, hence we try to only print+semantically significant binders by default.++An invisible binder is considered significant when it meets at least+one of the following two criteria:+  - It visibly occurs in the declaration's body (See more about that below)+  - It is followed by a significant binder,+    so it affects positioning+For non-generative type declarations (type synonyms and type families),+there is one additional criterion:+  - It is not followed by a visible binder, so it+    affects the arity of a type declaration++The overall solution consists of three functions:+- `iface_decl_non_generative` decides whether the current declaration is+   generative or not++- `iface_decl_mentioned_vars` gives a Set of variables that+  visibly occur in the declaration's body++- `suppressIfaceInvisibles` uses information provided+  by the first two functions to actually filter out insignificant+  @-binders++Here is what we consider "visibly occurs" in general and for+each declaration type:++- Variables that visibly occur in IfaceType are collected by the+  `visibleTypeVarOccurencies` function.++- Variables that visibly occur in IfaceAT are collected by `iface_at_mentioned_vars`+  function. It accounts visible binders for associated data and type+  families and for type families only, it counts invisible binders.+  Associated types can't have definitions, so it's safe to drop all other+  binders.++- None of the type variables in IfaceData declared using GADT syntax doesn't are considered+  as visibe occurrences. This is because each constructor has its own variables, e.g.:++    type D :: forall (a :: Type). Type+    data D @a where+      MkD :: D @b+      -- This is shorthand for:+      -- MkD :: forall b. D @b++- For IfaceData declared using Haskell98 syntax, a variable is considered visible+  if it visibly occurs in at least one argument's type in at least one constructor.++- For IfaceSynonym, a variable is considered visible if it visibly occurs+  in the RHS type.++- For IfaceFamily, a variable is considered visible if i occurs inside+  an injectivity annotation, e.g.++    type family F @a = r | r -> a++- For IfaceClass, a variable is considered visible if it occurs at least+  once inside a functional dependency annotation or in at least one method's+  type signature, or if it visibly occurs in at least one associated type's+  declaration (Visible occurrences in associated types are described above.)++- IfacePatSyn, IfaceId and IfaceAxiom are irrelevant to this problem.+-}++iface_decl_generative :: IfaceDecl -> Bool+iface_decl_generative IfaceSynonym{} = False+iface_decl_generative IfaceFamily{ifFamFlav = rhs}+  | IfaceDataFamilyTyCon <- rhs = True+  | otherwise = False+iface_decl_generative IfaceData{} = True+iface_decl_generative IfaceId{} = True+iface_decl_generative IfaceClass{} = True+iface_decl_generative IfaceAxiom{} = True+iface_decl_generative IfacePatSyn{} = True++iface_at_mentioned_vars :: IfaceAT -> Set.Set IfLclName+iface_at_mentioned_vars (IfaceAT decl _)+  = Set.fromList . map ifTyConBinderName . suppress_vars $ binders+  where+    -- ifBinders is not total, so we assume here that associated types+    -- cannot be IfaceId, IfaceAxiom or IfacePatSyn+    binders = case decl of+      IfaceFamily {ifBinders} -> ifBinders+      IfaceData{ifBinders} -> ifBinders+      IfaceSynonym{ifBinders} -> ifBinders+      IfaceClass{ifBinders} -> ifBinders+      IfaceId{} -> panic "IfaceId shoudn't be an associated type!"+      IfaceAxiom{} -> panic "IfaceAxiom shoudn't be an associated type!"+      IfacePatSyn {} -> panic "IfacePatSyn shoudn't be an associated type!"++    suppress_arity = not (iface_decl_generative decl)++    suppress_vars binders =+      suppressIfaceInvisibles+        -- We need to count trailing invisible binders for type families+        (MkPrintArityInvisibles suppress_arity)+        -- But this setting will simply count all invisible binderss+        (PrintExplicitKinds False)+        -- ...and associated types can't have a RHS+        mempty+        binders binders++-- See Note [Print invisible binders in interface declarations]+-- in particular, the parts about collecting visible occurrences+iface_decl_mentioned_vars :: IfaceDecl -> Set.Set IfLclName+iface_decl_mentioned_vars (IfaceData { ifCons = condecls, ifGadtSyntax = gadt })+  | gadt = mempty+  -- Get visible occurrences in each constructor in each alternative+  | otherwise = Set.unions (map mentioned_con_vars cons)+  where+    mentioned_con_vars = Set.unions . map (visibleTypeVarOccurencies . snd) . ifConArgTys+    cons = visibleIfConDecls condecls++iface_decl_mentioned_vars (IfaceClass { ifFDs = fds, ifBody = IfAbstractClass })+  = Set.unions (map fundep_names fds)+  where+    fundep_names fd = Set.fromList (fst fd) `Set.union` Set.fromList (snd fd)++iface_decl_mentioned_vars+  (IfaceClass { ifFDs    = fds+              , ifBody = IfConcreteClass {+                  ifATs = ats,+                  ifSigs = sigs+                }})+  = Set.unions+        [ Set.unions (map fundep_names fds)+        , Set.unions (map iface_at_mentioned_vars ats)+        , Set.unions (map (visibleTypeVarOccurencies . class_op_type) sigs)+        ]+  where+    class_op_type (IfaceClassOp _bndr ty _default) = ty++    fundep_names fd = Set.fromList (fst fd) `Set.union` Set.fromList (snd fd)++iface_decl_mentioned_vars (IfaceSynonym {ifSynRhs  = poly_ty})+  = visibleTypeVarOccurencies poly_ty++-- Consider a binder to be a visible occurrence if it occurs inside an injectivity annotation.+iface_decl_mentioned_vars (IfaceFamily { ifBinders = binders, ifResVar = res_var, ifFamInj = inj })+  | Just{} <- res_var+  , Injective injectivity <- inj+  = Set.fromList . map (ifTyConBinderName . snd) . filter fst $ zip injectivity binders+  | otherwise = mempty++iface_decl_mentioned_vars IfacePatSyn{} = mempty+iface_decl_mentioned_vars IfaceId{} = mempty+iface_decl_mentioned_vars IfaceAxiom{} = mempty+ pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc -- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi --     See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr-pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,-                             ifCtxt = context, ifResKind = kind,-                             ifRoles = roles, ifCons = condecls,-                             ifParent = parent,-                             ifGadtSyntax = gadt,-                             ifBinders = binders })+pprIfaceDecl ss decl@(IfaceData { ifName = tycon, ifCType = ctype,+                                  ifCtxt = context, ifResKind = kind,+                                  ifRoles = roles, ifCons = condecls,+                                  ifParent = parent,+                                  ifGadtSyntax = gadt,+                                  ifBinders = binders })    | gadt      = vcat [ pp_roles                      , pp_ki_sig@@ -948,8 +1207,10 @@     pp_kind    = ppUnless (ki_sig_printable || isIfaceLiftedTypeKind kind)                           (dcolon <+> ppr kind) +    decl_head = pprIfaceDeclHead decl suppress_bndr_sig context ss tycon binders+     pp_lhs = case parent of-               IfNoParent -> pprIfaceDeclHead suppress_bndr_sig context ss tycon binders+               IfNoParent -> decl_head                IfDataInstance{}                           -> text "instance" <+> pp_data_inst_forall                                              <+> pprIfaceTyConParent parent@@ -996,36 +1257,40 @@      pp_extra = vcat [pprCType ctype] -pprIfaceDecl ss (IfaceClass { ifName  = clas-                            , ifRoles = roles-                            , ifFDs    = fds-                            , ifBinders = binders-                            , ifBody = IfAbstractClass })+pprIfaceDecl ss decl@(IfaceClass { ifName  = clas+                                 , ifRoles = roles+                                 , ifFDs    = fds+                                 , ifBinders = binders+                                 , ifBody = IfAbstractClass })   = vcat [ pprClassRoles ss clas binders roles          , pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind)-         , text "class" <+> pprIfaceDeclHead suppress_bndr_sig [] ss clas binders <+> pprFundeps fds ]+         , text "class" <+> decl_head <+> pprFundeps fds ]   where+    decl_head = pprIfaceDeclHead decl suppress_bndr_sig [] ss clas binders+     -- See Note [Suppressing binder signatures] in GHC.Iface.Type     suppress_bndr_sig = SuppressBndrSig True -pprIfaceDecl ss (IfaceClass { ifName  = clas-                            , ifRoles = roles-                            , ifFDs    = fds-                            , ifBinders = binders-                            , ifBody = IfConcreteClass {-                                ifATs = ats,-                                ifSigs = sigs,-                                ifClassCtxt = context,-                                ifMinDef = minDef-                              }})+pprIfaceDecl ss decl@(IfaceClass { ifName  = clas+                                 , ifRoles = roles+                                 , ifFDs    = fds+                                 , ifBinders = binders+                                 , ifBody = IfConcreteClass {+                                     ifATs = ats,+                                     ifSigs = sigs,+                                     ifClassCtxt = context,+                                     ifMinDef = minDef+                                   }})   = vcat [ pprClassRoles ss clas binders roles          , pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind)-         , text "class" <+> pprIfaceDeclHead suppress_bndr_sig context ss clas binders <+> pprFundeps fds <+> pp_where+         , text "class" <+> decl_head <+> pprFundeps fds <+> pp_where          , nest 2 (vcat [ vcat asocs, vcat dsigs                         , ppShowAllSubs ss (pprMinDef $ fromIfaceBooleanFormula minDef)])]     where       pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where") +      decl_head = pprIfaceDeclHead decl suppress_bndr_sig context ss clas binders+       asocs = ppr_trim $ map maybeShowAssoc ats       dsigs = ppr_trim $ map maybeShowSig sigs @@ -1039,29 +1304,38 @@         | showSub ss sg = Just $  pprIfaceClassOp ss sg         | otherwise     = Nothing -      pprMinDef :: BooleanFormula IfLclName -> SDoc+      pprMinDef :: BooleanFormula GhcRn -> SDoc       pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions         text "{-# MINIMAL" <+>         pprBooleanFormula-          (\_ def -> cparen (isLexSym def) (ppr def)) 0 (fmap ifLclNameFS minDef) <+>+          (\_ def -> let fs = getOccFS def in cparen (isLexSym fs) (ppr fs)) 0 minDef <+>         text "#-}" +      fromIfaceBooleanFormula :: IfaceBooleanFormula -> BooleanFormula GhcRn+      -- `mkUnboundName` here is fine because the Name generated is only used for pretty printing and nothing else.+      fromIfaceBooleanFormula (IfVar nm   ) = Var    $ noLocA . mkUnboundName . mkVarOccFS . ifLclNameFS $ nm+      fromIfaceBooleanFormula (IfAnd bfs  ) = And    $ map (noLocA . fromIfaceBooleanFormula) bfs+      fromIfaceBooleanFormula (IfOr bfs   ) = Or     $ map (noLocA . fromIfaceBooleanFormula) bfs+      fromIfaceBooleanFormula (IfParens bf) = Parens $     (noLocA . fromIfaceBooleanFormula) bf++       -- See Note [Suppressing binder signatures] in GHC.Iface.Type       suppress_bndr_sig = SuppressBndrSig True -pprIfaceDecl ss (IfaceSynonym { ifName    = tc-                              , ifBinders = binders-                              , ifSynRhs  = mono_ty-                              , ifResKind = res_kind})+pprIfaceDecl ss decl@(IfaceSynonym { ifName    = tc+                                   , ifBinders = binders+                                   , ifSynRhs  = poly_ty+                                   , ifResKind = res_kind})   = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind)-         , hang (text "type" <+> pprIfaceDeclHead suppress_bndr_sig [] ss tc binders <+> equals)-           2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr_tau-                  , ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ])+         , hang (text "type" <+> decl_head <+> equals)+           2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr_tau ])          ]   where-    (tvs, theta, tau) = splitIfaceSigmaTy mono_ty+    (tvs, theta, tau) = splitIfaceSigmaTy poly_ty     name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tc) +    decl_head = pprIfaceDeclHead decl suppress_bndr_sig [] ss tc binders+     -- See Note [Printing type abbreviations] in GHC.Iface.Type     ppr_tau | tc `hasKey` liftedTypeKindTyConKey ||               tc `hasKey` unrestrictedFunTyConKey ||@@ -1072,20 +1346,18 @@     -- See Note [Suppressing binder signatures] in GHC.Iface.Type     suppress_bndr_sig = SuppressBndrSig True -pprIfaceDecl ss (IfaceFamily { ifName = tycon-                             , ifFamFlav = rhs, ifBinders = binders-                             , ifResKind = res_kind-                             , ifResVar = res_var, ifFamInj = inj })+pprIfaceDecl ss decl@(IfaceFamily { ifName = tycon+                                  , ifFamFlav = rhs, ifBinders = binders+                                  , ifResKind = res_kind+                                  , ifResVar = res_var, ifFamInj = inj })   | IfaceDataFamilyTyCon <- rhs   = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind)-         , text "data family" <+> pprIfaceDeclHead suppress_bndr_sig [] ss tycon binders+         , text "data family" <+> decl_head          ]    | otherwise   = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind)-         , hang (text "type family"-                   <+> pprIfaceDeclHead suppress_bndr_sig [] ss tycon binders-                   <+> pp_inj res_var inj+         , hang (text "type family" <+> decl_head <+> pp_inj res_var inj                    <+> ppShowRhs ss (pp_where rhs))               2 (ppShowRhs ss (pp_rhs rhs))            $$@@ -1094,6 +1366,8 @@   where     name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tycon) +    decl_head = pprIfaceDeclHead decl suppress_bndr_sig [] ss tycon binders+     pp_where (IfaceClosedSynFamilyTyCon {}) = text "where"     pp_where _                              = empty @@ -1105,7 +1379,7 @@      pp_inj_cond res inj = case filterByList inj binders of        []  -> empty-       tvs -> hsep [vbar, ppr res, text "->", interppSP (map ifTyConBinderName tvs)]+       tvs -> hsep [vbar, ppr res, arrow, interppSP (map ifTyConBinderName tvs)]      pp_rhs IfaceDataFamilyTyCon       = ppShowIface ss (text "data")@@ -1182,12 +1456,17 @@          -> [Role] -> SDoc pprRoles suppress_if tyCon bndrs roles   = sdocOption sdocPrintExplicitKinds $ \print_kinds ->-      let froles = suppressIfaceInvisibles (PrintExplicitKinds print_kinds) bndrs roles+      let froles =+            suppressIfaceInvisibles+              (MkPrintArityInvisibles False)+              (PrintExplicitKinds print_kinds)+              mempty+              bndrs roles       in ppUnless (all suppress_if froles || null froles) $          text "type role" <+> tyCon <+> hsep (map ppr froles)  pprStandaloneKindSig :: SDoc -> IfaceType -> SDoc-pprStandaloneKindSig tyCon ty = text "type" <+> tyCon <+> text "::" <+> ppr ty+pprStandaloneKindSig tyCon ty = text "type" <+> tyCon <+> dcolon <+> ppr ty  pprInfixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc pprInfixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name@@ -1239,16 +1518,25 @@ pprIfaceTyConParent (IfDataInstance _ tc tys)   = pprIfaceTypeApp topPrec tc tys -pprIfaceDeclHead :: SuppressBndrSig+pprIfaceDeclHead :: IfaceDecl+                 -> SuppressBndrSig                  -> IfaceContext -> ShowSub -> Name                  -> [IfaceTyConBinder]   -- of the tycon, for invisible-suppression                  -> SDoc-pprIfaceDeclHead suppress_sig context ss tc_occ bndrs+pprIfaceDeclHead decl suppress_sig context ss tc_occ bndrs   = sdocOption sdocPrintExplicitKinds $ \print_kinds ->     sep [ pprIfaceContextArr context         , pprPrefixIfDeclBndr (ss_how_much ss) (occName tc_occ)           <+> pprIfaceTyConBinders suppress_sig-                (suppressIfaceInvisibles (PrintExplicitKinds print_kinds) bndrs bndrs) ]+              (suppressIfaceInvisibles+                (MkPrintArityInvisibles print_arity)+                (PrintExplicitKinds print_kinds)+                mentioned_vars+                bndrs bndrs) ]+  where+    -- See Note [Print invisible binders in interface declarations]+    mentioned_vars = iface_decl_mentioned_vars decl+    print_arity = not (iface_decl_generative decl)  pprIfaceConDecl :: ShowSub -> Bool                 -> IfaceTopBndr@@ -1283,15 +1571,15 @@     -- the visibilities of the existential tyvar binders, we can simply drop     -- the universal tyvar binders from user_tvbs.     ex_tvbs = dropList tc_binders user_tvbs-    ppr_ex_quant = pprIfaceForAllPartMust (ifaceForAllSpecToBndrs ex_tvbs) ctxt+    ppr_ex_quant = pprIfaceForAllPartMust ex_tvbs ctxt     pp_gadt_res_ty = mk_user_con_res_ty eq_spec-    ppr_gadt_ty = pprIfaceForAllPart (ifaceForAllSpecToBndrs user_tvbs) ctxt pp_tau+    ppr_gadt_ty = pprIfaceForAllPart user_tvbs ctxt pp_tau          -- A bit gruesome this, but we can't form the full con_tau, and ppr it,         -- because we don't have a Name for the tycon, only an OccName     pp_tau | null fields            = case pp_args ++ [pp_gadt_res_ty] of-                (t:ts) -> fsep (t : zipWithEqual "pprIfaceConDecl" (\(w,_) d -> ppr_arr w <+> d)+                (t:ts) -> fsep (t : zipWithEqual (\(w,_) d -> ppr_arr w <+> d)                                                  arg_tys ts)                 []     -> panic "pp_con_taus"            | otherwise@@ -1306,9 +1594,9 @@      ppr_bang IfNoBang = whenPprDebug $ char '_'     ppr_bang IfStrict = char '!'-    ppr_bang IfUnpack = text "{-# UNPACK #-}"-    ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <>-                               pprParendIfaceCoercion co+    ppr_bang IfUnpack = text "{-# UNPACK #-} !"+    ppr_bang (IfUnpackCo co) = text "{-# UNPACK #-} !" <>+                               whenPprDebug (pprParendIfaceCoercion co)      pprFieldArgTy, pprArgTy :: (IfaceBang, IfaceType) -> SDoc     -- If using record syntax, the only reason one would need to parenthesize@@ -1562,7 +1850,7 @@   = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope) pprIfaceTickish (IfaceSource src _names)   = braces (pprUserRealSpan True src)-pprIfaceTickish (IfaceBreakpoint m ix fvs)+pprIfaceTickish (IfaceBreakpoint (BreakpointId m ix) fvs)   = braces (text "break" <+> ppr m <+> ppr ix <+> ppr fvs)  ------------------@@ -1912,7 +2200,7 @@   = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys  freeNamesIfTickish :: IfaceTickish -> NameSet-freeNamesIfTickish (IfaceBreakpoint _ fvs _) =+freeNamesIfTickish (IfaceBreakpoint _ fvs) =   fnList freeNamesIfExpr fvs freeNamesIfTickish _ = emptyNameSet @@ -2008,9 +2296,10 @@                 ifFDs     = a5,                 ifBody = IfConcreteClass {                     ifClassCtxt = a1,-                    ifATs  = a6,-                    ifSigs = a7,-                    ifMinDef  = a8+                    ifATs       = a6,+                    ifSigs      = a7,+                    ifMinDef    = a8,+                    ifUnary     = a9                 }}) = do         putByte bh 5         put_ bh a1@@ -2021,6 +2310,7 @@         put_ bh a6         put_ bh a7         put_ bh a8+        put_ bh a9      put_ bh (IfaceAxiom a1 a2 a3 a4) = do         putByte bh 6@@ -2094,6 +2384,7 @@                     a6 <- get bh                     a7 <- get bh                     a8 <- get bh+                    a9 <- get bh                     return (IfaceClass {                         ifName    = a2,                         ifRoles   = a3,@@ -2101,9 +2392,10 @@                         ifFDs     = a5,                         ifBody = IfConcreteClass {                             ifClassCtxt = a1,-                            ifATs  = a6,-                            ifSigs = a7,-                            ifMinDef  = a8+                            ifATs       = a6,+                            ifSigs      = a7,+                            ifMinDef    = a8,+                            ifUnary     = a9                         }})             6 -> do a1 <- getIfaceTopBndr bh                     a2 <- get bh@@ -2490,6 +2782,10 @@     return (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike                            , uf_is_work_free = wf, uf_expandable = exp }) +seqUnfoldingCache :: IfUnfoldingCache -> ()+seqUnfoldingCache (UnfoldingCache hnf conlike wf exp) =+    rnf hnf `seq` rnf conlike `seq` rnf wf `seq` rnf exp `seq` ()+ infixl 9 .<<|. (.<<|.) :: (Num a, Bits a) => a -> Bool -> a x .<<|. b = (if b then (`setBit` 0) else id) (x `shiftL` 1)@@ -2560,12 +2856,10 @@         putByte bh 13         put_ bh a         put_ bh b-    put_ bh (IfaceLitRubbish TypeLike r) = do+    put_ bh (IfaceLitRubbish torc r) = do         putByte bh 14         put_ bh r-    put_ bh (IfaceLitRubbish ConstraintLike r) = do-        putByte bh 15-        put_ bh r+        put_ bh torc     get bh = do         h <- getByte bh         case h of@@ -2609,9 +2903,8 @@                      b <- get bh                      return (IfaceECase a b)             14 -> do r <- get bh-                     return (IfaceLitRubbish TypeLike r)-            15 -> do r <- get bh-                     return (IfaceLitRubbish ConstraintLike r)+                     torc <- get bh+                     return (IfaceLitRubbish torc r)             _ -> panic ("get IfaceExpr " ++ show h)  instance Binary IfaceTickish where@@ -2632,7 +2925,7 @@         put_ bh (srcSpanEndLine src)         put_ bh (srcSpanEndCol src)         put_ bh name-    put_ bh (IfaceBreakpoint m ix fvs) = do+    put_ bh (IfaceBreakpoint (BreakpointId m ix) fvs) = do         putByte bh 3         put_ bh m         put_ bh ix@@ -2660,7 +2953,7 @@             3 -> do m <- get bh                     ix <- get bh                     fvs <- get bh-                    return (IfaceBreakpoint m ix fvs)+                    return (IfaceBreakpoint (BreakpointId m ix) fvs)             _ -> panic ("get IfaceTickish " ++ show h)  instance Binary IfaceConAlt where@@ -2762,7 +3055,7 @@ instance NFData ImpIfaceList where   rnf ImpIfaceAll = ()   rnf (ImpIfaceEverythingBut ns) = rnf ns-  rnf (ImpIfaceExplicit gre) = rnf gre+  rnf (ImpIfaceExplicit gre explicit) = rnf gre `seq` rnf explicit  instance NFData IfaceDecl where   rnf = \case@@ -2770,36 +3063,36 @@       rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4      IfaceData f1 f2 f3 f4 f5 f6 f7 f8 f9 ->-      f1 `seq` seqList f2 `seq` f3 `seq` f4 `seq` f5 `seq`+      rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq`       rnf f6 `seq` rnf f7 `seq` rnf f8 `seq` rnf f9      IfaceSynonym f1 f2 f3 f4 f5 ->-      rnf f1 `seq` f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5+      rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5      IfaceFamily f1 f2 f3 f4 f5 f6 ->-      rnf f1 `seq` rnf f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 `seq` f6 `seq` ()+      rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` ()      IfaceClass f1 f2 f3 f4 f5 ->-      rnf f1 `seq` f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5+      rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5      IfaceAxiom nm tycon role ax ->       rnf nm `seq`       rnf tycon `seq`-      role `seq`+      rnf role `seq`       rnf ax      IfacePatSyn f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 ->-      rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` f6 `seq`-      rnf f7 `seq` rnf f8 `seq` rnf f9 `seq` rnf f10 `seq` f11 `seq` ()+      rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq`+      rnf f7 `seq` rnf f8 `seq` rnf f9 `seq` rnf f10 `seq` rnf f11 `seq` ()  instance NFData IfaceAxBranch where   rnf (IfaceAxBranch f1 f2 f3 f4 f5 f6 f7) =-    rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` rnf f6 `seq` rnf f7+    rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` rnf f7  instance NFData IfaceClassBody where   rnf = \case     IfAbstractClass -> ()-    IfConcreteClass f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` ()+    IfConcreteClass f1 f2 f3 f4 f5 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` ()  instance NFData IfaceBooleanFormula where   rnf = \case@@ -2812,7 +3105,7 @@   rnf (IfaceAT f1 f2) = rnf f1 `seq` rnf f2  instance NFData IfaceClassOp where-  rnf (IfaceClassOp f1 f2 f3) = rnf f1 `seq` rnf f2 `seq` f3 `seq` ()+  rnf (IfaceClassOp f1 f2 f3) = rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` ()  instance NFData IfaceTyConParent where   rnf = \case@@ -2827,19 +3120,22 @@  instance NFData IfaceConDecl where   rnf (IfCon f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11) =-    rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` rnf f6 `seq`-    rnf f7 `seq` rnf f8 `seq` f9 `seq` rnf f10 `seq` rnf f11+    rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq`+    rnf f7 `seq` rnf f8 `seq` rnf f9 `seq` rnf f10 `seq` rnf f11  instance NFData IfaceSrcBang where-  rnf (IfSrcBang f1 f2) = f1 `seq` f2 `seq` ()+  rnf (IfSrcBang f1 f2) = rnf f1 `seq` rnf f2 `seq` ()  instance NFData IfaceBang where-  rnf x = x `seq` ()+  rnf IfNoBang = ()+  rnf IfStrict = ()+  rnf IfUnpack = ()+  rnf (IfUnpackCo co) = rnf co  instance NFData IfaceIdDetails where   rnf = \case     IfVanillaId -> ()-    IfWorkerLikeId dmds -> dmds `seqList` ()+    IfWorkerLikeId dmds -> rnf dmds `seq` ()     IfRecSelId (Left tycon) b c d -> rnf tycon `seq` rnf b `seq` rnf c `seq` rnf d     IfRecSelId (Right decl) b c d -> rnf decl `seq` rnf b `seq` rnf c `seq` rnf d     IfDFunId -> ()@@ -2848,23 +3144,22 @@   rnf = \case     HsArity a -> rnf a     HsDmdSig str -> seqDmdSig str-    HsInline p -> p `seq` () -- TODO: seq further?+    HsInline p -> rnf p `seq` ()     HsUnfold b unf -> rnf b `seq` rnf unf     HsNoCafRefs -> ()-    HsCprSig cpr -> cpr `seq` ()-    HsLFInfo lf_info -> lf_info `seq` () -- TODO: seq further?-    HsTagSig sig -> sig `seq` ()+    HsCprSig cpr -> seqCprSig cpr `seq` ()+    HsLFInfo lf_info -> rnf lf_info `seq` ()+    HsTagSig sig -> seqTagSig sig `seq` ()  instance NFData IfGuidance where   rnf = \case     IfNoGuidance -> ()-    IfWhen a b c -> a `seq` b `seq` c `seq` ()+    IfWhen a b c -> rnf a `seq` rnf b `seq` rnf c `seq` ()  instance NFData IfaceUnfolding where   rnf = \case-    IfCoreUnfold src cache guidance expr -> src `seq` cache `seq` rnf guidance `seq` rnf expr+    IfCoreUnfold src cache guidance expr -> rnf src `seq` seqUnfoldingCache cache `seq` rnf guidance `seq` rnf expr     IfDFunUnfold bndrs exprs             -> rnf bndrs `seq` rnf exprs-    -- See Note [UnfoldingCache] in GHC.Core for why it suffices to merely `seq` on cache  instance NFData IfaceExpr where   rnf = \case@@ -2872,16 +3167,16 @@     IfaceExt nm -> rnf nm     IfaceType ty -> rnf ty     IfaceCo co -> rnf co-    IfaceTuple sort exprs -> sort `seq` rnf exprs+    IfaceTuple sort exprs -> rnf sort `seq` rnf exprs     IfaceLam bndr expr -> rnf bndr `seq` rnf expr     IfaceApp e1 e2 -> rnf e1 `seq` rnf e2-    IfaceCase e nm alts -> rnf e `seq` nm `seq` rnf alts+    IfaceCase e nm alts -> rnf e `seq` rnf nm `seq` rnf alts     IfaceECase e ty -> rnf e `seq` rnf ty     IfaceLet bind e -> rnf bind `seq` rnf e     IfaceCast e co -> rnf e `seq` rnf co-    IfaceLit l -> l `seq` () -- FIXME-    IfaceLitRubbish tc r -> tc `seq` rnf r `seq` ()-    IfaceFCall fc ty -> fc `seq` rnf ty+    IfaceLit l -> rnf l `seq` ()+    IfaceLitRubbish tc r -> rnf tc `seq` rnf r `seq` ()+    IfaceFCall fc ty -> rnf fc `seq` rnf ty     IfaceTick tick e -> rnf tick `seq` rnf e  instance NFData IfaceAlt where@@ -2893,7 +3188,7 @@     IfaceRec binds -> rnf binds  instance NFData IfaceTopBndrInfo where-  rnf (IfGblTopBndr n) = n `seq` ()+  rnf (IfGblTopBndr n) = rnf n `seq` ()   rnf (IfLclTopBndr fs ty info dets) = rnf fs `seq` rnf ty `seq` rnf info `seq` rnf dets `seq` ()  instance NFData IfaceMaybeRhs where@@ -2915,22 +3210,22 @@ instance NFData IfaceTickish where   rnf = \case     IfaceHpcTick m i -> rnf m `seq` rnf i-    IfaceSCC cc b1 b2 -> cc `seq` rnf b1 `seq` rnf b2-    IfaceSource src str -> src `seq` rnf str-    IfaceBreakpoint m i fvs -> rnf m `seq` rnf i `seq` rnf fvs+    IfaceSCC cc b1 b2 -> rnf cc `seq` rnf b1 `seq` rnf b2+    IfaceSource src str -> rnf src `seq` rnf str+    IfaceBreakpoint i fvs -> rnf i `seq` rnf fvs  instance NFData IfaceConAlt where   rnf = \case     IfaceDefaultAlt -> ()     IfaceDataAlt nm -> rnf nm-    IfaceLitAlt lit -> lit `seq` ()+    IfaceLitAlt lit -> rnf lit `seq` ()  instance NFData IfaceCompleteMatch where   rnf (IfaceCompleteMatch f1 mtc) = rnf f1 `seq` rnf mtc  instance NFData IfaceRule where   rnf (IfaceRule f1 f2 f3 f4 f5 f6 f7 f8) =-    rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` f8 `seq` ()+    rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` rnf f8 `seq` ()  instance NFData IfaceDefault where   rnf (IfaceDefault f1 f2 f3) =@@ -2938,11 +3233,11 @@  instance NFData IfaceFamInst where   rnf (IfaceFamInst f1 f2 f3 f4) =-    rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` ()+    rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` ()  instance NFData IfaceClsInst where   rnf (IfaceClsInst f1 f2 f3 f4 f5 f6) =-    f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` rnf f6+    rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6  instance NFData IfaceWarnings where   rnf = \case@@ -2950,12 +3245,12 @@       IfWarnSome vs ds -> rnf vs `seq` rnf ds  instance NFData IfaceWarningTxt where-    rnf = \case-        IfWarningTxt f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3-        IfDeprecatedTxt f1 f2 -> rnf f1 `seq` rnf f2+  rnf = \case+    IfWarningTxt f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3+    IfDeprecatedTxt f1 f2 -> rnf f1 `seq` rnf f2  instance NFData IfaceStringLiteral where-    rnf (IfStringLiteral f1 f2) = rnf f1 `seq` rnf f2+  rnf (IfStringLiteral f1 f2) = rnf f1 `seq` rnf f2  instance NFData IfaceAnnotation where-  rnf (IfaceAnnotation f1 f2) = f1 `seq` f2 `seq` ()+  rnf (IfaceAnnotation f1 f2) = rnf f1 `seq` rnf f2 `seq` ()
compiler/GHC/Iface/Type.hs view
@@ -44,6 +44,7 @@         SuppressBndrSig(..),         UseBndrParens(..),         PrintExplicitKinds(..),+        PrintArityInvisibles(..),         pprIfaceType, pprParendIfaceType, pprPrecIfaceType,         pprIfaceContext, pprIfaceContextArr,         pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders,@@ -56,6 +57,7 @@         isIfaceRhoType,          suppressIfaceInvisibles,+        visibleTypeVarOccurencies,         stripIfaceInvisVars,         stripInvisArgs, @@ -98,6 +100,9 @@ import Control.Arrow (first) import Control.DeepSeq import Control.Monad ((<$!>))+import Data.List (dropWhileEnd)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Set as Set  {- ************************************************************************@@ -609,9 +614,21 @@   = case splitIfaceReqForallTy ty of { (bndrs, rho) -> (bndr:bndrs, rho) } splitIfaceReqForallTy rho = ([], rho) -suppressIfaceInvisibles :: PrintExplicitKinds -> [IfaceTyConBinder] -> [a] -> [a]-suppressIfaceInvisibles (PrintExplicitKinds True) _tys xs = xs-suppressIfaceInvisibles (PrintExplicitKinds False) tys xs = suppress tys xs+newtype PrintArityInvisibles = MkPrintArityInvisibles Bool++-- See Note [Print invisible binders in interface declarations]+-- for the definition of what binders are considered insignificant+suppressIfaceInvisibles :: PrintArityInvisibles+                        -> PrintExplicitKinds+                        -> Set.Set IfLclName+                        -> [IfaceTyConBinder]+                        -> [a]+                        -> [a]+suppressIfaceInvisibles _ (PrintExplicitKinds True) _ _tys xs = xs++suppressIfaceInvisibles -- This case is semantically the same as the third case, but it should be way f+  (MkPrintArityInvisibles False) (PrintExplicitKinds False) mentioned_vars tys xs+  | Set.null mentioned_vars = suppress tys xs     where       suppress _       []      = []       suppress []      a       = a@@ -619,6 +636,44 @@         | isInvisibleTyConBinder k =     suppress ks xs         | otherwise                = x : suppress ks xs +suppressIfaceInvisibles+  (MkPrintArityInvisibles arity_invisibles)+  (PrintExplicitKinds False) mentioned_vars tys xs+  = map snd (suppress (zip tys xs))+    where+      -- Consider this example:+      --   type T :: forall k1 k2. Type+      --   type T @a @b = b+      -- `@a` is not mentioned on the RHS. However, we can't just+      -- drop it because implicit argument positioning matters.+      --+      -- Hence just drop the end+      only_mentioned_binders = dropWhileEnd (not . is_binder_mentioned)++      is_binder_mentioned (bndr, _) = ifTyConBinderName bndr `Set.member` mentioned_vars++      suppress_invisibles group =+        applyWhen invis_group only_mentioned_binders bndrs+        where+          bndrs       = NonEmpty.toList group+          invis_group = is_invisible_bndr (NonEmpty.head group)++      suppress_invisible_groups [] = []+      suppress_invisible_groups [group] =+          if arity_invisibles+            then NonEmpty.toList group -- the last group affects arity+            else suppress_invisibles group+      suppress_invisible_groups (group : groups)+        = suppress_invisibles group ++ suppress_invisible_groups groups++      suppress+        = suppress_invisible_groups            -- Filter out insignificant invisible binders+        . NonEmpty.groupWith is_invisible_bndr -- Find chunks of @-binders+        . filterOut          is_inferred_bndr  -- We don't want to display @{binders}++      is_inferred_bndr = isInferredTyConBinder . fst+      is_invisible_bndr = isInvisibleTyConBinder . fst+ stripIfaceInvisVars :: PrintExplicitKinds -> [IfaceTyConBinder] -> [IfaceTyConBinder] stripIfaceInvisVars (PrintExplicitKinds True)  tyvars = tyvars stripIfaceInvisVars (PrintExplicitKinds False) tyvars@@ -659,6 +714,29 @@     go_args IA_Nil = True     go_args (IA_Arg arg _ args) = go arg && go_args args +visibleTypeVarOccurencies :: IfaceType -> Set.Set IfLclName+-- Returns True if the type contains this name. Doesn't count+-- invisible application+-- Just used to control pretty printing+visibleTypeVarOccurencies = go+  where+    (<>) = Set.union++    go (IfaceTyVar var)         = Set.singleton var+    go (IfaceFreeTyVar {})      = mempty+    go (IfaceAppTy fun args)    = go fun <> go_args args+    go (IfaceFunTy _ w arg res) = go w <> go arg <> go res+    go (IfaceForAllTy bndr ty)  = go (ifaceBndrType $ binderVar bndr) <> go ty+    go (IfaceTyConApp _ args)   = go_args args+    go (IfaceTupleTy _ _ args)  = go_args args+    go (IfaceLitTy _)           = mempty+    go (IfaceCastTy {})         = mempty -- Safe+    go (IfaceCoercionTy {})     = mempty -- Safe++    go_args IA_Nil = mempty+    go_args (IA_Arg arg Required args) = go arg <> go_args args+    go_args (IA_Arg _arg _ args) = go_args args+ {- Note [Substitution on IfaceType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Substitutions on IfaceType are done only during pretty-printing to@@ -1669,7 +1747,7 @@        , IA_Arg (IfaceLitTy (IfaceStrTyLit n))                 Required (IA_Arg ty Required IA_Nil) <- tys        -> maybeParen ctxt_prec funPrec-         $ char '?' <> ftext (getLexicalFastString n) <> text "::" <> ppr_ty topPrec ty+         $ char '?' <> ftext (getLexicalFastString n) <> dcolon <> ppr_ty topPrec ty         | IfaceTupleTyCon arity sort <- ifaceTyConSort info        , not debug@@ -2499,18 +2577,23 @@               0 -> return VanillaDM               _ -> do { t <- get bh; return (GenericDM t) } +instance NFData (DefMethSpec IfaceType) where+  rnf = \case+    VanillaDM -> ()+    GenericDM t -> rnf t+ instance NFData IfaceType where   rnf = \case     IfaceFreeTyVar f1 -> f1 `seq` ()     IfaceTyVar f1 -> rnf f1     IfaceLitTy f1 -> rnf f1     IfaceAppTy f1 f2 -> rnf f1 `seq` rnf f2-    IfaceFunTy f1 f2 f3 f4 -> f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4-    IfaceForAllTy f1 f2 -> f1 `seq` rnf f2+    IfaceFunTy f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4+    IfaceForAllTy f1 f2 -> rnf f1 `seq` rnf f2     IfaceTyConApp f1 f2 -> rnf f1 `seq` rnf f2     IfaceCastTy f1 f2 -> rnf f1 `seq` rnf f2     IfaceCoercionTy f1 -> rnf f1-    IfaceTupleTy f1 f2 f3 -> f1 `seq` f2 `seq` rnf f3+    IfaceTupleTy f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3  instance NFData IfaceTyLit where   rnf = \case@@ -2521,21 +2604,25 @@ instance NFData IfaceCoercion where   rnf = \case     IfaceReflCo f1 -> rnf f1-    IfaceGReflCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3-    IfaceFunCo f1 f2 f3 f4 -> f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4-    IfaceTyConAppCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3+    IfaceGReflCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3+    IfaceFunCo f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4+    IfaceTyConAppCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3     IfaceAppCo f1 f2 -> rnf f1 `seq` rnf f2     IfaceForAllCo f1 f2 f3 f4 f5 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5     IfaceCoVarCo f1 -> rnf f1     IfaceAxiomCo f1 f2 -> rnf f1 `seq` rnf f2-    IfaceUnivCo f1 f2 f3 f4 deps -> rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf deps+    IfaceUnivCo f1 f2 f3 f4 deps -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf deps     IfaceSymCo f1 -> rnf f1     IfaceTransCo f1 f2 -> rnf f1 `seq` rnf f2     IfaceSelCo f1 f2 -> rnf f1 `seq` rnf f2-    IfaceLRCo f1 f2 -> f1 `seq` rnf f2+    IfaceLRCo f1 f2 -> rnf f1 `seq` rnf f2     IfaceInstCo f1 f2 -> rnf f1 `seq` rnf f2     IfaceKindCo f1 -> rnf f1     IfaceSubCo f1 -> rnf f1+    -- These are not deeply forced because they are not used in ModIface,+    -- these constructors are for pretty-printing.+    -- See Note [Free TyVars and CoVars in IfaceType]+    -- See Note [Holes in IfaceCoercion]     IfaceFreeCoVar f1 -> f1 `seq` ()     IfaceHoleCo f1 -> f1 `seq` () @@ -2546,15 +2633,17 @@     IfaceAR_B n i -> rnf n `seq` rnf i  instance NFData IfaceMCoercion where-  rnf x = seq x ()+  rnf IfaceMRefl = ()+  rnf (IfaceMCo c) = rnf c  instance NFData IfaceOneShot where-  rnf x = seq x ()+  rnf IfaceOneShot = ()+  rnf IfaceNoOneShot = ()  instance NFData IfaceTyConSort where   rnf = \case     IfaceNormalTyCon -> ()-    IfaceTupleTyCon arity sort -> rnf arity `seq` sort `seq` ()+    IfaceTupleTyCon arity sort -> rnf arity `seq` rnf sort `seq` ()     IfaceSumTyCon arity -> rnf arity     IfaceEqualityTyCon -> () @@ -2562,7 +2651,7 @@   rnf (IfLclName lfs) = rnf lfs  instance NFData IfaceTyConInfo where-  rnf (IfaceTyConInfo f s) = f `seq` rnf s+  rnf (IfaceTyConInfo f s) = rnf f `seq` rnf s  instance NFData IfaceTyCon where   rnf (IfaceTyCon nm info) = rnf nm `seq` rnf info@@ -2575,4 +2664,4 @@ instance NFData IfaceAppArgs where   rnf = \case     IA_Nil -> ()-    IA_Arg f1 f2 f3 -> rnf f1 `seq` f2 `seq` rnf f3+    IA_Arg f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3
compiler/GHC/JS/Make.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP               #-} {-# LANGUAGE DataKinds         #-} {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE FlexibleInstances #-}@@ -135,9 +134,6 @@   -- * Statement helpers   , Solo(..)   , decl-#if __GLASGOW_HASKELL__ < 905-  , pattern MkSolo-#endif   ) where @@ -603,7 +599,7 @@ infixl 8 .!  assignAllEqual :: HasDebugCallStack => [JStgExpr] -> [JStgExpr] -> JStgStat-assignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" (|=) xs ys)+assignAllEqual xs ys = mconcat (zipWithEqual (|=) xs ys)  assignAll :: [JStgExpr] -> [JStgExpr] -> JStgStat assignAll xs ys = mconcat (zipWith (|=) xs ys)@@ -714,12 +710,6 @@     fromRational x = ValExpr (JDouble (realToFrac x))  --- The Solo constructor was renamed to MkSolo in ghc 9.5-#if __GLASGOW_HASKELL__ < 905-pattern MkSolo :: a -> Solo a-pattern MkSolo a = Solo a-{-# COMPLETE MkSolo #-}-#endif  -------------------------------------------------------------------------------- -- New Identifiers
compiler/GHC/JS/Ppr.hs view
@@ -74,6 +74,7 @@  import Numeric(showHex) +import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Types.Unique.Map@@ -170,7 +171,7 @@   SwitchStat e l d     -> hangBrace (text "switch" <+?> parens (jsToDocR r e)) cases         where l' = map (\(c,s) -> (text "case" <+?> parens (jsToDocR r c) <> colon) $$$ jnest (optBlock r s)) l                    ++ [(text "default:") $$$ jnest (optBlock r d)]-              cases = foldl1 ($$$) l'+              cases = foldl1 ($$$) $ expectNonEmpty l'   ReturnStat e      -> text "return" <+> jsToDocR r e   ApplStat e es     -> jsToDocR r e <> (parens . foldl' (<+?>) empty . punctuate comma $ map (jsToDocR r) es)   FuncStat i is b   -> hangBrace (text "function" <+> jsToDocR r i
compiler/GHC/Linker/Config.hs view
@@ -22,6 +22,6 @@   , linkerOptionsPre  :: [Option]         -- ^ Linker options (before user options)   , linkerOptionsPost :: [Option]         -- ^ Linker options (after user options)   , linkerTempDir     :: TempDir          -- ^ Temporary directory to use-  , linkerFilter      :: String -> String -- ^ Output filter+  , linkerFilter      :: [String] -> [String] -- ^ Output filter   }
compiler/GHC/Linker/Types.hs view
@@ -18,6 +18,8 @@    , ClosureEnv    , emptyClosureEnv    , extendClosureEnv+   , LinkedBreaks(..)+   , filterLinkedBreaks    , LinkableSet    , mkLinkableSet    , unionLinkableSet@@ -50,10 +52,12 @@  import GHC.Prelude import GHC.Unit                ( UnitId, Module )-import GHC.ByteCode.Types      ( ItblEnv, AddrEnv, CompiledByteCode )-import GHCi.RemoteTypes        ( ForeignHValue, RemotePtr )+import GHC.ByteCode.Types+import GHCi.BreakArray+import GHCi.RemoteTypes import GHCi.Message            ( LoadedDLL ) +import GHC.Stack.CCS import GHC.Types.Name.Env      ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv ) import GHC.Types.Name          ( Name ) import GHC.Types.SptEntry@@ -61,6 +65,7 @@ import GHC.Utils.Outputable  import Control.Concurrent.MVar+import Data.Array import Data.Time               ( UTCTime ) import GHC.Unit.Module.Env import GHC.Types.Unique.DSet@@ -156,6 +161,9 @@     , temp_sos :: ![(FilePath, String)]         -- ^ We need to remember the name of previous temporary DLL/.so         -- libraries so we can link them (see #10322)++    , linked_breaks :: !LinkedBreaks+        -- ^ Mapping from loaded modules to their breakpoint arrays     }  uninitializedLoader :: IO Loader@@ -184,10 +192,10 @@   }  filterLinkerEnv :: (Name -> Bool) -> LinkerEnv -> LinkerEnv-filterLinkerEnv f le = LinkerEnv-  { closure_env = filterNameEnv (f . fst) (closure_env le)-  , itbl_env    = filterNameEnv (f . fst) (itbl_env le)-  , addr_env    = filterNameEnv (f . fst) (addr_env le)+filterLinkerEnv f (LinkerEnv closure_e itbl_e addr_e) = LinkerEnv+  { closure_env = filterNameEnv (f . fst) closure_e+  , itbl_env    = filterNameEnv (f . fst) itbl_e+  , addr_env    = filterNameEnv (f . fst) addr_e   }  type ClosureEnv = NameEnv (Name, ForeignHValue)@@ -198,6 +206,29 @@ extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv extendClosureEnv cl_env pairs   = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]++-- | 'BreakArray's and CCSs are allocated per-module at link-time.+--+-- Specifically, a module's 'BreakArray' is allocated either:+--  - When a BCO for that module is linked+--  - When :break is used on a given module *before* the BCO has been linked.+--+-- We keep this structure in the 'LoaderState'+data LinkedBreaks+  = LinkedBreaks+  { breakarray_env :: !(ModuleEnv (ForeignRef BreakArray))+      -- ^ Each 'Module's remote pointer of 'BreakArray'.++  , ccs_env :: !(ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)))+      -- ^ Each 'Module's array of remote pointers of 'CostCentre'.+      -- Untouched when not profiling.+  }++filterLinkedBreaks :: (Module -> Bool) -> LinkedBreaks -> LinkedBreaks+filterLinkedBreaks f (LinkedBreaks ba_e ccs_e) = LinkedBreaks+  { breakarray_env = filterModuleEnv (\m _ -> f m) ba_e+  , ccs_env        = filterModuleEnv (\m _ -> f m) ccs_e+  }  type PkgsLoaded = UniqDFM UnitId LoadedPkgInfo
compiler/GHC/Parser.y view
@@ -13,6 +13,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonadComprehensions #-}  -- | 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.@@ -39,10 +40,10 @@ where  -- base-import Control.Monad    ( unless, liftM, when, (<=<) )+import Control.Monad      ( unless, liftM, when, (<=<) ) import GHC.Exts-import Data.Maybe       ( maybeToList )-import Data.List.NonEmpty ( NonEmpty(..) )+import Data.Maybe         ( maybeToList )+import Data.List.NonEmpty ( NonEmpty(..), head, init, last, tail ) import qualified Data.List.NonEmpty as NE import qualified Prelude -- for happy-generated code @@ -63,7 +64,7 @@ import GHC.Utils.Error import GHC.Utils.Misc          ( looksLikePackageName, fstOf3, sndOf3, thdOf3 ) import GHC.Utils.Panic-import GHC.Prelude+import GHC.Prelude hiding ( head, init, last, tail ) import qualified GHC.Data.Strict as Strict  import GHC.Types.Name.Reader@@ -638,6 +639,8 @@  'stock'        { L _ ITstock }    -- for DerivingStrategies extension  'anyclass'     { L _ ITanyclass } -- for DerivingStrategies extension  'via'          { L _ ITvia }      -- for DerivingStrategies extension+ 'splice'       { L _ ITsplice }   -- For StagedImports extension+ 'quote'        { L _ ITquote }    -- For StagedImports extension   'unit'         { L _ ITunit }  'signature'    { L _ ITsignature }@@ -1039,8 +1042,9 @@                                                                      ; anchor = (maybe glR (\loc -> spanAsAnchor . comb2 loc) $1) $2 }                                                           ; locImpExp <- return (sL span (IEModuleContents ($1, (epTok $2)) $3))                                                           ; return $ reLoc $ locImpExp } }-        | maybe_warning_pragma 'pattern' qcon            { let span = (maybe comb2 comb3 $1) $2 $>-                                                           in reLoc $ sL span $ IEVar $1 (sLLa $2 $> (IEPattern (epTok $2) $3)) Nothing }+        | maybe_warning_pragma 'pattern' qcon            {% do { warnPatternNamespaceSpecifier (getLoc $2)+                                                               ; let span = (maybe comb2 comb3 $1) $2 $>+                                                               ; return $ reLoc $ sL span $ IEVar $1 (sLLa $2 $> (IEPattern (epTok $2) $3)) Nothing } }         | maybe_warning_pragma 'default' qtycon          {% do { let { span = (maybe comb2 comb3 $1) $2 $> }                                                           ; locImpExp <- return (sL span (IEThingAbs $1 (sLLa $2 $> (IEDefault (epTok $2) $3)) Nothing))                                                           ; return $ reLoc $ locImpExp } }@@ -1074,9 +1078,11 @@         |  '..'                     { sL1a $1 (ImpExpQcWildcard (epTok $1) NoEpTok)  }  qcname_ext :: { LocatedA ImpExpQcSpec }-        :  qcname                   { sL1a $1 (ImpExpQcName $1) }-        |  'type' oqtycon           {% do { n <- mkTypeImpExp $2-                                          ; return $ sLLa $1 $> (ImpExpQcType (epTok $1) n) }}+        :  qcname                   { sL1a $1 (mkPlainImpExp $1) }+        |  'type' oqtycon           {% do { imp_exp <- mkTypeImpExp (epTok $1) $2+                                          ; return $ sLLa $1 $> imp_exp }}+        |  'data' qvarcon           {% do { imp_exp <- mkDataImpExp (epTok $1) $2+                                          ; return $ sLLa $1 $> imp_exp }}  qcname  :: { LocatedN RdrName }  -- Variable or type constructor         :  qvar                 { $1 } -- Things which look like functions@@ -1117,28 +1123,33 @@         | {- empty -}           { [] }  importdecl :: { LImportDecl GhcPs }-        : 'import' maybe_src maybe_safe optqualified maybe_pkg modid optqualified maybeas maybeimpspec+        : 'import' maybe_src maybe_splice maybe_safe optqualified maybe_pkg modid maybe_splice optqualified maybeas maybeimpspec                 {% do {-                  ; let { ; mPreQual = unLoc $4-                          ; mPostQual = unLoc $7 }-                  ; checkImportDecl mPreQual mPostQual+                  ; let { ; mPreQual = $5+                          ; mPostQual = $9+                          ; mPreLevel = $3+                          ; mPostLevel = $8 }+                  ; (qualSpec, levelSpec) <- checkImportDecl mPreQual mPostQual mPreLevel mPostLevel                   ; let anns                          = EpAnnImportDecl                              { importDeclAnnImport    = epTok $1                              , importDeclAnnPragma    = fst $ fst $2-                             , importDeclAnnSafe      = fst $3-                             , importDeclAnnQualified = fst $ importDeclQualifiedStyle mPreQual mPostQual-                             , importDeclAnnPackage   = fst $5-                             , importDeclAnnAs        = fst $8+                             , importDeclAnnLevel     = fst $ levelSpec+                             , importDeclAnnSafe      = fst $4+                             , importDeclAnnQualified = fst $ qualSpec+                             , importDeclAnnPackage   = fst $6+                             , importDeclAnnAs        = fst $10                              }-                  ; let loc = (comb5 $1 $6 $7 (snd $8) $9);+                  ; let loc = (comb6 $1 $7 $8 $9 (snd $10) $11);                   ; fmap reLoc $ acs loc (\loc cs -> L loc $                       ImportDecl { ideclExt = XImportDeclPass (EpAnn (spanAsAnchor loc) anns cs) (snd $ fst $2) False-                                  , ideclName = $6, ideclPkgQual = snd $5-                                  , ideclSource = snd $2, ideclSafe = snd $3-                                  , ideclQualified = snd $ importDeclQualifiedStyle mPreQual mPostQual-                                  , ideclAs = unLoc (snd $8)-                                  , ideclImportList = unLoc $9 })+                                  , ideclName = $7, ideclPkgQual = snd $6+                                  , ideclSource = snd $2+                                  , ideclLevelSpec = snd $ levelSpec+                                  , ideclSafe = snd $4+                                  , ideclQualified = snd $ qualSpec+                                  , ideclAs = unLoc (snd $10)+                                  , ideclImportList = unLoc $11 })                   }                 } @@ -1152,6 +1163,11 @@         : 'safe'                                { (Just (epTok $1),True) }         | {- empty -}                           { (Nothing,      False) } +maybe_splice :: { (Maybe EpAnnLevel) }+        : 'splice'                              { (Just (EpAnnLevelSplice (epTok $1))) }+        | 'quote'                               { (Just (EpAnnLevelQuote (epTok $1))) }+        | {- empty -}                           { (Nothing) }+ maybe_pkg :: { (Maybe EpaLocation, RawPkgQual) }         : STRING  {% do { let { pkgFS = getSTRING $1 }                         ; unless (looksLikePackageName (unpackFS pkgFS)) $@@ -1160,9 +1176,9 @@                         ; return (Just (glR $1), RawPkgQual (StringLiteral (getSTRINGs $1) pkgFS Nothing)) } }         | {- empty -}                           { (Nothing,NoRawPkgQual) } -optqualified :: { Located (Maybe (EpToken "qualified")) }-        : 'qualified'                           { sL1 $1 (Just (epTok $1)) }-        | {- empty -}                           { noLoc Nothing }+optqualified :: { Maybe (EpToken "qualified") }+        : 'qualified'                           { Just (epTok $1) }+        | {- empty -}                           { Nothing }  maybeas :: { (Maybe (EpToken "as"),Located (Maybe (LocatedA ModuleName))) }         : 'as' modid                           { (Just (epTok $1)@@ -1209,7 +1225,8 @@ import  :: { OrdList (LIE GhcPs) }         : qcname_ext export_subspec {% fmap (unitOL . reLoc . (sLL $1 $>)) $ mkModuleImpExp Nothing (fst $ unLoc $2) $1 (snd $ unLoc $2) }         | 'module' modid            {% fmap (unitOL . reLoc) $ return (sLL $1 $> (IEModuleContents (Nothing, (epTok $1)) $2)) }-        | 'pattern' qcon            { unitOL $ reLoc $ sLL $1 $> $ IEVar Nothing (sLLa $1 $> (IEPattern (epTok $1) $2)) Nothing }+        | 'pattern' qcon            {% do { warnPatternNamespaceSpecifier (getLoc $1)+                                          ; return $ unitOL $ reLoc $ sLL $1 $> $ IEVar Nothing (sLLa $1 $> (IEPattern (epTok $1) $2)) Nothing } }  ----------------------------------------------------------------------------- -- Fixity Declarations@@ -1721,7 +1738,7 @@                    }}  pattern_synonym_lhs :: { (LocatedN RdrName, HsPatSynDetails GhcPs, (Maybe (EpToken "{"), Maybe (EpToken "}"))) }-        : con vars0 { ($1, PrefixCon noTypeArgs $2, noAnn) }+        : con vars0 { ($1, PrefixCon $2, noAnn) }         | varid conop varid { ($2, InfixCon $1 $3, noAnn) }         | con '{' cvars1 '}' { ($1, RecCon $3, (Just (epTok $2), Just (epTok $4))) } @@ -1926,10 +1943,10 @@          {%runPV (unECP $4) >>= \ $4 ->            runPV (unECP $6) >>= \ $6 ->            amsA' (sLL $1 $> $ HsRule-                                   { rd_ext =(((fstOf3 $3) (epTok $5) (fst $2)), getSTRINGs $1)+                                   { rd_ext =((fst $2, epTok $5), getSTRINGs $1)                                    , rd_name = L (noAnnSrcSpan $ gl $1) (getSTRING $1)-                                   , rd_act = (snd $2) `orElse` AlwaysActive-                                   , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3+                                   , rd_act = snd $2 `orElse` AlwaysActive+                                   , rd_bndrs = ruleBndrsOrDef $3                                    , rd_lhs = $4, rd_rhs = $6 }) }  -- Rules can be specified to be NeverActive, unlike inline/specialize pragmas@@ -1965,19 +1982,22 @@                                 { ( ActivationAnn (epTok $1) (epTok $3) $2 Nothing                                   , NeverActive) } -rule_foralls :: { (EpToken "=" -> ActivationAnn -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs]) }-        : 'forall' rule_vars '.' 'forall' rule_vars '.'    {% let tyvs = mkRuleTyVarBndrs $2-                                                              in hintExplicitForall $1-                                                              >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2)-                                                              >> return (\an_eq an_act -> HsRuleAnn-                                                                          (Just (epUniTok $1,epTok $3))-                                                                          (Just (epUniTok $4,epTok $6))-                                                                          an_eq an_act,-                                                                         Just (mkRuleTyVarBndrs $2), mkRuleBndrs $5) }-        | 'forall' rule_vars '.'                           { (\an_eq an_act -> HsRuleAnn Nothing (Just (epUniTok $1,epTok $3)) an_eq an_act,-                                                              Nothing, mkRuleBndrs $2) }+rule_foralls :: { Maybe (RuleBndrs GhcPs) }+        : 'forall' rule_vars '.' 'forall' rule_vars '.'+              {% hintExplicitForall $1+                 >> checkRuleTyVarBndrNames $2+                 >> let ann = HsRuleBndrsAnn+                                (Just (epUniTok $1,epTok $3))+                                (Just (epUniTok $4,epTok $6))+                     in return (Just (mkRuleBndrs ann  (Just $2) $5)) }++        | 'forall' rule_vars '.'+           { Just (mkRuleBndrs (HsRuleBndrsAnn Nothing (Just (epUniTok $1,epTok $3)))+                               Nothing $2) }+         -- See Note [%shift: rule_foralls -> {- empty -}]-        | {- empty -}            %shift                    { (\an_eq an_act -> HsRuleAnn Nothing Nothing an_eq an_act, Nothing, []) }+        | {- empty -}            %shift+           { Nothing }  rule_vars :: { [LRuleTyTmVar] }         : rule_var rule_vars                    { $1 : $2 }@@ -2148,6 +2168,9 @@        : STRING var '::' sigtype        { sLL $1 $> (epUniTok $3                                              ,(L (getLoc $1)                                                     (getStringLiteral $1), $2, $4)) }+       | STRING_MULTI var '::' sigtype  { sLL $1 $> (epUniTok $3+                                             ,(L (getLoc $1)+                                                    (getStringMultiLiteral $1), $2, $4)) }        |        var '::' sigtype        { sLL $1 $> (epUniTok $2                                              ,(noLoc (StringLiteral NoSourceText nilFS Nothing), $1, $3)) }          -- if the entity string is missing, it defaults to the empty string;@@ -2157,11 +2180,11 @@ ----------------------------------------------------------------------------- -- Type signatures -opt_sig :: { Maybe (EpUniToken "::" "∷", LHsType GhcPs) }+opt_sig :: { Maybe (EpUniToken "::" "\8759", LHsType GhcPs) }         : {- empty -}                   { Nothing }         | '::' ctype                    { Just (epUniTok $1, $2) } -opt_tyconsig :: { (Maybe (EpUniToken "::" "∷"), Maybe (LocatedN RdrName)) }+opt_tyconsig :: { (Maybe (EpUniToken "::" "\8759"), Maybe (LocatedN RdrName)) }              : {- empty -}              { (Nothing, Nothing) }              | '::' gtycon              { (Just (epUniTok $1), Just $2) } @@ -2187,10 +2210,10 @@                                              return (sLL $1 $> ($3 : h' : t)) }          | var                        { sL1 $1 [$1] } -sigtypes1 :: { OrdList (LHsSigType GhcPs) }-   : sigtype                 { unitOL $1 }+sigtypes1 :: { Located (OrdList (LHsSigType GhcPs)) }+   : sigtype                 { sL1 $1 (unitOL $1) }    | sigtype ',' sigtypes1   {% do { st <- addTrailingCommaA $1 (epTok $2)-                                   ; return $ unitOL st `appOL` $3 } }+                                   ; return $ sLL $1 $> (unitOL st `appOL` unLoc $3) } } ----------------------------------------------------------------------------- -- Types @@ -2260,19 +2283,19 @@         -- See Note [%shift: type -> btype]         : btype %shift                 { $1 }         | btype '->' ctype             {% amsA' (sLL $1 $>-                                            $ HsFunTy noExtField (HsUnrestrictedArrow (epUniTok $2)) $1 $3) }+                                            $ HsFunTy noExtField (HsUnannotated (EpArrow (epUniTok $2))) $1 $3) }          | btype mult '->' ctype        {% hintLinear (getLoc $2)                                        >> let arr = (unLoc $2) (epUniTok $3)                                           in amsA' (sLL $1 $> $ HsFunTy noExtField arr $1 $4) }          | btype '->.' ctype            {% hintLinear (getLoc $2) >>-                                          amsA' (sLL $1 $> $ HsFunTy noExtField (HsLinearArrow (EpLolly (epTok $2))) $1 $3) }+                                          amsA' (sLL $1 $> $ HsFunTy noExtField (HsLinearAnn (EpLolly (epTok $2))) $1 $3) } -mult :: { Located (EpUniToken "->" "\8594" -> HsArrow GhcPs) }-        : PREFIX_PERCENT atype          { sLL $1 $> (mkMultTy (epTok $1) $2) }+mult :: { Located (EpUniToken "->" "\8594" -> HsMultAnn GhcPs) }+        : PREFIX_PERCENT atype          { sLL $1 $> (mkMultAnn (epTok $1) $2 . EpArrow) } -expmult :: { forall b. DisambECP b => PV (Located (EpUniToken "->" "\8594" -> HsArrowOf (LocatedA b) GhcPs)) }+expmult :: { forall b. DisambECP b => PV (Located (EpUniToken "->" "\8594" -> HsMultAnnOf (LocatedA b) GhcPs)) } expmult : PREFIX_PERCENT aexp           { unECP $2 >>= \ $2 ->                                           fmap (sLL $1 $>) (mkHsMultPV (epTok $1) $2) } @@ -2324,7 +2347,7 @@         | PREFIX_TILDE atype             {% amsA' (sLL $1 $> (mkBangTy (glR $1) SrcLazy $2)) }         | PREFIX_BANG  atype             {% amsA' (sLL $1 $> (mkBangTy (glR $1) SrcStrict $2)) } -        | '{' fielddecls '}'             {% do { decls <- amsA' (sLL $1 $> $ HsRecTy (AnnList (listAsAnchorM $2) (ListBraces (epTok $1) (epTok $3)) [] noAnn []) $2)+        | '{' fielddecls '}'             {% do { decls <- amsA' (sLL $1 $> $ XHsType $ HsRecTy (AnnList (listAsAnchorM $2) (ListBraces (epTok $1) (epTok $3)) [] noAnn []) $2)                                                ; checkRecordSyntax decls }}                                                         -- Constructor sigs only @@ -2581,23 +2604,30 @@          : ktype bars { ($1, 1, (snd $2 + 1)) }          | bars ktype bars0 { ($2, snd $1 + 1, snd $1 + snd $3 + 1) } -fielddecls :: { [LConDeclField GhcPs] }+fielddecls :: { [LHsConDeclRecField GhcPs] }         : {- empty -}     { [] }         | fielddecls1     { $1 } -fielddecls1 :: { [LConDeclField GhcPs] }+fielddecls1 :: { [LHsConDeclRecField GhcPs] }         : fielddecl ',' fielddecls1             {% do { h <- addTrailingCommaA $1 (epTok $2)                   ; return (h : $3) }}         | fielddecl   { [$1] } -fielddecl :: { LConDeclField GhcPs }+fielddecl :: { LHsConDeclRecField GhcPs }                                               -- A list because of   f,g :: Int         : sig_vars '::' ctype             {% amsA' (L (comb2 $1 $3)-                      (ConDeclField (epUniTok $2)+                      (HsConDeclRecField noExtField                                     (reverse (map (\ln@(L l n)-                                               -> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc $1))) $3 Nothing))}+                                               -> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc $1)))+                                    (mkConDeclField (HsUnannotated (EpColon (epUniTok $2))) $3)))}+        | sig_vars PREFIX_PERCENT atype '::' ctype+            {% amsA' (L (comb4 $1 $2 $3 $5)+                      (HsConDeclRecField noExtField+                                    (reverse (map (\ln@(L l n)+                                               -> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc $1)))+                                    (mkMultField (epTok $2) $3 (epUniTok $4) $5)))}  -- Reversed! maybe_derivings :: { Located (HsDeriving GhcPs) }@@ -2661,17 +2691,17 @@ decl_no_th :: { LHsDecl GhcPs }         : sigdecl               { $1 } -        | infixexp     opt_sig rhs  {% runPV (unECP $1) >>= \ $1 ->+        | infixexp opt_sig rhs  {% runPV (unECP $1) >>= \ $1 ->                                        do { let { l = comb2 $1 $> }-                                          ; r <- checkValDef l $1 (HsNoMultAnn noExtField, $2) $3;+                                          ; r <- checkValDef l $1 (HsUnannotated EpPatBind, $2) $3;                                         -- Depending upon what the pattern looks like we might get either                                         -- a FunBind or PatBind back from checkValDef. See Note                                         -- [FunBind vs PatBind]                                           ; !cs <- getCommentsFor l                                           ; return $! (sL (commentsA l cs) $ ValD noExtField r) } }-        | PREFIX_PERCENT atype infixexp     opt_sig rhs  {% runPV (unECP $3) >>= \ $3 ->+        | PREFIX_PERCENT atype infixexp opt_sig rhs {% runPV (unECP $3) >>= \ $3 ->                                        do { let { l = comb2 $1 $> }-                                          ; r <- checkValDef l $3 (mkMultAnn (epTok $1) $2, $4) $5;+                                          ; r <- checkValDef l $3 (mkMultAnn (epTok $1) $2 EpPatBind, $4) $5;                                         -- parses bindings of the form %p x or                                         -- %p x :: sig                                         --@@ -2700,11 +2730,11 @@                                                       bs)) } }         | gdrhs wherebinds      {% do { let {L l (bs, csw) = adaptWhereBinds $2}                                       ; acs (comb2 $1 (L l bs)) (\loc cs -> L loc-                                                (GRHSs (cs Semi.<> csw) (reverse (unLoc $1)) bs)) }}+                                                (GRHSs (cs Semi.<> csw) (NE.reverse (unLoc $1)) bs)) }} -gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }-        : gdrhs gdrh            { sLL $1 $> ($2 : unLoc $1) }-        | gdrh                  { sL1 $1 [$1] }+gdrhs :: { Located (NonEmpty (LGRHS GhcPs (LHsExpr GhcPs))) }+        : gdrhs gdrh            { sLL $1 $> ($2 NE.<| unLoc $1) }+        | gdrh                  { sL1 $1 (NE.singleton $1) }  gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) }         : '|' guardquals '=' exp  {% runPV (unECP $4) >>= \ $4 ->@@ -2762,16 +2792,21 @@                 ; let str_lit = StringLiteral (getSTRINGs $3) scc Nothing                 ; amsA' (sLL $1 $> (SigD noExtField (SCCFunSig ((glR $1, epTok $4), (getSCC_PRAGs $1)) $2 (Just ( sL1a $3 str_lit))))) }} -        | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'-             {% amsA' (-                 let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)-                                             (NoUserInlinePrag, FunLike) (snd $2)-                  in sLL $1 $> $ SigD noExtField (SpecSig (AnnSpecSig (glR $1) (epTok $6) (epUniTok $4) (fst $2)) $3 (fromOL $5) inl_prag)) }+        | '{-# SPECIALISE' activation rule_foralls infixexp sigtypes_maybe '#-}'+             {% runPV (unECP $4) >>= \ $4 -> do+                let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)+                                              (NoUserInlinePrag, FunLike)+                                              (snd $2)+                spec <- mkSpecSig inl_prag (AnnSpecSig (glR $1) (epTok $6) Nothing (fst $2)) $3 $4 $5+                amsA' $ sLL $1 $> $ SigD noExtField spec } -        | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'-             {% amsA' (sLL $1 $> $ SigD noExtField (SpecSig (AnnSpecSig (glR $1) (epTok $6) (epUniTok $4) (fst $2)) $3 (fromOL $5)-                               (mkInlinePragma (getSPEC_INLINE_PRAGs $1)-                                               (getSPEC_INLINE $1) (snd $2)))) }+        | '{-# SPECIALISE_INLINE' activation rule_foralls infixexp sigtypes_maybe '#-}'+             {% runPV (unECP $4) >>= \ $4 -> do+                let inl_prag = mkInlinePragma (getSPEC_INLINE_PRAGs $1)+                                              (getSPEC_INLINE $1)+                                              (snd $2)+                spec <- mkSpecSig inl_prag (AnnSpecSig (glR $1) (epTok $6) Nothing (fst $2)) $3 $4 $5+                amsA' $ sLL $1 $> $ SigD noExtField spec }          | '{-# SPECIALISE' 'instance' inst_type '#-}'                 {% amsA' (sLL $1 $> $ SigD noExtField (SpecInstSig ((glR $1,epTok $2,epTok $4), (getSPEC_PRAGs $1)) $3)) }@@ -2780,6 +2815,10 @@         | '{-# MINIMAL' name_boolformula_opt '#-}'             {% amsA' (sLL $1 $> $ SigD noExtField (MinimalSig ((glR $1,epTok $3), (getMINIMAL_PRAGs $1)) $2)) } +sigtypes_maybe :: { Maybe (Located (TokDcolon, OrdList (LHsSigType GhcPs))) }+        : '::' sigtypes1         { Just (sLL $1 $> (epUniTok $1, unLoc $2)) }+        | {- empty -}            { Nothing }+ activation :: { (ActivationAnn,Maybe Activation) }         -- See Note [%shift: activation -> {- empty -}]         : {- empty -} %shift                    { (noAnn ,Nothing) }@@ -2797,12 +2836,12 @@  quasiquote :: { Located (HsUntypedSplice GhcPs) }         : TH_QUASIQUOTE   { let { loc = getLoc $1-                                ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1-                                ; quoterId = mkUnqual varName quoter }+                                ; ITquasiQuote (quoter, quoterSpan, quote, quoteSpan) = unLoc $1+                                ; quoterId = L (noAnnSrcSpan (mkSrcSpanPs quoterSpan)) (mkUnqual varName quoter) }                             in sL1 $1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpan (mkSrcSpanPs quoteSpan)) quote)) }         | TH_QQUASIQUOTE  { let { loc = getLoc $1-                                ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1-                                ; quoterId = mkQual varName (qual, quoter) }+                                ; ITqQuasiQuote (qual, quoter, quoterSpan, quote, quoteSpan) = unLoc $1+                                ; quoterId = L (noAnnSrcSpan (mkSrcSpanPs quoterSpan)) (mkQual varName (qual, quoter)) }                             in sL1 $1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpan (mkSrcSpanPs quoteSpan)) quote)) }  exp  :: { ECP } : exp_gen(infixexp)  { $1 }@@ -2855,7 +2894,7 @@                                   withArrowParsingMode' $ \mode ->                                   unECP $1 >>= \ $1 ->                                   unECP $3 >>= \ $3 ->-                                  let arr = HsUnrestrictedArrow (epUniTok $2)+                                  let arr = HsUnannotated (EpArrow (epUniTok $2))                                   in mkHsArrowPV (comb2 $1 $>) mode $1 arr $3 }         | infixexp expmult '->'  infixexp2                                 { ECP $@@ -2870,7 +2909,7 @@                                   hintLinear (getLoc $2) >>                                   unECP $1 >>= \ $1 ->                                   unECP $3 >>= \ $3 ->-                                  let arr = HsLinearArrow (EpLolly (epTok $2))+                                  let arr = HsLinearAnn (EpLolly (epTok $2))                                   in mkHsArrowPV (comb2 $1 $>) ArrowIsFunType $1 arr $3 }         | expcontext    '=>'  infixexp2                                 { ECP $@@ -3049,7 +3088,7 @@                                            fmap ecpFromExp $                                            do { let (L _ ((o,c),_)) = $2                                               ; amsA' (sLL $1 $> $ HsMultiIf (epTok $1, o, c)-                                                     (reverse $ snd $ unLoc $2)) }}+                                                     (NE.reverse $ snd $ unLoc $2)) }}         | 'case' exp 'of' altslist(pats1) {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->                                              return $ ECP $                                                $4 >>= \ $4 ->@@ -3153,7 +3192,7 @@          -- Template Haskell Extension         | splice_untyped { ECP $ mkHsSplicePV $1 }-        | splice_typed   { ecpFromExp $ fmap (uncurry HsTypedSplice) (reLoc $1) }+        | splice_typed   { ecpFromExp $ fmap (HsTypedSplice noExtField) (reLoc $1) }          | SIMPLEQUOTE  qvar     {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket noExtField (VarBr (glR $1) True  $2)) }         | SIMPLEQUOTE  qcon     {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket noExtField (VarBr (glR $1) True  $2)) }@@ -3192,18 +3231,18 @@  splice_exp :: { LHsExpr GhcPs }         : splice_untyped { fmap (HsUntypedSplice noExtField) (reLoc $1) }-        | splice_typed   { fmap (uncurry HsTypedSplice) (reLoc $1) }+        | splice_typed   { fmap (HsTypedSplice noExtField) (reLoc $1) }  splice_untyped :: { Located (HsUntypedSplice GhcPs) }         -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer         : PREFIX_DOLLAR aexp2   {% runPV (unECP $2) >>= \ $2 ->                                    return (sLL $1 $> $ HsUntypedSpliceExpr (epTok $1) $2) } -splice_typed :: { Located (EpToken "$$", LHsExpr GhcPs) }+splice_typed :: { Located (HsTypedSplice GhcPs) }         -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer         : PREFIX_DOLLAR_DOLLAR aexp2                                 {% runPV (unECP $2) >>= \ $2 ->-                                   return (sLL $1 $> $ (epTok $1, $2)) }+                                   return (sLL $1 $> $ (HsTypedSpliceExpr (epTok $1) $2)) }  cmdargs :: { [LHsCmdTop GhcPs] }         : cmdargs acmd                  { $2 : $1 }@@ -3276,8 +3315,8 @@                                 ; return (Tuple (Right t : snd $2)) } }            | commas tup_tail                  { $2 >>= \ $2 ->-                   do { let {cos = map (\ll -> (Left (EpAnn (spanAsAnchor ll) True emptyComments))) (fst $1) }-                      ; return (Tuple (cos ++ $2)) } }+                   do { let {cos = NE.map (\ll -> (Left (EpAnn (spanAsAnchor ll) True emptyComments))) (fst $1) }+                      ; return (Tuple (toList cos ++ $2)) } }             | texp bars   { unECP $1 >>= \ $1 -> return $                             (Sum 1  (snd $2 + 1) $1 [] (fst $2)) }@@ -3357,8 +3396,8 @@ -- List Comprehensions  flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }-    : pquals   { case (unLoc $1) of-                    [qs] -> sL1 $1 qs+    : pquals   { case unLoc $1 of+                    qs:|[] -> sL1 $1 qs                     -- We just had one thing in our "parallel" list so                     -- we simply return that thing directly @@ -3369,30 +3408,30 @@                     -- we wrap them into as a ParStmt                 } -pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] }+pquals :: { Located (NonEmpty [LStmt GhcPs (LHsExpr GhcPs)]) }     : squals '|' pquals                      {% case unLoc $1 of-                          (h:t) -> do+                          h:|t -> do                             h' <- addTrailingVbarA h (epTok $2)-                            return (sLL $1 $> (reverse (h':t) : unLoc $3)) }-    | squals         { L (getLoc $1) [reverse (unLoc $1)] }+                            return (sLL $1 $> (reverse (h':t) NE.<| unLoc $3)) }+    | squals         { L (getLoc $1) (NE.singleton (reverse (toList (unLoc $1)))) } -squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }   -- In reverse order, because the last+squals :: { Located (NonEmpty (LStmt GhcPs (LHsExpr GhcPs))) }   -- In reverse order, because the last                                         -- one can "grab" the earlier ones     : squals ',' transformqual              {% case unLoc $1 of-                  (h:t) -> do+                  h:|t -> do                     h' <- addTrailingCommaA h (epTok $2)-                    return (sLL $1 $> [sLLa $1 $> ((unLoc $3) (reverse (h':t)))]) }+                    return (sLL $1 $> (NE.singleton (sLLa $1 $> ((unLoc $3) (reverse (h':t)))))) }     | squals ',' qual              {% runPV $3 >>= \ $3 ->                 case unLoc $1 of-                  (h:t) -> do+                  h:|t -> do                     h' <- addTrailingCommaA h (epTok $2)-                    return (sLL $1 $> ($3 : (h':t))) }-    | transformqual        { sLL $1 $> [L (getLocAnn $1) ((unLoc $1) [])] }+                    return (sLL $1 $> ($3 :| (h':t))) }+    | transformqual        { sLL $1 $> (NE.singleton (L (getLocAnn $1) ((unLoc $1) []))) }     | qual                               {% runPV $1 >>= \ $1 ->-                                            return $ sL1 $1 [$1] }+                                            return $ sL1 $1 (NE.singleton $1) } --  | transformquals1 ',' '{|' pquals '|}'   { sLL $1 $> ($4 : unLoc $1) } --  | '{|' pquals '|}'                       { sL1 $1 [$2] } @@ -3489,22 +3528,22 @@                                       do { let {L l (bs, csw) = adaptWhereBinds $2}                                          ; acs (comb2 alt (L l bs)) (\loc cs -> L loc (GRHSs (cs Semi.<> csw) (unLoc alt) bs)) }} -ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }+ralt :: { forall b. DisambECP b => PV (Located (NonEmpty (LGRHS GhcPs (LocatedA b)))) }         : '->' exp            { unECP $2 >>= \ $2 ->                                 acs (comb2 $1 $>) (\loc cs -> L loc (unguardedRHS (EpAnn (spanAsAnchor $ comb2 $1 $2) (GrhsAnn Nothing (Right $ epUniTok $1)) cs) (comb2 $1 $2) $2)) }         | gdpats              { $1 >>= \gdpats ->-                                return $ sL1 gdpats (reverse (unLoc gdpats)) }+                                return $ sL1 gdpats (NE.reverse (unLoc gdpats)) } -gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }+gdpats :: { forall b. DisambECP b => PV (Located (NonEmpty (LGRHS GhcPs (LocatedA b)))) }         : gdpats gdpat { $1 >>= \gdpats ->                          $2 >>= \gdpat ->-                         return $ sLL gdpats gdpat (gdpat : unLoc gdpats) }-        | gdpat        { $1 >>= \gdpat -> return $ sL1 gdpat [gdpat] }+                         return $ sLL gdpats gdpat (gdpat NE.<| unLoc gdpats) }+        | gdpat        { $1 >>= \gdpat -> return $ sL1 gdpat (NE.singleton gdpat) }  -- layout for MultiWayIf doesn't begin with an open brace, because it's hard to -- generate the open brace in addition to the vertical bar in the lexer, and -- we don't need it.-ifgdpats :: { Located ((EpToken "{", EpToken "}"), [LGRHS GhcPs (LHsExpr GhcPs)]) }+ifgdpats :: { Located ((EpToken "{", EpToken "}"), NonEmpty (LGRHS GhcPs (LHsExpr GhcPs))) }          : '{' gdpats '}'                 {% runPV $2 >>= \ $2 ->                                              return $ sLL $1 $> ((epTok $1,epTok $3),unLoc $2)  }          |     gdpats close               {% runPV $1 >>= \ $1 ->@@ -3647,7 +3686,7 @@                             let top = sL1a $1 $ DotFieldOcc noAnn $1                                 ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3)                                 lf' = comb2 $2 (L lf ())-                                fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (AnnFieldLabel (Just $ epTok $2))  f) : t+                                fields = top :| L (noAnnSrcSpan lf') (DotFieldOcc (AnnFieldLabel (Just $ epTok $2))  f) : t                                 final = last fields                                 l = comb2 $1 $3                                 isPun = False@@ -3663,7 +3702,7 @@                             let top =  sL1a $1 $ DotFieldOcc noAnn $1                                 ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3)                                 lf' = comb2 $2 (L lf ())-                                fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (AnnFieldLabel (Just $ epTok $2)) f) : t+                                fields = top :| L (noAnnSrcSpan lf') (DotFieldOcc (AnnFieldLabel (Just $ epTok $2)) f) : t                                 final = last fields                                 l = comb2 $1 $3                                 isPun = True@@ -3710,27 +3749,27 @@ ----------------------------------------------------------------------------- -- Warnings and deprecations -name_boolformula_opt :: { LBooleanFormula (LocatedN RdrName) }+name_boolformula_opt :: { LBooleanFormula GhcPs }         : name_boolformula          { $1 }         | {- empty -}               { noLocA mkTrue } -name_boolformula :: { LBooleanFormula (LocatedN RdrName) }-        : name_boolformula_and                      { $1 }+name_boolformula :: { LBooleanFormula GhcPs }+        : name_boolformula_and      { $1 }         | name_boolformula_and '|' name_boolformula                            {% do { h <- addTrailingVbarL $1 (epTok $2)                                  ; return (sLLa $1 $> (Or [h,$3])) } } -name_boolformula_and :: { LBooleanFormula (LocatedN RdrName) }+name_boolformula_and :: { LBooleanFormula GhcPs }         : name_boolformula_and_list-                  { sLLa (head $1) (last $1) (And ($1)) }+                  { sLLa (head $1) (last $1) (And (toList $1)) } -name_boolformula_and_list :: { [LBooleanFormula (LocatedN RdrName)] }-        : name_boolformula_atom                               { [$1] }+name_boolformula_and_list :: { NonEmpty (LBooleanFormula GhcPs) }+        : name_boolformula_atom                               { NE.singleton $1 }         | name_boolformula_atom ',' name_boolformula_and_list             {% do { h <- addTrailingCommaL $1 (epTok $2)-                  ; return (h : $3) } }+                  ; return (h NE.<| $3) } } -name_boolformula_atom :: { LBooleanFormula (LocatedN RdrName) }+name_boolformula_atom :: { LBooleanFormula GhcPs }         : '(' name_boolformula ')'  {% amsr (sLL $1 $> (Parens $2))                                       (AnnList Nothing (ListParens (epTok $1) (epTok $3)) [] noAnn []) }         | name_var                  { sL1a $1 (Var $1) }@@ -3776,10 +3815,10 @@ -- See Note [ExplicitTuple] in GHC.Hs.Expr sysdcon_nolist :: { LocatedN DataCon }  -- Wired in data constructors         : '(' commas ')'        {% amsr (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1))-                                       (NameAnnCommas (NameParens (epTok $1) (epTok $3)) (map (EpTok . srcSpan2e) (fst $2)) []) }+                                       (NameAnnCommas (NameParens (epTok $1) (epTok $3)) (map (EpTok . srcSpan2e) (toList $ fst $2)) []) }         | '(#' '#)'             {% amsr (sLL $1 $> $ unboxedUnitDataCon) (NameAnnOnly (NameParensHash (epTok $1) (epTok $2)) []) }         | '(#' commas '#)'      {% amsr (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1))-                                       (NameAnnCommas (NameParensHash (epTok $1) (epTok $3)) (map (EpTok . srcSpan2e) (fst $2)) []) }+                                       (NameAnnCommas (NameParensHash (epTok $1) (epTok $3)) (map (EpTok . srcSpan2e) (toList $ fst $2)) []) }  syscon :: { LocatedN RdrName }         : sysdcon               {  L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }@@ -3820,12 +3859,12 @@ ntgtycon :: { LocatedN RdrName }  -- A "general" qualified tycon, excluding unit tuples         : oqtycon               { $1 }         | '(' commas ')'        {% do { n <- mkTupleSyntaxTycon Boxed (snd $2 + 1)-                                      ; amsr (sLL $1 $> n) (NameAnnCommas (NameParens (epTok $1) (epTok $3)) (map (EpTok . srcSpan2e) (fst $2)) []) }}+                                      ; amsr (sLL $1 $> n) (NameAnnCommas (NameParens (epTok $1) (epTok $3)) (map (EpTok . srcSpan2e) (toList $ fst $2)) []) }}         | '(#' commas '#)'      {% do { n <- mkTupleSyntaxTycon Unboxed (snd $2 + 1)-                                      ; amsr (sLL $1 $> n) (NameAnnCommas (NameParensHash (epTok $1) (epTok $3)) (map (EpTok . srcSpan2e) (fst $2)) []) }}+                                      ; amsr (sLL $1 $> n) (NameAnnCommas (NameParensHash (epTok $1) (epTok $3)) (map (EpTok . srcSpan2e) (toList $ fst $2)) []) }}         | '(#' bars '#)'        {% do { requireLTPuns PEP_SumSyntaxType $1 $>                                       ; amsr (sLL $1 $> $ (getRdrName (sumTyCon (snd $2 + 1))))-                                       (NameAnnBars (epTok $1, epTok $3) (fst $2) []) } }+                                       (NameAnnBars (epTok $1, epTok $3) (toList $ fst $2) []) } }         | '(' '->' ')'          {% amsr (sLL $1 $> $ getRdrName unrestrictedFunTyCon)                                        (NameAnnRArrow  (Just $ epTok $1) (epUniTok $2) (Just $ epTok $3) []) } @@ -3925,8 +3964,9 @@         | qconop                { mkHsConOpPV $1 }         | hole_op               { mkHsInfixHolePV $1 } -hole_op :: { LocatedN (HsExpr GhcPs) }   -- used in sections-hole_op : '`' '_' '`'           { sLLa $1 $> (hsHoleExpr (Just $ EpAnnUnboundVar (epTok $1, epTok $3) (epTok $2))) }+hole_op :: { LocatedN RdrName }   -- used in sections+hole_op : '`' '_' '`'           {% amsr (sLL $1 $> (mkUnqual varName (fsLit "_")))+                                           (NameAnn (NameBackquotes (epTok $1) (epTok $3)) (glR $2) []) }  qvarop :: { LocatedN RdrName }         : qvarsym               { $1 }@@ -4044,7 +4084,10 @@         | 'unit'                { sL1 $1 (fsLit "unit") }         | 'dependency'          { sL1 $1 (fsLit "dependency") }         | 'signature'           { sL1 $1 (fsLit "signature") }+        | 'quote'               { sL1 $1 (fsLit "quote") }+        | 'splice'              { sL1 $1 (fsLit "splice") } + special_sym :: { Located FastString } special_sym : '.'       { sL1 $1 (fsLit ".") }             | '*'       { sL1 $1 (starSym (isUnicode $1)) }@@ -4154,9 +4197,9 @@                                    (concatFS [mod, fsLit ".", c])                                 } -commas :: { ([SrcSpan],Int) }   -- One or more commas-        : commas ','             { ((fst $1)++[gl $2],snd $1 + 1) }-        | ','                    { ([gl $1],1) }+commas :: { (NonEmpty SrcSpan,Int) }   -- One or more commas+        : commas ','             { (foldr (NE.<|) (NE.singleton $ gl $2) (fst $1) ,snd $1 + 1) }+        | ','                    { (NE.singleton $ gl $1, 1) }  bars0 :: { ([EpToken "|"],Int) }     -- Zero or more bars         : bars                   { $1 }@@ -4247,6 +4290,7 @@ getCTYPEs             (L _ (ITctype             src)) = src  getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) Nothing+getStringMultiLiteral l = StringLiteral (getSTRINGMULTIs l) (getSTRINGMULTI l) Nothing  isUnicode :: Located Token -> Bool isUnicode (L _ (ITforall         iu)) = iu == UnicodeSyntax@@ -4300,6 +4344,14 @@     combineSrcSpans (getHasLoc b) $     combineSrcSpans (getHasLoc c) $     combineSrcSpans (getHasLoc d) (getHasLoc e)++comb6 :: (HasLoc a, HasLoc b, HasLoc c, HasLoc d, HasLoc e, HasLoc f) => a -> b -> c -> d -> e -> f -> SrcSpan+comb6 !a !b !c !d !e !f =+    combineSrcSpans (getHasLoc a) $+    combineSrcSpans (getHasLoc b) $+    combineSrcSpans (getHasLoc c) $+    combineSrcSpans (getHasLoc d) $+    combineSrcSpans (getHasLoc e) (getHasLoc f)  -- strict constructor version: {-# INLINE sL #-}
compiler/GHC/Parser/Annotation.hs view
@@ -10,6 +10,7 @@   -- * Core Exact Print Annotation types   EpToken(..), EpUniToken(..),   getEpTokenSrcSpan,+  getEpTokenBufSpan,   getEpTokenLocs, getEpTokenLoc, getEpUniTokenLoc,   TokDcolon, TokDarrow, TokRarrow, TokForall,   EpLayout(..),@@ -19,7 +20,6 @@    -- * In-tree Exact Print Annotations   EpaLocation, EpaLocation'(..), epaLocationRealSrcSpan,-  TokenLocation(..),   DeltaPos(..), deltaPos, getDeltaLine,    EpAnn(..),@@ -65,7 +65,6 @@   srcSpan2e, realSrcSpan,    -- ** Building up annotations-  reAnnL, reAnnC,   addAnnsA, widenSpanL, widenSpanT, widenAnchorT, widenAnchorS,   widenLocatedAnL,   listLocation,@@ -93,7 +92,6 @@   noComments, comment, addCommentsToEpAnn, setCommentsEpAnn,   transferAnnsA, transferAnnsOnlyA, transferCommentsOnlyA,   transferPriorCommentsA, transferFollowingA,-  commentsOnlyA, removeCommentsA,    placeholderRealSpan,   ) where@@ -102,13 +100,14 @@  import Data.Data import Data.Function (on)-import Data.List (sortBy, foldl1')+import Data.List (sortBy) import Data.Semigroup import GHC.Data.FastString import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Hs.DocString+import GHC.Utils.Misc import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic import qualified GHC.Data.Strict as Strict@@ -254,6 +253,11 @@ getEpTokenSrcSpan (EpTok EpaDelta{}) = noSrcSpan getEpTokenSrcSpan (EpTok (EpaSpan span)) = span +getEpTokenBufSpan :: EpToken tok -> Strict.Maybe BufSpan+getEpTokenBufSpan NoEpTok = Strict.Nothing+getEpTokenBufSpan (EpTok EpaDelta{}) = Strict.Nothing+getEpTokenBufSpan (EpTok (EpaSpan span)) = getBufSpan span+ getEpTokenLocs :: [EpToken tok] -> [EpaLocation] getEpTokenLocs ls = concatMap go ls   where@@ -340,14 +344,6 @@ noCommentsToEpaLocation (EpaSpan ss) = EpaSpan ss noCommentsToEpaLocation (EpaDelta ss dp NoComments) = EpaDelta ss dp [] --- | Tokens embedded in the AST have an EpaLocation, unless they come from--- generated code (e.g. by TH).-data TokenLocation = NoTokenLoc | TokenLoc !EpaLocation-               deriving (Data,Eq)--instance Outputable a => Outputable (GenLocated TokenLocation a) where-  ppr (L _ x) = ppr x- -- | Used in the parser only, extract the 'RealSrcSpan' from an -- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the -- partial function is safe.@@ -489,7 +485,9 @@  So -  type instance XRec (GhcPass p) a = GenLocated (Anno a) a+  type instance XRec (GhcPass p) a = XRecGhc a+  type XRecGhc a = GenLocated (Anno a) a+   type instance Anno RdrName = SrcSpanAnnN   type LocatedN = GenLocated SrcSpanAnnN @@ -908,8 +906,7 @@   getHasLoc (EpUniTok l _) = getHasLoc l  getHasLocList :: HasLoc a => [a] -> SrcSpan-getHasLocList [] = noSrcSpan-getHasLocList xs = foldl1' combineSrcSpans $ map getHasLoc xs+getHasLocList = foldl1WithDefault' noSrcSpan combineSrcSpans . map getHasLoc  -- --------------------------------------------------------------------- @@ -923,12 +920,6 @@ srcSpan2e ss@(RealSrcSpan _ _) = EpaSpan ss srcSpan2e span = EpaSpan (RealSrcSpan (realSrcSpan span) Strict.Nothing) -reAnnC :: AnnContext -> EpAnnComments -> Located a -> LocatedC a-reAnnC anns cs (L l a) = L (EpAnn (spanAsAnchor l) anns cs) a--reAnnL :: ann -> EpAnnComments -> Located e -> GenLocated (EpAnn ann) e-reAnnL anns cs (L l a) = L (EpAnn (spanAsAnchor l) anns cs) a- getLocAnn :: Located a  -> SrcSpanAnnA getLocAnn (L l _) = noAnnSrcSpan l @@ -1087,16 +1078,6 @@     fc = getFollowingComments cs1     cs1' = setFollowingComments emptyComments fc     cs2' = setPriorComments cs2 (priorComments cs2 <> pc)----- | Remove the exact print annotations payload, leaving only the--- anchor and comments.-commentsOnlyA :: NoAnn ann => EpAnn ann -> EpAnn ann-commentsOnlyA (EpAnn a _ cs) = EpAnn a noAnn cs---- | Remove the comments, leaving the exact print annotations payload-removeCommentsA :: EpAnn ann -> EpAnn ann-removeCommentsA (EpAnn a an _) = EpAnn a an emptyComments  -- --------------------------------------------------------------------- -- Semigroup instances, to allow easy combination of annotation elements
compiler/GHC/Parser/Errors/Ppr.hs view
@@ -33,7 +33,6 @@ import GHC.Hs.Expr (prependQualified, HsExpr(..), HsLamVariant(..), lamCaseKeyword) import GHC.Hs.Type (pprLHsContext, pprHsArrow, pprHsForAll) import GHC.Builtin.Names (allNameStringList)-import GHC.Builtin.Types (filterCTuple) import qualified GHC.LanguageExtensions as LangExt import Data.List.NonEmpty (NonEmpty((:|))) import GHC.Hs.Pat (Pat(..), LPat)@@ -44,7 +43,7 @@ instance Diagnostic PsMessage where   type DiagnosticOpts PsMessage = NoDiagnosticOpts   diagnosticMessage opts = \case-    PsUnknownMessage (UnknownDiagnostic f m)+    PsUnknownMessage (UnknownDiagnostic f _ m)       -> diagnosticMessage (f opts) m      PsHeaderMessage m@@ -274,10 +273,15 @@                   2 (pprWithCommas ppr vs)                 , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details."                 ]-    PsErrIllegalExplicitNamespace+    PsErrIllegalExplicitNamespace kw       -> mkSimpleDecorated $-           text "Illegal keyword 'type'"+           text "Illegal keyword" <+> quotes kw_doc+         where+           kw_doc = case kw of+             ExplicitTypeNamespace{} -> text "type"+             ExplicitDataNamespace{} -> text "data" +     PsErrUnallowedPragma prag       -> mkSimpleDecorated $            hang (text "A pragma is not allowed in this position:") 2@@ -288,6 +292,8 @@              <+> text "in postpositive position. "     PsErrImportQualifiedTwice       -> mkSimpleDecorated $ text "Multiple occurrences of 'qualified'"+    PsErrSpliceOrQuoteTwice+      -> mkSimpleDecorated $ text "Multiple occurrences of a splice or quote keyword"     PsErrIllegalImportBundleForm       -> mkSimpleDecorated $            text "Illegal import form, this syntax can only be used to bundle"@@ -462,12 +468,6 @@       -> let msg  = parse_error_in_pat              body = case details of                  PEIP_NegApp -> text "-" <> ppr s-                 PEIP_TypeArgs peipd_tyargs-                   | not (null peipd_tyargs) -> ppr s <+> vcat [-                               hsep (map ppr peipd_tyargs)-                             , text "Type applications in patterns are only allowed on data constructors."-                             ]-                   | otherwise -> ppr s                  PEIP_OtherPatDetails (ParseContext (Just fun) _)                   -> ppr s <+> text "In a function binding for the"                                      <+> quotes (ppr fun)@@ -497,19 +497,14 @@        -> mkSimpleDecorated $             vcat [ text "Unexpected type" <+> quotes (ppr t)                  , text "In the" <+> what-                   <+> text "declaration for" <+> quotes tc'+                   <+> text "declaration for" <+> quotes (ppr tc)                  , vcat[ (text "A" <+> what                           <+> text "declaration should have form")                  , nest 2                    (what-                    <+> tc'+                    <+> ppr tc                     <+> hsep (map text (takeList tparms allNameStringList))                     <+> equals_or_where) ] ]-           where-             -- Avoid printing a constraint tuple in the error message. Print-             -- a plain old tuple instead (since that's what the user probably-             -- wrote). See #14907-             tc' = ppr $ filterCTuple tc     PsErrInvalidPackageName pkg       -> mkSimpleDecorated $ vcat             [ text "Parse error" <> colon <+> quotes (ftext pkg)@@ -571,6 +566,18 @@     PsErrIllegalOrPat pat       -> mkSimpleDecorated $ vcat [text "Illegal or-pattern:" <+> ppr (unLoc pat)] +    PsErrSpecExprMultipleTypeAscription+      -> mkSimpleDecorated $+           text "SPECIALISE expression doesn't support multiple type ascriptions"++    PsWarnSpecMultipleTypeAscription+      -> mkSimpleDecorated $+           text "SPECIALISE pragmas with multiple type ascriptions are deprecated, and will be removed in GHC 9.18"++    PsWarnPatternNamespaceSpecifier _explicit_namespaces+      -> mkSimpleDecorated $+          text "The" <+> quotes (text "pattern") <+> "namespace specifier is deprecated."+   diagnosticReason  = \case     PsUnknownMessage m                            -> diagnosticReason m     PsHeaderMessage  m                            -> psHeaderMessageReason m@@ -617,10 +624,11 @@     PsErrNoSingleWhereBindInPatSynDecl{}          -> ErrorWithoutFlag     PsErrDeclSpliceNotAtTopLevel{}                -> ErrorWithoutFlag     PsErrMultipleNamesInStandaloneKindSignature{} -> ErrorWithoutFlag-    PsErrIllegalExplicitNamespace                 -> ErrorWithoutFlag+    PsErrIllegalExplicitNamespace{}               -> ErrorWithoutFlag     PsErrUnallowedPragma{}                        -> ErrorWithoutFlag     PsErrImportPostQualified                      -> ErrorWithoutFlag     PsErrImportQualifiedTwice                     -> ErrorWithoutFlag+    PsErrSpliceOrQuoteTwice                       -> ErrorWithoutFlag     PsErrIllegalImportBundleForm                  -> ErrorWithoutFlag     PsErrInvalidRuleActivationMarker              -> ErrorWithoutFlag     PsErrMissingBlock                             -> ErrorWithoutFlag@@ -689,6 +697,9 @@     PsErrInvalidPun {}                            -> ErrorWithoutFlag     PsErrIllegalOrPat{}                           -> ErrorWithoutFlag     PsErrTypeSyntaxInPat{}                        -> ErrorWithoutFlag+    PsErrSpecExprMultipleTypeAscription{}         -> ErrorWithoutFlag+    PsWarnSpecMultipleTypeAscription{}            -> WarningWithFlag Opt_WarnDeprecatedPragmas+    PsWarnPatternNamespaceSpecifier{}             -> WarningWithFlag Opt_WarnPatternNamespaceSpecifier    diagnosticHints = \case     PsUnknownMessage m                            -> diagnosticHints m@@ -753,10 +764,11 @@     PsErrNoSingleWhereBindInPatSynDecl{}          -> noHints     PsErrDeclSpliceNotAtTopLevel{}                -> noHints     PsErrMultipleNamesInStandaloneKindSignature{} -> noHints-    PsErrIllegalExplicitNamespace                 -> [suggestExtension LangExt.ExplicitNamespaces]+    PsErrIllegalExplicitNamespace{}               -> [suggestExtension LangExt.ExplicitNamespaces]     PsErrUnallowedPragma{}                        -> noHints     PsErrImportPostQualified                      -> [suggestExtension LangExt.ImportQualifiedPost]     PsErrImportQualifiedTwice                     -> noHints+    PsErrSpliceOrQuoteTwice                       -> noHints     PsErrIllegalImportBundleForm                  -> noHints     PsErrInvalidRuleActivationMarker              -> noHints     PsErrMissingBlock                             -> noHints@@ -858,8 +870,16 @@     PsErrInvalidPun {}                            -> [suggestExtension LangExt.ListTuplePuns]     PsErrIllegalOrPat{}                           -> [suggestExtension LangExt.OrPatterns]     PsErrTypeSyntaxInPat{}                        -> noHints+    PsErrSpecExprMultipleTypeAscription {}        -> [SuggestSplittingIntoSeveralSpecialisePragmas]+    PsWarnSpecMultipleTypeAscription{}            -> [SuggestSplittingIntoSeveralSpecialisePragmas]+    PsWarnPatternNamespaceSpecifier explicit_namespaces+      | explicit_namespaces -> [SuggestDataKeyword]+      | otherwise ->+          let info = text "and replace" <+> quotes (text "pattern")+                        <+> text "with" <+> quotes (text "data") <> "."+          in [useExtensionInOrderTo info LangExt.ExplicitNamespaces] -  diagnosticCode = constructorCode+  diagnosticCode = constructorCode @GHC  psHeaderMessageDiagnostic :: PsHeaderMessage -> DecoratedSDoc psHeaderMessageDiagnostic = \case
compiler/GHC/Parser/Errors/Types.hs view
@@ -69,7 +69,7 @@         arbitrary messages to be embedded. The typical use case would be GHC plugins         willing to emit custom diagnostics.     -}-    PsUnknownMessage (UnknownDiagnostic (DiagnosticOpts PsMessage))+    PsUnknownMessage (UnknownDiagnosticFor PsMessage)      {-| A group of parser messages emitted in 'GHC.Parser.Header'.         See Note [Messages from GHC.Parser.Header].@@ -207,11 +207,14 @@    -- | Import: multiple occurrences of 'qualified'    | PsErrImportQualifiedTwice +   -- | Multiple occurrences of a splice or quote keyword+   | PsErrSpliceOrQuoteTwice+    -- | Post qualified import without 'ImportQualifiedPost'    | PsErrImportPostQualified     -- | Explicit namespace keyword without 'ExplicitNamespaces'-   | PsErrIllegalExplicitNamespace+   | PsErrIllegalExplicitNamespace !ExplicitNamespaceKeyword     -- | Expecting a type constructor but found a variable    | PsErrVarForTyCon !RdrName@@ -466,7 +469,7 @@    | PsErrParseRightOpSectionInPat !RdrName !(PatBuilder GhcPs)     -- | Illegal linear arrow or multiplicity annotation in GADT record syntax-   | PsErrIllegalGadtRecordMultiplicity !(HsArrow GhcPs)+   | PsErrIllegalGadtRecordMultiplicity !(HsMultAnn GhcPs)     | PsErrInvalidCApiImport @@ -491,6 +494,27 @@    --               T24159_pat_parse_error_6    | PsErrTypeSyntaxInPat !PsErrTypeSyntaxDetails +   -- | 'PsErrSpecExprMultipleTypeAscription' is an error that occurs when+   -- a user attempts to use the new form SPECIALISE pragma syntax with+   -- multiple type signatures, e.g.+   --+   -- @{-# SPECIALISE foo 3 :: Float -> Float; Double -> Double #-}+   | PsErrSpecExprMultipleTypeAscription++   -- | 'PsWarnSpecMultipleTypeAscription' is a warning that occurs when+   -- a user uses the old-form SPECIALISE pragma syntax with+   -- multiple type signatures, e.g.+   --+   -- @{-# SPECIALISE bar :: Float -> Float; Double -> Double #-}+   --+   -- This constructor is deprecated and will be removed in GHC 9.18.+   | PsWarnSpecMultipleTypeAscription++   -- | The deprecated ``pattern`` namespace specifier was used in an import or+   -- export list. Suggested fix: use the ``data`` keyword instead.+   | PsWarnPatternNamespaceSpecifier+      !Bool -- ^ Is ExplicitNamespaces on?+    deriving Generic  -- | Extra details about a parse error, which helps@@ -539,8 +563,6 @@ data PsErrInPatDetails   = PEIP_NegApp     -- ^ Negative application pattern?-  | PEIP_TypeArgs [HsConPatTyArg GhcPs]-    -- ^ The list of type arguments for the pattern   | PEIP_RecPattern [LPat GhcPs]    -- ^ The pattern arguments                     !PatIsRecursive -- ^ Is the parsed pattern recursive?                     !ParseContext@@ -554,7 +576,7 @@ data PsErrTypeSyntaxDetails   = PETS_FunctionArrow       !(LocatedA (PatBuilder GhcPs))-      !(HsArrowOf (LocatedA (PatBuilder GhcPs)) GhcPs)+      !(HsMultAnnOf (LocatedA (PatBuilder GhcPs)) GhcPs)       !(LocatedA (PatBuilder GhcPs))   | PETS_Multiplicity       !(EpToken "%")
compiler/GHC/Parser/HaddockLex.x view
@@ -176,7 +176,6 @@       pflags = mkParserOpts                  (EnumSet.fromList [LangExt.MagicHash])                  dopts-                 []                  False False False False       dopts = emptyDiagOpts       buffer = stringBufferFromByteString str0
compiler/GHC/Parser/Header.hs view
@@ -31,7 +31,6 @@ import GHC.Parser.Lexer  import GHC.Hs-import GHC.Unit.Module import GHC.Builtin.Names  import GHC.Types.Error@@ -39,6 +38,7 @@ import GHC.Types.SourceError import GHC.Types.SourceText import GHC.Types.PkgQual+import GHC.Types.Basic (ImportLevel(..), convImportLevel)  import GHC.Utils.Misc import GHC.Utils.Panic@@ -74,9 +74,8 @@                            --   in the function result)            -> IO (Either                (Messages PsMessage)-               ([(RawPkgQual, Located ModuleName)],-                [(RawPkgQual, Located ModuleName)],-                Bool, -- Is GHC.Prim imported or not+               ([Located ModuleName],+                [(ImportLevel, RawPkgQual, Located ModuleName)],                 Located ModuleName))               -- ^ The source imports and normal imports (with optional package               -- names from -XPackageImports), and the module name.@@ -101,21 +100,17 @@                 mod = mb_mod `orElse` L (noAnnSrcSpan main_loc) mAIN_NAME                 (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps -               -- GHC.Prim doesn't exist physically, so don't go looking for it.-                (ordinary_imps, ghc_prim_import)-                  = partition ((/= moduleName gHC_PRIM) . unLoc-                                  . ideclName . unLoc)-                                 ord_idecls-                 implicit_imports = mkPrelImports (unLoc mod) main_loc                                                  implicit_prelude imps-                convImport (L _ i) = (ideclPkgQual i, reLoc $ ideclName i)+                convImport (L _ (i :: ImportDecl GhcPs)) = (convImportLevel (ideclLevelSpec i), ideclPkgQual i, reLoc $ ideclName i)+                convImport_src (L _ (i :: ImportDecl GhcPs)) = (reLoc $ ideclName i)               in-              return (map convImport src_idecls-                     , map convImport (implicit_imports ++ ordinary_imps)-                     , not (null ghc_prim_import)+              return (map convImport_src src_idecls+                     , map convImport (implicit_imports ++ ord_idecls)                      , reLoc mod) ++ mkPrelImports :: ModuleName               -> SrcSpan    -- Attribute the "import Prelude" to this location               -> Bool -> [LImportDecl GhcPs]@@ -134,13 +129,17 @@   where       explicit_prelude_import = any is_prelude_import import_decls -      is_prelude_import (L _ decl) =+      is_prelude_import (L _ (decl::ImportDecl GhcPs)) =         unLoc (ideclName decl) == pRELUDE_NAME         -- See #17045, package qualified imports are never counted as         -- explicit prelude imports         && case ideclPkgQual decl of             NoRawPkgQual -> True             RawPkgQual {} -> False+        -- Only a "normal" level import will override the implicit prelude import.+        && case ideclLevelSpec decl of+              NotLevelled -> True+              _ -> False         loc' = noAnnSrcSpan loc@@ -157,6 +156,7 @@                                 ideclSafe      = False,  -- Not a safe import                                 ideclQualified = NotQualified,                                 ideclAs        = Nothing,+                                ideclLevelSpec = NotLevelled,                                 ideclImportList = Nothing  }  --------------------------------------------------------------@@ -167,14 +167,15 @@ -- -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) getOptionsFromFile :: ParserOpts+                   -> [String] -- ^ Supported LANGUAGE pragmas                    -> FilePath            -- ^ Input file                    -> IO (Messages PsMessage, [Located String]) -- ^ Parsed options, if any.-getOptionsFromFile opts filename+getOptionsFromFile opts supported filename     = Exception.bracket               (openBinaryFile filename ReadMode)               (hClose)               (\handle -> do-                  (warns, opts) <- fmap (getOptions' opts)+                  (warns, opts) <- fmap (getOptions' opts supported)                                (lazyGetToks opts' filename handle)                   seqList opts                     $ seqList (bagToList $ getMessages warns)@@ -248,20 +249,22 @@ -- -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) getOptions :: ParserOpts+           -> [String] -- ^ Supported LANGUAGE pragmas            -> StringBuffer -- ^ Input Buffer            -> FilePath     -- ^ Source filename.  Used for location info.            -> (Messages PsMessage,[Located String]) -- ^ warnings and parsed options.-getOptions opts buf filename-    = getOptions' opts (getToks opts filename buf)+getOptions opts supported buf filename+    = getOptions' opts supported (getToks opts filename buf)  -- The token parser is written manually because Happy can't -- return a partial result when it encounters a lexer error. -- We want to extract options before the buffer is passed through -- CPP, so we can't use the same trick as 'getImports'. getOptions' :: ParserOpts+            -> [String]             -> [Located Token]      -- Input buffer             -> (Messages PsMessage,[Located String])     -- Options.-getOptions' opts toks+getOptions' opts supported toks     = parseToks toks     where           parseToks (open:close:xs)@@ -273,7 +276,7 @@                   Right args -> fmap (args ++) (parseToks xs)             where               src_span      = getLoc open-              real_src_span = expectJust "getOptions'" (srcSpanToRealSrcSpan src_span)+              real_src_span = expectJust (srcSpanToRealSrcSpan src_span)               starting_loc  = realSrcSpanStart real_src_span           parseToks (open:close:xs)               | ITinclude_prag str <- unLoc open@@ -295,7 +298,7 @@           parseToks xs = (unionManyMessages $ mapMaybe mkMessage xs ,[])            parseLanguage ((L loc (ITconid fs)):rest)-              = fmap (checkExtension opts (L loc fs) :) $+              = fmap (checkExtension supported (L loc fs) :) $                 case rest of                   (L _loc ITcomma):more -> parseLanguage more                   (L _loc ITclose_prag):more -> parseToks more@@ -445,13 +448,13 @@  ----------------------------------------------------------------------------- -checkExtension :: ParserOpts -> Located FastString -> Located String-checkExtension opts (L l ext)+checkExtension :: [String] -> Located FastString -> Located String+checkExtension supported (L l ext) -- Checks if a given extension is valid, and if so returns -- its corresponding flag. Otherwise it throws an exception.-  = if ext' `elem` (pSupportedExts opts)+  = if ext' `elem` supported     then L l ("-X"++ext')-    else unsupportedExtnError opts l ext'+    else unsupportedExtnError supported l ext'   where     ext' = unpackFS ext @@ -459,9 +462,9 @@ languagePragParseError loc =     throwErr loc $ PsErrParseLanguagePragma -unsupportedExtnError :: ParserOpts -> SrcSpan -> String -> a-unsupportedExtnError opts loc unsup =-    throwErr loc $ PsErrUnsupportedExt unsup (pSupportedExts opts)+unsupportedExtnError :: [String] -> SrcSpan -> String -> a+unsupportedExtnError supported loc unsup =+    throwErr loc $ PsErrUnsupportedExt unsup supported  optionsParseError :: String -> SrcSpan -> a     -- #15053 optionsParseError str loc =
compiler/GHC/Parser/Lexer.x view
@@ -947,15 +947,18 @@   | ITdollar                            --  prefix $   | ITdollardollar                      --  prefix $$   | ITtyQuote                           --  ''-  | ITquasiQuote (FastString,FastString,PsSpan)-    -- ITquasiQuote(quoter, quote, loc)+  | ITquasiQuote (FastString, PsSpan, FastString, PsSpan)+    -- ITquasiQuote(quoter, quoter_loc, quote, quote_loc)     -- represents a quasi-quote of the form     -- [quoter| quote |]-  | ITqQuasiQuote (FastString,FastString,FastString,PsSpan)-    -- ITqQuasiQuote(Qual, quoter, quote, loc)+  | ITqQuasiQuote (FastString,FastString,PsSpan, FastString, PsSpan)+    -- ITqQuasiQuote(Qual, quoter, quoter_loc, quote, quote_loc)     -- represents a qualified quasi-quote of the form     -- [Qual.quoter| quote |] +  | ITsplice+  | ITquote+   -- Arrow notation extension   | ITproc   | ITrec@@ -1095,7 +1098,9 @@           ( "rec",            ITrec,           xbit ArrowsBit .|.                                               xbit RecursiveDoBit),-         ( "proc",           ITproc,          xbit ArrowsBit)+         ( "proc",           ITproc,          xbit ArrowsBit),+         ( "splice",         ITsplice,        xbit LevelImportsBit),+         ( "quote",          ITquote,         xbit LevelImportsBit)      ]  {-----------------------------------@@ -2283,11 +2288,16 @@ lex_qquasiquote_tok span buf len _buf2 = do   let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False   quoteStart <- getParsedLoc+  let quoter_span_start = advancePsLoc (psSpanStart span) '['+      quoter_span_end   = foldl' advancePsLoc quoter_span_start+                            (take (len - 2) (repeat 'a'))+      quoter_span       = mkPsSpan quoter_span_start quoter_span_end   quote <- lex_quasiquote (psRealLoc quoteStart) ""   end <- getParsedLoc   return (L (mkPsSpan (psSpanStart span) end)            (ITqQuasiQuote (qual,                            quoter,+                           quoter_span,                            mkFastString (reverse quote),                            mkPsSpan quoteStart end))) @@ -2297,10 +2307,14 @@                 -- 'tail' drops the initial '[',                 -- while the -1 drops the trailing '|'   quoteStart <- getParsedLoc+  let quoter_span_start = advancePsLoc (psSpanStart span) '['+      quoter_span_end   = foldl' advancePsLoc quoter_span_start quoter+      quoter_span       = mkPsSpan quoter_span_start quoter_span_end   quote <- lex_quasiquote (psRealLoc quoteStart) ""   end <- getParsedLoc   return (L (mkPsSpan (psSpanStart span) end)            (ITquasiQuote (mkFastString quoter,+                          quoter_span,                           mkFastString (reverse quote),                           mkPsSpan quoteStart end))) @@ -2419,8 +2433,6 @@   { pExtsBitmap     :: !ExtsBitmap -- ^ bitmap of permitted extensions   , pDiagOpts       :: !DiagOpts     -- ^ Options to construct diagnostic messages.-  , pSupportedExts  :: [String]-    -- ^ supported extensions (only used for suggestions in error messages)   }  pWarningFlags :: ParserOpts -> EnumSet WarningFlag@@ -2777,6 +2789,7 @@   | ViewPatternsBit   | RequiredTypeArgumentsBit   | MultilineStringsBit+  | LevelImportsBit    -- Flags that are updated once parsing starts   | InRulePragBit@@ -2791,7 +2804,6 @@ mkParserOpts   :: EnumSet LangExt.Extension  -- ^ permitted language extensions enabled   -> DiagOpts                   -- ^ diagnostic options-  -> [String]                   -- ^ Supported Languages and Extensions   -> Bool                       -- ^ are safe imports on?   -> Bool                       -- ^ keeping Haddock comment tokens   -> Bool                       -- ^ keep regular comment tokens@@ -2803,12 +2815,11 @@    -> ParserOpts -- ^ Given exactly the information needed, set up the 'ParserOpts'-mkParserOpts extensionFlags diag_opts supported+mkParserOpts extensionFlags diag_opts   safeImports isHaddock rawTokStream usePosPrags =     ParserOpts {       pDiagOpts      = diag_opts     , pExtsBitmap    = safeHaskellBit .|. langExtBits .|. optBits-    , pSupportedExts = supported     }   where     safeHaskellBit = SafeHaskellBit `setBitIf` safeImports@@ -2862,6 +2873,7 @@       .|. ViewPatternsBit             `xoptBit` LangExt.ViewPatterns       .|. RequiredTypeArgumentsBit    `xoptBit` LangExt.RequiredTypeArguments       .|. MultilineStringsBit         `xoptBit` LangExt.MultilineStrings+      .|. LevelImportsBit             `xoptBit` LangExt.ExplicitLevelImports     optBits =           HaddockBit        `setBitIf` isHaddock       .|. RawTokenStreamBit `setBitIf` rawTokStream
compiler/GHC/Parser/PostProcess.hs view
@@ -62,26 +62,29 @@         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl         checkValSigLhs,         LRuleTyTmVar, RuleTyTmVar(..),-        mkRuleBndrs, mkRuleTyVarBndrs,+        mkRuleBndrs,+        ruleBndrsOrDef,         checkRuleTyVarBndrNames,+        mkSpecSig,         checkRecordSyntax,         checkEmptyGADTs,         addFatalError, hintBangPat,         mkBangTy,         UnpackednessPragma(..),-        mkMultTy,         mkMultAnn,--        -- Token location-        mkTokenLocation,+        mkMultField,+        mkConDeclField,          -- Help with processing exports         ImpExpSubSpec(..),         ImpExpQcSpec(..),         mkModuleImpExp,+        mkPlainImpExp,         mkTypeImpExp,+        mkDataImpExp,         mkImpExpSubSpec,         checkImportSpec,+        warnPatternNamespaceSpecifier,          -- Token symbols         starSym,@@ -92,6 +95,7 @@         failOpFewArgs,         failNotEnabledImportQualifiedPost,         failImportQualifiedTwice,+        failSpliceOrQuoteTwice,          SumOrTuple (..), @@ -108,7 +112,6 @@         withArrowParsingMode, withArrowParsingMode',         setTelescopeBndrsNameSpace,         PatBuilder,-        hsHoleExpr,          -- Type/datacon ambiguity resolution         DisambTD(..),@@ -174,7 +177,7 @@ import Data.Char import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs ) import Data.Kind       ( Type )-import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty ( NonEmpty (..) )  {- ********************************************************************** @@ -732,9 +735,9 @@            -- conAnn should only be AnnOpenP, AnnCloseP, so the rest should be empty            ; let ann_fun = mk_ann_funrhs [] []            ; match <- case details of-               PrefixCon _ pats -> return $ Match { m_ext = noExtField-                                                  , m_ctxt = ctxt, m_pats = L l pats-                                                  , m_grhss = rhs }+               PrefixCon pats -> return $ Match { m_ext = noExtField+                                                , m_ctxt = ctxt, m_pats = L l pats+                                                , m_grhss = rhs }                    where                      l = listLocation pats                      ctxt = FunRhs { mc_fun = ln@@ -803,9 +806,9 @@    (args, res_ty, (ops, cps), csa) <-     case body_ty of-     L ll (HsFunTy _ hsArr (L (EpAnn anc _ cs) (HsRecTy an rf)) res_ty) -> do+     L ll (HsFunTy _ hsArr (L (EpAnn anc _ cs) (XHsType (HsRecTy an rf))) res_ty) -> do        arr <- case hsArr of-         HsUnrestrictedArrow arr -> return arr+         HsUnannotated (EpArrow arr) -> return arr          _ -> do addError $ mkPlainErrorMsgEnvelope (getLocA body_ty) $                                  (PsErrIllegalGadtRecordMultiplicity hsArr)                  return noAnn@@ -816,23 +819,24 @@        let ((ops, cps), cs, arg_types, res_type) = splitHsFunType body_ty        return (PrefixConGADT noExtField arg_types, res_type, (ops,cps), cs) -  let bndrs_loc = case outer_bndrs of-        HsOuterImplicit{} -> getLoc ty-        HsOuterExplicit an _ -> EpAnn (entry an) noAnn emptyComments-   let l = EpAnn (spanAsAnchor loc) noAnn csa    pure $ L l ConDeclGADT                      { con_g_ext  = AnnConDeclGADT ops cps dcol                      , con_names  = names-                     , con_bndrs  = L bndrs_loc outer_bndrs+                     , con_outer_bndrs = L outer_bndrs_loc outer_bndrs+                     , con_inner_bndrs = inner_bndrs                      , con_mb_cxt = mcxt                      , con_g_args = args                      , con_res_ty = res_ty                      , con_doc    = Nothing }   where-    (outer_bndrs, mcxt, body_ty) = splitLHsGadtTy ty+    (outer_bndrs, inner_bndrs, mcxt, body_ty) = splitLHsGadtTy ty+    outer_bndrs_loc = case outer_bndrs of+      HsOuterImplicit{} -> getLoc ty+      HsOuterExplicit an _ -> EpAnn (entry an) noAnn emptyComments + setRdrNameSpace :: RdrName -> NameSpace -> RdrName -- ^ This rather gruesome function is used mainly by the parser. --@@ -1006,30 +1010,86 @@ data RuleTyTmVar = RuleTyTmVar AnnTyVarBndr (LocatedN RdrName) (Maybe (LHsType GhcPs)) -- ^ Essentially a wrapper for a @RuleBndr GhcPs@ --- turns RuleTyTmVars into RuleBnrs - this is straightforward-mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]-mkRuleBndrs = fmap (fmap cvt_one)-  where cvt_one (RuleTyTmVar ann v Nothing) = RuleBndr ann v-        cvt_one (RuleTyTmVar ann v (Just sig)) =-          RuleBndrSig ann v (mkHsPatSigType noAnn sig)+ruleBndrsOrDef :: Maybe (RuleBndrs GhcPs) -> RuleBndrs GhcPs+ruleBndrsOrDef (Just bndrs) = bndrs+ruleBndrsOrDef Nothing      = mkRuleBndrs noAnn Nothing [] --- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting-mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]-mkRuleTyVarBndrs = fmap (setLHsTyVarBndrNameSpace tvName . cvt_one)-  where cvt_one (L l (RuleTyTmVar ann v msig))+mkRuleBndrs :: HsRuleBndrsAnn -> Maybe [LRuleTyTmVar] -> [LRuleTyTmVar] -> RuleBndrs GhcPs+mkRuleBndrs ann tvbs tmbs+  = RuleBndrs { rb_ext = ann+              , rb_tyvs = fmap (fmap (setLHsTyVarBndrNameSpace tvName . cvt_tv)) tvbs+              , rb_tmvs = fmap (fmap cvt_tm) tmbs }+  where+    -- cvt_tm turns RuleTyTmVars into RuleBnrs - this is straightforward+    cvt_tm (RuleTyTmVar ann v Nothing)    = RuleBndr ann v+    cvt_tm (RuleTyTmVar ann v (Just sig)) = RuleBndrSig ann v (mkHsPatSigType noAnn sig)++    -- cvt_tv turns RuleTyTmVars into HsTyVarBndrs - this is more interesting+    cvt_tv (L l (RuleTyTmVar ann v msig))           = L (l2l l) (HsTvb ann () (HsBndrVar noExtField v) (cvt_sig msig))-        cvt_sig Nothing    = HsBndrNoKind noExtField-        cvt_sig (Just sig) = HsBndrKind   noExtField sig+    cvt_sig Nothing    = HsBndrNoKind noExtField+    cvt_sig (Just sig) = HsBndrKind   noExtField sig +checkRuleTyVarBndrNames :: [LRuleTyTmVar] -> P () -- See Note [Parsing explicit foralls in Rules] in Parser.y-checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()-checkRuleTyVarBndrNames = mapM_ check . mapMaybe (hsTyVarLName . unLoc)-  where check (L loc (Unqual occ)) =-          when (occNameFS occ `elem` [fsLit "family",fsLit "role"])-            (addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $-               (PsErrParseErrorOnInput occ))-        check _ = panic "checkRuleTyVarBndrNames"+checkRuleTyVarBndrNames bndrs+   = sequence_ [ check lname | L _ (RuleTyTmVar _ lname _) <- bndrs ]+  where+    check (L loc (Unqual occ)) =+          when (occNameFS occ `elem` [fsLit "family",fsLit "role"]) $+          addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $+                          PsErrParseErrorOnInput occ+    check _ = panic "checkRuleTyVarBndrNames" +-- | Deal with both old-form and new-form specialise pragmas, using the new+-- 'SpecSigE' form unless there are multiple comma-separated type signatures,+-- in which case we use the old-form.+--+-- See Note [Overview of SPECIALISE pragmas] in GHC.Tc.Gen.Sig.+mkSpecSig :: InlinePragma+          -> AnnSpecSig+          -> Maybe (RuleBndrs GhcPs)+          -> LHsExpr GhcPs+          -> Maybe (Located (TokDcolon, OrdList (LHsSigType GhcPs)))+          -> P (Sig GhcPs)+mkSpecSig inl_prag activation_anns m_rule_binds expr m_sigtypes_ascr+  = case m_sigtypes_ascr of+      Nothing+        -- New form, no trailing type signature, e.g {-# SPECIALISE f @Int #-}+        -> pure $+           SpecSigE activation_anns+                    (ruleBndrsOrDef m_rule_binds) expr inl_prag++      Just (L lt (colon_ann, sigtype_ol))++        -- Singleton, e.g.  {-# SPECIALISE f :: ty #-}+        -- Use the SpecSigE route+        | [sigtype] <- sigtype_list+        -> pure $+           SpecSigE activation_anns+                    (ruleBndrsOrDef m_rule_binds)+                    (L ((combineSrcSpansA (getLoc expr) (noAnnSrcSpan lt)))+                       (ExprWithTySig colon_ann expr (mkHsWildCardBndrs sigtype)))+                    inl_prag++        -- So we must have the old form  {# SPECIALISE f :: ty1, ty2, ty3 #-}+        -- Use the old SpecSig route+        | Nothing <- m_rule_binds+        , L _ (HsVar _ var) <- expr+        -> do addPsMessage sigs_loc PsWarnSpecMultipleTypeAscription+              pure $+                SpecSig (activation_anns {ass_dcolon = Just colon_ann })+                        var sigtype_list inl_prag++        | otherwise ->+            addFatalError $+              mkPlainErrorMsgEnvelope sigs_loc PsErrSpecExprMultipleTypeAscription++        where+          sigtype_list = fromOL sigtype_ol+          sigs_loc =+            getHasLoc colon_ann `combineSrcSpans` getHasLoc (last sigtype_list)+ checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a) checkRecordSyntax lr@(L loc r)     = do allowed <- getBit TraditionalRecordSyntaxBit@@ -1221,8 +1281,11 @@  checkImportDecl :: Maybe (EpToken "qualified")                 -> Maybe (EpToken "qualified")-                -> P ()-checkImportDecl mPre mPost = do+                -> Maybe EpAnnLevel+                -> Maybe EpAnnLevel+                -> P ((Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)+                     , (Maybe EpAnnLevel, ImportDeclLevelStyle))+checkImportDecl mPre mPost preLevel postLevel = do   let whenJust mg f = maybe (pure ()) f mg       tokenSpan tok = RealSrcSpan (epaLocationRealSrcSpan $ getEpTokenLoc tok) Strict.Nothing @@ -1236,15 +1299,47 @@    -- Error if 'qualified' occurs in both pre and postpositive   -- positions.-  whenJust mPost $ \post ->-    when (isJust mPre) $-      failImportQualifiedTwice (tokenSpan post)+  qualSpec <- importDeclQualifiedStyle mPre mPost+  levelSpec <- importDeclLevelStyle preLevel postLevel    -- Warn if 'qualified' found in prepositive position and   -- 'Opt_WarnPrepositiveQualifiedModule' is enabled.   whenJust mPre $ \pre ->     warnPrepositiveQualifiedModule (tokenSpan pre) +  return (qualSpec, levelSpec)++-- | Given two possible located 'qualified' tokens, compute a style+-- (in a conforming Haskell program only one of the two can be not+-- 'Nothing'). This is called from "GHC.Parser".+importDeclQualifiedStyle :: Maybe (EpToken "qualified")+                         -> Maybe (EpToken "qualified")+                         -> P (Maybe (EpToken "qualified"), ImportDeclQualifiedStyle)+importDeclQualifiedStyle mPre mPost =+  case (mPre, mPost) of+    (Just {}, Just post) -> failImportQualifiedTwice (getEpTokenSrcSpan post)+                            >> return (Just post, QualifiedPost)+    (Nothing, Just post) -> pure (Just post, QualifiedPost)+    (Just pre, Nothing) -> pure (Just pre, QualifiedPre)+    (Nothing, Nothing) -> pure (Nothing, NotQualified)++importDeclLevelStyle :: (Maybe EpAnnLevel)+                     -> (Maybe EpAnnLevel)+                     -> P (Maybe EpAnnLevel, ImportDeclLevelStyle)+importDeclLevelStyle preImportLevel postImportLevel =+  case (preImportLevel, postImportLevel) of+    (Just {}, Just tok) -> failSpliceOrQuoteTwice tok+                            >> return (Just tok, LevelStylePost (tokToLevel tok))+    (Nothing, Just post) -> pure (Just post, LevelStylePost (tokToLevel post))+    (Just pre, Nothing) -> pure (Just pre, LevelStylePre (tokToLevel pre))+    (Nothing, Nothing) -> pure (Nothing, NotLevelled)+  where+    tokToLevel tok = case tok of+      EpAnnLevelSplice {} -> ImportDeclSplice+      EpAnnLevelQuote {} -> ImportDeclQuote+++ -- ------------------------------------------------------------------------- -- Checking Patterns. @@ -1257,41 +1352,44 @@ checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs) checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat) -checkLArgPat :: LocatedA (ArgPatBuilder GhcPs) -> PV (LPat GhcPs)-checkLArgPat (L l (ArgPatBuilderVisPat p)) = checkLPat (L l p)-checkLArgPat (L l (ArgPatBuilderArgPat p)) = return (L l p)- checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat (L l@(EpAnn anc an _) p) = do-  (L l' p', cs) <- checkPat (EpAnn anc an emptyComments) emptyComments (L l p) [] []+  (L l' p', cs) <- checkPat (EpAnn anc an emptyComments) emptyComments (L l p) []   return (L (addCommentsToEpAnn l' cs) p') -checkPat :: SrcSpanAnnA -> EpAnnComments -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs]+checkPat :: SrcSpanAnnA -> EpAnnComments -> LocatedA (PatBuilder GhcPs) -> [LPat GhcPs]          -> PV (LPat GhcPs, EpAnnComments) -- SG: I think this function checks what Haskell2010 calls the `pat` and `lpat` -- productions-checkPat loc cs (L l e@(PatBuilderVar (L ln c))) tyargs args+checkPat loc cs (L l e@(PatBuilderVar (L ln c))) args   | isRdrDataCon c || isRdrTc c   = return (L loc $ ConPat       { pat_con_ext = noAnn -- AZ: where should this come from?       , pat_con = L ln c-      , pat_args = PrefixCon tyargs args+      , pat_args = PrefixCon args       }, comments l Semi.<> cs)   | (not (null args) && patIsRec c) = do       ctx <- askParseContext       patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx-checkPat loc cs (L la (PatBuilderAppType f at t)) tyargs args =-  checkPat loc (cs Semi.<> comments la) f (HsConPatTyArg at t : tyargs) args-checkPat loc cs (L la (PatBuilderApp f e)) [] args = do+checkPat loc cs (L la (PatBuilderAppType f at t)) args =+  checkPat loc (cs Semi.<> comments la) f (mkInvisLPat at t : args)+checkPat loc cs (L la (PatBuilderApp f e)) args = do   p <- checkLPat e-  checkPat loc (cs Semi.<> comments la) f [] (p : args)-checkPat loc cs (L l e) [] [] = do+  checkPat loc (cs Semi.<> comments la) f (p : args)+checkPat loc cs (L l e) [] = do   p <- checkAPat loc e   return (L l p, cs)-checkPat loc _ e _ _ = do+checkPat loc _ e _ = do   details <- fromParseContext <$> askParseContext   patFail (locA loc) (PsErrInPat (unLoc e) details) +mkInvisLPat :: EpToken "@" -> HsTyPat GhcPs -> LPat GhcPs+mkInvisLPat tok ty_pat = L l invis_pat+  where+    HsTP _ (L (EpAnn anc _ _) _) = ty_pat+    l = EpAnn (widenAnchorT anc tok) noAnn emptyComments+    invis_pat = InvisPat (tok, SpecifiedSpec) ty_pat+ checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs) checkAPat loc e0 = do  nPlusKPatterns <- getBit NPlusKPatternsBit@@ -1374,7 +1472,7 @@        checkPatBind loc lhs' grhss mult  checkValDef loc lhs (mult_ann, Nothing) grhss-  | HsNoMultAnn{} <- mult_ann+  | HsUnannotated{} <- mult_ann   = do  { mb_fun <- isFunLhs lhs         ; case mb_fun of             Just (fun, is_infix, pats, ops, cps) -> do@@ -1398,11 +1496,11 @@              -> AnnFunRhs              -> LocatedN RdrName              -> LexicalFixity-             -> LocatedE [LocatedA (ArgPatBuilder GhcPs)]+             -> LocatedE [LocatedA (PatBuilder GhcPs)]              -> Located (GRHSs GhcPs (LHsExpr GhcPs))              -> P (HsBind GhcPs) checkFunBind locF ann_fun (L lf fun) is_infix (L lp pats) (L _ grhss)-  = do  ps <- runPV_details extraDetails (mapM checkLArgPat pats)+  = do  ps <- runPV_details extraDetails (mapM checkLPat pats)         let match_span = noAnnSrcSpan $ locF         return (makeFunBind (L (l2l lf) fun) (L (noAnnSrcSpan $ locA match_span)                  [L match_span (Match { m_ext = noExtField@@ -1435,7 +1533,7 @@              -> HsMultAnn GhcPs              -> P (HsBind GhcPs) checkPatBind loc (L _ (BangPat an (L _ (VarPat _ v))))-                        (L _match_span grhss) (HsNoMultAnn _)+                        (L _match_span grhss) (HsUnannotated _)       = return (makeFunBind v (L (noAnnSrcSpan loc)                 [L (noAnnSrcSpan loc) (m an v)]))   where@@ -1483,20 +1581,18 @@  isFunLhs :: LocatedA (PatBuilder GhcPs)       -> P (Maybe (LocatedN RdrName, LexicalFixity,-                   [LocatedA (ArgPatBuilder GhcPs)],[EpToken "("],[EpToken ")"]))+                   [LocatedA (PatBuilder GhcPs)],[EpToken "("],[EpToken ")"])) -- A variable binding is parsed as a FunBind. -- Just (fun, is_infix, arg_pats) if e is a function LHS isFunLhs e = go e [] [] []  where-   mk = fmap ArgPatBuilderVisPat-    go (L l (PatBuilderVar (L loc f))) es ops cps        | not (isRdrDataCon f)        = do            let (_l, loc') = transferCommentsOnlyA l loc            return (Just (L loc' f, Prefix, es, (reverse ops), cps))    go (L l (PatBuilderApp (L lf f) e))   es       ops cps = do      let (_l, lf') = transferCommentsOnlyA l lf-     go (L lf' f) (mk e:es) ops cps+     go (L lf' f) (e:es) ops cps    go (L l (PatBuilderPar _ (L le e) _)) es@(_:_) ops cps = go (L le' e) es (o:ops) (c:cps)       -- NB: es@(_:_) means that there must be an arg after the parens for the       -- LHS to be a function LHS. This corresponds to the Haskell Report's definition@@ -1507,36 +1603,28 @@    go (L loc (PatBuilderOpApp (L ll l) (L loc' op) r (os,cs))) es ops cps       | not (isRdrDataCon op)         -- We have found the function!       = do { let (_l, ll') = transferCommentsOnlyA loc ll-           ; return (Just (L loc' op, Infix, (mk (L ll' l):mk r:es), (os ++ reverse ops), (cs ++ cps))) }+           ; return (Just (L loc' op, Infix, ((L ll' l):r:es), (os ++ reverse ops), (cs ++ cps))) }       | otherwise                     -- Infix data con; keep going       = do { let (_l, ll') = transferCommentsOnlyA loc ll            ; mb_l <- go (L ll' l) es ops cps            ; return (reassociate =<< mb_l) }         where-          reassociate (op', Infix, j : L k_loc (ArgPatBuilderVisPat k) : es', ops', cps')+          reassociate (op', Infix, j : L k_loc k : es', ops', cps')             = Just (op', Infix, j : op_app : es', ops', cps')             where-              op_app = mk $ L loc (PatBuilderOpApp (L k_loc k)+              op_app = L loc (PatBuilderOpApp (L k_loc k)                                     (L loc' op) r (reverse ops, cps))           reassociate _other = Nothing    go (L l (PatBuilderAppType (L lp pat) tok ty_pat@(HsTP _ (L (EpAnn anc ann cs) _)))) es ops cps-             = go (L lp' pat) (L (EpAnn anc' ann cs) (ArgPatBuilderArgPat invis_pat) : es) ops cps+             = go (L lp' pat) (L (EpAnn anc' ann cs) (PatBuilderPat invis_pat) : es) ops cps              where invis_pat = InvisPat (tok, SpecifiedSpec) ty_pat                    anc' = widenAnchorT anc tok                    (_l, lp') = transferCommentsOnlyA l lp    go _ _ _ _ = return Nothing -data ArgPatBuilder p-  = ArgPatBuilderVisPat (PatBuilder p)-  | ArgPatBuilderArgPat (Pat p)--instance Outputable (ArgPatBuilder GhcPs) where-  ppr (ArgPatBuilderVisPat p) = ppr p-  ppr (ArgPatBuilderArgPat p) = ppr p- mkBangTy :: EpaLocation -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs-mkBangTy tok_loc strictness =-  HsBangTy ((noAnn, noAnn, tok_loc), NoSourceText) (HsBang NoSrcUnpack strictness)+mkBangTy tok_loc strictness lty =+  XHsType (HsBangTy (noAnn, noAnn, tok_loc) (HsSrcBang NoSourceText NoSrcUnpack strictness) lty)  -- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@. data UnpackednessPragma =@@ -1553,11 +1641,11 @@     -- such as ~T or !T, then add the pragma to the existing HsBangTy.     --     -- Otherwise, wrap the type in a new HsBangTy constructor.-    addUnpackedness (o,c) (L _ (HsBangTy ((_,_,tl), NoSourceText) bang t))-      | HsBang NoSrcUnpack strictness <- bang-      = HsBangTy ((o,c,tl), prag) (HsBang unpk strictness) t+    addUnpackedness (o,c) (L _ (XHsType (HsBangTy (_,_,tl) bang t)))+      | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang+      = XHsType (HsBangTy (o,c,tl) (HsSrcBang prag unpk strictness) t)     addUnpackedness (o,c) t-      = HsBangTy ((o,c,noAnn), prag) (HsBang unpk NoSrcStrict) t+      = XHsType (HsBangTy (o,c,noAnn) (HsSrcBang prag unpk NoSrcStrict) t)  --------------------------------------------------------------------------- -- | Check for monad comprehensions@@ -1610,12 +1698,12 @@ class DisambInfixOp b where   mkHsVarOpPV :: LocatedN RdrName -> PV (LocatedN b)   mkHsConOpPV :: LocatedN RdrName -> PV (LocatedN b)-  mkHsInfixHolePV :: LocatedN (HsExpr GhcPs) -> PV (LocatedN b)+  mkHsInfixHolePV :: LocatedN RdrName -> PV (LocatedN b)  instance DisambInfixOp (HsExpr GhcPs) where   mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v)   mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v)-  mkHsInfixHolePV h = return h+  mkHsInfixHolePV v = return $ L (getLoc v) (HsHole (HoleVar v))  instance DisambInfixOp RdrName where   mkHsConOpPV (L l v) = return $ L l v@@ -1643,7 +1731,7 @@   ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b)   -- | Return a pattern without ambiguity, or fail in a non-pattern context.   ecpFromPat' :: LPat GhcPs -> PV (LocatedA b)-  mkHsProjUpdatePV :: SrcSpan -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]+  mkHsProjUpdatePV :: SrcSpan -> Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))     -> LocatedA b -> Bool -> Maybe (EpToken "=") -> PV (LHsRecProj GhcPs (LocatedA b))   -- | Disambiguate "let ... in ..."   mkHsLetPV@@ -1728,10 +1816,10 @@     :: SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (LocatedA b)   -- | Disambiguate "(a -> b)" (view pattern or function type arrow)   mkHsArrowPV-    :: SrcSpan -> ArrowParsingMode lhs b -> LocatedA lhs -> HsArrowOf (LocatedA b) GhcPs -> LocatedA b -> PV (LocatedA b)+    :: SrcSpan -> ArrowParsingMode lhs b -> LocatedA lhs -> HsMultAnnOf (LocatedA b) GhcPs -> LocatedA b -> PV (LocatedA b)   -- | Disambiguate "%m" to the left of "->" (multiplicity)   mkHsMultPV-    :: EpToken "%" -> LocatedA b -> PV (TokRarrow -> HsArrowOf (LocatedA b) GhcPs)+    :: EpToken "%" -> LocatedA b -> PV (TokRarrow -> HsMultAnnOf (LocatedA b) GhcPs)   -- | Disambiguate "forall a. b" and "forall a -> b" (forall telescope)   mkHsForallPV :: SrcSpan -> HsForAllTelescope GhcPs -> LocatedA b -> PV (LocatedA b)   -- | Disambiguate "(a,b,c)" to the left of "=>" (constraint list)@@ -1849,7 +1937,7 @@   mkHsLitPV (L l a) = cmdFail l (ppr a)   mkHsOverLitPV (L l a) = cmdFail (locA l) (ppr a)   mkHsWildCardPV l = cmdFail l (text "_")-  mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> text "::" <+> ppr sig)+  mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> dcolon <+> ppr sig)   mkHsExplicitListPV l xs _ = cmdFail l $     brackets (pprWithCommas ppr xs)   mkHsSplicePV (L l sp) = cmdFail l (pprUntypedSplice True Nothing sp)@@ -1897,11 +1985,11 @@   type Body (HsExpr GhcPs) = HsExpr   ecpFromCmd' (L l c) = do     addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInExpr c-    return (L l (hsHoleExpr noAnn))+    return (L l parseError)   ecpFromExp' = return   ecpFromPat' p@(L l _) = do     addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrOrPatInExpr p-    return (L l (hsHoleExpr noAnn))+    return (L l parseError)   mkHsProjUpdatePV l fields arg isPun anns = do     !cs <- getCommentsFor l     return $ mkRdrProjUpdate (EpAnn (spanAsAnchor l) noAnn cs) fields arg isPun anns@@ -1950,7 +2038,7 @@   mkHsOverLitPV (L (EpAnn l an csIn) a) = do     !cs <- getCommentsFor (locA l)     return $ L (EpAnn  l an (cs Semi.<> csIn)) (HsOverLit NoExtField a)-  mkHsWildCardPV l = return $ L (noAnnSrcSpan l) (hsHoleExpr noAnn)+  mkHsWildCardPV l = return $ L (noAnnSrcSpan l) (HsHole (HoleVar (L (noAnnSrcSpan l) (mkUnqual varName (fsLit "_")))))   mkHsTySigPV l@(EpAnn anc an csIn) a sig anns = do     !cs <- getCommentsFor (locA l)     return $ L (EpAnn anc an (csIn Semi.<> cs)) (ExprWithTySig anns a (hsTypeToHsSigWcType sig))@@ -1971,11 +2059,11 @@     !cs <- getCommentsFor l     return $ L (EpAnn (spanAsAnchor l) noAnn cs) (SectionR noExtField op e)   mkHsAsPatPV l v _ e   = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e)-                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))+                          >> return (L (noAnnSrcSpan l) parseError)   mkHsLazyPatPV l e   _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e)-                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))+                          >> return (L (noAnnSrcSpan l) parseError)   mkHsBangPatPV l e   _ = addError (mkPlainErrorMsgEnvelope l $ PsErrBangPatWithoutSpace e)-                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))+                          >> return (L (noAnnSrcSpan l) parseError)   mkSumOrTuplePV = mkSumOrTupleExpr   mkHsEmbTyPV l toktype ty =     return $ L (noAnnSrcSpan l) $@@ -2002,9 +2090,6 @@                                                          (PsErrUnallowedPragma prag)   rejectPragmaPV _                        = return () -hsHoleExpr :: Maybe EpAnnUnboundVar -> HsExpr GhcPs-hsHoleExpr anns = HsUnboundVar anns (mkRdrUnqual (mkVarOccFS (fsLit "_")))- instance DisambECP (PatBuilder GhcPs) where   type Body (PatBuilder GhcPs) = PatBuilder   ecpFromCmd' (L l c)    = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInPat c@@ -2071,10 +2156,10 @@     where       tok :: TokRarrow       tok = case arr of-        HsUnrestrictedArrow x -> x+        HsUnannotated (EpArrow x) -> x         _ -> -- unreachable case because in Parser.y the reduction rules for              -- (a %m -> b) and (a ->. b) use ArrowIsFunType-             panic "mkHsArrowPV ArrowIsViewPat: expected HsUnrestrictedArrow"+             panic "mkHsArrowPV ArrowIsViewPat: expected HsUnannotated"   mkHsArrowPV l ArrowIsFunType a arr b =     patFail l (PsErrTypeSyntaxInPat (PETS_FunctionArrow a arr b))   mkHsMultPV tok arg =@@ -2331,16 +2416,16 @@ -- Detect when the record syntax is used: --   data T = MkT { ... } dataConBuilderDetails (L _ (PrefixDataConBuilder flds _))-  | [L (EpAnn anc _ cs) (HsRecTy an fields)] <- toList flds+  | [L (EpAnn anc _ cs) (XHsType (HsRecTy an fields))] <- toList flds   = RecCon (L (EpAnn anc an cs) fields)  -- Normal prefix constructor, e.g.  data T = MkT A B C dataConBuilderDetails (L _ (PrefixDataConBuilder flds _))-  = PrefixCon noTypeArgs (map hsLinear (toList flds))+  = PrefixCon (map hsPlainTypeField (toList flds))  -- Infix constructor, e.g. data T = Int :! Bool dataConBuilderDetails (L (EpAnn _ _ csl) (InfixDataConBuilder (L (EpAnn anc ann csll) lhs) _ rhs))-  = InfixCon (hsLinear (L (EpAnn anc ann (csl Semi.<> csll)) lhs)) (hsLinear rhs)+  = InfixCon (hsPlainTypeField (L (EpAnn anc ann (csl Semi.<> csll)) lhs)) (hsPlainTypeField rhs)   instance DisambTD DataConBuilder where@@ -2367,7 +2452,7 @@       return $ L (addCommentsToEpAnn l cs) (InfixDataConBuilder lhs data_con rhs)     where       l = combineLocsA lhs rhs-      check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)+      check_no_ops (XHsType (HsBangTy _ _ t)) = check_no_ops (unLoc t)       check_no_ops (HsOpTy{}) =         addError $ mkPlainErrorMsgEnvelope (locA l) $                      (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs))@@ -2408,7 +2493,7 @@  mkUnboxedSumCon :: LHsType GhcPs -> ConTag -> Arity -> (LocatedN RdrName, HsConDeclH98Details GhcPs) mkUnboxedSumCon t tag arity =-  (noLocA (getRdrName (sumDataCon tag arity)), PrefixCon noTypeArgs [hsLinear t])+  (noLocA (getRdrName (sumDataCon tag arity)), PrefixCon [hsPlainTypeField t])  {- Note [Ambiguous syntactic categories] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2934,7 +3019,7 @@         let f = occNameFS . rdrNameOcc $ rdr             fl = DotFieldOcc noAnn (L loc (FieldLabelString f))             lf = locA loc-        in mkRdrProjUpdate l (L lf [L (l2l loc) fl]) (punnedVar f) pun anns+        in mkRdrProjUpdate l (L lf (L (l2l loc) fl :| [])) (punnedVar f) pun anns         where           -- If punning, compute HsVar "f" otherwise just arg. This           -- has the effect that sentinel HsVar "pun-rhs" is replaced@@ -3157,8 +3242,7 @@                    | ImpExpList [LocatedA ImpExpQcSpec]                    | ImpExpAllWith [LocatedA ImpExpQcSpec] -data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName)-                  | ImpExpQcType (EpToken "type") (LocatedN RdrName)+data ImpExpQcSpec = ImpExpQcName (Maybe ExplicitNamespaceKeyword) (LocatedN RdrName)                   | ImpExpQcWildcard (EpToken "..") (EpToken ",")  mkModuleImpExp :: Maybe (LWarningTxt GhcPs) -> (EpToken "(", EpToken ")") -> LocatedA ImpExpQcSpec@@ -3202,23 +3286,38 @@                (PsErrVarForTyCon name)         else return $ ieNameFromSpec specname -    ieNameVal (ImpExpQcName ln)   = unLoc ln-    ieNameVal (ImpExpQcType _ ln) = unLoc ln+    ieNameVal (ImpExpQcName _ ln) = unLoc ln     ieNameVal ImpExpQcWildcard{}  = panic "ieNameVal got wildcard"      ieNameFromSpec :: ImpExpQcSpec -> IEWrappedName GhcPs-    ieNameFromSpec (ImpExpQcName   (L l n)) = IEName noExtField (L l n)-    ieNameFromSpec (ImpExpQcType r (L l n)) = IEType r (L l n)-    ieNameFromSpec ImpExpQcWildcard{}       = panic "ieName got wildcard"+    ieNameFromSpec (ImpExpQcName m_kw name) = case m_kw of+        Nothing                          -> IEName noExtField name+        Just (ExplicitTypeNamespace tok) -> IEType tok name+        Just (ExplicitDataNamespace tok) -> IEData tok name+    ieNameFromSpec ImpExpQcWildcard{} = panic "ieNameFromSpec got wildcard"      wrapped = map (fmap ieNameFromSpec) -mkTypeImpExp :: LocatedN RdrName   -- TcCls or Var name space-             -> P (LocatedN RdrName)-mkTypeImpExp name =-  do requireExplicitNamespaces (getLocA name)-     return (fmap (`setRdrNameSpace` tcClsName) name)+mkPlainImpExp :: LocatedN RdrName -> ImpExpQcSpec+mkPlainImpExp name = ImpExpQcName Nothing name +mkTypeImpExp :: EpToken "type"+             -> LocatedN RdrName   -- TcCls or Var name space+             -> P ImpExpQcSpec+mkTypeImpExp tok name = do+  let name' = fmap (`setRdrNameSpace` tcClsName) name+      ns_kw = ExplicitTypeNamespace tok+  requireExplicitNamespaces ns_kw+  return (ImpExpQcName (Just ns_kw) name')++mkDataImpExp :: EpToken "data"+             -> LocatedN RdrName+             -> P ImpExpQcSpec+mkDataImpExp tok name = do+  let ns_kw = ExplicitDataNamespace tok+  requireExplicitNamespaces ns_kw+  return (ImpExpQcName (Just ns_kw) name)+ checkImportSpec :: LocatedLI [LIE GhcPs] -> P (LocatedLI [LIE GhcPs]) checkImportSpec ie@(L _ specs) =     case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of@@ -3257,6 +3356,14 @@ failImportQualifiedTwice loc =   addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportQualifiedTwice +failSpliceOrQuoteTwice :: EpAnnLevel -> P ()+failSpliceOrQuoteTwice lvl =+  addError $ mkPlainErrorMsgEnvelope loc $ PsErrSpliceOrQuoteTwice+  where+    loc = case lvl of+      EpAnnLevelSplice tok -> getEpTokenSrcSpan tok+      EpAnnLevelQuote tok -> getEpTokenSrcSpan tok+ warnStarIsType :: SrcSpan -> P () warnStarIsType span = addPsMessage span PsWarnStarIsType @@ -3267,12 +3374,21 @@      ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $          (PsErrOpFewArgs is_star_type op) } -requireExplicitNamespaces :: MonadP m => SrcSpan -> m ()-requireExplicitNamespaces l = do+requireExplicitNamespaces :: MonadP m => ExplicitNamespaceKeyword -> m ()+requireExplicitNamespaces kw = do   allowed <- getBit ExplicitNamespacesBit   unless allowed $-    addError $ mkPlainErrorMsgEnvelope l PsErrIllegalExplicitNamespace+    addError $ mkPlainErrorMsgEnvelope loc $ PsErrIllegalExplicitNamespace kw+  where+    loc = case kw of+      ExplicitTypeNamespace tok -> getEpTokenSrcSpan tok+      ExplicitDataNamespace tok -> getEpTokenSrcSpan tok +warnPatternNamespaceSpecifier :: MonadP m => SrcSpan -> m ()+warnPatternNamespaceSpecifier l = do+  explicit_namespaces <- getBit ExplicitNamespacesBit+  addPsMessage l (PsWarnPatternNamespaceSpecifier explicit_namespaces)+ ----------------------------------------------------------------------------- -- Misc utils @@ -3488,39 +3604,28 @@   let loc = locA x `combineSrcSpans` locA op `combineSrcSpans` locA y   in L (noAnnSrcSpan loc) (mkHsOpTy prom x op y) -mkMultTy :: EpToken "%" -> LHsType GhcPs -> TokRarrow -> HsArrow GhcPs-mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) arr-  -- See #18888 for the use of (SourceText "1") above-  = HsLinearArrow (EpPct1 pct1 arr)-  where-    -- The location of "%" combined with the location of "1".-    pct1 :: EpToken "%1"-    pct1 = epTokenWidenR pct (locA (getLoc t))-mkMultTy pct t arr = HsExplicitMult (pct, arr) t--mkMultExpr :: EpToken "%" -> LHsExpr GhcPs -> TokRarrow -> HsArrowOf (LHsExpr GhcPs) GhcPs+mkMultExpr :: EpToken "%" -> LHsExpr GhcPs -> TokRarrow -> HsMultAnnOf (LHsExpr GhcPs) GhcPs mkMultExpr pct t@(L _ (HsOverLit _ (OverLit _ (HsIntegral (IL (SourceText (unpackFS -> "1")) _ 1))))) arr   -- See #18888 for the use of (SourceText "1") above-  = HsLinearArrow (EpPct1 pct1 arr)+  = HsLinearAnn (EpPct1 pct1 (EpArrow arr))   where     -- The location of "%" combined with the location of "1".     pct1 :: EpToken "%1"     pct1 = epTokenWidenR pct (locA (getLoc t))-mkMultExpr pct t arr = HsExplicitMult (pct, arr) t+mkMultExpr pct t arr = HsExplicitMult (pct, EpArrow arr) t -mkMultAnn :: EpToken "%" -> LHsType GhcPs -> HsMultAnn GhcPs-mkMultAnn pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1)))+mkMultAnn :: EpToken "%" -> LHsType GhcPs -> EpArrowOrColon -> HsMultAnn GhcPs+mkMultAnn pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) ep   -- See #18888 for the use of (SourceText "1") above-  = HsPct1Ann pct1+  = HsLinearAnn (EpPct1 pct1 ep)   where     -- The location of "%" combined with the location of "1".     pct1 :: EpToken "%1"     pct1 = epTokenWidenR pct (locA (getLoc t))-mkMultAnn pct t = HsMultAnn pct t+mkMultAnn pct t ep = HsExplicitMult (pct, ep) t -mkTokenLocation :: SrcSpan -> TokenLocation-mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc-mkTokenLocation (RealSrcSpan r mb) = TokenLoc (EpaSpan (RealSrcSpan r mb))+mkMultField :: EpToken "%" -> LHsType GhcPs -> TokDcolon -> LHsType GhcPs -> HsConDeclField GhcPs+mkMultField pct mult col t = mkConDeclField (mkMultAnn pct mult (EpColon col)) t  -- Precondition: the EpToken has EpaSpan, never EpaDelta. epTokenWidenR :: EpToken tok -> SrcSpan -> EpToken tok'@@ -3557,10 +3662,9 @@     , proj_flds = fmap unLoc flds     } -mkRdrProjUpdate :: SrcSpanAnnA -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]+mkRdrProjUpdate :: SrcSpanAnnA -> Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))                 -> LHsExpr GhcPs -> Bool -> Maybe (EpToken "=")                 -> LHsRecProj GhcPs (LHsExpr GhcPs)-mkRdrProjUpdate _ (L _ []) _ _ _ = panic "mkRdrProjUpdate: The impossible has happened!" mkRdrProjUpdate loc (L l flds) arg isPun anns =   L loc HsFieldBind {       hfbAnn = anns@@ -3678,3 +3782,6 @@      annsKeyword = (NoEpTok, brkOpen, brkClose)     annParen = AnnParensSquare brkOpen brkClose++parseError :: HsExpr GhcPs+parseError = HsHole HoleError
compiler/GHC/Parser/PostProcess/Haddock.hs view
@@ -59,7 +59,6 @@ import Data.Traversable import qualified Data.List.NonEmpty as NE import Control.Applicative-import Control.Monad import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import Data.Functor.Identity@@ -215,9 +214,8 @@ -- But having a single name for all of them is just easier to read, and makes it clear -- that they all are of the form  t -> HdkA t  for some t. ----- If you need to handle a more complicated scenario that doesn't fit this--- pattern, it's always possible to define separate functions outside of this--- class, as is done in case of e.g. addHaddockConDeclField.+-- If you need to handle a more complicated scenario that doesn't fit this pattern,+-- it's always possible to define separate functions outside of this class. -- -- See Note [Adding Haddock comments to the syntax tree]. class HasHaddock a where@@ -238,6 +236,8 @@ -- instance HasHaddock (Located (HsModule GhcPs)) where   addHaddock (L l_mod mod) = do+    let mod_anns = anns (hsmodAnn (hsmodExt mod))+     -- Step 1, get the module header documentation comment:     --     --    -- | Module header comment@@ -245,14 +245,19 @@     --     -- Only do this when the module header exists.     headerDocs <--      for @Maybe (hsmodName mod) $ \(L l_name _) ->-      extendHdkA (locA l_name) $ liftHdkA $ do-        -- todo: register keyword location of 'module', see Note [Register keyword location]-        docs <--          inLocRange (locRangeTo (getBufPos (srcSpanStart (locA l_name)))) $-          takeHdkComments mkDocNext-        dc <- selectDocString docs-        pure $ lexLHsDocString <$> dc+      case hsmodName mod of+        Nothing -> pure Nothing+        Just (L l_name _) -> do+          let modspan =+                getEpTokenBufSpan (am_mod mod_anns) <>+                getEpTokenBufSpan (am_sig mod_anns) <>+                getBufSpan (locA l_name)+          HdkA modspan $ do+            docs <-+              inLocRange (locRangeTo (fmap bufSpanStart modspan)) $+              takeHdkComments mkDocNext+            dc <- selectDocString docs+            pure $ lexLHsDocString <$> dc      -- Step 2, process documentation comments in the export list:     --@@ -290,7 +295,7 @@     pure $ L l_mod $       mod { hsmodExports = hsmodExports'           , hsmodDecls = hsmodDecls'-          , hsmodExt = (hsmodExt mod) { hsmodHaddockModHeader = join @Maybe headerDocs } }+          , hsmodExt = (hsmodExt mod) { hsmodHaddockModHeader = headerDocs } }  lexHsDocString :: HsDocString -> HsDoc GhcPs lexHsDocString = lexHsDoc parseIdentifier@@ -510,7 +515,7 @@                   tcdSigs, tcdMeths, tcdATs, tcdATDefs } <- decl     = do         registerHdkA tcdLName-        -- todo: register keyword location of 'where', see Note [Register keyword location]+        registerEpTokenHdkA (acd_where x)         where_cls' <-           addHaddockInterleaveItems layout (mkDocHsDecl layout) $           flattenBindsAndSigs (tcdMeths, tcdSigs, tcdATs, tcdATDefs, [], [])@@ -555,7 +560,6 @@     | SynDecl { tcdSExt, tcdLName, tcdTyVars, tcdFixity, tcdRhs } <- decl     = do         registerHdkA tcdLName-        -- todo: register keyword location of '=', see Note [Register keyword location]         tcdRhs' <- addHaddock tcdRhs         pure $           TyClD noExtField (SynDecl {@@ -585,7 +589,7 @@     --    data D :: Type -> Type        where ...     --    data instance D Bool :: Type  where ...     traverse_ @Maybe registerHdkA (dd_kindSig defn)-    -- todo: register keyword location of '=' or 'where', see Note [Register keyword location]+    registerEpTokenHdkA (andd_where (dd_ext defn))      -- Process the data constructors:     --@@ -705,17 +709,19 @@   addHaddock (L l_con_decl con_decl) =     extendHdkA (locA l_con_decl) $     case con_decl of-      ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, con_g_args, con_res_ty } -> do+      ConDeclGADT { con_g_ext, con_names, con_outer_bndrs, con_inner_bndrs+                  , con_mb_cxt, con_g_args, con_res_ty } -> do         con_doc' <- getConDoc (getLocA (NE.head con_names))         con_g_args' <-           case con_g_args of             PrefixConGADT x ts -> PrefixConGADT x <$> addHaddock ts             RecConGADT arr (L l_rec flds) -> do-              flds' <- traverse addHaddockConDeclField flds+              flds' <- traverse addHaddock flds               pure $ RecConGADT arr (L l_rec flds')         con_res_ty' <- addHaddock con_res_ty         pure $ L l_con_decl $-          ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt,+          ConDeclGADT { con_g_ext, con_names,+                        con_outer_bndrs, con_inner_bndrs, con_mb_cxt,                         con_doc = lexLHsDocString <$> con_doc',                         con_g_args = con_g_args',                         con_res_ty = con_res_ty' }@@ -733,24 +739,24 @@           getMixed :: HdkA (LocatedA (ConDecl GhcPs))           getMixed =             case con_args of-              PrefixCon _ ts -> do+              PrefixCon ts -> do                 con_doc' <- getConDoc (getLocA con_name)-                ts' <- traverse addHaddockConDeclFieldTy ts+                ts' <- traverse addHaddock ts                 pure $ L l_con_decl $                   ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,                                con_doc = lexLHsDocString <$> con_doc',-                               con_args = PrefixCon noTypeArgs ts' }+                               con_args = PrefixCon ts' }               InfixCon t1 t2 -> do-                t1' <- addHaddockConDeclFieldTy t1+                t1' <- addHaddock t1                 con_doc' <- getConDoc (getLocA con_name)-                t2' <- addHaddockConDeclFieldTy t2+                t2' <- addHaddock t2                 pure $ L l_con_decl $                   ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,                                con_doc = lexLHsDocString <$> con_doc',                                con_args = InfixCon t1' t2' }               RecCon (L l_rec flds) -> do                 con_doc' <- getConDoc (getLocA con_name)-                flds' <- traverse addHaddockConDeclField flds+                flds' <- traverse addHaddock flds                 pure $ L l_con_decl $                   ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,                                con_doc = lexLHsDocString <$> con_doc',@@ -785,25 +791,11 @@   -> HdkA (Maybe (Located HsDocString)) getConDoc l = extendHdkA l $ liftHdkA $ getPrevNextDoc l --- Add documentation comment to a data constructor field.--- Used for PrefixCon and InfixCon.-addHaddockConDeclFieldTy-  :: HsScaled GhcPs (LHsType GhcPs)-  -> HdkA (HsScaled GhcPs (LHsType GhcPs))-addHaddockConDeclFieldTy (HsScaled mult (L l t)) =-  extendHdkA (locA l) $ liftHdkA $ do-    mDoc <- getPrevNextDoc (locA l)-    return (HsScaled mult (mkLHsDocTy (L l t) mDoc))---- Add documentation comment to a data constructor field.--- Used for RecCon.-addHaddockConDeclField-  :: LConDeclField GhcPs-  -> HdkA (LConDeclField GhcPs)-addHaddockConDeclField (L l_fld fld) =-  extendHdkA (locA l_fld) $ liftHdkA $ do-    cd_fld_doc <- fmap lexLHsDocString <$> getPrevNextDoc (locA l_fld)-    return (L l_fld (fld { cd_fld_doc }))+instance HasHaddock (LocatedA (HsConDeclRecField GhcPs)) where+  addHaddock (L l_fld (HsConDeclRecField ext nms cfs)) =+    extendHdkA (locA l_fld) $ liftHdkA $ do+      cdf_doc <- fmap lexLHsDocString <$> getPrevNextDoc (locA l_fld)+      return $ L l_fld (HsConDeclRecField ext nms (cfs { cdf_doc }))  {- Note [Leading and trailing comments on H98 constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -906,8 +898,12 @@             including its field types -} -instance HasHaddock a => HasHaddock (HsScaled GhcPs a) where-  addHaddock (HsScaled mult a) = HsScaled mult <$> addHaddock a+instance HasHaddock (HsConDeclField GhcPs) where+  addHaddock cfs = do+    cdf_type <- addHaddock (cdf_type cfs)+    return $ case cdf_type of+      L _ (HsDocTy _ ty doc) -> cfs { cdf_type = ty, cdf_doc = Just doc }+      _ -> cfs { cdf_type }  instance HasHaddock a => HasHaddock (HsWildCardBndrs GhcPs a) where   addHaddock (HsWC _ t) = HsWC noExtField <$> addHaddock t@@ -1130,6 +1126,13 @@ -- See Note [Adding Haddock comments to the syntax tree]. registerHdkA :: GenLocated (EpAnn a) e -> HdkA () registerHdkA a = registerLocHdkA (getLocA a)++-- Let the neighbours know about a token at this location.+-- Similar to registerLocHdkA and registerHdkA.+--+-- See Note [Adding Haddock comments to the syntax tree].+registerEpTokenHdkA :: EpToken tok -> HdkA ()+registerEpTokenHdkA tok = HdkA (getEpTokenBufSpan tok) (pure ())  -- Modify the action of a HdkA computation. hoistHdkA :: (HdkM a -> HdkM b) -> HdkA a -> HdkA b
compiler/GHC/Parser/Types.hs view
@@ -8,6 +8,7 @@    , pprSumOrTuple    , PatBuilder(..)    , DataConBuilder(..)+   , ExplicitNamespaceKeyword(..)    ) where @@ -111,3 +112,7 @@     ppr lhs <+> ppr data_con <+> ppr rhs  type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnLW++data ExplicitNamespaceKeyword+  = ExplicitTypeNamespace !(EpToken "type")+  | ExplicitDataNamespace !(EpToken "data")
compiler/GHC/Platform.hs view
@@ -269,6 +269,7 @@    = SSE1    | SSE2    | SSE3+   | SSSE3    | SSE4    | SSE42    deriving (Eq, Ord)
+ compiler/GHC/Platform/LA64.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE CPP #-}++module GHC.Platform.LA64 where++import GHC.Prelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_loongarch64 1+#include "CodeGen.Platform.h"
− compiler/GHC/Platform/LoongArch64.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE CPP #-}--module GHC.Platform.LoongArch64 where--import GHC.Prelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_loongarch64 1-#include "CodeGen.Platform.h"
compiler/GHC/Platform/Regs.hs view
@@ -16,7 +16,7 @@ import qualified GHC.Platform.X86_64     as X86_64 import qualified GHC.Platform.RISCV64    as RISCV64 import qualified GHC.Platform.Wasm32     as Wasm32-import qualified GHC.Platform.LoongArch64 as LoongArch64+import qualified GHC.Platform.LA64       as LA64 import qualified GHC.Platform.NoRegs     as NoRegs  -- | Returns 'True' if this global register is stored in a caller-saves@@ -34,7 +34,7 @@    ArchAArch64 -> AArch64.callerSaves    ArchRISCV64 -> RISCV64.callerSaves    ArchWasm32  -> Wasm32.callerSaves-   ArchLoongArch64 -> LoongArch64.callerSaves+   ArchLoongArch64 -> LA64.callerSaves    arch     | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->         PPC.callerSaves@@ -58,7 +58,7 @@    ArchAArch64 -> AArch64.activeStgRegs    ArchRISCV64 -> RISCV64.activeStgRegs    ArchWasm32  -> Wasm32.activeStgRegs-   ArchLoongArch64 -> LoongArch64.activeStgRegs+   ArchLoongArch64 -> LA64.activeStgRegs    arch     | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->         PPC.activeStgRegs@@ -77,7 +77,7 @@    ArchAArch64 -> AArch64.haveRegBase    ArchRISCV64 -> RISCV64.haveRegBase    ArchWasm32  -> Wasm32.haveRegBase-   ArchLoongArch64 -> LoongArch64.haveRegBase+   ArchLoongArch64 -> LA64.haveRegBase    arch     | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->         PPC.haveRegBase@@ -96,7 +96,7 @@    ArchAArch64 -> AArch64.globalRegMaybe    ArchRISCV64 -> RISCV64.globalRegMaybe    ArchWasm32  -> Wasm32.globalRegMaybe-   ArchLoongArch64 -> LoongArch64.globalRegMaybe+   ArchLoongArch64 -> LA64.globalRegMaybe    arch     | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->         PPC.globalRegMaybe@@ -112,10 +112,21 @@    ArchX86_64  -> X86_64.freeReg    ArchS390X   -> S390X.freeReg    ArchARM {}  -> ARM.freeReg-   ArchAArch64 -> AArch64.freeReg+   ArchAArch64 ->+    -- See Note [Aarch64 Register x18 at Darwin and Windows].+    -- It already has `freeReg 18 = False` but that line does not work for cross-compile when+    -- we use host not from the list (darwin_HOST_OS, ios_HOST_OS, mingw32_HOST_OS) i.e. Linux+    if platformOS platform == OSMinGW32 || platformOS platform == OSDarwin+        then+            let+                x18Check :: RegNo -> Bool+                x18Check 18 = False+                x18Check a = AArch64.freeReg a+            in x18Check+        else AArch64.freeReg    ArchRISCV64 -> RISCV64.freeReg    ArchWasm32  -> Wasm32.freeReg-   ArchLoongArch64 -> LoongArch64.freeReg+   ArchLoongArch64 -> LA64.freeReg    arch     | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->         PPC.freeReg
compiler/GHC/Platform/Ways.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-}  -- | Ways --@@ -220,8 +219,6 @@  foreign import ccall unsafe "rts_isDynamic" rtsIsDynamic_ :: Int --- we need this until the bootstrap GHC is always recent enough-#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)  -- | Consult the RTS to find whether it is threaded. hostIsThreaded :: Bool@@ -242,18 +239,6 @@ foreign import ccall unsafe "rts_isTracing" rtsIsTracing_ :: Int  -#else--hostIsThreaded :: Bool-hostIsThreaded = False--hostIsDebugged :: Bool-hostIsDebugged = False--hostIsTracing :: Bool-hostIsTracing = False--#endif   -- | Host ways.
compiler/GHC/Prelude/Basic.hs view
@@ -24,7 +24,9 @@   , bit   , shiftL, shiftR   , setBit, clearBit-  , head, tail+  , head, tail, unzip++  , strictGenericLength   ) where  @@ -57,24 +59,19 @@ -}  import qualified Prelude-import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail)+import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, unzip) import Control.Applicative (Applicative(..))-import Data.Foldable as X (Foldable(elem, foldMap, foldr, foldl, foldl', foldr1, foldl1, maximum, minimum, product, sum, null, length))+import Data.Foldable as X (Foldable (elem, foldMap, foldl, foldl', foldr, length, null, product, sum))+import Data.Foldable1 as X hiding (head, last)+import qualified Data.List as List+import qualified GHC.Data.List.NonEmpty as NE import GHC.Stack.Types (HasCallStack) -#if MIN_VERSION_base(4,16,0) import GHC.Bits as Bits hiding (bit, shiftL, shiftR, setBit, clearBit) # if defined(DEBUG) import qualified GHC.Bits as Bits (shiftL, shiftR) # endif -#else---base <4.15-import Data.Bits as Bits hiding (bit, shiftL, shiftR, setBit, clearBit)-# if defined(DEBUG)-import qualified Data.Bits as Bits (shiftL, shiftR)-# endif-#endif  {- Note [Default to unsafe shifts inside GHC]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -138,3 +135,22 @@ tail :: HasCallStack => [a] -> [a] tail = Prelude.tail {-# INLINE tail #-}++{- |+The 'genericLength' function defined in base can't be specialised due to the+NOINLINE pragma.++It is also not strict in the accumulator, and strictGenericLength is not exported.++See #25706 for why it is important to use a strict, specialised version.++-}+strictGenericLength :: Num a => [x] -> a+strictGenericLength = fromIntegral . length++-- This is `Data.Functor.unzip`. Unfortunately, that function lacks the RULES for specialization.+unzip :: Functor f => f (a, b) -> (f a, f b)+unzip = \ xs -> (fmap fst xs, fmap snd xs)+{-# NOINLINE [1] unzip #-}+{-# RULES "unzip/List" unzip = List.unzip #-}+{-# RULES "unzip/NonEmpty" unzip = NE.unzip #-}
compiler/GHC/Runtime/Context.hs view
@@ -115,6 +115,51 @@   modules.  +Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId']+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The 'InteractiveContext' is used to store 'DynFlags', 'Plugins' and similar+information about the so-called interactive "home unit". We are using+quotes here, since, originally, GHC wasn't aware of more than one 'HomeUnitEnv's.+So the 'InteractiveContext' was a hack/solution to have 'DynFlags' and 'Plugins'+independent of the 'DynFlags' and 'Plugins' stored in 'HscEnv'.+Nowadays, GHC has support for multiple home units via the 'HomeUnitGraph', thus,+this part of the 'InteractiveContext' is strictly speaking redundant, as we+can simply manage one 'HomeUnitEnv' for the 'DynFlags' and 'Plugins' that are+currently stored in the 'InteractiveContext'.++As a matter of fact, that's exactly what we do nowadays.+That means, we can also lift other restrictions in the future, for example+allowing @:seti@ commands to modify the package-flags, since we now have a+separate 'UnitState' for the interactive session.+However, we did not rip out 'ic_dflags' and 'ic_plugins', yet, as it makes+it easier to access them for functions that want to use the interactive 'DynFlags',+such as 'runInteractiveHsc' and 'mkInteractiveHscEnv', without having to look that+information up in the 'HomeUnitGraph'.+It is reasonable to change this in the future, and remove 'ic_dflags' and 'ic_plugins'.++We keep 'ic_dflags' and 'ic_plugins' around, but we also store a 'HomeUnitEnv'+for the 'DynFlags' and 'Plugins' of the interactive session.++It is important to keep the 'DynFlags' in these two places consistent.++In other words, whenever you update the 'DynFlags' of the 'interactiveGhciUnitId'+in the 'HscEnv', then you also need to update the 'DynFlags' of the+'InteractiveContext'.+The easiest way to update them is via 'setInteractiveDynFlags'.+However, careful, footgun! It is very easy to call 'setInteractiveDynFlags'+and forget to call 'normaliseInteractiveDynFlags' on the 'DynFlags' in the+'HscEnv'! This is important, because you may, accidentally, have enabled+Language Extensions that are not supported in the interactive ghc session,+which we do not want.++To summarise, the 'ic_dflags' and 'ic_plugins' are currently used to+conveniently cache them for easy access.+The 'ic_dflags' must be identical to the 'DynFlags' stored in the 'HscEnv'+for the 'HomeUnitEnv' identified by 'interactiveGhciUnitId'.++See Note [Multiple Home Units aware GHCi] for the design and rationale for+the current 'interactiveGhciUnitId'.+ Note [Interactively-bound Ids in GHCi] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Ids bound by previous Stmts in GHCi are currently@@ -296,7 +341,7 @@       -- ^ Bring the exports of a particular module       -- (filtered by an import decl) into scope -  | IIModule ModuleName+  | IIModule Module       -- ^ Bring into scope the entire top-level envt of       -- of this module, including the things imported       -- into it.
compiler/GHC/Runtime/Eval/Types.hs view
@@ -9,17 +9,19 @@ module GHC.Runtime.Eval.Types (         Resume(..), ResumeBindings, IcGlobalRdrEnv(..),         History(..), ExecResult(..),-        SingleStep(..), isStep, ExecOptions(..)+        SingleStep(..), enableGhcStepMode, breakHere,+        ExecOptions(..)         ) where  import GHC.Prelude  import GHCi.RemoteTypes import GHCi.Message (EvalExpr, ResumeContext)+import GHC.ByteCode.Types (InternalBreakpointId(..))+import GHC.Driver.Config (EvalStep(..)) import GHC.Types.Id import GHC.Types.Name import GHC.Types.TyThing-import GHC.Types.Breakpoint import GHC.Types.Name.Reader import GHC.Types.SrcLoc import GHC.Utils.Exception@@ -35,21 +37,121 @@      , execWrap :: ForeignHValue -> EvalExpr ForeignHValue      } +-- | What kind of stepping are we doing? data SingleStep    = RunToCompletion-   | SingleStep++   -- | :trace [expr]    | RunAndLogSteps -isStep :: SingleStep -> Bool-isStep RunToCompletion = False-isStep _ = True+   -- | :step [expr]+   | SingleStep +   -- | :stepout+   | StepOut+      { initiatedFrom :: Maybe SrcSpan+        -- ^ Step-out locations are filtered to make sure we don't stop at a+        -- continuation that is within the function from which step-out was+        -- initiated. See Note [Debugger: Step-out]+      }++   -- | :steplocal [expr]+   | LocalStep+      { breakAt :: SrcSpan }++   -- | :stepmodule [expr]+   | ModuleStep+      { breakAt :: SrcSpan }++-- | Whether this 'SingleStep' mode requires instructing the interpreter to+-- step at every breakpoint or after every return (see @'EvalStep'@).+enableGhcStepMode :: SingleStep -> EvalStep+enableGhcStepMode RunToCompletion = EvalStepNone+enableGhcStepMode StepOut{}       = EvalStepOut+-- for the remaining step modes we need to stop at every single breakpoint.+enableGhcStepMode _               = EvalStepSingle++-- | Given a 'SingleStep' mode, whether the breakpoint was explicitly active,+-- and the SrcSpan of a breakpoint we hit, return @True@ if we should stop at+-- this breakpoint.+--+-- In particular, this will always be @False@ for @'RunToCompletion'@ and+-- @'RunAndLogSteps'@. We'd need further information e.g. about the user+-- breakpoints to determine whether to break in those modes.+breakHere :: Bool       -- ^ Was this breakpoint explicitly active (in the @BreakArray@s)?+          -> SingleStep -- ^ What kind of stepping were we doing+          -> SrcSpan    -- ^ The span of the breakpoint we hit+          -> Bool       -- ^ Should we stop here then?+breakHere b RunToCompletion _ = b+breakHere b RunAndLogSteps  _ = b+breakHere _ SingleStep      _ = True+breakHere b step break_span   = case step of+  LocalStep start_span  -> b || break_span `isSubspanOf` start_span+  ModuleStep start_span -> b || srcSpanFileName_maybe start_span == srcSpanFileName_maybe break_span+  StepOut Nothing       -> True+  StepOut (Just start)  ->+    -- See Note [Debugger: Filtering step-out stops]+    not (break_span `isSubspanOf` start)++{-+Note [Debugger: Filtering step-out stops]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Recall from Note [Debugger: Step-out] that the RTS explicitly enables the+breakpoint at the start of the first continuation frame on the stack, when+the step-out flag is set.++Often, the continuation on top of the stack will be part of the same function+from which step-out was initiated. A trivial example is a case expression:++  f x = case <brk>g x of ...++If we're stopped in <brk>, the continuation will be in the case alternatives rather+than in the function which called `f`. This is especially relevant for monadic+do-blocks which may end up being compiled to long chains of case expressions,+such as IO, and we don't want to stop at every line in the block while stepping out!++To make sure we only stop at a continuation outside of the current function, we+compare the continuation breakpoint `SrcSpan` against the current one. If the+continuation breakpoint is within the current function, instead of stopping, we+re-trigger step-out and return to the RTS interpreter right away.++This behaviour is very similar to `:steplocal`, which is implemented by+yielding from the RTS at every breakpoint (using `:step`) but only really+stopping when the breakpoint's `SrcSpan` is contained in the current function.++The function which determines if we should stop at the current breakpoint is+`breakHere`. For `StepOut`, `breakHere` will only return `True` if the+breakpoint is not contained in the function from which step-out was initiated.++Notably, this means we will ignore breakpoints enabled by the user if they are+contained in the function we are stepping out of.++If we had a way to distinguish whether a breakpoint was explicitly enabled (in+`BreakArrays`) by the user vs by step-out we could additionally break on+user-enabled breakpoints; however, it's not straightforward to determine this+and arguably it may be uncommon for a user to use step-out to run until the+next breakpoint in the same function. Of course, if a breakpoint in any other+function is hit before returning to the continuation, we will still stop there+(`breakHere` will be `True` because the break point is not within the initiator+function).+-}+ data ExecResult++  -- | Execution is complete with either an exception or the list of+  -- user-visible names that were brought into scope.   = ExecComplete        { execResult :: Either SomeException [Name]        , execAllocation :: Word64        }-  | ExecBreak++    -- | Execution stopped at a breakpoint.+    --+    -- Note: `ExecBreak` is only returned by `handleRunStatus` when GHCi should+    -- definitely stop at this breakpoint. GHCi is /not/ responsible for+    -- subsequently deciding whether to really stop here.+    -- `ExecBreak` always means GHCi breaks.+    | ExecBreak        { breakNames   :: [Name]        , breakPointId :: Maybe InternalBreakpointId        }@@ -74,7 +176,7 @@        , resumeApStack   :: ForeignHValue -- The object from which we can get                                         -- value of the free variables.        , resumeBreakpointId :: Maybe InternalBreakpointId-                                        -- ^ the breakpoint we stopped at+                                        -- ^ the internal breakpoint we stopped at                                         -- (Nothing <=> exception)        , resumeSpan      :: SrcSpan     -- just a copy of the SrcSpan                                         -- from the ModBreaks,
compiler/GHC/Runtime/Interpreter/Types.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecordWildCards #-}  -- | Types used by the runtime interpreter module GHC.Runtime.Interpreter.Types@@ -10,6 +12,21 @@    , ExtInterpInstance (..)    , ExtInterpState (..)    , InterpStatus(..)+   -- * InterpSymbolCache+   , InterpSymbolCache(..)+   , mkInterpSymbolCache+   , lookupInterpSymbolCache+   , updateInterpSymbolCache+   , purgeInterpSymbolCache+   , InterpSymbol(..)+   , SuffixOrInterpreted(..)+   , interpSymbolName+   , interpSymbolSuffix+   , eliminateInterpSymbol+   , interpretedInterpSymbol+   , interpreterProfiled+   , interpreterDynamic+    -- * IServ    , IServ    , IServConfig(..)@@ -30,11 +47,11 @@  import GHCi.RemoteTypes import GHCi.Message         ( Pipe )-import GHC.Types.Unique.FM-import GHC.Data.FastString ( FastString )-import Foreign  import GHC.Platform+#if defined(HAVE_INTERNAL_INTERPRETER)+import GHC.Platform.Ways+#endif import GHC.Utils.TmpFs import GHC.Utils.Logger import GHC.Unit.Env@@ -42,6 +59,7 @@ import GHC.Unit.Types import GHC.StgToJS.Types import GHC.StgToJS.Linker.Types+import GHC.Runtime.Interpreter.Types.SymbolCache  import Control.Concurrent import System.Process   ( ProcessHandle, CreateProcess )@@ -56,7 +74,7 @@   , interpLoader   :: !Loader       -- ^ Interpreter loader -  , interpLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ())))+  , interpSymbolCache :: !InterpSymbolCache       -- ^ LookupSymbol cache   } @@ -122,6 +140,28 @@       -- ^ Instance specific extra fields   } +-- | Interpreter uses Profiling way+interpreterProfiled :: Interp -> Bool+interpreterProfiled interp = case interpInstance interp of+#if defined(HAVE_INTERNAL_INTERPRETER)+  InternalInterp     -> hostIsProfiled+#endif+  ExternalInterp ext -> case ext of+    ExtIServ i -> iservConfProfiled (interpConfig i)+    ExtJS {}   -> False -- we don't support profiling yet in the JS backend+    ExtWasm i -> wasmInterpProfiled $ interpConfig i++-- | Interpreter uses Dynamic way+interpreterDynamic :: Interp -> Bool+interpreterDynamic interp = case interpInstance interp of+#if defined(HAVE_INTERNAL_INTERPRETER)+  InternalInterp     -> hostIsDynamic+#endif+  ExternalInterp ext -> case ext of+    ExtIServ i -> iservConfDynamic (interpConfig i)+    ExtJS {}   -> False -- dynamic doesn't make sense for JS+    ExtWasm {} -> True  -- wasm dyld can only load dynamic code+ ------------------------ -- JS Stuff ------------------------@@ -176,6 +216,16 @@   { wasmInterpDyLD           :: !FilePath  -- ^ Location of dyld.mjs script   , wasmInterpLibDir         ::  FilePath  -- ^ wasi-sdk sysroot libdir containing libc.so, etc   , wasmInterpOpts           :: ![String]  -- ^ Additional command line arguments for iserv++  -- wasm ghci browser mode+  , wasmInterpBrowser                      :: !Bool+  , wasmInterpBrowserHost                  :: !String+  , wasmInterpBrowserPort                  :: !Int+  , wasmInterpBrowserRedirectWasiConsole   :: !Bool+  , wasmInterpBrowserPuppeteerLaunchOpts   :: !(Maybe String)+  , wasmInterpBrowserPlaywrightBrowserType :: !(Maybe String)+  , wasmInterpBrowserPlaywrightLaunchOpts  :: !(Maybe String)+   , wasmInterpTargetPlatform :: !Platform   , wasmInterpProfiled       :: !Bool      -- ^ Are we profiling yet?   , wasmInterpHsSoSuffix     :: !String    -- ^ Shared lib filename common suffix sans .so, e.g. p-ghc9.13.20241001
+ compiler/GHC/Runtime/Interpreter/Types/SymbolCache.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecordWildCards #-}++-- | The SymbolCache is used to cache lookups for specific symbols when using+-- the interpreter.+module GHC.Runtime.Interpreter.Types.SymbolCache (+     InterpSymbolCache(..)+   , mkInterpSymbolCache+   , lookupInterpSymbolCache+   , updateInterpSymbolCache+   , purgeInterpSymbolCache+   , InterpSymbol(..)+   , SuffixOrInterpreted(..)+   , interpSymbolName+   , interpSymbolSuffix+   , eliminateInterpSymbol+   , interpretedInterpSymbol+   ) where++import GHC.Prelude++import GHC.Types.Unique.FM+import GHC.Types.Name+import GHC.Data.FastString+import Foreign++import Control.Concurrent+import GHC.Utils.Outputable+import GHC.TypeLits+++-- The symbols records the suffix which each cache deals with.+newtype SymbolCache (s :: Symbol) = SymbolCache { _getSymbolCache :: UniqFM Name (Ptr ()) }++-- Each cache is keyed by Name, there is one cache for each type of symbol we will+-- potentially lookup. The caches are keyed by 'Name' so that it is not necessary to consult+-- a complicated `FastString` each time.+data InterpSymbolCache = InterpSymbolCache {+        interpClosureCache :: MVar (SymbolCache "closure")+      , interpConInfoCache :: MVar (SymbolCache "con_info")+      , interpStaticInfoCache :: MVar (SymbolCache "static_info")+      , interpBytesCache   :: MVar (SymbolCache "bytes")+      , interpFaststringCache   :: MVar (UniqFM FastString (Ptr ()))+      }++data SuffixOrInterpreted = Suffix Symbol | Interpreted++data InterpSymbol (s :: SuffixOrInterpreted) where+  IClosureSymbol :: Name -> InterpSymbol (Suffix "closure")+  IConInfoSymbol :: Name -> InterpSymbol (Suffix "con_info")+  IStaticInfoSymbol :: Name -> InterpSymbol (Suffix "static_info")+  IBytesSymbol   :: Name -> InterpSymbol (Suffix "bytes")+  IFaststringSymbol   :: FastString -> InterpSymbol Interpreted++instance Outputable (InterpSymbol s) where+  ppr s = eliminateInterpSymbol s+            (\(IFaststringSymbol s) -> text "interpreted:" <> ppr s)+            (\s -> text (interpSymbolSuffix s) <> colon <> ppr (interpSymbolName s))++eliminateInterpSymbol :: InterpSymbol s -> (InterpSymbol Interpreted -> r)+                                        -> (forall x . InterpSymbol (Suffix x) -> r)+                                        -> r+eliminateInterpSymbol s k1 k2 =+  case s of+    IFaststringSymbol {} -> k1 s+    IBytesSymbol {}      -> k2 s+    IStaticInfoSymbol {} -> k2 s+    IConInfoSymbol {}    -> k2 s+    IClosureSymbol {}    -> k2 s+++interpSymbolName :: InterpSymbol (Suffix s) -> Name+interpSymbolName (IClosureSymbol n) = n+interpSymbolName (IConInfoSymbol n) = n+interpSymbolName (IStaticInfoSymbol n) = n+interpSymbolName (IBytesSymbol n) = n++interpretedInterpSymbol :: InterpSymbol Interpreted -> FastString+interpretedInterpSymbol (IFaststringSymbol s) = s++interpSymbolSuffix :: InterpSymbol (Suffix s) -> String+interpSymbolSuffix (IClosureSymbol {}) = "closure"+interpSymbolSuffix (IConInfoSymbol {}) = "con_info"+interpSymbolSuffix (IStaticInfoSymbol {}) = "static_info"+interpSymbolSuffix (IBytesSymbol {})      = "bytes"++emptySymbolCache :: SymbolCache s+emptySymbolCache = SymbolCache emptyUFM++lookupSymbolCache :: InterpSymbol (Suffix s) -> SymbolCache s -> Maybe (Ptr ())+lookupSymbolCache s (SymbolCache cache) = lookupUFM cache (interpSymbolName s)++insertSymbolCache :: InterpSymbol (Suffix s) -> Ptr () -> SymbolCache s -> SymbolCache s+insertSymbolCache s v (SymbolCache cache) = SymbolCache (addToUFM cache (interpSymbolName s) v)++lookupInterpSymbolCache :: InterpSymbol s -> InterpSymbolCache -> IO (Maybe (Ptr ()))+lookupInterpSymbolCache = withInterpSymbolCache+                            (\(IFaststringSymbol f) mvar_var -> (\cache -> lookupUFM cache f) <$> readMVar mvar_var)+                            (\s mvar_var -> lookupSymbolCache s <$> readMVar mvar_var)+++updateInterpSymbolCache :: InterpSymbol s+                                 -> InterpSymbolCache -> Ptr () -> IO ()+updateInterpSymbolCache = withInterpSymbolCache+                            (\(IFaststringSymbol f) mvar_var v -> modifyMVar_ mvar_var (\cache -> pure $ addToUFM cache f v))+                            (\s mvar_var v -> modifyMVar_ mvar_var (\cache -> pure $ insertSymbolCache s v cache))++withInterpSymbolCache ::+                (InterpSymbol Interpreted -> MVar (UniqFM FastString (Ptr ())) -> r)+                -> (forall x . InterpSymbol (Suffix x) -> MVar (SymbolCache x) -> r)+                -> InterpSymbol s+                -> InterpSymbolCache+                -> r+withInterpSymbolCache k1 k2 key InterpSymbolCache{..} =+  case key of+    IClosureSymbol {} -> k2 key interpClosureCache+    IConInfoSymbol {} -> k2 key interpConInfoCache+    IStaticInfoSymbol {} -> k2 key interpStaticInfoCache+    IBytesSymbol {} -> k2 key interpBytesCache+    IFaststringSymbol {} -> k1 key interpFaststringCache++-- | Clear all symbol caches.+purgeInterpSymbolCache :: InterpSymbolCache -> IO ()+purgeInterpSymbolCache (InterpSymbolCache a b c d e) = do+  modifyMVar_ a (\_ ->  do+    modifyMVar_ b (\_ -> do+      modifyMVar_ c (\_ -> do+        modifyMVar_ d (\_ -> do+          modifyMVar_ e (\_ -> pure emptyUFM)+          pure emptySymbolCache)+        pure emptySymbolCache)+      pure emptySymbolCache)+    pure emptySymbolCache)++mkInterpSymbolCache :: IO InterpSymbolCache+mkInterpSymbolCache = do+  InterpSymbolCache <$> newMVar emptySymbolCache+                    <*> newMVar emptySymbolCache+                    <*> newMVar emptySymbolCache+                    <*> newMVar emptySymbolCache+                    <*> newMVar emptyUFM
compiler/GHC/Settings.hs view
@@ -5,6 +5,7 @@   ( Settings (..)   , ToolSettings (..)   , FileSettings (..)+  , UnitSettings(..)   , GhcNameVersion (..)   , Platform (..)   , PlatformMisc (..)@@ -73,6 +74,7 @@ import GHC.Utils.CliOption import GHC.Utils.Fingerprint import GHC.Platform+import GHC.Unit.Types  data Settings = Settings   { sGhcNameVersion    :: {-# UNPACk #-} !GhcNameVersion@@ -80,11 +82,14 @@   , sTargetPlatform    :: Platform       -- Filled in by SysTools   , sToolSettings      :: {-# UNPACK #-} !ToolSettings   , sPlatformMisc      :: {-# UNPACK #-} !PlatformMisc+  , sUnitSettings      :: !UnitSettings    -- You shouldn't need to look things up in rawSettings directly.   -- They should have their own fields instead.   , sRawSettings       :: [(String, String)]   }++data UnitSettings = UnitSettings { unitSettings_baseUnitId :: !UnitId }  -- | Settings for other executables GHC calls. --
+ compiler/GHC/Stg/EnforceEpt/TagSig.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}++-- We export this type from this module instead of GHC.Stg.EnforceEpt.Types+-- because it's used by more than the analysis itself. For example in interface+-- files where we record a tag signature for bindings.+-- By putting the sig into its own module we can avoid module loops.+module GHC.Stg.EnforceEpt.TagSig++where++import GHC.Prelude++import GHC.Types.Var+import GHC.Types.Name.Env( NameEnv )+import GHC.Utils.Outputable+import GHC.Utils.Binary+import GHC.Utils.Panic.Plain+import Data.Coerce++-- | Information to be exposed in interface files which is produced+-- by the stg2stg passes.+type StgCgInfos = NameEnv TagSig++newtype TagSig  -- The signature for each binding, this is a newtype as we might+                -- want to track more information in the future.+  = TagSig TagInfo+  deriving (Eq)++data TagInfo+  = TagDunno            -- We don't know anything about the tag.+  | TagTuple [TagInfo]  -- Represents a function/thunk which when evaluated+                        -- will return a Unboxed tuple whos components have+                        -- the given TagInfos.+  | TagProper           -- Heap pointer to properly-tagged value+  | TagTagged           -- Bottom of the domain.+  deriving (Eq)++instance Outputable TagInfo where+  ppr TagTagged      = text "TagTagged"+  ppr TagDunno       = text "TagDunno"+  ppr TagProper      = text "TagProper"+  ppr (TagTuple tis) = text "TagTuple" <> brackets (pprWithCommas ppr tis)++instance Binary TagInfo where+  put_ bh TagDunno  = putByte bh 1+  put_ bh (TagTuple flds) = putByte bh 2 >> put_ bh flds+  put_ bh TagProper = putByte bh 3+  put_ bh TagTagged = putByte bh 4++  get bh = do tag <- getByte bh+              case tag of 1 -> return TagDunno+                          2 -> TagTuple <$> get bh+                          3 -> return TagProper+                          4 -> return TagTagged+                          _ -> panic ("get TagInfo " ++ show tag)++instance Outputable TagSig where+  ppr (TagSig ti) = char '<' <> ppr ti <> char '>'+instance OutputableBndr (Id,TagSig) where+  pprInfixOcc  = ppr+  pprPrefixOcc = ppr++instance Binary TagSig where+  put_ bh (TagSig sig) = put_ bh sig+  get bh = pure TagSig <*> get bh++isTaggedSig :: TagSig -> Bool+isTaggedSig (TagSig TagProper) = True+isTaggedSig (TagSig TagTagged) = True+isTaggedSig _ = False++seqTagSig :: TagSig -> ()+seqTagSig = coerce seqTagInfo++seqTagInfo :: TagInfo -> ()+seqTagInfo TagTagged      = ()+seqTagInfo TagDunno       = ()+seqTagInfo TagProper      = ()+seqTagInfo (TagTuple tis) = foldl' (\_unit sig -> seqTagSig (coerce sig)) () tis
− compiler/GHC/Stg/InferTags/TagSig.hs 
@@ -1,81 +0,0 @@-{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}---- We export this type from this module instead of GHC.Stg.InferTags.Types--- because it's used by more than the analysis itself. For example in interface--- files where we record a tag signature for bindings.--- By putting the sig into its own module we can avoid module loops.-module GHC.Stg.InferTags.TagSig--where--import GHC.Prelude--import GHC.Types.Var-import GHC.Types.Name.Env( NameEnv )-import GHC.Utils.Outputable-import GHC.Utils.Binary-import GHC.Utils.Panic.Plain-import Data.Coerce---- | Information to be exposed in interface files which is produced--- by the stg2stg passes.-type StgCgInfos = NameEnv TagSig--newtype TagSig  -- The signature for each binding, this is a newtype as we might-                -- want to track more information in the future.-  = TagSig TagInfo-  deriving (Eq)--data TagInfo-  = TagDunno            -- We don't know anything about the tag.-  | TagTuple [TagInfo]  -- Represents a function/thunk which when evaluated-                        -- will return a Unboxed tuple whos components have-                        -- the given TagInfos.-  | TagProper           -- Heap pointer to properly-tagged value-  | TagTagged           -- Bottom of the domain.-  deriving (Eq)--instance Outputable TagInfo where-  ppr TagTagged      = text "TagTagged"-  ppr TagDunno       = text "TagDunno"-  ppr TagProper      = text "TagProper"-  ppr (TagTuple tis) = text "TagTuple" <> brackets (pprWithCommas ppr tis)--instance Binary TagInfo where-  put_ bh TagDunno  = putByte bh 1-  put_ bh (TagTuple flds) = putByte bh 2 >> put_ bh flds-  put_ bh TagProper = putByte bh 3-  put_ bh TagTagged = putByte bh 4--  get bh = do tag <- getByte bh-              case tag of 1 -> return TagDunno-                          2 -> TagTuple <$> get bh-                          3 -> return TagProper-                          4 -> return TagTagged-                          _ -> panic ("get TagInfo " ++ show tag)--instance Outputable TagSig where-  ppr (TagSig ti) = char '<' <> ppr ti <> char '>'-instance OutputableBndr (Id,TagSig) where-  pprInfixOcc  = ppr-  pprPrefixOcc = ppr--instance Binary TagSig where-  put_ bh (TagSig sig) = put_ bh sig-  get bh = pure TagSig <*> get bh--isTaggedSig :: TagSig -> Bool-isTaggedSig (TagSig TagProper) = True-isTaggedSig (TagSig TagTagged) = True-isTaggedSig _ = False--seqTagSig :: TagSig -> ()-seqTagSig = coerce seqTagInfo--seqTagInfo :: TagInfo -> ()-seqTagInfo TagTagged      = ()-seqTagInfo TagDunno       = ()-seqTagInfo TagProper      = ()-seqTagInfo (TagTuple tis) = foldl' (\_unit sig -> seqTagSig (coerce sig)) () tis
compiler/GHC/Stg/Syntax.hs view
@@ -72,7 +72,7 @@  import GHC.Prelude -import GHC.Stg.InferTags.TagSig( TagSig )+import GHC.Stg.EnforceEpt.TagSig( TagSig ) import GHC.Stg.Lift.Types   -- To avoid having an orphan instances for BinderP, XLet etc @@ -610,9 +610,9 @@      each binding.      See Note [Late lambda lifting in STG]. -  4. Tag inference takes in 'Vanilla and produces 'InferTagged STG, while using+  4. EPT enforcement takes in 'Vanilla and produces 'InferTagged STG, while using      the InferTaggedBinders annotated AST internally.-     See Note [Tag Inference].+     See Note [EPT enforcement].    5. Stg.FVs annotates closures with their free variables. To store these      annotations we use the 'CodeGen parameterisation.@@ -627,9 +627,9 @@   = Vanilla   | LiftLams -- ^ Use internally by the lambda lifting pass   | InferTaggedBinders -- ^ Tag inference information on binders.-                       -- See Note [Tag inference passes] in GHC.Stg.InferTags+                       -- See Note [EPT enforcement] in GHC.Stg.EnforceEpt   | InferTagged -- ^ Tag inference information put on relevant StgApp nodes-                -- See Note [Tag inference passes] in GHC.Stg.InferTags+                -- See Note [EPT enforcement] in GHC.Stg.EnforceEpt   | CodeGen  type family BinderP (pass :: StgPass)
compiler/GHC/StgToCmm/CgUtils.hs view
@@ -147,7 +147,7 @@  -- | Fixup global registers so that they assign to locations within the -- RegTable if they aren't pinned for the current target.-fixStgRegisters :: Platform -> RawCmmDecl -> RawCmmDecl+fixStgRegisters :: Platform -> GenCmmDecl d h (GenCmmGraph CmmNode) -> GenCmmDecl d h (GenCmmGraph CmmNode) fixStgRegisters _ top@(CmmData _ _) = top  fixStgRegisters platform (CmmProc info lbl live graph) =
compiler/GHC/StgToCmm/Config.hs view
@@ -72,6 +72,7 @@   , stgToCmmAllowIntMul2Instr         :: !Bool   -- ^ Allowed to generate IntMul2 instruction   , stgToCmmAllowWordMul2Instr        :: !Bool   -- ^ Allowed to generate WordMul2 instruction   , stgToCmmAllowFMAInstr             :: FMASign -> Bool -- ^ Allowed to generate FMA instruction+  , stgToCmmAllowIntWord64X2MinMax    :: !Bool   -- ^ Allowed to generate min/max instructions for Int64X2/Word64X2   , stgToCmmTickyAP                   :: !Bool   -- ^ Disable use of precomputed standard thunks.   , stgToCmmSaveFCallTargetToLocal    :: !Bool   -- ^ Save a foreign call target to a Cmm local, see                                                  -- Note [Saving foreign call target to local] for details
compiler/GHC/StgToJS/Object.hs view
@@ -255,23 +255,23 @@ -- index putObjBlock :: WriteBinHandle -> ObjBlock -> IO () putObjBlock bh (ObjBlock _syms b c d e f g) = do-    put_ bh b-    put_ bh c+    lazyPut bh b+    lazyPut bh c     lazyPut bh d-    put_ bh e-    put_ bh f-    put_ bh g+    lazyPut bh e+    lazyPut bh f+    lazyPut bh g  -- | Read an ObjBlock and associate it to the given symbols (that must have been -- read from the index) getObjBlock :: [FastString] -> ReadBinHandle -> IO ObjBlock getObjBlock syms bh = do-    b <- get bh-    c <- get bh+    b <- lazyGet bh+    c <- lazyGet bh     d <- lazyGet bh-    e <- get bh-    f <- get bh-    g <- get bh+    e <- lazyGet bh+    f <- lazyGet bh+    g <- lazyGet bh     pure $ ObjBlock       { oiSymbols  = syms       , oiClInfo   = b@@ -615,16 +615,16 @@   get bh = StaticInfo <$> get bh <*> get bh <*> get bh  instance Binary StaticVal where-  put_ bh (StaticFun f args)   = putByte bh 1 >> put_ bh f  >> put_ bh args-  put_ bh (StaticThunk t)      = putByte bh 2 >> put_ bh t-  put_ bh (StaticUnboxed u)    = putByte bh 3 >> put_ bh u-  put_ bh (StaticData dc args) = putByte bh 4 >> put_ bh dc >> put_ bh args-  put_ bh (StaticList xs t)    = putByte bh 5 >> put_ bh xs >> put_ bh t+  put_ bh (StaticApp SAKFun   f  args)   = putByte bh 1 >> put_ bh f  >> put_ bh args+  put_ bh (StaticApp SAKThunk f  args)   = putByte bh 2 >> put_ bh f  >> put_ bh args+  put_ bh (StaticUnboxed u)              = putByte bh 3 >> put_ bh u+  put_ bh (StaticApp SAKData  dc args)   = putByte bh 4 >> put_ bh dc >> put_ bh args+  put_ bh (StaticList xs t)              = putByte bh 5 >> put_ bh xs >> put_ bh t   get bh = getByte bh >>= \case-    1 -> StaticFun     <$> get bh <*> get bh-    2 -> StaticThunk   <$> get bh+    1 -> StaticApp SAKFun <$> get bh <*> get bh+    2 -> StaticApp SAKThunk <$> get bh <*> get bh     3 -> StaticUnboxed <$> get bh-    4 -> StaticData    <$> get bh <*> get bh+    4 -> StaticApp SAKData <$> get bh <*> get bh     5 -> StaticList    <$> get bh <*> get bh     n -> error ("Binary get bh StaticVal: invalid tag " ++ show n)
compiler/GHC/StgToJS/Symbols.hs view
@@ -849,9 +849,6 @@ typeof :: FastString typeof = fsLit "typeof" -hdRawStr :: FastString-hdRawStr = fsLit "h$rstr"- throwStr :: FastString throwStr = fsLit "throw" @@ -1213,5 +1210,7 @@ hdStiStr :: FastString hdStiStr = fsLit "h$sti" -hdStrStr :: FastString-hdStrStr = fsLit "h$str"+------------------------------ Pack/Unpack --------------------------------------------++hdDecodeUtf8Z :: FastString+hdDecodeUtf8Z = fsLit "h$decodeUtf8z"
compiler/GHC/StgToJS/Types.hs view
@@ -231,18 +231,22 @@   , siCC     :: !(Maybe Ident) -- ^ optional CCS name   } deriving stock (Eq, Show) +data StaticAppKind+  = SAKFun+  -- ^ heap object for function+  | SAKThunk+  -- ^ heap object for CAF+  | SAKData+  -- ^ regular datacon app+  deriving stock (Eq, Show)+ data StaticVal-  = StaticFun     !FastString [StaticArg]-    -- ^ heap object for function-  | StaticThunk   !(Maybe (FastString,[StaticArg]))-    -- ^ heap object for CAF (field is Nothing when thunk is initialized in an-    -- alternative way, like string thunks through h$str)-  | StaticUnboxed !StaticUnboxed+  = StaticUnboxed !StaticUnboxed     -- ^ unboxed constructor (Bool, Int, Double etc)-  | StaticData    !FastString [StaticArg]-    -- ^ regular datacon app   | StaticList    [StaticArg] (Maybe FastString)     -- ^ list initializer (with optional tail)+  | StaticApp StaticAppKind !FastString [StaticArg]+    -- ^ static application of static args. Can be a CAF, a FUN, or a CON app.   deriving stock (Eq, Show)  data StaticUnboxed@@ -284,8 +288,8 @@   toJExpr (IntLit i)            = toJExpr i   toJExpr NullLit               = null_   toJExpr (DoubleLit d)         = toJExpr (unSaneDouble d)-  toJExpr (StringLit t)         = app hdStrStr [toJExpr t]-  toJExpr (BinLit b)            = app hdRawStr [toJExpr (map toInteger (BS.unpack b))]+  toJExpr (StringLit t)         = app hdEncodeModifiedUtf8Str [toJExpr t]+  toJExpr (BinLit b)            = app hdRawStringDataStr      [toJExpr (map toInteger (BS.unpack b))]   toJExpr (LabelLit _isFun lbl) = global lbl  -- | A foreign reference to some JS code@@ -297,6 +301,7 @@   , foreignRefArgs     :: ![FastString]   , foreignRefResult   :: !FastString   }+  deriving (Show)  -- | data used to generate one ObjBlock in our object file data LinkableUnit = LinkableUnit@@ -312,13 +317,13 @@  -- | one toplevel block in the object file data ObjBlock = ObjBlock-  { oiSymbols  :: ![FastString]   -- ^ toplevel symbols (stored in index)-  , oiClInfo   :: ![ClosureInfo]  -- ^ closure information of all closures in block-  , oiStatic   :: ![StaticInfo]   -- ^ static closure data+  { oiSymbols  :: [FastString]   -- ^ toplevel symbols (stored in index)+  , oiClInfo   :: [ClosureInfo]  -- ^ closure information of all closures in block+  , oiStatic   :: [StaticInfo]   -- ^ static closure data   , oiStat     :: Sat.JStat       -- ^ the code-  , oiRaw      :: !BS.ByteString  -- ^ raw JS code-  , oiFExports :: ![ExpFun]-  , oiFImports :: ![ForeignJSRef]+  , oiRaw      :: BS.ByteString  -- ^ raw JS code+  , oiFExports :: [ExpFun]+  , oiFImports :: [ForeignJSRef]   }  data ExpFun = ExpFun
compiler/GHC/Tc/Errors/Hole/FitTypes.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} module GHC.Tc.Errors.Hole.FitTypes (-  TypedHole (..), HoleFit (..), HoleFitCandidate (..),+  TypedHole (..), HoleFit (..), TcHoleFit(..), HoleFitCandidate (..),   hfIsLcl, pprHoleFitCand   ) where @@ -77,7 +77,7 @@ -- element that was checked, the Id of that element as found by `tcLookup`, -- and the refinement level of the fit, which is the number of extra argument -- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`).-data HoleFit =+data TcHoleFit =   HoleFit { hfId   :: Id       -- ^ The elements id in the TcM           , hfCand :: HoleFitCandidate  -- ^ The candidate that was checked.           , hfType :: TcType -- ^ The type of the id, possibly zonked.@@ -88,16 +88,22 @@           , hfDoc :: Maybe [HsDocString]           -- ^ Documentation of this HoleFit, if available.           }- | RawHoleFit SDoc- -- ^ A fit that is just displayed as is. Here so thatHoleFitPlugins++data HoleFit+  = TcHoleFit  TcHoleFit+  | RawHoleFit SDoc+ -- ^ A fit that is just displayed as is. Here so that HoleFitPlugins  --   can inject any fit they want.  -- We define an Eq and Ord instance to be able to build a graph.-instance Eq HoleFit where+instance Eq TcHoleFit where    (==) = (==) `on` hfId  instance Outputable HoleFit where+  ppr (TcHoleFit hf)  = ppr hf   ppr (RawHoleFit sd) = sd++instance Outputable TcHoleFit where   ppr (HoleFit _ cand ty _ _ mtchs _) =     hang (name <+> holes) 2 (text "where" <+> name <+> dcolon <+> (ppr ty))     where name = ppr $ getName cand@@ -107,20 +113,18 @@ -- want our tests to be affected by the non-determinism of `nonDetCmpVar`, -- which is used to compare Ids. When comparing, we want HoleFits with a lower -- refinement level to come first.-instance Ord HoleFit where-  compare (RawHoleFit _) (RawHoleFit _) = EQ-  compare (RawHoleFit _) _ = LT-  compare _ (RawHoleFit _) = GT+instance Ord TcHoleFit where+--  compare (RawHoleFit _) (RawHoleFit _) = EQ+--  compare (RawHoleFit _) _ = LT+--  compare _ (RawHoleFit _) = GT   compare a@(HoleFit {}) b@(HoleFit {}) = cmp a b     where cmp  = if hfRefLvl a == hfRefLvl b                  then compare `on` (getName . hfCand)                  else compare `on` hfRefLvl -hfIsLcl :: HoleFit -> Bool+hfIsLcl :: TcHoleFit -> Bool hfIsLcl hf@(HoleFit {}) = case hfCand hf of                             IdHFCand _    -> True                             NameHFCand _  -> False                             GreHFCand gre -> gre_lcl gre-hfIsLcl _ = False-
compiler/GHC/Tc/Errors/Hole/Plugin.hs view
compiler/GHC/Tc/Errors/Ppr.hs view
@@ -15,6988 +15,7537 @@ module GHC.Tc.Errors.Ppr   ( pprTypeDoesNotHaveFixedRuntimeRep   , pprScopeError-  ---  , tidySkolemInfo-  , tidySkolemInfoAnon-  ---  , pprHsDocContext-  , inHsDocContext-  , TcRnMessageOpts(..)-  , pprTyThingUsedWrong-  , pprUntouchableVariable--  ---  , mismatchMsg_ExpectedActuals--  -- | Useful when overriding message printing.-  , messageWithInfoDiagnosticMessage-  , messageWithHsDocContext-  )-  where--import GHC.Prelude--import qualified GHC.Boot.TH.Syntax as TH--- In stage1: import "ghc-boot-th-next" qualified GHC.Boot.TH.Syntax as TH--- In stage2: import "ghc-boot-th"      qualified GHC.Boot.TH.Syntax as TH---            which is a rexport of---            import "ghc-internal"     qualified GHC.Internal.TH.Syntax as TH-import qualified GHC.Boot.TH.Ppr as TH--import GHC.Builtin.Names-import GHC.Builtin.Types ( boxedRepDataConTyCon, tYPETyCon, filterCTuple, pretendNameIsInScope )--import GHC.Types.Name.Reader-import GHC.Unit.Module.ModIface-import GHC.Unit.Module.Warnings--import GHC.Core.Coercion-import GHC.Core.Unify     ( tcMatchTys )-import GHC.Core.TyCon-import GHC.Core.Class-import GHC.Core.DataCon-import GHC.Core.Coercion.Axiom (CoAxBranch, coAxiomTyCon, coAxiomSingleBranch)-import GHC.Core.ConLike-import GHC.Core.FamInstEnv ( FamInst(..), famInstAxiom, pprFamInst )-import GHC.Core.InstEnv-import GHC.Core.TyCo.Rep (Type(..))-import GHC.Core.TyCo.Ppr (pprWithInvisibleBitsWhen, pprSourceTyCon,-                          pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType, pprForAll)-import GHC.Core.PatSyn ( patSynName, pprPatSynType )-import GHC.Core.Predicate-import GHC.Core.Type-import GHC.Core.FVs( orphNamesOfTypes )-import GHC.CoreToIface--import GHC.Driver.Flags-import GHC.Driver.Backend-import GHC.Hs--import GHC.Tc.Errors.Types-import GHC.Tc.Types.BasicTypes-import GHC.Tc.Types.Constraint-import GHC.Tc.Types.Origin hiding ( Position(..) )-import GHC.Tc.Types.CtLoc-import GHC.Tc.Types.Rank (Rank(..))-import GHC.Tc.Types.TH-import GHC.Tc.Utils.TcType--import GHC.Types.DefaultEnv (ClassDefaults(ClassDefaults, cd_types, cd_module))-import GHC.Types.Error-import GHC.Types.Error.Codes-import GHC.Types.Hint-import GHC.Types.Hint.Ppr () -- Outputable GhcHint-import GHC.Types.Basic-import GHC.Types.Id-import GHC.Types.Id.Info ( RecSelParent(..) )-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Name.Set-import GHC.Types.SourceFile-import GHC.Types.SrcLoc-import GHC.Types.TyThing-import GHC.Types.TyThing.Ppr ( pprTyThingInContext )-import GHC.Types.Unique.Set ( nonDetEltsUniqSet )-import GHC.Types.Var-import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Types.Fixity (defaultFixity)--import GHC.Iface.Errors.Types-import GHC.Iface.Errors.Ppr-import GHC.Iface.Syntax--import GHC.Unit.State-import GHC.Unit.Module--import GHC.Data.Bag-import GHC.Data.FastString-import GHC.Data.List.SetOps ( nubOrdBy )-import GHC.Data.Maybe-import GHC.Data.Pair-import GHC.Settings.Constants (mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE)-import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Utils.Panic--import qualified GHC.LanguageExtensions as LangExt--import GHC.Data.BooleanFormula (pprBooleanFormulaNice)--import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NE-import Data.Foldable ( fold )-import Data.Function (on)-import Data.List ( groupBy, sortBy, tails-                 , partition, unfoldr )-import Data.Ord ( comparing )-import Data.Bifunctor---defaultTcRnMessageOpts :: TcRnMessageOpts-defaultTcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext = True-                                         , tcOptsIfaceOpts = defaultDiagnosticOpts @IfaceMessage }--instance HasDefaultDiagnosticOpts TcRnMessageOpts where-  defaultOpts = defaultTcRnMessageOpts--instance Diagnostic TcRnMessage where-  type DiagnosticOpts TcRnMessage = TcRnMessageOpts-  diagnosticMessage opts = \case-    TcRnUnknownMessage (UnknownDiagnostic f m)-      -> diagnosticMessage (f opts) m-    TcRnMessageWithInfo unit_state msg_with_info-      -> case msg_with_info of-           TcRnMessageDetailed err_info msg-             -> messageWithInfoDiagnosticMessage unit_state err_info-                  (tcOptsShowContext opts)-                  (diagnosticMessage opts msg)-    TcRnWithHsDocContext ctxt msg-      -> messageWithHsDocContext opts ctxt (diagnosticMessage opts msg)-    TcRnSolverReport msg _-      -> mkSimpleDecorated $ pprSolverReportWithCtxt msg-    TcRnSolverDepthError ty depth -> mkSimpleDecorated msg-      where-        msg =-          vcat [ text "Reduction stack overflow; size =" <+> ppr depth-               , hang (text "When simplifying the following type:")-                    2 (ppr ty) ]-    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 contra-      -> mkSimpleDecorated $-         hang (text "Inaccessible code in")-           2 (ppr (ic_info implic))-         $$ pprSolverReportWithCtxt contra-    TcRnInaccessibleCoAxBranch fam_tc cur_branch-      -> mkSimpleDecorated $-          text "Type family instance equation is overlapped:" $$-          nest 2 (pprCoAxBranchUser fam_tc cur_branch)-    TcRnTypeDoesNotHaveFixedRuntimeRep ty prov (ErrInfo extra supplementary)-      -> mkDecorated [pprTypeDoesNotHaveFixedRuntimeRep ty prov, extra, supplementary]-    TcRnImplicitLift id_or_name ErrInfo{..}-      -> mkDecorated $-           ( text "The variable" <+> quotes (ppr id_or_name) <+>-             text "is implicitly lifted in the TH quotation"-           ) : [errInfoContext, errInfoSupplementary]-    TcRnUnusedPatternBinds bind-      -> mkDecorated [hang (text "This pattern-binding binds no variables:") 2 (ppr bind)]-    TcRnDodgyImports (DodgyImportsEmptyParent gre)-      -> mkDecorated [dodgy_msg (text "import") gre (dodgy_msg_insert gre)]-    TcRnDodgyImports (DodgyImportsHiding reason)-      -> mkSimpleDecorated $-         pprImportLookup reason-    TcRnDodgyExports gre-      -> mkDecorated [dodgy_msg (text "export") gre (dodgy_msg_insert gre)]-    TcRnMissingImportList ie-      -> mkDecorated [ text "The import item" <+> quotes (ppr ie) <+>-                       text "does not have an explicit import list"-                     ]-    TcRnUnsafeDueToPlugin-      -> mkDecorated [text "Use of plugins makes the module unsafe"]-    TcRnModMissingRealSrcSpan mod-      -> mkDecorated [text "Module does not have a RealSrcSpan:" <+> ppr mod]-    TcRnIdNotExportedFromModuleSig name mod-      -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+>-                       text "does not exist in the signature for" <+> ppr mod-                     ]-    TcRnIdNotExportedFromLocalSig name-      -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+>-                       text "does not exist in the local signature."-                     ]-    TcRnShadowedName occ provenance-      -> let shadowed_locs = case provenance of-               ShadowedNameProvenanceLocal n     -> [text "bound at" <+> ppr n]-               ShadowedNameProvenanceGlobal gres -> map pprNameProvenance gres-         in mkSimpleDecorated $-            sep [text "This binding for" <+> quotes (ppr occ)-             <+> text "shadows the existing binding" <> plural shadowed_locs,-                   nest 2 (vcat shadowed_locs)]-    TcRnInvalidWarningCategory cat-      -> mkSimpleDecorated $-           vcat [text "Warning category" <+> quotes (ppr cat) <+> text "is not valid",-                 text "(user-defined category names must begin with" <+> quotes (text "x-"),-                 text "and contain only letters, numbers, apostrophes and dashes)" ]-    TcRnDuplicateWarningDecls d rdr_name-      -> mkSimpleDecorated $-           vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),-                 text "also at " <+> ppr (getLocA d)]-    TcRnSimplifierTooManyIterations simples limit wc-      -> mkSimpleDecorated $-           hang (text "solveWanteds: too many iterations"-                   <+> parens (text "limit =" <+> ppr limit))-                2 (vcat [ text "Unsolved:" <+> ppr wc-                        , text "Simples:"  <+> ppr simples-                        ])-    TcRnIllegalPatSynDecl rdrname-      -> mkSimpleDecorated $-           hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname))-              2 (text "Pattern synonym declarations are only valid at top level")-    TcRnLinearPatSyn ty-      -> mkSimpleDecorated $-           hang (text "Pattern synonyms do not support linear fields (GHC #18806):") 2 (ppr ty)-    TcRnEmptyRecordUpdate-      -> mkSimpleDecorated $ text "Empty record update"-    TcRnIllegalFieldPunning fld-      -> mkSimpleDecorated $ text "Illegal use of punning for field" <+> quotes (ppr fld)-    TcRnIllegalWildcardsInRecord fld_part-      -> mkSimpleDecorated $ text "Illegal `..' in record" <+> pprRecordFieldPart fld_part-    TcRnIllegalWildcardInType mb_name bad-      -> mkSimpleDecorated $ case bad of-          WildcardNotLastInConstraint ->-            hang notAllowed 2 constraint_hint_msg-          ExtraConstraintWildcardNotAllowed allow_sole ->-            case allow_sole of-              SoleExtraConstraintWildcardNotAllowed ->-                notAllowed-              SoleExtraConstraintWildcardAllowed ->-                hang notAllowed 2 sole_msg-          WildcardsNotAllowedAtAll ->-            notAllowed-          WildcardBndrInForallTelescope ->-            notAllowed-          WildcardBndrInTyFamResultVar ->-            notAllowed-      where-        notAllowed, what, wildcard, how :: SDoc-        notAllowed = what <+> quotes wildcard <+> how-        wildcard = case mb_name of-          Nothing   -> pprAnonWildCard-          Just name -> ppr name-        what-          | Just _ <- mb_name-          = text "Named wildcard"-          | ExtraConstraintWildcardNotAllowed {} <- bad-          = text "Extra-constraint wildcard"-          | WildcardBndrInForallTelescope {} <- bad-          = text "Wildcard binder"-          | WildcardBndrInTyFamResultVar {} <- bad-          = text "Wildcard binder"-          | otherwise-          = text "Wildcard"-        how = case bad of-          WildcardNotLastInConstraint-            -> text "not allowed in a constraint"-          WildcardBndrInForallTelescope-            -> text "not allowed in a forall telescope"-          WildcardBndrInTyFamResultVar-            -> text "not allowed in a type family result"-          _ -> text "not allowed"-        constraint_hint_msg :: SDoc-        constraint_hint_msg-          | Just _ <- mb_name-          = vcat [ text "Extra-constraint wildcards must be anonymous"-                 , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]-          | otherwise-          = vcat [ text "except as the last top-level constraint of a type signature"-                 , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]-        sole_msg :: SDoc-        sole_msg =-          vcat [ text "except as the sole constraint"-               , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ]-    TcRnIllegalNamedWildcardInTypeArgument rdr-      -> mkSimpleDecorated $-           hang (text "Illegal named wildcard in a required type argument:")-                2 (quotes (ppr rdr))-    TcRnIllegalImplicitTyVarInTypeArgument rdr-      -> mkSimpleDecorated $-            hang (text "Illegal implicitly quantified type variable in a required type argument:")-                2 (quotes (ppr rdr))-    TcRnDuplicateFieldName fld_part dups-      -> mkSimpleDecorated $-           hsep [ text "Duplicate field name"-                , quotes (ppr (rdrNameOcc $ NE.head dups))-                , text "in record", pprRecordFieldPart fld_part ]-    TcRnIllegalViewPattern pat-      -> mkSimpleDecorated $ vcat [text "Illegal view pattern: " <+> ppr pat]-    TcRnCharLiteralOutOfRange c-      -> mkSimpleDecorated $ text "character literal out of range: '\\" <> char c  <> char '\''-    TcRnIllegalWildcardsInConstructor con-      -> mkSimpleDecorated $-           vcat [ text "Illegal `{..}' notation for constructor" <+> quotes (ppr con)-                , nest 2 (text "Record wildcards may not be used for constructors with unlabelled fields.")-                , nest 2 (text "Possible fix: Remove the `{..}' and add a match for each field of the constructor.")-                ]-    TcRnIgnoringAnnotations anns-      -> mkSimpleDecorated $-           text "Ignoring ANN annotation" <> plural anns <> comma-           <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi"-    TcRnAnnotationInSafeHaskell-      -> mkSimpleDecorated $-           vcat [ text "Annotations are not compatible with Safe Haskell."-                , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ]-    TcRnInvalidTypeApplication fun_ty hs_ty-      -> mkSimpleDecorated $-           text "Cannot apply expression of type" <+> quotes (ppr fun_ty) $$-           text "to a visible type argument" <+> quotes (ppr hs_ty)-    TcRnTagToEnumMissingValArg-      -> mkSimpleDecorated $-           text "tagToEnum# must appear applied to one value argument"-    TcRnTagToEnumUnspecifiedResTy ty-      -> mkSimpleDecorated $-           hang (text "Bad call to tagToEnum# at type" <+> ppr ty)-              2 (vcat [ text "Specify the type by giving a type signature"-                      , text "e.g. (tagToEnum# x) :: Bool" ])-    TcRnTagToEnumResTyNotAnEnum ty-      -> mkSimpleDecorated $-           hang (text "Bad call to tagToEnum# at type" <+> ppr ty)-              2 (text "Result type must be an enumeration type")-    TcRnTagToEnumResTyTypeData ty-      -> mkSimpleDecorated $-           hang (text "Bad call to tagToEnum# at type" <+> ppr ty)-              2 (text "Result type cannot be headed by a `type data` type")-    TcRnArrowIfThenElsePredDependsOnResultTy-      -> mkSimpleDecorated $-           text "Predicate type of `ifThenElse' depends on result type"-    TcRnIllegalHsBootOrSigDecl boot_or_sig decls-      -> mkSimpleDecorated $-           text "Illegal" <+> what <+> text "in" <+> whr <> dot-        where-          what = case decls of-            BootBindsPs      {} -> text "binding"-            BootBindsRn      {} -> text "binding"-            BootInstanceSigs {} -> text "instance body"-            BootFamInst      {} -> text "family instance"-            BootSpliceDecls  {} -> text "splice"-            BootForeignDecls {} -> text "foreign declaration"-            BootDefaultDecls {} -> text "default declaration"-            BootRuleDecls    {} -> text "RULE pragma"-          whr = case boot_or_sig of-            HsBoot -> text "an hs-boot file"-            Hsig   -> text "a backpack signature file"-    TcRnBootMismatch boot_or_sig err ->-      mkSimpleDecorated $ pprBootMismatch boot_or_sig err-    TcRnRecursivePatternSynonym binds-      -> mkSimpleDecorated $-            hang (text "Recursive pattern synonym definition with following bindings:")-               2 (vcat $ map pprLBind binds)-          where-            pprLoc loc = parens (text "defined at" <+> ppr loc)-            pprLBind :: CollectPass GhcRn => GenLocated (EpAnn a) (HsBindLR GhcRn idR) -> SDoc-            pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind)-                                        <+> pprLoc (locA loc)-    TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty-      -> mkSimpleDecorated $-           hang (text "Couldn't match" <+> quotes (ppr n1)-                   <+> text "with" <+> quotes (ppr n2))-                2 (hang (text "both bound by the partial type signature:")-                        2 (ppr fn_name <+> dcolon <+> ppr hs_ty))-    TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty-      -> mkSimpleDecorated $-           hang (text "Can't quantify over" <+> quotes (ppr n))-                2 (vcat [ hang (text "bound by the partial type signature:")-                             2 (ppr fn_name <+> dcolon <+> ppr hs_ty)-                        , extra ])-      where-        extra | Just rhs_ty <- m_unif_ty-              = sep [ quotes (ppr n), text "should really be", quotes (ppr rhs_ty) ]-              | otherwise-              = empty-    TcRnMissingSignature what _ ->-      mkSimpleDecorated $-      case what of-        MissingPatSynSig p ->-          hang (text "Pattern synonym with no type signature:")-            2 (text "pattern" <+> pprPrefixName (patSynName p) <+> dcolon <+> pprPatSynType p)-        MissingTopLevelBindingSig name ty ->-          hang (text "Top-level binding with no type signature:")-            2 (pprPrefixName name <+> dcolon <+> pprSigmaType ty)-        MissingTyConKindSig tc cusks_enabled ->-          hang msg-            2 (text "type" <+> pprPrefixName (tyConName tc) <+> dcolon <+> pprKind (tyConKind tc))-          where-            msg | cusks_enabled-                = text "Top-level type constructor with no standalone kind signature or CUSK:"-                | otherwise-                = text "Top-level type constructor with no standalone kind signature:"--    TcRnPolymorphicBinderMissingSig n ty-      -> mkSimpleDecorated $-           sep [ text "Polymorphic local binding with no type signature:"-               , nest 2 $ pprPrefixName n <+> dcolon <+> ppr ty ]-    TcRnOverloadedSig sig-      -> mkSimpleDecorated $-           hang (text "Overloaded signature conflicts with monomorphism restriction")-              2 (ppr sig)-    TcRnTupleConstraintInst _-      -> mkSimpleDecorated $ text "You can't specify an instance for a tuple constraint"-    TcRnUserTypeError ty-      -> mkSimpleDecorated (pprUserTypeErrorTy ty)-    TcRnConstraintInKind ty-      -> mkSimpleDecorated $-           text "Illegal constraint in a kind:" <+> pprType ty-    TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum ty-      -> mkSimpleDecorated $-           sep [ text "Illegal unboxed" <+> what <+> text "type as function argument:"-               , pprType ty ]-        where-          what = case tuple_or_sum of-            UnboxedTupleType -> text "tuple"-            UnboxedSumType   -> text "sum"-    TcRnLinearFuncInKind ty-      -> mkSimpleDecorated $-           text "Illegal linear function in a kind:" <+> pprType ty-    TcRnForAllEscapeError ty kind-      -> mkSimpleDecorated $ vcat-           [ hang (text "Quantified type's kind mentions quantified type variable")-                2 (text "type:" <+> quotes (ppr ty))-           , hang (text "where the body of the forall has this kind:")-                2 (quotes (pprKind kind)) ]-    TcRnSimplifiableConstraint pred what-      -> mkSimpleDecorated $ vcat-           [ hang (text "The constraint" <+> quotes (pprType pred) <+> text "matches")-                2 (ppr what)-           , hang (text "This makes type inference for inner bindings fragile;")-                2 (text "either use MonoLocalBinds, or simplify it using the instance") ]-    TcRnArityMismatch thing thing_arity nb_args-      -> mkSimpleDecorated $-           hsep [ text "The" <+> what, quotes (ppr $ getName thing), text "should have"-                , n_arguments <> comma, text "but has been given"-                , if nb_args == 0 then text "none" else int nb_args-                ]-          where-            what = case thing of-              ATyCon tc -> ppr (tyConFlavour tc)-              _         -> text (tyThingCategory thing)-            n_arguments | thing_arity == 0 = text "no arguments"-                        | thing_arity == 1 = text "1 argument"-                        | True          = hsep [int thing_arity, text "arguments"]-    TcRnIllegalInstance reason ->-      mkSimpleDecorated $ pprIllegalInstance reason-    TcRnVDQInTermType mb_ty-      -> mkSimpleDecorated $-             case mb_ty of-               Nothing -> main_msg-               Just ty -> hang (main_msg <> char ':') 2 (pprType ty)-      where-        main_msg =-          text "Illegal visible, dependent quantification" <+>-          text "in the type of a term"-    TcRnBadQuantPredHead ty-      -> mkSimpleDecorated $-           hang (text "Quantified predicate must have a class or type variable head:")-              2 (pprType ty)-    TcRnIllegalTupleConstraint ty-      -> mkSimpleDecorated $-           text "Illegal tuple constraint:" <+> pprType ty-    TcRnNonTypeVarArgInConstraint ty-      -> mkSimpleDecorated $-           hang (text "Non type-variable argument")-              2 (text "in the constraint:" <+> pprType ty)-    TcRnIllegalImplicitParam ty-      -> mkSimpleDecorated $-           text "Illegal implicit parameter" <+> quotes (pprType ty)-    TcRnIllegalConstraintSynonymOfKind kind-      -> mkSimpleDecorated $-           text "Illegal constraint synonym of kind:" <+> quotes (pprKind kind)-    TcRnOversaturatedVisibleKindArg ty-      -> mkSimpleDecorated $-           text "Illegal oversaturated visible kind argument:" <+>-           quotes (char '@' <> pprParendType ty)-    TcRnForAllRankErr rank ty-      -> let herald = case tcSplitForAllTyVars ty of-               ([], _) -> text "Illegal qualified type:"-               _       -> text "Illegal polymorphic type:"-             extra = case rank of-               MonoTypeConstraint -> text "A constraint must be a monotype"-               _                  -> empty-         in mkSimpleDecorated $ vcat [hang herald 2 (pprType ty), extra]-    TcRnMonomorphicBindings bindings-      -> let pp_bndrs = pprBindings bindings-         in mkSimpleDecorated $-              sep [ text "The Monomorphism Restriction applies to the binding"-                  <> plural bindings-                  , text "for" <+> pp_bndrs ]-    TcRnOrphanInstance (Left cls_inst)-      -> mkSimpleDecorated $-           hang (text "Orphan class instance:")-              2 (pprInstanceHdr cls_inst)-    TcRnOrphanInstance (Right fam_inst)-      -> mkSimpleDecorated $-           hang (text "Orphan family instance:")-              2 (pprFamInst fam_inst)-    TcRnFunDepConflict unit_state sorted-      -> let herald = text "Functional dependencies conflict between instance declarations:"-         in mkSimpleDecorated $-              pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted))-    TcRnDupInstanceDecls unit_state sorted-      -> let herald = text "Duplicate instance declarations:"-         in mkSimpleDecorated $-              pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted))-    TcRnConflictingFamInstDecls sortedNE-      -> let sorted = NE.toList sortedNE-         in mkSimpleDecorated $-              hang (text "Conflicting family instance declarations:")-                 2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)-                         | fi <- sorted-                         , let ax = famInstAxiom fi ])-    TcRnFamInstNotInjective rea fam_tc (eqn1 NE.:| rest_eqns)-      -> let (herald, show_kinds) = case rea of-               InjErrRhsBareTyVar tys ->-                 (injectivityErrorHerald $$-                  text "RHS of injective type family equation is a bare" <+>-                  text "type variable" $$-                  text "but these LHS type and kind patterns are not bare" <+>-                  text "variables:" <+> pprQuotedList tys, False)-               InjErrRhsCannotBeATypeFam ->-                 (injectivityErrorHerald $$-                   text "RHS of injective type family equation cannot" <+>-                   text "be a type family:", False)-               InjErrRhsOverlap ->-                  (text "Type family equation right-hand sides overlap; this violates" $$-                   text "the family's injectivity annotation:", False)-               InjErrCannotInferFromRhs tvs has_kinds _ ->-                 let show_kinds = has_kinds == YesHasKinds-                     what = if show_kinds then text "Type/kind" else text "Type"-                     body = sep [ what <+> text "variable" <>-                                  pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort)-                                , text "cannot be inferred from the right-hand side." ]-                     in (injectivityErrorHerald $$ body $$ text "In the type family equation:", show_kinds)--         in mkSimpleDecorated $ pprWithInvisibleBitsWhen show_kinds $-              hang herald-                2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns)))-    TcRnBangOnUnliftedType ty-      -> mkSimpleDecorated $-           text "Strictness flag has no effect on unlifted type" <+> quotes (ppr ty)-    TcRnLazyBangOnUnliftedType ty-      -> mkSimpleDecorated $-           text "Lazy flag has no effect on unlifted type" <+> quotes (ppr ty)-    TcRnMultipleDefaultDeclarations cls dup_things-      -> mkSimpleDecorated $-           hang (text "Multiple default declarations for class" <+> quotes (ppr cls))-              2 (vcat (map pp dup_things))-         where-           pp :: LDefaultDecl GhcRn -> SDoc-           pp (L locn DefaultDecl {})-             = text "here was another default declaration" <+> ppr (locA locn)-    TcRnBadDefaultType ty deflt_clss-      -> mkSimpleDecorated $-           hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of")-              2 (foldr1 (\a b -> a <+> text "or" <+> b) (NE.map (quotes. ppr) deflt_clss))-    TcRnPatSynBundledWithNonDataCon-      -> mkSimpleDecorated $-           text "Pattern synonyms can be bundled only with datatypes."-    TcRnPatSynBundledWithWrongType expected_res_ty res_ty-      -> mkSimpleDecorated $-           text "Pattern synonyms can only be bundled with matching type constructors"-               $$ text "Couldn't match expected type of"-               <+> quotes (ppr expected_res_ty)-               <+> text "with actual type of"-               <+> quotes (ppr res_ty)-    TcRnDupeModuleExport mod-      -> mkSimpleDecorated $-           hsep [ text "Duplicate"-                , quotes (text "Module" <+> ppr mod)-                , text "in export list" ]-    TcRnExportedModNotImported mod-      -> mkSimpleDecorated-       $ formatExportItemError-           (text "module" <+> ppr mod)-           "is not imported"-    TcRnNullExportedModule mod-      -> mkSimpleDecorated-       $ formatExportItemError-           (text "module" <+> ppr mod)-           "exports nothing"-    TcRnMissingExportList mod-      -> mkSimpleDecorated-       $ formatExportItemError-           (text "module" <+> ppr mod)-           "is missing an export list"-    TcRnExportHiddenComponents export_item-      -> mkSimpleDecorated-       $ formatExportItemError-           (ppr export_item)-           "attempts to export constructors or class methods that are not visible here"-    TcRnExportHiddenDefault export_item-      -> mkSimpleDecorated-       $ formatExportItemError-           (ppr export_item)-           "attempts to export a default class declaration that is not visible here"-    TcRnDuplicateExport gre ie1 ie2-      -> mkSimpleDecorated $-           hsep [ quotes (ppr $ greName gre)-                , text "is exported by", quotes (ppr ie1)-                , text "and",            quotes (ppr ie2) ]-    TcRnExportedParentChildMismatch parent_name ty_thing child parent_names-      -> mkSimpleDecorated $-           text "The type constructor" <+> quotes (ppr parent_name)-                 <+> text "is not the parent of the" <+> text what_is-                 <+> quotes thing <> char '.'-                 $$ text (capitalise what_is)-                    <> text "s can only be exported with their parent type constructor."-                 $$ (case parents of-                       [] -> empty-                       [_] -> text "Parent:"-                       _  -> text "Parents:") <+> fsep (punctuate comma parents)-      where-        pp_category :: TyThing -> String-        pp_category (AnId i)-          | isRecordSelector i = "record selector"-        pp_category i = tyThingCategory i-        what_is = pp_category ty_thing-        thing = ppr $ nameOccName child-        parents = map ppr parent_names-    TcRnConflictingExports occ child_gre1 ie1 child_gre2 ie2-      -> mkSimpleDecorated $-           vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon-                , ppr_export child_gre1 ie1-                , ppr_export child_gre2 ie2-                ]-      where-        ppr_export gre ie =-          nest 3 $-            hang (quotes (ppr ie) <+> text "exports" <+> quotes (ppr $ greName gre))-               2 (pprNameProvenance gre)-    TcRnDuplicateFieldExport (gre, ie1) gres_ies ->-      mkSimpleDecorated $-           vcat ( hsep [ text "Duplicate record field"-                       , quotes (ppr $ greOccName gre)-                       , text "in export list" <> colon ]-                : map ppr_export ((gre,ie1) : NE.toList gres_ies)-                )-      where-        ppr_export (gre,ie) =-          nest 3 $-            hang (sep [ quotes (ppr ie) <+> text "exports the field" <+> quotes (ppr $ greName gre)-                       , text "belonging to the constructor" <> plural fld_cons <+> pprQuotedList fld_cons ])-               2 (pprNameProvenance gre)-          where-            fld_cons :: [ConLikeName]-            fld_cons = nonDetEltsUniqSet $ recFieldCons $ fieldGREInfo gre-    TcRnAmbiguousFieldInUpdate (gre1, gre2, gres)-      -> mkSimpleDecorated $-          vcat [ text "Ambiguous record field" <+> fld <> dot-               , hang (text "It could refer to any of the following:")-                  2 $ vcat (map pprSugg (gre1 : gre2 : gres))-               ]-        where-          fld = quotes $ ppr (occNameFS $ greOccName gre1)-          pprSugg gre = vcat [ bullet <+> pprGRE gre <> comma-                             , nest 2 (pprNameProvenance gre) ]-          pprGRE gre = case greInfo gre of-            IAmRecField {}-              -> let parent = par_is $ greParent gre-                 in text "record field" <+> fld <+> text "of" <+> quotes (ppr parent)-            _ -> text "variable" <+> fld-    TcRnAmbiguousRecordUpdate _rupd tc-      -> mkSimpleDecorated $-          vcat [ text "Ambiguous record update with parent" <+> what <> dot-               , hsep [ text "This type-directed disambiguation mechanism"-                      , text "will not be supported by -XDuplicateRecordFields in future releases of GHC." ]-               , text "Consider disambiguating using module qualification instead."-               ]-        where-          what :: SDoc-          what = text "type constructor" <+> quotes (ppr $ RecSelData tc)-    TcRnMissingFields con fields-      -> mkSimpleDecorated $ vcat [header, nest 2 rest]-         where-           rest | null fields = empty-                | otherwise   = vcat (fmap pprField fields)-           header = text "Fields of" <+> quotes (ppr con) <+>-                    text "not initialised" <>-                    if null fields then empty else colon-    TcRnFieldUpdateInvalidType prs-      -> mkSimpleDecorated $-           hang (text "Record update for insufficiently polymorphic field"-                   <> plural prs <> colon)-              2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])-    TcRnMissingStrictFields con fields-      -> mkSimpleDecorated $ vcat [header, nest 2 rest]-         where-           rest | null fields = empty  -- Happens for non-record constructors-                                       -- with strict fields-                | otherwise   = vcat (fmap pprField fields)--           header = text "Constructor" <+> quotes (ppr con) <+>-                    text "does not have the required strict field(s)" <>-                    if null fields then empty else colon-    TcRnBadRecordUpdate upd_flds reason-      -> case reason of-          NoConstructorHasAllFields { conflictingFields = conflicts }-            | [fld] <- conflicts-            -> mkSimpleDecorated $-                vcat [ header-                     , text "No constructor in scope has the field" <+> quotes (ppr fld) ]-            | otherwise-            ->-              mkSimpleDecorated $-                vcat [ header-                     , hang (text "No constructor in scope has all of the following fields:")-                        2 (pprQuotedList conflicts) ]-            where-              header :: SDoc-              header = text "Invalid record update."-          MultiplePossibleParents (par1, par2, pars) ->-            mkSimpleDecorated $-              vcat [ hang (text "Ambiguous record update with field" <> plural upd_flds)-                       2 ppr_flds-                   , hang (thisOrThese upd_flds <+> text "field" <> plural upd_flds <+> what_parent)-                       2 (quotedListWithAnd (map ppr (par1:par2:pars))) ]-            where-              ppr_flds, what_parent, which :: SDoc-              ppr_flds = quotedListWithAnd $ map ppr upd_flds-              what_parent = case par1 of-                RecSelData   {} -> text "appear" <> singular upd_flds-                                <+> text "in" <+> which <+> text "datatypes"-                RecSelPatSyn {} -> isOrAre upd_flds <+> text "associated with"-                                <+> which <+> text "pattern synonyms"-              which = case pars of-                [] -> text "both"-                _  -> text "all of the"-          InvalidTyConParent tc pars ->-            mkSimpleDecorated $-              vcat [ hang (text "No data constructor of" <+> what $$ text "has all of the fields:")-                      2 (pprQuotedList upd_flds)-                   , pat_syn_msg ]-            where-              what = text "type constructor" <+> quotes (ppr (RecSelData tc))-              pat_syn_msg-                | any (\case { RecSelPatSyn {} -> True; _ -> False}) pars-                = note "Type-directed disambiguation is not supported for pattern synonym record fields"-                | otherwise-                = empty-    TcRnStaticFormNotClosed name reason-      -> mkSimpleDecorated $-           quotes (ppr name)-             <+> text "is used in a static form but it is not closed"-             <+> text "because it"-             $$ sep (causes reason)-         where-          causes :: NotClosedReason -> [SDoc]-          causes NotLetBoundReason = [text "is not let-bound."]-          causes (NotTypeClosed vs) =-            [ text "has a non-closed type because it contains the"-            , text "type variables:" <+>-              pprVarSet vs (hsep . punctuate comma . map (quotes . ppr))-            ]-          causes (NotClosed n reason) =-            let msg = text "uses" <+> quotes (ppr n) <+> text "which"-             in case reason of-                  NotClosed _ _ -> msg : causes reason-                  _   -> let (xs0, xs1) = splitAt 1 $ causes reason-                          in fmap (msg <+>) xs0 ++ xs1-    TcRnUselessTypeable-      -> mkSimpleDecorated $-           text "Deriving" <+> quotes (ppr typeableClassName) <+>-           text "has no effect: all types now auto-derive Typeable"-    TcRnDerivingDefaults cls-      -> mkSimpleDecorated $ sep-                     [ text "Both DeriveAnyClass and"-                       <+> text "GeneralizedNewtypeDeriving are enabled"-                     , text "Defaulting to the DeriveAnyClass strategy"-                       <+> text "for instantiating" <+> ppr cls-                     ]-    TcRnNonUnaryTypeclassConstraint ctxt ct-      -> mkSimpleDecorated $-           quotes (ppr ct)-           <+> text "is not a unary constraint, as expected by"-           <+> pprUserTypeCtxt ctxt-    TcRnPartialTypeSignatures _ theta-      -> mkSimpleDecorated $-           text "Found type wildcard" <+> quotes (char '_')-                       <+> text "standing for" <+> quotes (pprTheta theta)-    TcRnCannotDeriveInstance cls cls_tys mb_strat newtype_deriving reason-      -> mkSimpleDecorated $-           derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving True reason-    TcRnLookupInstance cls tys reason-      -> mkSimpleDecorated $-          text "Couldn't match instance:" <+>-           lookupInstanceErrDiagnosticMessage cls tys reason-    TcRnLazyGADTPattern-      -> mkSimpleDecorated $-           hang (text "An existential or GADT data constructor cannot be used")-              2 (text "inside a lazy (~) pattern")-    TcRnArrowProcGADTPattern-      -> mkSimpleDecorated $-           text "Proc patterns cannot use existential or GADT data constructors"-    TcRnTypeEqualityOutOfScope-      -> mkDecorated-           [ text "The" <+> quotes (text "~") <+> text "operator is out of scope." $$-             text "Assuming it to stand for an equality constraint."-           , note $ quotes "~" <+> "used to be built-in syntax but now is a regular type operator" $$-                      "exported from Data.Type.Equality and Prelude." $$-                      "If you are using a custom Prelude, consider re-exporting it"-           , text "This will become an error in a future GHC release." ]-    TcRnTypeEqualityRequiresOperators-      -> mkSimpleDecorated $-            fsep [ text "The use of" <+> quotes (text "~")-                                     <+> text "without TypeOperators",-                   text "will become an error in a future GHC release." ]-    TcRnIllegalTypeOperator overall_ty op-      -> mkSimpleDecorated $-           text "Illegal operator" <+> quotes (ppr op) <+>-           text "in type" <+> quotes (ppr overall_ty)-    TcRnIllegalTypeOperatorDecl name-      -> mkSimpleDecorated $-        text "Illegal declaration of a type or class operator" <+> quotes (ppr name)-    TcRnGADTMonoLocalBinds-      -> mkSimpleDecorated $-            fsep [ text "Pattern matching on GADTs without MonoLocalBinds"-                 , text "is fragile." ]-    TcRnIncorrectNameSpace name _-      -> mkSimpleDecorated $-           text "The" <+> what <+> text "does not live in" <+> other_ns-        where-          -- the other (opposite) namespace-          other_ns | isValNameSpace ns = text "the type-level namespace"-                   | otherwise         = text "the term-level namespace"-          ns = nameNameSpace name-          what = pprNameSpace ns <+> quotes (ppr name)-    TcRnNotInScope err name imp_errs _-      -> mkSimpleDecorated $-           pprScopeError name err $$ vcat (map ppr imp_errs)-    TcRnTermNameInType name _-      -> mkSimpleDecorated $-           quotes (ppr name) <+>-             (text "is a term-level binding") $+$-             (text " and can not be used at the type level.")-    TcRnUntickedPromotedThing thing-      -> mkSimpleDecorated $-         text "Unticked promoted" <+> what-           where-             what :: SDoc-             what = case thing of-               UntickedExplicitList -> text "list" <> dot-               UntickedConstructor fixity nm ->-                 let con      = pprUntickedConstructor fixity nm-                     bare_sym = isBareSymbol fixity nm-                 in text "constructor:" <+> con <> if bare_sym then empty else dot-    TcRnIllegalBuiltinSyntax what rdr_name-      -> mkSimpleDecorated $-           hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr_name]-    TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty-      -> mkSimpleDecorated $-           hang (hsep $ [ text "Defaulting" ]-                     ++-                     (case tidy_tv of-                         Nothing -> []-                         Just tv -> [text "the type variable"-                                    , quotes (ppr tv)])-                     ++-                     [ text "to type"-                     , quotes (ppr default_ty)-                     , text "in the following constraint" <> plural tidy_wanteds ])-             2-             (pprWithArising tidy_wanteds)-    TcRnWarnClashingDefaultImports cls Nothing imports-      -> mkSimpleDecorated $-           hang (text "Clashing imported defaults for class" <+> quotes (ppr cls) <> colon)-              2 (vcat $ defaultTypesAndImport <$> NE.toList imports)-    TcRnWarnClashingDefaultImports cls (Just local) imports-      -> mkSimpleDecorated $-           sep [ hang (text "Imported defaults for class" <+> quotes (ppr cls) <> colon)-                    2 (vcat $ defaultTypesAndImport <$> NE.toList imports)-               , hang (text "are not subsumed by the local `default` declaration")-                    2 (parens $ pprWithCommas ppr local)-               ]--    TcRnForeignImportPrimExtNotSet _decl-      -> mkSimpleDecorated $-           text "`foreign import prim' requires GHCForeignImportPrim."--    TcRnForeignImportPrimSafeAnn _decl-      -> mkSimpleDecorated $-           text "The safe/unsafe annotation should not be used with `foreign import prim'."--    TcRnForeignFunctionImportAsValue _decl-      -> mkSimpleDecorated $-           text "`value' imports cannot have function types"--    TcRnFunPtrImportWithoutAmpersand _decl-      -> mkSimpleDecorated $-           text "possible missing & in foreign import of FunPtr"--    TcRnIllegalForeignDeclBackend _decl _backend expectedBknds-      -> mkSimpleDecorated $-         fsep (text "Illegal foreign declaration: requires one of these back ends:" :-               commafyWith (text "or") (map (text . backendDescription) expectedBknds))--    TcRnUnsupportedCallConv _decl unsupportedCC-      -> mkSimpleDecorated $-           case unsupportedCC of-             StdCallConvUnsupported ->-               text "the 'stdcall' calling convention is unsupported on this platform,"-               $$ text "treating as ccall"-             PrimCallConvUnsupported ->-               text "The `prim' calling convention can only be used with `foreign import'"-             JavaScriptCallConvUnsupported ->-               text "The `javascript' calling convention is unsupported on this platform"--    TcRnIllegalForeignType mArgOrResult reason-      -> mkSimpleDecorated $ hang msg 2 extra-      where-        arg_or_res = case mArgOrResult of-          Nothing -> empty-          Just Arg -> text "argument"-          Just Result -> text "result"-        msg = hsep [ text "Unacceptable", arg_or_res-                   , text "type in foreign declaration:"]-        extra =-          case reason of-            TypeCannotBeMarshaled ty why ->-              let innerMsg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call"-               in case why of-                NotADataType ->-                  quotes (ppr ty) <+> text "is not a data type"-                NewtypeDataConNotInScope _ [] ->-                  hang innerMsg 2 $ text "because its data constructor is not in scope"-                NewtypeDataConNotInScope tc _ ->-                  hang innerMsg 2 $-                    text "because the data constructor for"-                    <+> quotes (ppr tc) <+> text "is not in scope"-                UnliftedFFITypesNeeded ->-                  innerMsg $$ text "UnliftedFFITypes is required to marshal unlifted types"-                NotABoxedMarshalableTyCon -> innerMsg-                ForeignLabelNotAPtr ->-                  innerMsg $$ text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)"-                NotSimpleUnliftedType ->-                  innerMsg $$ text "foreign import prim only accepts simple unlifted types"-                NotBoxedKindAny ->-                  text "Expected kind" <+> quotes (text "Type") <+> text "or" <+> quotes (text "UnliftedType") <> comma $$-                  text "but" <+> quotes (ppr ty) <+> text "has kind" <+> quotes (ppr (typeKind ty))-            ForeignDynNotPtr expected ty ->-              vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma, text "  Actual:" <+> ppr ty ]-            SafeHaskellMustBeInIO ->-              text "Safe Haskell is on, all FFI imports must be in the IO monad"-            IOResultExpected ->-              text "IO result type expected"-            UnexpectedNestedForall ->-              text "Unexpected nested forall"-            LinearTypesNotAllowed ->-              text "Linear types are not supported in FFI declarations, see #18472"-            OneArgExpected ->-              text "One argument expected"-            AtLeastOneArgExpected ->-              text "At least one argument expected"-    TcRnInvalidCIdentifier target-      -> mkSimpleDecorated $-           sep [quotes (ppr target) <+> text "is not a valid C identifier"]-    TcRnExpectedValueId thing-      -> mkSimpleDecorated $-           ppr thing <+> text "used where a value identifier was expected"-    TcRnRecSelectorEscapedTyVar lbl-      -> mkSimpleDecorated $-           text "Cannot use record selector" <+> quotes (ppr lbl) <+>-           text "as a function due to escaped type variables"-    TcRnPatSynNotBidirectional name-      -> mkSimpleDecorated $-           text "non-bidirectional pattern synonym"-           <+> quotes (ppr name) <+> text "used in an expression"-    TcRnIllegalDerivingItem hs_ty-      -> mkSimpleDecorated $-           text "Illegal deriving item" <+> quotes (ppr hs_ty)-    TcRnIllegalDefaultClass hs_ty-      -> mkSimpleDecorated $-           quotes (ppr hs_ty) <+> text "is not a class"-    TcRnIllegalNamedDefault hs_decl-      -> mkSimpleDecorated $ text "Illegal use of default class name:" <+> quotes (ppr hs_decl)-    TcRnUnexpectedAnnotation ty bang-      -> mkSimpleDecorated $-           let err = case bang of-                 HsBang SrcUnpack   _       -> "UNPACK"-                 HsBang SrcNoUnpack _       -> "NOUNPACK"-                 HsBang NoSrcUnpack SrcLazy -> "laziness"-                 HsBang _           _       -> "strictness"-            in text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$-               text err <+> text "annotation cannot appear nested inside a type"-    TcRnIllegalRecordSyntax either_ty_ty-      -> mkSimpleDecorated $-           text "Record syntax is illegal here:" <+> either ppr ppr either_ty_ty--    TcRnInvalidVisibleKindArgument arg ty-      -> mkSimpleDecorated $-           text "Cannot apply function of kind" <+> quotes (ppr ty)-             $$ text "to visible kind argument" <+> quotes (ppr arg)-    TcRnTooManyBinders ki bndrs-      -> mkSimpleDecorated $-           hang (text "Not a function kind:")-              4 (ppr ki) $$-           hang (text "but extra binders found:")-              4 (fsep (map ppr bndrs))-    TcRnDifferentNamesForTyVar n1 n2-      -> mkSimpleDecorated $-           hang (text "Different names for the same type variable:") 2 info-         where-           info | nameOccName n1 /= nameOccName n2-                = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2)-                | otherwise -- Same OccNames! See C2 in-                            -- Note [Swizzling the tyvars before generaliseTcTyCon]-                = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1)-                       , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ]--    TcRnDisconnectedTyVar n-      -> mkSimpleDecorated $-           hang (text "Scoped type variable only appears non-injectively in declaration header:")-              2 (quotes (ppr n) <+> text "bound at" <+> ppr (getSrcLoc n))--    TcRnInvalidReturnKind data_sort allowed_kind kind _suggested_ext-      -> mkSimpleDecorated $-           sep [ ppDataSort data_sort <+>-                 text "has non-" <>-                 allowed_kind_tycon-               , (if is_data_family then text "and non-variable" else empty) <+>-                 text "return kind" <+> quotes (ppr kind)-               ]-         where-          is_data_family =-            case data_sort of-              DataDeclSort{}     -> False-              DataInstanceSort{} -> False-              DataFamilySort     -> True-          allowed_kind_tycon =-            case allowed_kind of-              AnyTYPEKind  -> ppr tYPETyCon-              AnyBoxedKind -> ppr boxedRepDataConTyCon-              LiftedKind   -> ppr liftedTypeKind-    TcRnClassKindNotConstraint _kind-      -> mkSimpleDecorated $-           text "Kind signature on a class must end with" <+> ppr constraintKind $$-           text "unobscured by type families"-    TcRnUnpromotableThing name err-      -> mkSimpleDecorated $-           (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here")-                        2 (parens reason))-        where-          reason = case err of-                     ConstrainedDataConPE theta-                                    -> text "it has an unpromotable context"-                                       <+> quotes (pprTheta theta)--                     FamDataConPE   -> text "it comes from a data family instance"-                     PatSynPE       -> text "pattern synonyms cannot be promoted"-                     RecDataConPE   -> same_rec_group_msg-                     ClassPE        -> same_rec_group_msg-                     TyConPE        -> same_rec_group_msg-                     TermVariablePE -> text "term variables cannot be promoted"-                     TypeVariablePE -> text "type variables bound in a kind signature cannot be used in the type"-          same_rec_group_msg = text "it is defined and used in the same recursive group"-    TcRnIllegalTermLevelUse name err-      -> mkSimpleDecorated $-           text "Illegal term-level use of the" <+>-             text (teCategory err) <+> quotes (ppr name)-    TcRnMatchesHaveDiffNumArgs argsContext (MatchArgMatches match1 bad_matches)-      -> mkSimpleDecorated $-           (vcat [ pprMatchContextNouns argsContext <+>-                   text "have different numbers of arguments"-                 , nest 2 (ppr (getLocA match1))-                 , nest 2 (ppr (getLocA (NE.head bad_matches)))])-    TcRnCannotBindScopedTyVarInPatSig sig_tvs-      -> mkSimpleDecorated $-           hang (text "You cannot bind scoped type variable"-                  <> plural (NE.toList sig_tvs)-                 <+> pprQuotedList (map fst $ NE.toList sig_tvs))-              2 (text "in a pattern binding signature")-    TcRnCannotBindTyVarsInPatBind _offenders-      -> mkSimpleDecorated $-           text "Binding type variables is not allowed in pattern bindings"-    TcRnTooManyTyArgsInConPattern con_like expected_number actual_number-      -> mkSimpleDecorated $-           text "Too many type arguments in constructor pattern for" <+> quotes (ppr con_like) $$-           text "Expected no more than" <+> ppr expected_number <> semi <+> text "got" <+> ppr actual_number-    TcRnMultipleInlinePragmas poly_id fst_inl_prag inl_prags-      -> mkSimpleDecorated $-           hang (text "Multiple INLINE pragmas for" <+> ppr poly_id)-             2 (vcat (text "Ignoring all but the first"-                      : map pp_inl (fst_inl_prag : NE.toList inl_prags)))-         where-           pp_inl (L loc prag) = ppr prag <+> parens (ppr loc)-    TcRnUnexpectedPragmas poly_id bad_sigs-      -> mkSimpleDecorated $-           hang (text "Discarding unexpected pragmas for" <+> ppr poly_id)-              2 (vcat (map (ppr . getLoc) $ NE.toList bad_sigs))-    TcRnNonOverloadedSpecialisePragma fun_name-       -> mkSimpleDecorated $-            text "SPECIALISE pragma for non-overloaded function"-              <+> quotes (ppr fun_name)-    TcRnSpecialiseNotVisible name-      -> mkSimpleDecorated $-         text "You cannot SPECIALISE" <+> quotes (ppr name)-           <+> text "because its definition is not visible in this module"-    TcRnPragmaWarning-      { pragma_warning_info = PragmaWarningInstance{pwarn_dfunid, pwarn_ctorig}-      , pragma_warning_msg }-      -> mkSimpleDecorated $-        sep [ hang (text "In the use of")-                 2 (pprDFunId pwarn_dfunid)-            , ppr pwarn_ctorig-            , pprWarningTxtForMsg pragma_warning_msg-         ]-    TcRnPragmaWarning-      { pragma_warning_info = PragmaWarningDefault{pwarn_class, pwarn_impmod}-      , pragma_warning_msg }-      -> mkSimpleDecorated $-        sep [ sep [ text "In the use of class"-                    <+> ppr pwarn_class-                    <+> text "defaults imported from"-                    <+> ppr pwarn_impmod <> colon ]-            , pprWarningTxtForMsg pragma_warning_msg-         ]-    TcRnPragmaWarning {pragma_warning_info, pragma_warning_msg}-      -> mkSimpleDecorated $-        sep [ sep [ text "In the use of"-                <+> pprNonVarNameSpace (occNameSpace occ_name)-                <+> quotes (ppr occ_name)-                , parens imp_msg <> colon ]-          , pprWarningTxtForMsg pragma_warning_msg ]-          where-            occ_name = pwarn_occname pragma_warning_info-            imp_mod = pwarn_impmod pragma_warning_info-            imp_msg  = text "imported from" <+> ppr imp_mod <> extra-            extra | PragmaWarningName {pwarn_declmod = decl_mod} <- pragma_warning_info-                  , imp_mod /= decl_mod = text ", but defined in" <+> ppr decl_mod-                  | otherwise = empty-    TcRnDifferentExportWarnings name locs-      -> mkSimpleDecorated $ vcat [quotes (ppr name) <+> text "exported with different error messages",-                                   text "at" <+> vcat (map ppr $ sortBy leftmost_smallest $ NE.toList locs)]-    TcRnIncompleteExportWarnings name locs-      -> mkSimpleDecorated $ vcat [quotes (ppr name) <+> text "will not have its export warned about",-                                   text "missing export warning at" <+> vcat (map ppr $ sortBy leftmost_smallest $ NE.toList locs)]-    TcRnIllegalHsigDefaultMethods name meths-      -> mkSimpleDecorated $-        text "Illegal default method" <> plural (NE.toList meths) <+> text "in class definition of" <+> ppr name <+> text "in hsig file"-    TcRnHsigFixityMismatch real_thing real_fixity sig_fixity-      ->-      let ppr_fix f = ppr f <+> if f == defaultFixity then parens (text "default") else empty-      in mkSimpleDecorated $-        vcat [ppr real_thing <+> text "has conflicting fixities in the module",-              text "and its hsig file",-              text "Main module:" <+> ppr_fix real_fixity,-              text "Hsig file:" <+> ppr_fix sig_fixity]-    TcRnHsigShapeMismatch (HsigShapeSortMismatch info1 info2)-      -> mkSimpleDecorated $-            text "While merging export lists, could not combine"-            <+> ppr info1 <+> text "with" <+> ppr info2-            <+> parens (text "one is a type, the other is a plain identifier")-    TcRnHsigShapeMismatch (HsigShapeNotUnifiable name1 name2 notHere)-      ->-      let extra = if notHere-                  then text "Neither name variable originates from the current signature."-                  else empty-      in mkSimpleDecorated $-        text "While merging export lists, could not unify"-        <+> ppr name1 <+> text "with" <+> ppr name2 $$ extra-    TcRnHsigMissingModuleExport occ unit_state impl_mod-      -> mkSimpleDecorated $-            quotes (ppr occ)-        <+> text "is exported by the hsig file, but not exported by the implementing module"-        <+> quotes (pprWithUnitState unit_state $ ppr impl_mod)-    TcRnBadGenericMethod clas op-      -> mkSimpleDecorated $-        hsep [text "Class", quotes (ppr clas),-          text "has a generic-default signature without a binding", quotes (ppr op)]-    TcRnWarningMinimalDefIncomplete mindef-      -> mkSimpleDecorated $-        vcat [ text "The MINIMAL pragma does not require:"-          , nest 2 (pprBooleanFormulaNice mindef)-          , text "but there is no default implementation." ]-    TcRnDefaultMethodForPragmaLacksBinding sel_id prag-      -> mkSimpleDecorated $-        text "The" <+> hsSigDoc prag <+> text "for default method"-          <+> quotes (ppr sel_id)-          <+> text "lacks an accompanying binding"-    TcRnIgnoreSpecialisePragmaOnDefMethod sel_name-      -> mkSimpleDecorated $-        text "Ignoring SPECIALISE pragmas on default method"-          <+> quotes (ppr sel_name)-    TcRnBadMethodErr{badMethodErrClassName, badMethodErrMethodName}-      -> mkSimpleDecorated $-        hsep [text "Class", quotes (ppr badMethodErrClassName),-          text "does not have a method", quotes (ppr badMethodErrMethodName)]-    TcRnIllegalTypeData-      -> mkSimpleDecorated $-        text "Illegal type-level data declaration"-    TcRnTypeDataForbids feature-      -> mkSimpleDecorated $-        ppr feature <+> text "are not allowed in type data declarations."--    TcRnIllegalNewtype con show_linear_types reason-      -> mkSimpleDecorated $-        vcat [msg, additional]-        where-          (msg,additional) =-            case reason of-              DoesNotHaveSingleField n_flds ->-                (sep [-                  text "A newtype constructor must have exactly one field",-                  nest 2 $-                    text "but" <+> quotes (ppr con) <+> text "has" <+> speakN n_flds-                ],-                ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con))-              IsNonLinear ->-                (text "A newtype constructor must be linear",-                ppr con <+> dcolon <+> ppr (dataConDisplayType True con))-              IsGADT ->-                (text "A newtype must not be a GADT",-                ppr con <+> dcolon <+> pprWithInvisibleBitsWhen sneaky_eq_spec-                                       (ppr $ dataConDisplayType show_linear_types con))-              HasConstructorContext ->-                (text "A newtype constructor must not have a context in its type",-                ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con))-              HasExistentialTyVar ->-                (text "A newtype constructor must not have existential type variables",-                ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con))-              HasStrictnessAnnotation ->-                (text "A newtype constructor must not have a strictness annotation", empty)--          -- Is the data con a "covert" GADT?  See Note [isCovertGadtDataCon]-          -- in GHC.Core.DataCon-          sneaky_eq_spec = isCovertGadtDataCon con-    TcRnOrPatBindsVariables bndrs -> mkSimpleDecorated $-      text "An or-pattern may not bind term or type variables such as"-        <+> quotedListWithOr (map ppr (NE.toList bndrs))-    TcRnUnsatisfiedMinimalDef mindef-      -> mkSimpleDecorated $-        vcat [text "No explicit implementation for"-              ,nest 2 $ pprBooleanFormulaNice mindef-             ]-    TcRnMisplacedInstSig name hs_ty-      -> mkSimpleDecorated $-        vcat [ hang (text "Illegal type signature in instance declaration:")-                  2 (hang (pprPrefixName name)-                        2 (dcolon <+> ppr hs_ty))-             ]-    TcRnNoRebindableSyntaxRecordDot -> mkSimpleDecorated $-      text "RebindableSyntax is required if OverloadedRecordUpdate is enabled."-    TcRnNoFieldPunsRecordDot -> mkSimpleDecorated $-      text "For this to work enable NamedFieldPuns"-    TcRnIllegalStaticExpression e -> mkSimpleDecorated $-        text "Illegal static expression:" <+> ppr e-    TcRnListComprehensionDuplicateBinding n -> mkSimpleDecorated $-        (text "Duplicate binding in parallel list comprehension for:"-          <+> quotes (ppr n))-    TcRnEmptyStmtsGroup cause -> mkSimpleDecorated  $ case cause of-      EmptyStmtsGroupInParallelComp ->-        text "Empty statement group in parallel comprehension"-      EmptyStmtsGroupInTransformListComp ->-        text "Empty statement group preceding 'group' or 'then'"-      EmptyStmtsGroupInDoNotation ctxt ->-        text "Empty" <+> pprHsDoFlavour ctxt-      EmptyStmtsGroupInArrowNotation ->-        text "Empty 'do' block in an arrow command"-    TcRnLastStmtNotExpr ctxt (UnexpectedStatement stmt) ->-      mkSimpleDecorated $ hang last_error 2 (ppr stmt)-      where-        last_error =-          text "The last statement in" <+> pprAStmtContext ctxt-          <+> text "must be an expression"-    TcRnUnexpectedStatementInContext ctxt (UnexpectedStatement stmt) _ -> mkSimpleDecorated $-       sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement"-                       , text "in" <+> pprAStmtContext ctxt ]-    TcRnIllegalTupleSection -> mkSimpleDecorated $-      text "Illegal tuple section"-    TcRnIllegalImplicitParameterBindings eBinds -> mkSimpleDecorated $-        either msg msg eBinds-      where-        msg binds = hang-          (text "Implicit-parameter bindings illegal in an mdo expression")-          2 (ppr binds)-    TcRnSectionWithoutParentheses expr -> mkSimpleDecorated $-      hang (text "A section must be enclosed in parentheses")-         2 (text "thus:" <+> (parens (ppr expr)))-    TcRnMissingRoleAnnotation name roles -> mkSimpleDecorated $-      hang (text "Missing role annotation" <> colon)-         2 (text "type role" <+> ppr name <+> hsep (map ppr roles))--    TcRnIllformedTypePattern p-      -> mkSimpleDecorated $-          hang (text "Ill-formed type pattern:") 2 (ppr p)-    TcRnIllegalTypePattern-      -> mkSimpleDecorated $-          text "Illegal type pattern." $$-          text "A type pattern must be checked against a visible forall."-    TcRnIllformedTypeArgument e-      -> mkSimpleDecorated $-          hang (text "Ill-formed type argument:") 2 (ppr e)-    TcRnIllegalTypeExpr syntax -> mkSimpleDecorated $-      vcat [ text "Illegal" <+> pprTypeSyntaxName syntax-           , text "Type syntax may only be used in a required type argument,"-           , text "i.e. to instantiate a visible forall." ]--    TcRnCapturedTermName tv_name shadowed_term_names-      -> mkSimpleDecorated $-        text "The type variable" <+> quotes (ppr tv_name) <+>-          text "is implicitly quantified," $+$-          text "even though another variable of the same name is in scope:" $+$-          nest 2 var_names $+$-          text "This is not compatible with the RequiredTypeArguments extension."-        where-          var_names = case shadowed_term_names of-              Left gbl_names -> vcat (map (\name -> quotes (ppr $ greName name) <+> pprNameProvenance name) gbl_names)-              Right lcl_name -> quotes (ppr lcl_name) <+> text "defined at"-                <+> ppr (nameSrcLoc lcl_name)-    TcRnBindingOfExistingName name -> mkSimpleDecorated $-      text "Illegal binding of an existing name:" <+> ppr (filterCTuple name)-    TcRnMultipleFixityDecls loc rdr_name -> mkSimpleDecorated $-      vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name),-            text "also at " <+> ppr loc]-    TcRnIllegalPatternSynonymDecl -> mkSimpleDecorated $-      text "Illegal pattern synonym declaration"-    TcRnIllegalClassBinding dsort bind -> mkSimpleDecorated $-      vcat [ what <+> text "not allowed in" <+> decl_sort-              , nest 2 (ppr bind) ]-      where-        decl_sort = case dsort of-          ClassDeclSort -> text "class declaration:"-          InstanceDeclSort -> text "instance declaration:"-        what = case bind of-                  PatBind {}    -> text "Pattern bindings (except simple variables)"-                  PatSynBind {} -> text "Pattern synonyms"-                                   -- Associated pattern synonyms are not implemented yet-                  _ -> pprPanic "rnMethodBind" (ppr bind)-    TcRnOrphanCompletePragma -> mkSimpleDecorated $-      text "Orphan COMPLETE pragmas not supported" $$-      text "A COMPLETE pragma must mention at least one data constructor" $$-      text "or pattern synonym defined in the same module."-    TcRnEmptyCase ctxt reason -> mkSimpleDecorated $-      case reason of-        EmptyCaseWithoutFlag ->-          text "Empty list of alternatives in" <+> pp_ctxt-        EmptyCaseDisallowedCtxt ->-          text "Empty list of alternatives is not allowed in" <+> pp_ctxt-        EmptyCaseForall tvb ->-          vcat [ text "Empty list of alternatives in" <+> pp_ctxt-               , hang (text "checked against a forall-type:")-                      2 (pprForAll [tvb] <+> text "...")-               ]-        where-          pp_ctxt = case ctxt of-            CaseAlt                                -> text "case expression"-            LamAlt LamCase                         -> text "\\case expression"-            LamAlt LamCases                        -> text "\\cases expression"-            ArrowMatchCtxt (ArrowLamAlt LamSingle) -> text "kappa abstraction"-            ArrowMatchCtxt (ArrowLamAlt LamCase)   -> text "\\case command"-            ArrowMatchCtxt (ArrowLamAlt LamCases)  -> text "\\cases command"-            ArrowMatchCtxt ArrowCaseAlt            -> text "case command"-            ctxt                                   -> text "(unexpected)" <+> pprMatchContextNoun ctxt-    TcRnNonStdGuards (NonStandardGuards guards) -> mkSimpleDecorated $-      text "accepting non-standard pattern guards" $$-      nest 4 (interpp'SP guards)-    TcRnDuplicateSigDecl pairs@((L _ name, sig) :| _) -> mkSimpleDecorated $-      vcat [ text "Duplicate" <+> what_it_is-            <> text "s for" <+> quotes (ppr name)-          , text "at" <+> vcat (map ppr $ sortBy leftmost_smallest-                                        $ map (getLocA . fst)-                                        $ NE.toList pairs)-          ]-      where-        what_it_is = hsSigDoc sig-    TcRnMisplacedSigDecl sig -> mkSimpleDecorated $-      sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig]-    TcRnUnexpectedDefaultSig sig -> mkSimpleDecorated $-      hang (text "Unexpected default signature:")-         2 (ppr sig)-    TcRnDuplicateMinimalSig sig1 sig2 otherSigs -> mkSimpleDecorated $-      vcat [ text "Multiple minimal complete definitions"-           , text "at" <+> vcat (map ppr $ sortBy leftmost_smallest $ map getLocA sigs)-           , text "Combine alternative minimal complete definitions with `|'" ]-      where-        sigs = sig1 : sig2 : otherSigs-    TcRnUnexpectedStandaloneDerivingDecl -> mkSimpleDecorated $-      text "Illegal standalone deriving declaration"-    TcRnUnusedVariableInRuleDecl name var -> mkSimpleDecorated $-      sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,-          text "Forall'd variable" <+> quotes (ppr var) <+>-                  text "does not appear on left hand side"]-    TcRnUnexpectedStandaloneKindSig -> mkSimpleDecorated $-      text "Illegal standalone kind signature"-    TcRnIllegalRuleLhs errReason name lhs bad_e -> mkSimpleDecorated $-      sep [text "Rule" <+> pprRuleName name <> colon,-           nest 2 (vcat [err,-                         text "in left-hand side:" <+> ppr lhs])]-      $$-      text "LHS must be of form (f e1 .. en) where f is not forall'd"-      where-        err = case errReason of-          UnboundVariable uv nis -> pprScopeError uv nis-          IllegalExpression -> text "Illegal expression:" <+> ppr bad_e-    TcRnDuplicateRoleAnnot list -> mkSimpleDecorated $-      hang (text "Duplicate role annotations for" <+>-            quotes (ppr $ roleAnnotDeclName first_decl) <> colon)-        2 (vcat $ map pp_role_annot $ NE.toList sorted_list)-      where-        sorted_list = NE.sortBy cmp_loc list-        ((L _ first_decl) :| _) = sorted_list--        pp_role_annot (L loc decl) = hang (ppr decl)-                                        4 (text "-- written at" <+> ppr (locA loc))--        cmp_loc = leftmost_smallest `on` getLocA-    TcRnDuplicateKindSig list -> mkSimpleDecorated $-      hang (text "Duplicate standalone kind signatures for" <+>-            quotes (ppr $ standaloneKindSigName first_decl) <> colon)-        2 (vcat $ map pp_kisig $ NE.toList sorted_list)-      where-        sorted_list = NE.sortBy cmp_loc list-        ((L _ first_decl) :| _) = sorted_list--        pp_kisig (L loc decl) =-          hang (ppr decl) 4 (text "-- written at" <+> ppr (locA loc))--        cmp_loc = leftmost_smallest `on` getLocA-    TcRnIllegalDerivStrategy ds -> mkSimpleDecorated $-      text "Illegal deriving strategy" <> colon <+> derivStrategyName ds-    TcRnIllegalMultipleDerivClauses -> mkSimpleDecorated $-      text "Illegal use of multiple, consecutive deriving clauses"-    TcRnNoDerivStratSpecified{} -> mkSimpleDecorated $ text-      "No deriving strategy specified. Did you want stock, newtype, or anyclass?"-    TcRnStupidThetaInGadt{} -> mkSimpleDecorated $-      vcat [text "No context is allowed on a GADT-style data declaration",-            text "(You can put a context on each constructor, though.)"]-    TcRnShadowedTyVarNameInFamResult resName -> mkSimpleDecorated $-       hsep [ text "Type variable", quotes (ppr resName) <> comma-            , text "naming a type family result,"-            ] $$-      text "shadows an already bound type variable"-    TcRnIncorrectTyVarOnLhsOfInjCond resName injFrom -> mkSimpleDecorated $-        vcat [ text $ "Incorrect type variable on the LHS of "-                   ++ "injectivity condition"-      , nest 5-      ( vcat [ text "Expected :" <+> ppr resName-             , text "Actual   :" <+> ppr injFrom ])]-    TcRnUnknownTyVarsOnRhsOfInjCond errorVars -> mkSimpleDecorated $-      hsep [ text "Unknown type variable" <> plural errorVars-           , text "on the RHS of injectivity condition:"-           , interpp'SP errorVars ]-    TcRnBadlyStaged reason bind_lvl use_lvl-      -> mkSimpleDecorated $-         vcat $-         [ text "Stage error:" <+> pprStageCheckReason reason <+>-           hsep [text "is bound at stage" <+> ppr bind_lvl,-                 text "but used at stage" <+> ppr use_lvl]-         ] ++-         [ hsep [ text "Hint: quoting" <+> thBrackets (ppUnless (isValName n) "t") (ppr n)-                , text "or an enclosing expression would allow the quotation to be used in an earlier stage"-                ]-         | StageCheckSplice n <- [reason]-         ]-    TcRnBadlyStagedType name bind_lvl use_lvl-      -> mkSimpleDecorated $-         text "Badly staged type:" <+> ppr name <+>-         hsep [text "is bound at stage" <+> ppr bind_lvl,-               text "but used at stage" <+> ppr use_lvl]-    TcRnStageRestriction reason-      -> mkSimpleDecorated $-         sep [ text "GHC stage restriction:"-             , nest 2 (vcat [ pprStageCheckReason reason <+>-                              text "is used in a top-level splice, quasi-quote, or annotation,"-                            , text "and must be imported, not defined locally"])]-    TcRnTyThingUsedWrong sort thing name-      -> mkSimpleDecorated $-         pprTyThingUsedWrong sort thing name-    TcRnCannotDefaultKindVar var knd ->-      mkSimpleDecorated $-      (vcat [ text "Cannot default kind variable" <+> quotes (ppr var)-            , text "of kind:" <+> ppr knd-            , text "Perhaps enable PolyKinds or add a kind signature" ])-    TcRnUninferrableTyVar tidied_tvs context ->-      mkSimpleDecorated $-      pprWithInvisibleBitsWhen True $-      vcat [ text "Uninferrable type variable"-              <> plural tidied_tvs-              <+> pprWithCommas pprTyVar tidied_tvs-              <+> text "in"-            , pprUninferrableTyVarCtx context ]-    TcRnSkolemEscape escapees tv orig_ty ->-      mkSimpleDecorated $-      pprWithInvisibleBitsWhen True $-      vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees-                , quotes $ pprTyVars escapees-                , text "would escape" <+> itsOrTheir escapees <+> text "scope"-                ]-          , sep [ text "if I tried to quantify"-                , pprTyVar tv-                , text "in this type:"-                ]-          , nest 2 (pprTidiedType orig_ty)-          , text "(Indeed, I sometimes struggle even printing this correctly,"-          , text " due to its ill-scoped nature.)"-          ]-    TcRnPatSynEscapedCoercion arg bad_co_ne -> mkSimpleDecorated $-      vcat [ text "Iceland Jack!  Iceland Jack! Stop torturing me!"-           , hang (text "Pattern-bound variable")-                2 (ppr arg <+> dcolon <+> ppr (idType arg))-           , nest 2 $-             hang (text "has a type that mentions pattern-bound coercion"-                   <> plural bad_co_list <> colon)-                2 (pprWithCommas ppr bad_co_list)-           , text "Hint: use -fprint-explicit-coercions to see the coercions"-           , text "Probable fix: add a pattern signature" ]-      where-        bad_co_list = NE.toList bad_co_ne-    TcRnPatSynExistentialInResult name pat_ty bad_tvs -> mkSimpleDecorated $-      hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma-                , text "namely" <+> quotes (ppr pat_ty) ])-        2 (text "mentions existential type variable" <> plural bad_tvs-           <+> pprQuotedList bad_tvs)-    TcRnPatSynArityMismatch name decl_arity missing -> mkSimpleDecorated $-      hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has"-            <+> speakNOf decl_arity (text "argument"))-         2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")-    TcRnPatSynInvalidRhs ps_name lpat _ reason -> mkSimpleDecorated $-      vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"-                   <+> quotes (ppr ps_name) <> colon)-                2 (pprPatSynInvalidRhsReason reason)-           , text "RHS pattern:" <+> ppr lpat ]-    TcRnTyFamDepsDisabled -> mkSimpleDecorated $-      text "Illegal injectivity annotation"-    TcRnAbstractClosedTyFamDecl -> mkSimpleDecorated $-      text "You may define an abstract closed type family" $$-      text "only in a .hs-boot file"-    TcRnPartialFieldSelector fld -> mkSimpleDecorated $-      vcat [ sep [ text "Definition of partial record field" <> colon-                 , nest 2 $ quotes (ppr (occName fld)) ]-           , text "Record selection and update using this field will be partial." ]-    TcRnHasFieldResolvedIncomplete name -> mkSimpleDecorated $-      text "The invocation of `getField` on the record field" <+> quotes (ppr name)-      <+> text "may produce an error since it is not defined for all data constructors"-    TcRnBadFieldAnnotation n con reason -> mkSimpleDecorated $-      hang (pprBadFieldAnnotationReason reason)-         2 (text "on the" <+> speakNth n-            <+> text "argument of" <+> quotes (ppr con))-    TcRnSuperclassCycle (MkSuperclassCycle cls definite details) ->-      let herald | definite  = text "Superclass cycle for"-                 | otherwise = text "Potential superclass cycle for"-      in mkSimpleDecorated $-       vcat [ herald <+> quotes (ppr cls), nest 2 (vcat (pprSuperclassCycleDetail <$> details))]-    TcRnDefaultSigMismatch sel_id dm_ty -> mkSimpleDecorated $-      hang (text "The default type signature for"-            <+> ppr sel_id <> colon)-         2 (ppr dm_ty)-      $$ (text "does not match its corresponding"-          <+> text "non-default type signature")-    TcRnTyFamsDisabled reason -> mkSimpleDecorated $-      text "Illegal family" <+> text sort <+> text "for" <+> quotes name-      where-        (sort, name) = case reason of-          TyFamsDisabledFamily n -> ("declaration", ppr n)-          TyFamsDisabledInstance n -> ("instance", ppr n)-    TcRnBadTyConTelescope tc -> mkSimpleDecorated $-      vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped")-                2 pp_tc_kind-           , extra-           , hang (text "Perhaps try this order instead:")-                2 (pprTyVars sorted_tvs) ]-      where-        pp_tc_kind = text "Inferred kind:" <+> ppr tc <+> dcolon <+> ppr_untidy (tyConKind tc)-        ppr_untidy ty = pprIfaceType (toIfaceType ty)-          -- We need ppr_untidy here because pprType will tidy the type, which-          -- will turn the bogus kind we are trying to report-          --     T :: forall (a::k) k (b::k) -> blah-          -- into a misleadingly sanitised version-          --     T :: forall (a::k) k1 (b::k1) -> blah--        tcbs = tyConBinders tc-        tvs  = binderVars tcbs-        sorted_tvs = scopedSort tvs--        inferred_tvs  = [ binderVar tcb-                        | tcb <- tcbs, Inferred == tyConBinderForAllTyFlag tcb ]-        specified_tvs = [ binderVar tcb-                        | tcb <- tcbs, Specified == tyConBinderForAllTyFlag tcb ]--        extra-          | null inferred_tvs && null specified_tvs-          = empty-          | null inferred_tvs-          = note $ "Specified variables" <+> pp_spec <+> "always come first"-          | null specified_tvs-          = note inf_always_first-          | otherwise-          = note $ inf_always_first $$-              "then specified variables" <+> pp_spec--        inf_always_first = "Inferred variables" <+> pp_inf $$ "always come first"--        pp_inf  = parens (text "namely:" <+> pprTyVars inferred_tvs)-        pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs)-    TcRnTyFamResultDisabled tc_name tvb -> mkSimpleDecorated $-      text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name)-    TcRnRoleValidationFailed role reason -> mkSimpleDecorated $-      vcat [text "Internal error in role inference:",-            pprRoleValidationFailedReason role reason,-            text "Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug"]-    TcRnCommonFieldResultTypeMismatch con1 con2 field_name -> mkSimpleDecorated $-      vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,-                 text "have a common field" <+> quotes (ppr field_name) <> comma],-            nest 2 $ text "but have different result types"]-    TcRnCommonFieldTypeMismatch con1 con2 field_name -> mkSimpleDecorated $-      sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,-           text "give different types for field", quotes (ppr field_name)]-    TcRnClassExtensionDisabled cls reason -> mkSimpleDecorated $-      pprDisabledClassExtension cls reason-    TcRnDataConParentTypeMismatch data_con res_ty_tmpl -> mkSimpleDecorated $-      hang (text "Data constructor" <+> quotes (ppr data_con) <+>-            text "returns type" <+> quotes (ppr actual_res_ty))-         2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl))-      where-        actual_res_ty = dataConOrigResTy data_con-    TcRnGADTsDisabled tc_name -> mkSimpleDecorated $-      text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name)-    TcRnExistentialQuantificationDisabled con -> mkSimpleDecorated $-      sdocOption sdocLinearTypes (\show_linear_types ->-        hang (text "Data constructor" <+> quotes (ppr con) <+>-              text "has existential type variables, a context, or a specialised result type")-           2 (ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)))-    TcRnGADTDataContext tc_name -> mkSimpleDecorated $-      text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name)-    TcRnMultipleConForNewtype tycon n -> mkSimpleDecorated $-      sep [text "A newtype must have exactly one constructor,",-           nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n]-    TcRnKindSignaturesDisabled thing -> mkSimpleDecorated $-      text "Illegal kind signature" <+> quotes (either ppr with_sig thing)-      where-        with_sig (tc_name, ksig) = ppr tc_name <+> dcolon <+> ppr ksig-    TcRnEmptyDataDeclsDisabled tycon -> mkSimpleDecorated $-      quotes (ppr tycon) <+> text "has no constructors"-    TcRnRoleMismatch var annot inferred -> mkSimpleDecorated $-      hang (text "Role mismatch on variable" <+> ppr var <> colon)-         2 (sep [ text "Annotation says", ppr annot-                , text "but role", ppr inferred-                , text "is required" ])-    TcRnRoleCountMismatch tyvars d@(L _ (RoleAnnotDecl _ _ annots)) -> mkSimpleDecorated $-      hang (text "Wrong number of roles listed in role annotation;" $$-            text "Expected" <+> (ppr tyvars) <> comma <+>-            text "got" <+> (ppr $ length annots) <> colon)-         2 (ppr d)-    TcRnIllegalRoleAnnotation (RoleAnnotDecl _ tycon _) -> mkSimpleDecorated $-      (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$-       text "they are allowed only for datatypes and classes.")-    TcRnRoleAnnotationsDisabled  tc -> mkSimpleDecorated $-      text "Illegal role annotation for" <+> ppr tc-    TcRnIncoherentRoles _ -> mkSimpleDecorated $-      (text "Roles other than" <+> quotes (text "nominal") <+>-      text "for class parameters can lead to incoherence.")-    TcRnUnexpectedKindVar tv_name-      -> mkSimpleDecorated $ text "Unexpected kind variable" <+> quotes (ppr tv_name)--    TcRnNegativeNumTypeLiteral tyLit-      -> mkSimpleDecorated $ text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit--    TcRnIllegalKind ty_thing _-      -> mkSimpleDecorated $ text "Illegal kind:" <+> (ppr ty_thing)--    TcRnPrecedenceParsingError op1 op2-      -> mkSimpleDecorated $-           hang (text "Precedence parsing error")-           4 (hsep [text "cannot mix", ppr_opfix op1, text "and",-           ppr_opfix op2,-           text "in the same infix expression"])--    TcRnSectionPrecedenceError op arg_op section-      -> mkSimpleDecorated $-           vcat [text "The operator" <+> ppr_opfix op <+> text "of a section",-             nest 4 (sep [text "must have lower precedence than that of the operand,",-                          nest 2 (text "namely" <+> ppr_opfix arg_op)]),-             nest 4 (text "in the section:" <+> quotes (ppr section))]--    TcRnUnexpectedPatSigType ty-      -> mkSimpleDecorated $-           hang (text "Illegal type signature:" <+> quotes (ppr ty))-              2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")--    TcRnIllegalKindSignature ty-      -> mkSimpleDecorated $ text "Illegal kind signature:" <+> quotes (ppr ty)--    TcRnUnusedQuantifiedTypeVar doc tyVar-      -> mkSimpleDecorated $-           vcat [ text "Unused quantified type variable" <+> quotes (ppr tyVar)-                , inHsDocContext doc ]--    TcRnDataKindsError typeOrKind thing-      -- See Note [Checking for DataKinds] (Wrinkle: Migration story for-      -- DataKinds typechecker errors) in GHC.Tc.Validity for why we give-      -- different diagnostic messages below.-      -> case thing of-           Left renamer_thing ->-             mkSimpleDecorated $-               text "Illegal" <+> ppr_level <> colon <+> quotes (ppr renamer_thing)-           Right typechecker_thing ->-             mkSimpleDecorated $ vcat-               [ text "An occurrence of" <+> quotes (ppr typechecker_thing) <+>-                 text "in a" <+> ppr_level <+> text "requires DataKinds."-               , text "Future versions of GHC will turn this warning into an error."-               ]-      where-        ppr_level = text $ levelString typeOrKind--    TcRnTypeSynonymCycle decl_or_tcs-      -> mkSimpleDecorated $-           sep [ text "Cycle in type synonym declarations:"-               , nest 2 (vcat (map ppr_decl decl_or_tcs)) ]-      where-        ppr_decl = \case-          Right (L loc decl) -> ppr (locA loc) <> colon <+> ppr decl-          Left tc ->-            let n = tyConName tc-            in ppr (getSrcSpan n) <> colon <+> ppr (tyConName tc)-                   <+> text "from external module"-    TcRnZonkerMessage err-      -> mkSimpleDecorated $ pprZonkerMessage err-    TcRnInterfaceError reason-      -> diagnosticMessage (tcOptsIfaceOpts opts) reason-    TcRnSelfImport imp_mod_name-      -> mkSimpleDecorated $-         text "A module cannot import itself:" <+> ppr imp_mod_name-    TcRnNoExplicitImportList mod-      -> mkSimpleDecorated $-         text "The module" <+> quotes (ppr mod) <+> text "does not have an explicit import list"-    TcRnSafeImportsDisabled _-      -> mkSimpleDecorated $-         text "safe import can't be used as Safe Haskell isn't on!"-    TcRnDeprecatedModule mod txt-      -> mkSimpleDecorated $-         sep [ text "Module" <+> quotes (ppr mod) <> text extra <> colon,-               nest 2 (vcat (map (ppr . hsDocString . unLoc) msg)) ]-         where-          (extra, msg) = case txt of-            WarningTxt _ _ msg -> ("", msg)-            DeprecatedTxt _ msg -> (" is deprecated", msg)-    TcRnRedundantSourceImport mod_name-      -> mkSimpleDecorated $-         text "Unnecessary {-# SOURCE #-} in the import of module" <+> quotes (ppr mod_name)-    TcRnImportLookup reason-      -> mkSimpleDecorated $-         pprImportLookup reason-    TcRnUnusedImport decl reason-      -> mkSimpleDecorated $-         pprUnusedImport decl reason-    TcRnDuplicateDecls name sorted_names-      -> mkSimpleDecorated $-         vcat [text "Multiple declarations of" <+>-               quotes (ppr name),-                -- NB. print the OccName, not the Name, because the-                -- latter might not be in scope in the RdrEnv and so will-                -- be printed qualified.-               text "Declared at:" <+>-               vcat (NE.toList $ ppr . nameSrcLoc <$> sorted_names)]-    TcRnPackageImportsDisabled-      -> mkSimpleDecorated $-         text "Package-qualified imports are not enabled"-    TcRnIllegalDataCon name-      -> mkSimpleDecorated $-         hsep [text "Illegal data constructor name", quotes (ppr name)]-    TcRnNestedForallsContexts entity-      -> mkSimpleDecorated $-         what <+> text "cannot contain nested"-         <+> quotes forAllLit <> text "s or contexts"-         where-           what = case entity of-             NFC_Specialize -> text "SPECIALISE instance type"-             NFC_ViaType -> quotes (text "via") <+> text "type"-             NFC_GadtConSig -> text "GADT constructor type signature"-             NFC_InstanceHead -> text "Instance head"-             NFC_StandaloneDerivedInstanceHead -> text "Standalone-derived instance head"-             NFC_DerivedClassType -> text "Derived class type"-    TcRnRedundantRecordWildcard-      -> mkSimpleDecorated $-         text "Record wildcard does not bind any new variables"-    TcRnUnusedRecordWildcard _-      -> mkSimpleDecorated $-         text "No variables bound in the record wildcard match are used"-    TcRnUnusedName name reason-      -> mkSimpleDecorated $-         pprUnusedName name reason-    TcRnQualifiedBinder rdr_name-      -> mkSimpleDecorated $-         text "Qualified name in binding position:" <+> ppr rdr_name-    TcRnTypeApplicationsDisabled ty_app-      -> mkSimpleDecorated $-         text "Illegal visible" <+> what <+> text "application" <+> ctx <> colon-           <+> ppr arg-         where-           arg = case ty_app of-            TypeApplication ty _ -> char '@' <> ppr ty-            TypeApplicationInPattern ty_app -> ppr ty_app-           what = case ty_app of-             TypeApplication _ ty_or_ki ->-              case ty_or_ki of-                TypeLevel -> text "type"-                KindLevel -> text "kind"-             TypeApplicationInPattern _ -> text "type"-           ctx = case ty_app of-            TypeApplicationInPattern _ -> text "in a pattern"-            _                          -> empty-    TcRnInvalidRecordField con field-      -> mkSimpleDecorated $-         hsep [text "Constructor" <+> quotes (ppr con),-               text "does not have field", quotes (ppr field)]-    TcRnTupleTooLarge tup_size-      -> mkSimpleDecorated $-         sep [text "A" <+> int tup_size <> text "-tuple is too large for GHC",-              nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),-              nest 2 (text "Workaround: use nested tuples or define a data type")]-    TcRnCTupleTooLarge tup_size-      -> mkSimpleDecorated $-         hang (text "Constraint tuple arity too large:" <+> int tup_size-               <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))-            2 (text "Instead, use a nested tuple")-    TcRnIllegalInferredTyVars _-      -> mkSimpleDecorated $-         text "Inferred type variables are not allowed"-    TcRnAmbiguousName gre_env name gres-      -> mkSimpleDecorated $-         vcat [ text "Ambiguous occurrence" <+> quotes (ppr name) <> dot-              , text "It could refer to"-              , nest 3 (vcat msgs) ]-         where-           np1 NE.:| nps = gres-           msgs = punctuateFinal comma dot $-                    text "either" <+> ppr_gre np1-                 : [text "    or" <+> ppr_gre np | np <- nps]--           ppr_gre gre = pprAmbiguousGreName gre_env gre--    TcRnBindingNameConflict name locs-      -> mkSimpleDecorated $-         vcat [text "Conflicting definitions for" <+> quotes (ppr name),-               locations]-         where-           locations =-             text "Bound at:"-             <+> vcat (map ppr (sortBy leftmost_smallest (NE.toList locs)))-    TcRnNonCanonicalDefinition reason inst_ty-      -> mkSimpleDecorated $-         pprNonCanonicalDefinition inst_ty reason-    TcRnDefaultedExceptionContext ct_loc ->-      mkSimpleDecorated $ vcat [ header, warning, proposal ]-      where-        header, warning, proposal :: SDoc-        header-          = vcat [ text "Solving for an implicit ExceptionContext constraint"-                 , nest 2 $ pprCtOrigin (ctLocOrigin ct_loc) <> text "." ]-        warning-          = vcat [ text "Future versions of GHC will turn this warning into an error." ]-        proposal-          = vcat [ text "See GHC Proposal #330." ]-    TcRnImplicitImportOfPrelude-      -> mkSimpleDecorated $-         text "Module" <+> quotes (text "Prelude") <+> text "implicitly imported."-    TcRnMissingMain explicit_export_list main_mod main_occ-      -> mkSimpleDecorated $-         text "The" <+> ppMainFn main_occ-        <+> text "is not" <+> defOrExp <+> text "module"-        <+> quotes (ppr main_mod)-      where-        defOrExp :: SDoc-        defOrExp | explicit_export_list = text "exported by"-                 | otherwise            = text "defined in"-    TcRnGhciUnliftedBind id-      -> mkSimpleDecorated $-         sep [ text "GHCi can't bind a variable of unlifted type:"-             , nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id)) ]-    TcRnGhciMonadLookupFail ty lookups-      -> mkSimpleDecorated $-         hang (text "Can't find type" <+> pp_ty <> dot $$ ambig_msg)-           2 (text "When checking that" <+> pp_ty <>-              text "is a monad that can execute GHCi statements.")-      where-        pp_ty = quotes (text ty)-        ambig_msg = case lookups of-          Just (_:_:_) -> text "The type is ambiguous."-          _            -> empty-    TcRnIllegalQuasiQuotes -> mkSimpleDecorated $-      text "Quasi-quotes are not permitted without QuasiQuotes"-    TcRnTHError err -> pprTHError err-    TcRnPatersonCondFailure reason ctxt lhs rhs ->-      mkSimpleDecorated $ pprPatersonCondFailure reason ctxt lhs rhs-    TcRnIllegalInvisTyVarBndr bndr ->-      mkSimpleDecorated $-        hang (text "Illegal invisible type variable binder:")-           2 (ppr bndr)-    TcRnIllegalWildcardTyVarBndr bndr ->-      mkSimpleDecorated $-        hang (text "Illegal wildcard binder:")-           2 (ppr bndr)--    TcRnInvalidInvisTyVarBndr name hs_bndr ->-      mkSimpleDecorated $-        vcat [ hang (text "Invalid invisible type variable binder:")-                  2 (ppr hs_bndr)-             , text "There is no matching forall-bound variable"-             , text "in the standalone kind signature for" <+> quotes (ppr name) <> dot-             , note $ vcat [-                "Only" <+> quotes "forall a." <+> "-quantification matches invisible binders,",-                "whereas" <+> quotes "forall {a}." <+> "and" <+> quotes "forall a ->" <+> "do not"-             ]]--    TcRnDeprecatedInvisTyArgInConPat ->-      mkSimpleDecorated $-        cat [ text "Type applications in constructor patterns will require"-            , text "the TypeAbstractions extension starting from GHC 9.14." ]--    TcRnInvisBndrWithoutSig _ hs_bndr ->-      mkSimpleDecorated $-        vcat [ hang (text "Invalid invisible type variable binder:")-                  2 (ppr hs_bndr)-             , text "Either a standalone kind signature (SAKS)"-             , text "or a complete user-supplied kind (CUSK, legacy feature)"-             , text "is required to use invisible binders." ]--    TcRnImplicitRhsQuantification kv -> mkSimpleDecorated $-      vcat [ text "The variable" <+> quotes (ppr kv) <+> text "occurs free on the RHS of the type declaration"-           , text "In the future GHC will no longer implicitly quantify over such variables"-           ]--    TcRnInvalidDefaultedTyVar wanteds proposal bad_tvs ->-      mkSimpleDecorated $-      pprWithInvisibleBitsWhen True $-      vcat [ text "Invalid defaulting proposal."-           , hang (text "The following type variable" <> plural (NE.toList bad_tvs) <+> text "cannot be defaulted, as" <+> why <> colon)-                2 (pprQuotedList (NE.toList bad_tvs))-           , hang (text "Defaulting proposal:")-                2 (ppr proposal)-           , hang (text "Wanted constraints:")-                2 (pprQuotedList (map ctPred wanteds))-           ]-        where-          why-            | _ :| [] <- bad_tvs-            = text "it is not an unfilled metavariable"-            | otherwise-            = text "they are not unfilled metavariables"--    TcRnNamespacedWarningPragmaWithoutFlag warning@(Warning (kw, _) _ txt) -> mkSimpleDecorated $-      vcat [ text "Illegal use of the" <+> quotes (ppr kw) <+> text "keyword:"-           , nest 2 (ppr warning)-           , text "in a" <+> pragma_type <+> text "pragma"-           ]-      where-        pragma_type = case txt of-          WarningTxt{} -> text "WARNING"-          DeprecatedTxt{} -> text "DEPRECATED"--    TcRnIllegalInvisibleTypePattern tp -> mkSimpleDecorated $-      text "Illegal invisible type pattern:" <+> ppr tp--    TcRnInvisPatWithNoForAll tp -> mkSimpleDecorated $-      text "Invisible type pattern" <+> ppr tp <+> text "has no associated forall"--    TcRnNamespacedFixitySigWithoutFlag sig@(FixitySig kw _ _) -> mkSimpleDecorated $-      vcat [ text "Illegal use of the" <+> quotes (ppr kw) <+> text "keyword:"-           , nest 2 (ppr sig)-           , text "in a fixity signature"-           ]--    TcRnOutOfArityTyVar ts_name tv_name -> mkDecorated-      [ vcat [ text "The arity of" <+> quotes (ppr ts_name) <+> text "is insufficiently high to accommodate"-             , text "an implicit binding for the" <+> quotes (ppr tv_name) <+> text "type variable." ]-      , suggestion ]-      where-        suggestion =-          text "Use" <+> quotes at_bndr     <+> text "on the LHS" <+>-          text "or"  <+> quotes forall_bndr <+> text "on the RHS" <+>-          text "to bring it into scope."-        at_bndr     = char '@' <> ppr tv_name-        forall_bndr = text "forall" <+> ppr tv_name <> text "."--    TcRnMisplacedInvisPat tp -> mkSimpleDecorated $-      text "Invisible type pattern" <+> ppr tp <+> text "is not allowed here"--    TcRnUnexpectedTypeSyntaxInTerms syntax -> mkSimpleDecorated $-      text "Unexpected" <+> pprTypeSyntaxName syntax--  diagnosticReason :: TcRnMessage -> DiagnosticReason-  diagnosticReason = \case-    TcRnUnknownMessage m-      -> diagnosticReason m-    TcRnMessageWithInfo _ msg_with_info-      -> case msg_with_info of-           TcRnMessageDetailed _ m -> diagnosticReason m-    TcRnWithHsDocContext _ msg-      -> diagnosticReason msg-    TcRnSolverReport _ reason-      -> reason -- Error, or a Warning if we are deferring type errors-    TcRnSolverDepthError {}-      -> ErrorWithoutFlag-    TcRnRedundantConstraints {}-      -> WarningWithFlag Opt_WarnRedundantConstraints-    TcRnInaccessibleCode {}-      -> WarningWithFlag Opt_WarnInaccessibleCode-    TcRnInaccessibleCoAxBranch {}-      -> WarningWithFlag Opt_WarnInaccessibleCode-    TcRnTypeDoesNotHaveFixedRuntimeRep{}-      -> ErrorWithoutFlag-    TcRnImplicitLift{}-      -> WarningWithFlag Opt_WarnImplicitLift-    TcRnUnusedPatternBinds{}-      -> WarningWithFlag Opt_WarnUnusedPatternBinds-    TcRnDodgyImports{}-      -> WarningWithFlag Opt_WarnDodgyImports-    TcRnDodgyExports{}-      -> WarningWithFlag Opt_WarnDodgyExports-    TcRnMissingImportList{}-      -> WarningWithFlag Opt_WarnMissingImportList-    TcRnUnsafeDueToPlugin{}-      -> WarningWithoutFlag-    TcRnModMissingRealSrcSpan{}-      -> ErrorWithoutFlag-    TcRnIdNotExportedFromModuleSig{}-      -> ErrorWithoutFlag-    TcRnIdNotExportedFromLocalSig{}-      -> ErrorWithoutFlag-    TcRnShadowedName{}-      -> WarningWithFlag Opt_WarnNameShadowing-    TcRnInvalidWarningCategory{}-      -> ErrorWithoutFlag-    TcRnDuplicateWarningDecls{}-      -> ErrorWithoutFlag-    TcRnSimplifierTooManyIterations{}-      -> ErrorWithoutFlag-    TcRnIllegalPatSynDecl{}-      -> ErrorWithoutFlag-    TcRnLinearPatSyn{}-      -> ErrorWithoutFlag-    TcRnEmptyRecordUpdate-      -> ErrorWithoutFlag-    TcRnIllegalFieldPunning{}-      -> ErrorWithoutFlag-    TcRnIllegalWildcardsInRecord{}-      -> ErrorWithoutFlag-    TcRnIllegalWildcardInType{}-      -> ErrorWithoutFlag-    TcRnIllegalNamedWildcardInTypeArgument{}-      -> ErrorWithoutFlag-    TcRnIllegalImplicitTyVarInTypeArgument{}-      -> ErrorWithoutFlag-    TcRnDuplicateFieldName{}-      -> ErrorWithoutFlag-    TcRnIllegalViewPattern{}-      -> ErrorWithoutFlag-    TcRnCharLiteralOutOfRange{}-      -> ErrorWithoutFlag-    TcRnIllegalWildcardsInConstructor{}-      -> ErrorWithoutFlag-    TcRnIgnoringAnnotations{}-      -> WarningWithoutFlag-    TcRnAnnotationInSafeHaskell-      -> ErrorWithoutFlag-    TcRnInvalidTypeApplication{}-      -> ErrorWithoutFlag-    TcRnTagToEnumMissingValArg-      -> ErrorWithoutFlag-    TcRnTagToEnumUnspecifiedResTy{}-      -> ErrorWithoutFlag-    TcRnTagToEnumResTyNotAnEnum{}-      -> ErrorWithoutFlag-    TcRnTagToEnumResTyTypeData{}-      -> ErrorWithoutFlag-    TcRnArrowIfThenElsePredDependsOnResultTy-      -> ErrorWithoutFlag-    TcRnIllegalHsBootOrSigDecl {}-      -> ErrorWithoutFlag-    TcRnBootMismatch {}-      -> ErrorWithoutFlag-    TcRnRecursivePatternSynonym{}-      -> ErrorWithoutFlag-    TcRnPartialTypeSigTyVarMismatch{}-      -> ErrorWithoutFlag-    TcRnPartialTypeSigBadQuantifier{}-      -> ErrorWithoutFlag-    TcRnMissingSignature what exported-      -> WarningWithFlags $ missingSignatureWarningFlags what exported-    TcRnPolymorphicBinderMissingSig{}-      -> WarningWithFlag Opt_WarnMissingLocalSignatures-    TcRnOverloadedSig{}-      -> ErrorWithoutFlag-    TcRnTupleConstraintInst{}-      -> ErrorWithoutFlag-    TcRnUserTypeError{}-      -> ErrorWithoutFlag-    TcRnConstraintInKind{}-      -> ErrorWithoutFlag-    TcRnUnboxedTupleOrSumTypeFuncArg{}-      -> ErrorWithoutFlag-    TcRnLinearFuncInKind{}-      -> ErrorWithoutFlag-    TcRnForAllEscapeError{}-      -> ErrorWithoutFlag-    TcRnSimplifiableConstraint{}-      -> WarningWithFlag Opt_WarnSimplifiableClassConstraints-    TcRnArityMismatch{}-      -> ErrorWithoutFlag-    TcRnIllegalInstance rea-      -> illegalInstanceReason rea-    TcRnVDQInTermType{}-      -> ErrorWithoutFlag-    TcRnBadQuantPredHead{}-      -> ErrorWithoutFlag-    TcRnIllegalTupleConstraint{}-      -> ErrorWithoutFlag-    TcRnNonTypeVarArgInConstraint{}-      -> ErrorWithoutFlag-    TcRnIllegalImplicitParam{}-      -> ErrorWithoutFlag-    TcRnIllegalConstraintSynonymOfKind{}-      -> ErrorWithoutFlag-    TcRnOversaturatedVisibleKindArg{}-      -> ErrorWithoutFlag-    TcRnForAllRankErr{}-      -> ErrorWithoutFlag-    TcRnMonomorphicBindings{}-      -> WarningWithFlag Opt_WarnMonomorphism-    TcRnOrphanInstance{}-      -> WarningWithFlag Opt_WarnOrphans-    TcRnFunDepConflict{}-      -> ErrorWithoutFlag-    TcRnDupInstanceDecls{}-      -> ErrorWithoutFlag-    TcRnConflictingFamInstDecls{}-      -> ErrorWithoutFlag-    TcRnFamInstNotInjective{}-      -> ErrorWithoutFlag-    TcRnBangOnUnliftedType{}-      -> WarningWithFlag Opt_WarnRedundantStrictnessFlags-    TcRnLazyBangOnUnliftedType{}-      -> WarningWithFlag Opt_WarnRedundantStrictnessFlags-    TcRnMultipleDefaultDeclarations{}-      -> ErrorWithoutFlag-    TcRnBadDefaultType{}-      -> ErrorWithoutFlag-    TcRnPatSynBundledWithNonDataCon{}-      -> ErrorWithoutFlag-    TcRnPatSynBundledWithWrongType{}-      -> ErrorWithoutFlag-    TcRnDupeModuleExport{}-      -> WarningWithFlag Opt_WarnDuplicateExports-    TcRnExportedModNotImported{}-      -> ErrorWithoutFlag-    TcRnNullExportedModule{}-      -> WarningWithFlag Opt_WarnDodgyExports-    TcRnMissingExportList{}-      -> WarningWithFlag Opt_WarnMissingExportList-    TcRnExportHiddenComponents{}-      -> ErrorWithoutFlag-    TcRnExportHiddenDefault{}-      -> ErrorWithoutFlag-    TcRnDuplicateExport{}-      -> WarningWithFlag Opt_WarnDuplicateExports-    TcRnExportedParentChildMismatch{}-      -> ErrorWithoutFlag-    TcRnConflictingExports{}-      -> ErrorWithoutFlag-    TcRnDuplicateFieldExport {}-      -> ErrorWithoutFlag-    TcRnAmbiguousFieldInUpdate {}-      -> ErrorWithoutFlag-    TcRnAmbiguousRecordUpdate{}-      -> WarningWithFlag Opt_WarnAmbiguousFields-    TcRnMissingFields{}-      -> WarningWithFlag Opt_WarnMissingFields-    TcRnFieldUpdateInvalidType{}-      -> ErrorWithoutFlag-    TcRnMissingStrictFields{}-      -> ErrorWithoutFlag-    TcRnBadRecordUpdate{}-      -> ErrorWithoutFlag-    TcRnIllegalStaticExpression {}-      -> ErrorWithoutFlag-    TcRnStaticFormNotClosed{}-      -> ErrorWithoutFlag-    TcRnUselessTypeable-      -> WarningWithFlag Opt_WarnDerivingTypeable-    TcRnDerivingDefaults{}-      -> WarningWithFlag Opt_WarnDerivingDefaults-    TcRnNonUnaryTypeclassConstraint{}-      -> ErrorWithoutFlag-    TcRnPartialTypeSignatures{}-      -> WarningWithFlag Opt_WarnPartialTypeSignatures-    TcRnCannotDeriveInstance _ _ _ _ rea-      -> case rea of-           DerivErrNotWellKinded{}                 -> ErrorWithoutFlag-           DerivErrSafeHaskellGenericInst          -> ErrorWithoutFlag-           DerivErrDerivingViaWrongKind{}          -> ErrorWithoutFlag-           DerivErrNoEtaReduce{}                   -> ErrorWithoutFlag-           DerivErrBootFileFound                   -> ErrorWithoutFlag-           DerivErrDataConsNotAllInScope{}         -> ErrorWithoutFlag-           DerivErrGNDUsedOnData                   -> ErrorWithoutFlag-           DerivErrNullaryClasses                  -> ErrorWithoutFlag-           DerivErrLastArgMustBeApp                -> ErrorWithoutFlag-           DerivErrNoFamilyInstance{}              -> ErrorWithoutFlag-           DerivErrNotStockDeriveable{}            -> ErrorWithoutFlag-           DerivErrHasAssociatedDatatypes{}        -> ErrorWithoutFlag-           DerivErrNewtypeNonDeriveableClass       -> ErrorWithoutFlag-           DerivErrCannotEtaReduceEnough{}         -> ErrorWithoutFlag-           DerivErrOnlyAnyClassDeriveable{}        -> ErrorWithoutFlag-           DerivErrNotDeriveable{}                 -> ErrorWithoutFlag-           DerivErrNotAClass{}                     -> ErrorWithoutFlag-           DerivErrNoConstructors{}                -> ErrorWithoutFlag-           DerivErrLangExtRequired{}               -> ErrorWithoutFlag-           DerivErrDunnoHowToDeriveForType{}       -> ErrorWithoutFlag-           DerivErrMustBeEnumType{}                -> ErrorWithoutFlag-           DerivErrMustHaveExactlyOneConstructor{} -> ErrorWithoutFlag-           DerivErrMustHaveSomeParameters{}        -> ErrorWithoutFlag-           DerivErrMustNotHaveClassContext{}       -> ErrorWithoutFlag-           DerivErrBadConstructor{}                -> ErrorWithoutFlag-           DerivErrGenerics{}                      -> ErrorWithoutFlag-           DerivErrEnumOrProduct{}                 -> ErrorWithoutFlag-    TcRnLookupInstance _ _ _-      -> ErrorWithoutFlag-    TcRnLazyGADTPattern-      -> ErrorWithoutFlag-    TcRnArrowProcGADTPattern-      -> ErrorWithoutFlag-    TcRnTypeEqualityOutOfScope-      -> WarningWithFlag Opt_WarnTypeEqualityOutOfScope-    TcRnTypeEqualityRequiresOperators-      -> WarningWithFlag Opt_WarnTypeEqualityRequiresOperators-    TcRnIllegalTypeOperator {}-      -> ErrorWithoutFlag-    TcRnIllegalTypeOperatorDecl {}-      -> ErrorWithoutFlag-    TcRnGADTMonoLocalBinds {}-      -> WarningWithFlag Opt_WarnGADTMonoLocalBinds-    TcRnIncorrectNameSpace {}-      -> ErrorWithoutFlag-    TcRnNotInScope {}-      -> ErrorWithoutFlag-    TcRnTermNameInType {}-      -> ErrorWithoutFlag-    TcRnUntickedPromotedThing {}-      -> WarningWithFlag Opt_WarnUntickedPromotedConstructors-    TcRnIllegalBuiltinSyntax {}-      -> ErrorWithoutFlag-    TcRnWarnDefaulting {}-      -> WarningWithFlag Opt_WarnTypeDefaults-    TcRnWarnClashingDefaultImports {}-      -> WarningWithFlag Opt_WarnTypeDefaults-    TcRnForeignImportPrimExtNotSet{}-      -> ErrorWithoutFlag-    TcRnForeignImportPrimSafeAnn{}-      -> ErrorWithoutFlag-    TcRnForeignFunctionImportAsValue{}-      -> ErrorWithoutFlag-    TcRnFunPtrImportWithoutAmpersand{}-      -> WarningWithFlag Opt_WarnDodgyForeignImports-    TcRnIllegalForeignDeclBackend{}-      -> ErrorWithoutFlag-    TcRnUnsupportedCallConv _ unsupportedCC-      -> case unsupportedCC of-           StdCallConvUnsupported -> WarningWithFlag Opt_WarnUnsupportedCallingConventions-           _ -> ErrorWithoutFlag-    TcRnIllegalForeignType{}-      -> ErrorWithoutFlag-    TcRnInvalidCIdentifier{}-      -> ErrorWithoutFlag-    TcRnExpectedValueId{}-      -> ErrorWithoutFlag-    TcRnRecSelectorEscapedTyVar{}-      -> ErrorWithoutFlag-    TcRnPatSynNotBidirectional{}-      -> ErrorWithoutFlag-    TcRnIllegalDerivingItem{}-      -> ErrorWithoutFlag-    TcRnIllegalDefaultClass{}-      -> ErrorWithoutFlag-    TcRnIllegalNamedDefault{}-      -> ErrorWithoutFlag-    TcRnUnexpectedAnnotation{}-      -> ErrorWithoutFlag-    TcRnIllegalRecordSyntax{}-      -> ErrorWithoutFlag-    TcRnInvalidVisibleKindArgument{}-      -> ErrorWithoutFlag-    TcRnTooManyBinders{}-      -> ErrorWithoutFlag-    TcRnDifferentNamesForTyVar{}-      -> ErrorWithoutFlag-    TcRnDisconnectedTyVar{}-      -> ErrorWithoutFlag-    TcRnInvalidReturnKind{}-      -> ErrorWithoutFlag-    TcRnClassKindNotConstraint{}-      -> ErrorWithoutFlag-    TcRnUnpromotableThing{}-      -> ErrorWithoutFlag-    TcRnIllegalTermLevelUse{}-      -> ErrorWithoutFlag-    TcRnMatchesHaveDiffNumArgs{}-      -> ErrorWithoutFlag-    TcRnCannotBindScopedTyVarInPatSig{}-      -> ErrorWithoutFlag-    TcRnCannotBindTyVarsInPatBind{}-      -> ErrorWithoutFlag-    TcRnTooManyTyArgsInConPattern{}-      -> ErrorWithoutFlag-    TcRnMultipleInlinePragmas{}-      -> WarningWithoutFlag-    TcRnUnexpectedPragmas{}-      -> WarningWithoutFlag-    TcRnNonOverloadedSpecialisePragma{}-      -> WarningWithoutFlag-    TcRnSpecialiseNotVisible{}-      -> WarningWithoutFlag-    TcRnPragmaWarning{pragma_warning_msg}-      -> WarningWithCategory (warningTxtCategory pragma_warning_msg)-    TcRnDifferentExportWarnings _ _-      -> ErrorWithoutFlag-    TcRnIncompleteExportWarnings _ _-      -> WarningWithFlag Opt_WarnIncompleteExportWarnings-    TcRnIllegalHsigDefaultMethods{}-      -> ErrorWithoutFlag-    TcRnHsigFixityMismatch{}-      -> ErrorWithoutFlag-    TcRnHsigShapeMismatch{}-      -> ErrorWithoutFlag-    TcRnHsigMissingModuleExport{}-      -> ErrorWithoutFlag-    TcRnBadGenericMethod{}-      -> ErrorWithoutFlag-    TcRnWarningMinimalDefIncomplete{}-      -> WarningWithoutFlag-    TcRnDefaultMethodForPragmaLacksBinding{}-      -> ErrorWithoutFlag-    TcRnIgnoreSpecialisePragmaOnDefMethod{}-      -> WarningWithoutFlag-    TcRnBadMethodErr{}-      -> ErrorWithoutFlag-    TcRnIllegalTypeData-      -> ErrorWithoutFlag-    TcRnIllegalQuasiQuotes{}-      -> ErrorWithoutFlag-    TcRnTHError err-      -> thErrorReason err-    TcRnTypeDataForbids{}-      -> ErrorWithoutFlag-    TcRnIllegalNewtype{}-      -> ErrorWithoutFlag-    TcRnOrPatBindsVariables{}-      -> ErrorWithoutFlag-    TcRnUnsatisfiedMinimalDef{}-      -> WarningWithFlag (Opt_WarnMissingMethods)-    TcRnMisplacedInstSig{}-      -> ErrorWithoutFlag-    TcRnNoRebindableSyntaxRecordDot{}-      -> ErrorWithoutFlag-    TcRnNoFieldPunsRecordDot{}-      -> ErrorWithoutFlag-    TcRnListComprehensionDuplicateBinding{}-      -> ErrorWithoutFlag-    TcRnEmptyStmtsGroup{}-      -> ErrorWithoutFlag-    TcRnLastStmtNotExpr{}-      -> ErrorWithoutFlag-    TcRnUnexpectedStatementInContext{}-      -> ErrorWithoutFlag-    TcRnSectionWithoutParentheses{}-      -> ErrorWithoutFlag-    TcRnIllegalImplicitParameterBindings{}-      -> ErrorWithoutFlag-    TcRnIllegalTupleSection{}-      -> ErrorWithoutFlag-    TcRnCapturedTermName{}-      -> WarningWithFlag Opt_WarnTermVariableCapture-    TcRnBindingOfExistingName{}-      -> ErrorWithoutFlag-    TcRnMultipleFixityDecls{}-      -> ErrorWithoutFlag-    TcRnIllegalPatternSynonymDecl{}-      -> ErrorWithoutFlag-    TcRnIllegalClassBinding{}-      -> ErrorWithoutFlag-    TcRnOrphanCompletePragma{}-      -> ErrorWithoutFlag-    TcRnEmptyCase{}-      -> ErrorWithoutFlag-    TcRnNonStdGuards{}-      -> WarningWithoutFlag-    TcRnDuplicateSigDecl{}-      -> ErrorWithoutFlag-    TcRnMisplacedSigDecl{}-      -> ErrorWithoutFlag-    TcRnUnexpectedDefaultSig{}-      -> ErrorWithoutFlag-    TcRnDuplicateMinimalSig{}-      -> ErrorWithoutFlag-    TcRnUnexpectedStandaloneDerivingDecl{}-      -> ErrorWithoutFlag-    TcRnUnusedVariableInRuleDecl{}-      -> ErrorWithoutFlag-    TcRnUnexpectedStandaloneKindSig{}-      -> ErrorWithoutFlag-    TcRnIllegalRuleLhs{}-      -> ErrorWithoutFlag-    TcRnDuplicateRoleAnnot{}-      -> ErrorWithoutFlag-    TcRnDuplicateKindSig{}-      -> ErrorWithoutFlag-    TcRnIllegalDerivStrategy{}-      -> ErrorWithoutFlag-    TcRnIllegalMultipleDerivClauses{}-      -> ErrorWithoutFlag-    TcRnNoDerivStratSpecified{}-      -> WarningWithFlag Opt_WarnMissingDerivingStrategies-    TcRnStupidThetaInGadt{}-      -> ErrorWithoutFlag-    TcRnShadowedTyVarNameInFamResult{}-      -> ErrorWithoutFlag-    TcRnIncorrectTyVarOnLhsOfInjCond{}-      -> ErrorWithoutFlag-    TcRnUnknownTyVarsOnRhsOfInjCond{}-      -> ErrorWithoutFlag-    TcRnBadlyStaged{}-      -> ErrorWithoutFlag-    TcRnBadlyStagedType{}-      -> WarningWithFlag Opt_WarnBadlyStagedTypes-    TcRnStageRestriction{}-      -> ErrorWithoutFlag-    TcRnTyThingUsedWrong{}-      -> ErrorWithoutFlag-    TcRnCannotDefaultKindVar{}-      -> ErrorWithoutFlag-    TcRnUninferrableTyVar{}-      -> ErrorWithoutFlag-    TcRnSkolemEscape{}-      -> ErrorWithoutFlag-    TcRnPatSynEscapedCoercion{}-      -> ErrorWithoutFlag-    TcRnPatSynExistentialInResult{}-      -> ErrorWithoutFlag-    TcRnPatSynArityMismatch{}-      -> ErrorWithoutFlag-    TcRnPatSynInvalidRhs{}-      -> ErrorWithoutFlag-    TcRnTyFamDepsDisabled{}-      -> ErrorWithoutFlag-    TcRnAbstractClosedTyFamDecl{}-      -> ErrorWithoutFlag-    TcRnPartialFieldSelector{}-      -> WarningWithFlag Opt_WarnPartialFields-    TcRnHasFieldResolvedIncomplete{}-      -> WarningWithFlag Opt_WarnIncompleteRecordSelectors-    TcRnBadFieldAnnotation _ _ LazyFieldsDisabled-      -> ErrorWithoutFlag-    TcRnBadFieldAnnotation{}-      -> WarningWithoutFlag-    TcRnSuperclassCycle{}-      -> ErrorWithoutFlag-    TcRnDefaultSigMismatch{}-      -> ErrorWithoutFlag-    TcRnTyFamsDisabled{}-      -> ErrorWithoutFlag-    TcRnBadTyConTelescope {}-      -> ErrorWithoutFlag-    TcRnTyFamResultDisabled{}-      -> ErrorWithoutFlag-    TcRnRoleValidationFailed{}-      -> ErrorWithoutFlag-    TcRnCommonFieldResultTypeMismatch{}-      -> ErrorWithoutFlag-    TcRnCommonFieldTypeMismatch{}-      -> ErrorWithoutFlag-    TcRnClassExtensionDisabled{}-      -> ErrorWithoutFlag-    TcRnDataConParentTypeMismatch{}-      -> ErrorWithoutFlag-    TcRnGADTsDisabled{}-      -> ErrorWithoutFlag-    TcRnExistentialQuantificationDisabled{}-      -> ErrorWithoutFlag-    TcRnGADTDataContext{}-      -> ErrorWithoutFlag-    TcRnMultipleConForNewtype{}-      -> ErrorWithoutFlag-    TcRnKindSignaturesDisabled{}-      -> ErrorWithoutFlag-    TcRnEmptyDataDeclsDisabled{}-      -> ErrorWithoutFlag-    TcRnRoleMismatch{}-      -> ErrorWithoutFlag-    TcRnRoleCountMismatch{}-      -> ErrorWithoutFlag-    TcRnIllegalRoleAnnotation{}-      -> ErrorWithoutFlag-    TcRnRoleAnnotationsDisabled{}-      -> ErrorWithoutFlag-    TcRnIncoherentRoles{}-      -> ErrorWithoutFlag-    TcRnUnexpectedKindVar{}-      -> ErrorWithoutFlag-    TcRnNegativeNumTypeLiteral{}-      -> ErrorWithoutFlag-    TcRnIllegalKind{}-      -> ErrorWithoutFlag-    TcRnPrecedenceParsingError{}-      -> ErrorWithoutFlag-    TcRnSectionPrecedenceError{}-      -> ErrorWithoutFlag-    TcRnUnexpectedPatSigType{}-      -> ErrorWithoutFlag-    TcRnIllegalKindSignature{}-      -> ErrorWithoutFlag-    TcRnUnusedQuantifiedTypeVar{}-      -> WarningWithFlag Opt_WarnUnusedForalls-    TcRnDataKindsError _ thing-      -- DataKinds errors can arise from either the renamer (Left) or the-      -- typechecker (Right). The latter category of DataKinds errors are a-      -- fairly recent addition to GHC (introduced in GHC 9.10), and in order-      -- to prevent these new errors from breaking users' code, we temporarily-      -- downgrade these errors to warnings. See Note [Checking for DataKinds]-      -- (Wrinkle: Migration story for DataKinds typechecker errors)-      -- in GHC.Tc.Validity.-      -> case thing of-           Left  _ -> ErrorWithoutFlag-           Right _ -> WarningWithFlag Opt_WarnDataKindsTC-    TcRnTypeSynonymCycle{}-      -> ErrorWithoutFlag-    TcRnZonkerMessage msg-      -> zonkerMessageReason msg-    TcRnInterfaceError err-      -> interfaceErrorReason err-    TcRnSelfImport{}-      -> ErrorWithoutFlag-    TcRnNoExplicitImportList{}-      -> WarningWithFlag Opt_WarnMissingImportList-    TcRnSafeImportsDisabled{}-      -> ErrorWithoutFlag-    TcRnDeprecatedModule _ txt-      -> WarningWithCategory (warningTxtCategory txt)-    TcRnRedundantSourceImport{}-      -> WarningWithoutFlag-    TcRnImportLookup{}-      -> ErrorWithoutFlag-    TcRnUnusedImport{}-      -> WarningWithFlag Opt_WarnUnusedImports-    TcRnDuplicateDecls{}-      -> ErrorWithoutFlag-    TcRnPackageImportsDisabled-      -> ErrorWithoutFlag-    TcRnIllegalDataCon{}-      -> ErrorWithoutFlag-    TcRnNestedForallsContexts{}-      -> ErrorWithoutFlag-    TcRnRedundantRecordWildcard-      -> WarningWithFlag Opt_WarnRedundantRecordWildcards-    TcRnUnusedRecordWildcard{}-      -> WarningWithFlag Opt_WarnUnusedRecordWildcards-    TcRnUnusedName _ prov-      -> WarningWithFlag $ case prov of-        UnusedNameTopDecl -> Opt_WarnUnusedTopBinds-        UnusedNameImported _ -> Opt_WarnUnusedTopBinds-        UnusedNameTypePattern -> Opt_WarnUnusedTypePatterns-        UnusedNameMatch -> Opt_WarnUnusedMatches-        UnusedNameLocalBind -> Opt_WarnUnusedLocalBinds-    TcRnQualifiedBinder{}-      -> ErrorWithoutFlag-    TcRnTypeApplicationsDisabled{}-      -> ErrorWithoutFlag-    TcRnInvalidRecordField{}-      -> ErrorWithoutFlag-    TcRnTupleTooLarge{}-      -> ErrorWithoutFlag-    TcRnCTupleTooLarge{}-      -> ErrorWithoutFlag-    TcRnIllegalInferredTyVars{}-      -> ErrorWithoutFlag-    TcRnAmbiguousName{}-      -> ErrorWithoutFlag-    TcRnBindingNameConflict{}-      -> ErrorWithoutFlag-    TcRnNonCanonicalDefinition (NonCanonicalMonoid _) _-      -> WarningWithFlag Opt_WarnNonCanonicalMonoidInstances-    TcRnNonCanonicalDefinition (NonCanonicalMonad _) _-      -> WarningWithFlag Opt_WarnNonCanonicalMonadInstances-    TcRnDefaultedExceptionContext{}-      -> WarningWithFlag Opt_WarnDefaultedExceptionContext-    TcRnImplicitImportOfPrelude {}-      -> WarningWithFlag Opt_WarnImplicitPrelude-    TcRnMissingMain {}-      -> ErrorWithoutFlag-    TcRnGhciUnliftedBind {}-      -> ErrorWithoutFlag-    TcRnGhciMonadLookupFail {}-      -> ErrorWithoutFlag-    TcRnMissingRoleAnnotation{}-      -> WarningWithFlag Opt_WarnMissingRoleAnnotations-    TcRnIllegalInvisTyVarBndr{}-      -> ErrorWithoutFlag-    TcRnIllegalWildcardTyVarBndr{}-      -> ErrorWithoutFlag-    TcRnDeprecatedInvisTyArgInConPat {}-      -> WarningWithFlag Opt_WarnDeprecatedTypeAbstractions-    TcRnInvalidInvisTyVarBndr{}-      -> ErrorWithoutFlag-    TcRnInvisBndrWithoutSig{}-      -> ErrorWithoutFlag-    TcRnImplicitRhsQuantification{}-      -> WarningWithFlag Opt_WarnImplicitRhsQuantification-    TcRnPatersonCondFailure{}-      -> ErrorWithoutFlag-    TcRnIllformedTypePattern{}-      -> ErrorWithoutFlag-    TcRnIllegalTypePattern{}-      -> ErrorWithoutFlag-    TcRnIllformedTypeArgument{}-      -> ErrorWithoutFlag-    TcRnIllegalTypeExpr{}-      -> ErrorWithoutFlag-    TcRnInvalidDefaultedTyVar{}-      -> ErrorWithoutFlag-    TcRnNamespacedWarningPragmaWithoutFlag{}-      -> ErrorWithoutFlag-    TcRnIllegalInvisibleTypePattern{}-      -> ErrorWithoutFlag-    TcRnInvisPatWithNoForAll{}-      -> ErrorWithoutFlag-    TcRnNamespacedFixitySigWithoutFlag{}-      -> ErrorWithoutFlag-    TcRnOutOfArityTyVar{}-      -> ErrorWithoutFlag-    TcRnMisplacedInvisPat{}-      -> ErrorWithoutFlag-    TcRnUnexpectedTypeSyntaxInTerms{}-      -> ErrorWithoutFlag--  diagnosticHints = \case-    TcRnUnknownMessage m-      -> diagnosticHints m-    TcRnMessageWithInfo _ msg_with_info-      -> case msg_with_info of-           TcRnMessageDetailed _ m -> diagnosticHints m-    TcRnWithHsDocContext _ msg-      -> diagnosticHints msg-    TcRnSolverReport (SolverReportWithCtxt ctxt msg) _-      -> tcSolverReportMsgHints ctxt msg-    TcRnSolverDepthError {}-      -> [SuggestIncreaseReductionDepth]-    TcRnRedundantConstraints{}-      -> noHints-    TcRnInaccessibleCode{}-      -> noHints-    TcRnInaccessibleCoAxBranch{}-      -> noHints-    TcRnTypeDoesNotHaveFixedRuntimeRep{}-      -> noHints-    TcRnImplicitLift{}-      -> noHints-    TcRnUnusedPatternBinds{}-      -> noHints-    TcRnDodgyImports{}-      -> noHints-    TcRnDodgyExports{}-      -> noHints-    TcRnMissingImportList{}-      -> noHints-    TcRnUnsafeDueToPlugin{}-      -> noHints-    TcRnModMissingRealSrcSpan{}-      -> noHints-    TcRnIdNotExportedFromModuleSig name mod-      -> [SuggestAddToHSigExportList name $ Just mod]-    TcRnIdNotExportedFromLocalSig name-      -> [SuggestAddToHSigExportList name Nothing]-    TcRnShadowedName{}-      -> noHints-    TcRnInvalidWarningCategory{}-      -> noHints-    TcRnDuplicateWarningDecls{}-      -> noHints-    TcRnSimplifierTooManyIterations{}-      -> [SuggestIncreaseSimplifierIterations]-    TcRnIllegalPatSynDecl{}-      -> noHints-    TcRnLinearPatSyn{}-      -> noHints-    TcRnEmptyRecordUpdate{}-      -> noHints-    TcRnIllegalFieldPunning{}-      -> [suggestExtension LangExt.NamedFieldPuns]-    TcRnIllegalWildcardsInRecord{}-      -> [suggestExtension LangExt.RecordWildCards]-    TcRnIllegalWildcardInType{}-      -> noHints-    TcRnIllegalNamedWildcardInTypeArgument{}-      -> [SuggestAnonymousWildcard]-    TcRnIllegalImplicitTyVarInTypeArgument tv-      -> [SuggestExplicitQuantification tv]-    TcRnDuplicateFieldName{}-      -> noHints-    TcRnIllegalViewPattern{}-      -> [suggestExtension LangExt.ViewPatterns]-    TcRnCharLiteralOutOfRange{}-      -> noHints-    TcRnIllegalWildcardsInConstructor{}-      -> noHints-    TcRnIgnoringAnnotations{}-      -> noHints-    TcRnAnnotationInSafeHaskell-      -> noHints-    TcRnInvalidTypeApplication{}-      -> noHints-    TcRnTagToEnumMissingValArg-      -> noHints-    TcRnTagToEnumUnspecifiedResTy{}-      -> noHints-    TcRnTagToEnumResTyNotAnEnum{}-      -> noHints-    TcRnTagToEnumResTyTypeData{}-      -> noHints-    TcRnArrowIfThenElsePredDependsOnResultTy-      -> noHints-    TcRnIllegalHsBootOrSigDecl {}-      -> noHints-    TcRnBootMismatch boot_or_sig err-      | Hsig <- boot_or_sig-      , BootMismatch _ _ (BootMismatchedTyCons _boot_tc real_tc tc_errs) <- err-      , any is_synAbsData_etaReduce (NE.toList tc_errs)-      -> [SuggestEtaReduceAbsDataTySyn real_tc]-      | otherwise-      -> noHints-      where-        is_synAbsData_etaReduce (SynAbstractData SynAbsDataTySynNotNullary) = True-        is_synAbsData_etaReduce _ = False-    TcRnRecursivePatternSynonym{}-      -> noHints-    TcRnPartialTypeSigTyVarMismatch{}-      -> noHints-    TcRnPartialTypeSigBadQuantifier{}-      -> noHints-    TcRnMissingSignature {}-      -> noHints-    TcRnPolymorphicBinderMissingSig{}-      -> noHints-    TcRnOverloadedSig{}-      -> noHints-    TcRnTupleConstraintInst{}-      -> noHints-    TcRnUserTypeError{}-      -> noHints-    TcRnConstraintInKind{}-      -> noHints-    TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum _-      -> [suggestExtension $ unboxedTupleOrSumExtension tuple_or_sum]-    TcRnLinearFuncInKind{}-      -> noHints-    TcRnForAllEscapeError{}-      -> noHints-    TcRnVDQInTermType mb_ty-      | isJust mb_ty -> [suggestExtension LangExt.RequiredTypeArguments]-      | otherwise    -> []-    TcRnBadQuantPredHead{}-      -> noHints-    TcRnIllegalTupleConstraint{}-      -> [suggestExtension LangExt.ConstraintKinds]-    TcRnNonTypeVarArgInConstraint{}-      -> [suggestExtension LangExt.FlexibleContexts]-    TcRnIllegalImplicitParam{}-      -> noHints-    TcRnIllegalConstraintSynonymOfKind{}-      -> [suggestExtension LangExt.ConstraintKinds]-    TcRnOversaturatedVisibleKindArg{}-      -> noHints-    TcRnForAllRankErr rank _-      -> case rank of-           LimitedRank{}      -> [suggestExtension LangExt.RankNTypes]-           MonoTypeRankZero   -> [suggestExtension LangExt.RankNTypes]-           MonoTypeTyConArg   -> [suggestExtension LangExt.ImpredicativeTypes]-           MonoTypeSynArg     -> [suggestExtension LangExt.LiberalTypeSynonyms]-           MonoTypeConstraint -> [suggestExtension LangExt.QuantifiedConstraints]-           _                  -> noHints-    TcRnSimplifiableConstraint{}-      -> noHints-    TcRnArityMismatch{}-      -> noHints-    TcRnIllegalInstance rea-      -> illegalInstanceHints rea-    TcRnMonomorphicBindings bindings-      -> case bindings of-          []     -> noHints-          (x:xs) -> [SuggestAddTypeSignatures $ NamedBindings (x NE.:| xs)]-    TcRnOrphanInstance clsOrFamInst-      -> [SuggestFixOrphanInst { isFamilyInstance = isFam }]-        where-          isFam = case clsOrFamInst :: Either ClsInst FamInst of-            Left  _clsInst -> Nothing-            Right famInst  -> Just $ fi_flavor famInst-    TcRnFunDepConflict{}-      -> noHints-    TcRnDupInstanceDecls{}-      -> noHints-    TcRnConflictingFamInstDecls{}-      -> noHints-    TcRnFamInstNotInjective rea _ _-      -> case rea of-           InjErrRhsBareTyVar{}      -> noHints-           InjErrRhsCannotBeATypeFam -> noHints-           InjErrRhsOverlap          -> noHints-           InjErrCannotInferFromRhs _ _ suggestUndInst-             | YesSuggestUndecidableInstaces <- suggestUndInst-             -> [suggestExtension LangExt.UndecidableInstances]-             | otherwise-             -> noHints-    TcRnBangOnUnliftedType{}-      -> noHints-    TcRnLazyBangOnUnliftedType{}-      -> noHints-    TcRnMultipleDefaultDeclarations{}-      -> noHints-    TcRnBadDefaultType{}-      -> noHints-    TcRnPatSynBundledWithNonDataCon{}-      -> noHints-    TcRnPatSynBundledWithWrongType{}-      -> noHints-    TcRnDupeModuleExport{}-      -> noHints-    TcRnExportedModNotImported{}-      -> noHints-    TcRnNullExportedModule{}-      -> noHints-    TcRnMissingExportList{}-      -> noHints-    TcRnExportHiddenComponents{}-      -> noHints-    TcRnExportHiddenDefault{}-      -> noHints-    TcRnDuplicateExport{}-      -> noHints-    TcRnExportedParentChildMismatch{}-      -> noHints-    TcRnConflictingExports{}-      -> noHints-    TcRnDuplicateFieldExport {}-      -> [suggestExtension LangExt.DuplicateRecordFields]-    TcRnAmbiguousFieldInUpdate {}-      -> [suggestExtension LangExt.DisambiguateRecordFields]-    TcRnAmbiguousRecordUpdate{}-      -> noHints-    TcRnMissingFields{}-      -> noHints-    TcRnFieldUpdateInvalidType{}-      -> noHints-    TcRnMissingStrictFields{}-      -> noHints-    TcRnBadRecordUpdate{}-      -> noHints-    TcRnIllegalStaticExpression {}-      -> [suggestExtension LangExt.StaticPointers]-    TcRnStaticFormNotClosed{}-      -> noHints-    TcRnUselessTypeable-      -> noHints-    TcRnDerivingDefaults{}-      -> [useDerivingStrategies]-    TcRnNonUnaryTypeclassConstraint{}-      -> noHints-    TcRnPartialTypeSignatures suggestParSig _-      -> case suggestParSig of-           YesSuggestPartialTypeSignatures-             -> let info = text "to use the inferred type"-                in [suggestExtensionWithInfo info LangExt.PartialTypeSignatures]-           NoSuggestPartialTypeSignatures-             -> noHints-    TcRnCannotDeriveInstance cls _ _ newtype_deriving rea-      -> deriveInstanceErrReasonHints cls newtype_deriving rea-    TcRnLookupInstance _ _ _-      -> noHints-    TcRnLazyGADTPattern-      -> noHints-    TcRnArrowProcGADTPattern-      -> noHints-    TcRnTypeEqualityOutOfScope-      -> noHints-    TcRnTypeEqualityRequiresOperators-      -> [suggestExtension LangExt.TypeOperators]-    TcRnIllegalTypeOperator {}-      -> [suggestExtension LangExt.TypeOperators]-    TcRnIllegalTypeOperatorDecl {}-      -> [suggestExtension LangExt.TypeOperators]-    TcRnGADTMonoLocalBinds {}-      -> [suggestAnyExtension [LangExt.GADTs, LangExt.TypeFamilies]]-    TcRnIncorrectNameSpace nm is_th_use-      | is_th_use-      -> [SuggestAppropriateTHTick $ nameNameSpace nm]-      | otherwise-      -> noHints-    TcRnNotInScope err _ _ hints-      -> scopeErrorHints err ++ hints-    TcRnTermNameInType _ hints-      -> hints-    TcRnUntickedPromotedThing thing-      -> [SuggestAddTick thing]-    TcRnIllegalBuiltinSyntax {}-      -> noHints-    TcRnWarnDefaulting {}-      -> noHints-    TcRnWarnClashingDefaultImports cls local imports-      -> suggestDefaultDeclaration cls (fold local) (cd_types <$> NE.toList imports)-    TcRnForeignImportPrimExtNotSet{}-      -> [suggestExtension LangExt.GHCForeignImportPrim]-    TcRnForeignImportPrimSafeAnn{}-      -> noHints-    TcRnForeignFunctionImportAsValue{}-      -> noHints-    TcRnFunPtrImportWithoutAmpersand{}-      -> noHints-    TcRnIllegalForeignDeclBackend{}-      -> noHints-    TcRnUnsupportedCallConv{}-      -> noHints-    TcRnIllegalForeignType _ reason-      -> case reason of-           TypeCannotBeMarshaled _ why-             | NewtypeDataConNotInScope tc _ <- why-             -> let tc_nm = tyConName tc-                    dc = dataConName $ head $ tyConDataCons tc-                in [ ImportSuggestion (occName dc)-                   $ ImportDataCon Nothing (nameOccName tc_nm) ]-             | UnliftedFFITypesNeeded <- why-             -> [suggestExtension LangExt.UnliftedFFITypes]-           _ -> noHints-    TcRnInvalidCIdentifier{}-      -> noHints-    TcRnExpectedValueId{}-      -> noHints-    TcRnRecSelectorEscapedTyVar{}-      -> [SuggestPatternMatchingSyntax]-    TcRnPatSynNotBidirectional{}-      -> noHints-    TcRnIllegalDerivingItem{}-      -> noHints-    TcRnIllegalDefaultClass{}-      -> noHints-    TcRnIllegalNamedDefault{}-      -> [suggestExtension LangExt.NamedDefaults]-    TcRnUnexpectedAnnotation{}-      -> noHints-    TcRnIllegalRecordSyntax{}-      -> noHints-    TcRnInvalidVisibleKindArgument{}-      -> noHints-    TcRnTooManyBinders{}-      -> noHints-    TcRnDifferentNamesForTyVar{}-      -> noHints-    TcRnDisconnectedTyVar n-      -> [SuggestBindTyVarExplicitly n]-    TcRnInvalidReturnKind _ _ _ mb_suggest_unlifted_ext-      -> case mb_suggest_unlifted_ext of-           Nothing -> noHints-           Just SuggestUnliftedNewtypes -> [suggestExtension LangExt.UnliftedNewtypes]-           Just SuggestUnliftedDatatypes -> [suggestExtension LangExt.UnliftedDatatypes]-    TcRnClassKindNotConstraint{}-      -> noHints-    TcRnUnpromotableThing{}-      -> noHints-    TcRnIllegalTermLevelUse{}-      -> noHints-    TcRnMatchesHaveDiffNumArgs{}-      -> noHints-    TcRnCannotBindScopedTyVarInPatSig{}-      -> noHints-    TcRnCannotBindTyVarsInPatBind{}-      -> noHints-    TcRnTooManyTyArgsInConPattern{}-      -> noHints-    TcRnMultipleInlinePragmas{}-      -> noHints-    TcRnUnexpectedPragmas{}-      -> noHints-    TcRnNonOverloadedSpecialisePragma{}-      -> noHints-    TcRnSpecialiseNotVisible name-      -> [SuggestSpecialiseVisibilityHints name]-    TcRnPragmaWarning{}-      -> noHints-    TcRnDifferentExportWarnings _ _-      -> noHints-    TcRnIncompleteExportWarnings _ _-      -> noHints-    TcRnIllegalHsigDefaultMethods{}-      -> noHints-    TcRnIllegalQuasiQuotes{}-      -> [suggestExtension LangExt.QuasiQuotes]-    TcRnTHError err-      -> thErrorHints err-    TcRnHsigFixityMismatch{}-      -> noHints-    TcRnHsigShapeMismatch{}-      -> noHints-    TcRnHsigMissingModuleExport{}-      -> noHints-    TcRnBadGenericMethod{}-      -> noHints-    TcRnWarningMinimalDefIncomplete{}-      -> noHints-    TcRnDefaultMethodForPragmaLacksBinding{}-      -> noHints-    TcRnIgnoreSpecialisePragmaOnDefMethod{}-      -> noHints-    TcRnBadMethodErr{}-      -> noHints-    TcRnIllegalTypeData-      -> [suggestExtension LangExt.TypeData]-    TcRnTypeDataForbids{}-      -> noHints-    TcRnIllegalNewtype{}-      -> noHints-    TcRnOrPatBindsVariables{}-      -> noHints-    TcRnUnsatisfiedMinimalDef{}-      -> noHints-    TcRnMisplacedInstSig{}-      -> [suggestExtension LangExt.InstanceSigs]-    TcRnNoRebindableSyntaxRecordDot{}-      -> noHints-    TcRnNoFieldPunsRecordDot{}-      -> noHints-    TcRnListComprehensionDuplicateBinding{}-      -> noHints-    TcRnEmptyStmtsGroup EmptyStmtsGroupInDoNotation{}-      -> [suggestExtension LangExt.NondecreasingIndentation]-    TcRnEmptyStmtsGroup{}-      -> noHints-    TcRnLastStmtNotExpr{}-      -> noHints-    TcRnUnexpectedStatementInContext _ _ mExt-      | Nothing <- mExt -> noHints-      | Just ext <- mExt -> [suggestExtension ext]-    TcRnSectionWithoutParentheses{}-      -> noHints-    TcRnIllegalImplicitParameterBindings{}-      -> noHints-    TcRnIllegalTupleSection{}-      -> [suggestExtension LangExt.TupleSections]-    TcRnCapturedTermName{}-      -> [SuggestRenameTypeVariable]-    TcRnBindingOfExistingName{}-      -> noHints-    TcRnMultipleFixityDecls{}-      -> noHints-    TcRnIllegalPatternSynonymDecl{}-      -> [suggestExtension LangExt.PatternSynonyms]-    TcRnIllegalClassBinding{}-      -> noHints-    TcRnOrphanCompletePragma{}-      -> noHints-    TcRnEmptyCase _ reason ->-      case reason of-        EmptyCaseWithoutFlag{}    -> [suggestExtension LangExt.EmptyCase]-        EmptyCaseDisallowedCtxt{} -> noHints-        EmptyCaseForall{}         -> noHints-    TcRnNonStdGuards{}-      -> [suggestExtension LangExt.PatternGuards]-    TcRnDuplicateSigDecl{}-      -> noHints-    TcRnMisplacedSigDecl{}-      -> noHints-    TcRnUnexpectedDefaultSig{}-      -> [suggestExtension LangExt.DefaultSignatures]-    TcRnDuplicateMinimalSig{}-      -> noHints-    TcRnUnexpectedStandaloneDerivingDecl{}-      -> [suggestExtension LangExt.StandaloneDeriving]-    TcRnUnusedVariableInRuleDecl{}-      -> noHints-    TcRnUnexpectedStandaloneKindSig{}-      -> [suggestExtension LangExt.StandaloneKindSignatures]-    TcRnIllegalRuleLhs{}-      -> noHints-    TcRnDuplicateRoleAnnot{}-      -> noHints-    TcRnDuplicateKindSig{}-      -> noHints-    TcRnIllegalDerivStrategy ds -> case ds of-      ViaStrategy{} -> [suggestExtension LangExt.DerivingVia]-      _ -> [suggestExtension LangExt.DerivingStrategies]-    TcRnIllegalMultipleDerivClauses{}-      -> [suggestExtension LangExt.DerivingStrategies]-    TcRnNoDerivStratSpecified is_ds_enabled info -> do-      let explicit_strategy_hint = case info of-            TcRnNoDerivingClauseStrategySpecified assumed_derivings ->-              SuggestExplicitDerivingClauseStrategies assumed_derivings-            TcRnNoStandaloneDerivingStrategySpecified assumed_strategy deriv_sig ->-              SuggestExplicitStandaloneDerivingStrategy assumed_strategy deriv_sig-      explicit_strategy_hint : [suggestExtension LangExt.DerivingStrategies | not is_ds_enabled]-    TcRnStupidThetaInGadt{}-      -> noHints-    TcRnShadowedTyVarNameInFamResult{}-      -> noHints-    TcRnIncorrectTyVarOnLhsOfInjCond{}-      -> noHints-    TcRnUnknownTyVarsOnRhsOfInjCond{}-      -> noHints-    TcRnBadlyStaged{}-      -> noHints-    TcRnBadlyStagedType{}-      -> noHints-    TcRnStageRestriction{}-      -> noHints-    TcRnTyThingUsedWrong{}-      -> noHints-    TcRnCannotDefaultKindVar{}-      -> noHints-    TcRnUninferrableTyVar{}-      -> noHints-    TcRnSkolemEscape{}-      -> noHints-    TcRnPatSynEscapedCoercion{}-      -> noHints-    TcRnPatSynExistentialInResult{}-      -> noHints-    TcRnPatSynArityMismatch{}-      -> noHints-    TcRnPatSynInvalidRhs name pat args (PatSynNotInvertible _)-      -> [SuggestExplicitBidiPatSyn name pat args]-    TcRnPatSynInvalidRhs{}-      -> noHints-    TcRnTyFamDepsDisabled{}-      -> [suggestExtension LangExt.TypeFamilyDependencies]-    TcRnAbstractClosedTyFamDecl{}-      -> noHints-    TcRnPartialFieldSelector{}-      -> noHints-    TcRnHasFieldResolvedIncomplete{}-      -> noHints-    TcRnBadFieldAnnotation _ _ LazyFieldsDisabled-      -> [suggestExtension LangExt.StrictData]-    TcRnBadFieldAnnotation{}-      -> noHints-    TcRnSuperclassCycle{}-      -> [suggestExtension LangExt.UndecidableSuperClasses]-    TcRnDefaultSigMismatch{}-      -> noHints-    TcRnTyFamsDisabled{}-      -> [suggestExtension LangExt.TypeFamilies]-    TcRnBadTyConTelescope{}-      -> noHints-    TcRnTyFamResultDisabled{}-      -> [suggestExtension LangExt.TypeFamilyDependencies]-    TcRnRoleValidationFailed{}-      -> noHints-    TcRnCommonFieldResultTypeMismatch{}-      -> noHints-    TcRnCommonFieldTypeMismatch{}-      -> noHints-    TcRnClassExtensionDisabled _ MultiParamDisabled{}-      -> [suggestExtension LangExt.MultiParamTypeClasses]-    TcRnClassExtensionDisabled _ FunDepsDisabled{}-      -> [suggestExtension LangExt.FunctionalDependencies]-    TcRnClassExtensionDisabled _ ConstrainedClassMethodsDisabled{}-      -> [suggestExtension LangExt.ConstrainedClassMethods]-    TcRnDataConParentTypeMismatch{}-      -> noHints-    TcRnGADTsDisabled{}-      -> [suggestExtension LangExt.GADTs]-    TcRnExistentialQuantificationDisabled{}-      -> [suggestAnyExtension [LangExt.ExistentialQuantification, LangExt.GADTs]]-    TcRnGADTDataContext{}-      -> noHints-    TcRnMultipleConForNewtype{}-      -> noHints-    TcRnKindSignaturesDisabled{}-      -> [suggestExtension LangExt.KindSignatures]-    TcRnEmptyDataDeclsDisabled{}-      -> [suggestExtension LangExt.EmptyDataDecls]-    TcRnRoleMismatch{}-      -> noHints-    TcRnRoleCountMismatch{}-      -> noHints-    TcRnIllegalRoleAnnotation{}-      -> noHints-    TcRnRoleAnnotationsDisabled{}-      -> [suggestExtension LangExt.RoleAnnotations]-    TcRnIncoherentRoles{}-      -> [suggestExtension LangExt.IncoherentInstances]-    TcRnUnexpectedKindVar{}-      -> [suggestExtension LangExt.PolyKinds]-    TcRnNegativeNumTypeLiteral{}-      -> noHints-    TcRnIllegalKind _ suggest_polyKinds-      -> if suggest_polyKinds-         then [suggestExtension LangExt.PolyKinds]-         else noHints-    TcRnPrecedenceParsingError{}-      -> noHints-    TcRnSectionPrecedenceError{}-      -> noHints-    TcRnUnexpectedPatSigType{}-      -> [suggestExtension LangExt.ScopedTypeVariables]-    TcRnIllegalKindSignature{}-      -> [suggestExtension LangExt.KindSignatures]-    TcRnUnusedQuantifiedTypeVar{}-      -> noHints-    TcRnDataKindsError{}-      -> [suggestExtension LangExt.DataKinds]-    TcRnTypeSynonymCycle{}-      -> noHints-    TcRnZonkerMessage msg-      -> zonkerMessageHints msg-    TcRnInterfaceError reason-      -> interfaceErrorHints reason-    TcRnSelfImport{}-      -> noHints-    TcRnNoExplicitImportList{}-      -> noHints-    TcRnSafeImportsDisabled{}-      -> [SuggestSafeHaskell]-    TcRnDeprecatedModule{}-      -> noHints-    TcRnRedundantSourceImport{}-      -> noHints-    TcRnImportLookup (ImportLookupBad k _ is ie patsyns_enabled) ->-      let mod_name = moduleName $ is_mod is-          occ = rdrNameOcc $ ieName ie-      in case k of-        BadImportAvailVar          -> [ImportSuggestion occ $ CouldRemoveTypeKeyword mod_name]-        BadImportNotExported suggs -> suggs-        BadImportAvailTyCon ex_ns  ->-          [useExtensionInOrderTo empty LangExt.ExplicitNamespaces | not ex_ns]-          ++ [ImportSuggestion occ $ CouldAddTypeKeyword mod_name]-        BadImportAvailDataCon par  -> [ImportSuggestion occ $ ImportDataCon (Just (mod_name, patsyns_enabled)) par]-        BadImportNotExportedSubordinates{} -> noHints-    TcRnImportLookup{}-      -> noHints-    TcRnUnusedImport{}-      -> noHints-    TcRnDuplicateDecls{}-      -> noHints-    TcRnPackageImportsDisabled-      -> [suggestExtension LangExt.PackageImports]-    TcRnIllegalDataCon{}-      -> noHints-    TcRnNestedForallsContexts{}-      -> noHints-    TcRnRedundantRecordWildcard-      -> [SuggestRemoveRecordWildcard]-    TcRnUnusedRecordWildcard{}-      -> [SuggestRemoveRecordWildcard]-    TcRnUnusedName{}-      -> noHints-    TcRnQualifiedBinder{}-      -> noHints-    TcRnTypeApplicationsDisabled ty_app-      -> case ty_app of-          TypeApplication {}-            -> [suggestExtension LangExt.TypeApplications]-          TypeApplicationInPattern {}-            -> [suggestExtension LangExt.TypeAbstractions]-    TcRnInvalidRecordField{}-      -> noHints-    TcRnTupleTooLarge{}-      -> noHints-    TcRnCTupleTooLarge{}-      -> noHints-    TcRnIllegalInferredTyVars{}-      -> noHints-    TcRnAmbiguousName{}-      -> noHints-    TcRnBindingNameConflict{}-      -> noHints-    TcRnNonCanonicalDefinition reason _-      -> suggestNonCanonicalDefinition reason-    TcRnDefaultedExceptionContext _-      -> noHints-    TcRnImplicitImportOfPrelude {}-      -> noHints-    TcRnMissingMain {}-      -> noHints-    TcRnGhciUnliftedBind {}-      -> noHints-    TcRnGhciMonadLookupFail {}-      -> noHints-    TcRnMissingRoleAnnotation{}-      -> noHints-    TcRnIllegalInvisTyVarBndr{}-      -> [suggestExtension LangExt.TypeAbstractions]-    TcRnIllegalWildcardTyVarBndr{}-      -> [suggestExtension LangExt.TypeAbstractions]-    TcRnDeprecatedInvisTyArgInConPat{}-      -> [suggestExtension LangExt.TypeAbstractions]-    TcRnInvalidInvisTyVarBndr{}-      -> noHints-    TcRnInvisBndrWithoutSig name _-      -> [SuggestAddStandaloneKindSignature name]-    TcRnImplicitRhsQuantification kv-      -> [SuggestBindTyVarOnLhs (unLoc kv)]-    TcRnPatersonCondFailure{}-      -> [suggestExtension LangExt.UndecidableInstances]-    TcRnIllformedTypePattern{}-      -> noHints-    TcRnIllegalTypePattern{}-      -> noHints-    TcRnIllformedTypeArgument{}-      -> noHints-    TcRnIllegalTypeExpr{}-      -> noHints-    TcRnInvalidDefaultedTyVar{}-      -> noHints-    TcRnNamespacedWarningPragmaWithoutFlag{}-      -> [suggestExtension LangExt.ExplicitNamespaces]-    TcRnIllegalInvisibleTypePattern{}-      -> [suggestExtension LangExt.TypeAbstractions]-    TcRnInvisPatWithNoForAll{}-      -> noHints-    TcRnNamespacedFixitySigWithoutFlag{}-      -> [suggestExtension LangExt.ExplicitNamespaces]-    TcRnOutOfArityTyVar{}-      -> noHints-    TcRnMisplacedInvisPat{}-      -> noHints-    TcRnUnexpectedTypeSyntaxInTerms syntax-      -> [suggestExtension (typeSyntaxExtension syntax)]--  diagnosticCode = constructorCode---note :: SDoc -> SDoc-note note = "Note" <> colon <+> note <> dot---- | 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]-commafyWith _ [] = []-commafyWith _ [x] = [x]-commafyWith conjunction [x, y] = [x <+> conjunction <+> y]-commafyWith conjunction xs = addConjunction $ punctuate comma xs-    where addConjunction [x, y] = [x, conjunction, y]-          addConjunction (x : xs) = x : addConjunction xs-          addConjunction _ = panic "commafyWith expected 2 or more elements"--deriveInstanceErrReasonHints :: Class-                             -> UsingGeneralizedNewtypeDeriving-                             -> DeriveInstanceErrReason-                             -> [GhcHint]-deriveInstanceErrReasonHints cls newtype_deriving = \case-  DerivErrNotWellKinded _ _ n_args_to_keep-    | cls `hasKey` gen1ClassKey && n_args_to_keep >= 0-    -> [suggestExtension LangExt.PolyKinds]-    | otherwise-    -> noHints-  DerivErrSafeHaskellGenericInst  -> noHints-  DerivErrDerivingViaWrongKind{}  -> noHints-  DerivErrNoEtaReduce{}           -> noHints-  DerivErrBootFileFound           -> noHints-  DerivErrDataConsNotAllInScope{} -> noHints-  DerivErrGNDUsedOnData           -> noHints-  DerivErrNullaryClasses          -> noHints-  DerivErrLastArgMustBeApp        -> noHints-  DerivErrNoFamilyInstance{}      -> noHints-  DerivErrNotStockDeriveable deriveAnyClassEnabled-    | deriveAnyClassEnabled == NoDeriveAnyClassEnabled-    -> [suggestExtension LangExt.DeriveAnyClass]-    | otherwise-    -> noHints-  DerivErrHasAssociatedDatatypes{}-    -> noHints-  DerivErrNewtypeNonDeriveableClass-    | newtype_deriving == NoGeneralizedNewtypeDeriving-    -> [useGND]-    | otherwise-    -> noHints-  DerivErrCannotEtaReduceEnough{}-    | newtype_deriving == NoGeneralizedNewtypeDeriving-    -> [useGND]-    | otherwise-    -> noHints-  DerivErrOnlyAnyClassDeriveable _ deriveAnyClassEnabled-    | deriveAnyClassEnabled == NoDeriveAnyClassEnabled-    -> [suggestExtension LangExt.DeriveAnyClass]-    | otherwise-    -> noHints-  DerivErrNotDeriveable deriveAnyClassEnabled-    | deriveAnyClassEnabled == NoDeriveAnyClassEnabled-    -> [suggestExtension LangExt.DeriveAnyClass]-    | otherwise-    -> noHints-  DerivErrNotAClass{}-    -> noHints-  DerivErrNoConstructors{}-    -> let info = text "to enable deriving for empty data types"-       in [useExtensionInOrderTo info LangExt.EmptyDataDeriving]-  DerivErrLangExtRequired{}-    -- This is a slightly weird corner case of GHC: we are failing-    -- to derive a typeclass instance because a particular 'Extension'-    -- is not enabled (and so we report in the main error), but here-    -- we don't want to /repeat/ to enable the extension in the hint.-    -> noHints-  DerivErrDunnoHowToDeriveForType{}-    -> noHints-  DerivErrMustBeEnumType rep_tc-    -- We want to suggest GND only if this /is/ a newtype.-    | newtype_deriving == NoGeneralizedNewtypeDeriving && isNewTyCon rep_tc-    -> [useGND]-    | otherwise-    -> noHints-  DerivErrMustHaveExactlyOneConstructor{}-    -> noHints-  DerivErrMustHaveSomeParameters{}-    -> noHints-  DerivErrMustNotHaveClassContext{}-    -> noHints-  DerivErrBadConstructor wcard _-    -> case wcard of-         Nothing        -> noHints-         Just YesHasWildcard -> [SuggestFillInWildcardConstraint]-         Just NoHasWildcard  -> [SuggestAddStandaloneDerivation]-  DerivErrGenerics{}-    -> noHints-  DerivErrEnumOrProduct{}-    -> noHints--messageWithInfoDiagnosticMessage :: UnitState-                                 -> ErrInfo-                                 -> Bool-                                 -> DecoratedSDoc-                                 -> DecoratedSDoc-messageWithInfoDiagnosticMessage unit_state ErrInfo{..} show_ctxt important =-  let err_info' = map (pprWithUnitState unit_state) ([errInfoContext | show_ctxt] ++ [errInfoSupplementary])-      in (mapDecoratedSDoc (pprWithUnitState unit_state) important) `unionDecoratedSDoc`-         mkDecorated err_info'--messageWithHsDocContext :: TcRnMessageOpts -> HsDocContext -> DecoratedSDoc -> DecoratedSDoc-messageWithHsDocContext opts ctxt main_msg = do-      if tcOptsShowContext opts-         then main_msg `unionDecoratedSDoc` ctxt_msg-         else main_msg-      where-        ctxt_msg = mkSimpleDecorated (inHsDocContext ctxt)--dodgy_msg :: Outputable ie => SDoc -> GlobalRdrElt -> ie -> SDoc-dodgy_msg kind tc ie-  = vcat [ text "The" <+> kind <+> text "item" <+> quotes (ppr ie) <+> text "suggests that"-         , quotes (ppr $ greName tc) <+> text "has" <+> sep rest ]-  where-    rest :: [SDoc]-    rest =-      case greInfo tc of-        IAmTyCon ClassFlavour-          -> [ text "(in-scope) class methods or associated types" <> comma-             , text "but it has none" ]-        IAmTyCon _-          -> [ text "(in-scope) constructors or record fields" <> comma-             , text "but it has none" ]-        _ -> [ text "children" <> comma-             , text "but it is not a type constructor or a class" ]--dodgy_msg_insert :: GlobalRdrElt -> IE GhcRn-dodgy_msg_insert tc_gre = IEThingAll (Nothing, noAnn) ii Nothing-  where-    ii = noLocA (IEName noExtField $ noLocA $ greName tc_gre)--pprTypeDoesNotHaveFixedRuntimeRep :: Type -> FixedRuntimeRepProvenance -> SDoc-pprTypeDoesNotHaveFixedRuntimeRep ty prov =-  let what = pprFixedRuntimeRepProvenance prov-  in text "The" <+> what <+> text "does not have a fixed runtime representation:"-  $$ format_frr_err ty--format_frr_err :: Type  -- ^ the type which doesn't have a fixed runtime representation-                -> SDoc-format_frr_err ty-  = (bullet <+> ppr tidy_ty <+> dcolon <+> ppr tidy_ki)-  where-    (tidy_env, tidy_ty) = tidyOpenTypeX emptyTidyEnv ty-    tidy_ki             = tidyType tidy_env (typeKind ty)--pprField :: (FieldLabelString, TcType) -> SDoc-pprField (f,ty) = ppr f <+> dcolon <+> ppr ty--pprRecordFieldPart :: RecordFieldPart -> SDoc-pprRecordFieldPart = \case-  RecordFieldDecl {}       -> text "declaration"-  RecordFieldConstructor{} -> text "construction"-  RecordFieldPattern{}     -> text "pattern"-  RecordFieldUpdate        -> text "update"--ppr_opfix :: (OpName, Fixity) -> SDoc-ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)-   where-     pp_op | NegateOp <- op = text "prefix `-'"-           | otherwise      = quotes (ppr op)--pprBindings :: [Name] -> SDoc-pprBindings = pprWithCommas (quotes . ppr)---injectivityErrorHerald :: SDoc-injectivityErrorHerald =-  text "Type family equation violates the family's injectivity annotation."--formatExportItemError :: SDoc -> String -> SDoc-formatExportItemError exportedThing reason =-  hsep [ text "The export item"-       , quotes exportedThing-       , text reason ]---- | What warning flags are associated with the given missing signature?-missingSignatureWarningFlags :: MissingSignature -> Exported -> NonEmpty WarningFlag-missingSignatureWarningFlags (MissingTopLevelBindingSig {}) exported-  -- We prefer "bigger" warnings first: #14794-  ---  -- See Note [Warnings controlled by multiple flags]-  = Opt_WarnMissingSignatures :|-    [ Opt_WarnMissingExportedSignatures | IsExported == exported ]-missingSignatureWarningFlags (MissingPatSynSig {}) exported-  = Opt_WarnMissingPatternSynonymSignatures :|-    [ Opt_WarnMissingExportedPatternSynonymSignatures | IsExported  == exported ]-missingSignatureWarningFlags (MissingTyConKindSig ty_con _) _-  = Opt_WarnMissingKindSignatures :| [Opt_WarnMissingPolyKindSignatures | isForAllTy_invis_ty (tyConKind ty_con) ]--useDerivingStrategies :: GhcHint-useDerivingStrategies =-  useExtensionInOrderTo (text "to pick a different strategy") LangExt.DerivingStrategies--useGND :: GhcHint-useGND = let info = text "for GHC's" <+> text "newtype-deriving extension"-         in suggestExtensionWithInfo info LangExt.GeneralizedNewtypeDeriving--cannotMakeDerivedInstanceHerald :: Class-                                -> [Type]-                                -> Maybe (DerivStrategy GhcTc)-                                -> UsingGeneralizedNewtypeDeriving-                                -> Bool -- ^ If False, only prints the why.-                                -> SDoc-                                -> SDoc-cannotMakeDerivedInstanceHerald cls cls_args mb_strat newtype_deriving pprHerald why =-  if pprHerald-     then sep [(hang (text "Can't make a derived instance of")-                   2 (quotes (ppr pred) <+> via_mechanism)-                $$ nest 2 extra) <> colon,-               nest 2 why]-      else why-  where-    strat_used = isJust mb_strat-    extra | not strat_used, (newtype_deriving == YesGeneralizedNewtypeDeriving)-          = text "(even with cunning GeneralizedNewtypeDeriving)"-          | otherwise = empty-    pred = mkClassPred cls cls_args-    via_mechanism | strat_used-                  , Just strat <- mb_strat-                  = text "with the" <+> (derivStrategyName strat) <+> text "strategy"-                  | otherwise-                  = empty--badCon :: DataCon -> SDoc -> SDoc-badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg--derivErrDiagnosticMessage :: Class-                          -> [Type]-                          -> Maybe (DerivStrategy GhcTc)-                          -> UsingGeneralizedNewtypeDeriving-                          -> Bool -- If True, includes the herald \"can't make a derived..\"-                          -> DeriveInstanceErrReason-                          -> SDoc-derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald = \case-  DerivErrNotWellKinded tc cls_kind _-    -> sep [ hang (text "Cannot derive well-kinded instance of form"-                         <+> quotes (pprClassPred cls cls_tys-                                       <+> parens (ppr tc <+> text "...")))-                  2 empty-           , nest 2 (text "Class" <+> quotes (ppr cls)-                         <+> text "expects an argument of kind"-                         <+> quotes (pprKind cls_kind))-           ]-  DerivErrSafeHaskellGenericInst-    ->     text "Generic instances can only be derived in"-       <+> text "Safe Haskell using the stock strategy."-  DerivErrDerivingViaWrongKind cls_kind via_ty via_kind-    -> hang (text "Cannot derive instance via" <+> quotes (pprType via_ty))-          2 (text "Class" <+> quotes (ppr cls)-                  <+> text "expects an argument of kind"-                  <+> quotes (pprKind cls_kind) <> char ','-         $+$ text "but" <+> quotes (pprType via_ty)-                  <+> text "has kind" <+> quotes (pprKind via_kind))-  DerivErrNoEtaReduce inst_ty-    -> sep [text "Cannot eta-reduce to an instance of form",-            nest 2 (text "instance (...) =>"-                   <+> pprClassPred cls (cls_tys ++ [inst_ty]))]-  DerivErrBootFileFound-    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-         (text "Cannot derive instances in hs-boot files"-          $+$ text "Write an instance declaration instead")-  DerivErrDataConsNotAllInScope tc-    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-         (hang (text "The data constructors of" <+> quotes (ppr tc) <+> text "are not all in scope")-            2 (text "so you cannot derive an instance for it"))-  DerivErrGNDUsedOnData-    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-         (text "GeneralizedNewtypeDeriving cannot be used on non-newtypes")-  DerivErrNullaryClasses-    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-         (text "Cannot derive instances for nullary classes")-  DerivErrLastArgMustBeApp-    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-         ( text "The last argument of the instance must be a"-         <+> text "data or newtype application")-  DerivErrNoFamilyInstance tc tc_args-    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-         (text "No family instance for" <+> quotes (pprTypeApp tc tc_args))-  DerivErrNotStockDeriveable _-    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-         (quotes (ppr cls) <+> text "is not a stock derivable class (Eq, Show, etc.)")-  DerivErrHasAssociatedDatatypes hasAdfs at_last_cls_tv_in_kinds at_without_last_cls_tv-    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-         $ vcat [ ppWhen (hasAdfs == YesHasAdfs) adfs_msg-               , case at_without_last_cls_tv of-                    YesAssociatedTyNotParamOverLastTyVar tc -> at_without_last_cls_tv_msg tc-                    NoAssociatedTyNotParamOverLastTyVar     -> empty-               , case at_last_cls_tv_in_kinds of-                   YesAssocTyLastVarInKind tc -> at_last_cls_tv_in_kinds_msg tc-                   NoAssocTyLastVarInKind     -> empty-               ]-       where--         adfs_msg  = text "the class has associated data types"--         at_without_last_cls_tv_msg at_tc = hang-           (text "the associated type" <+> quotes (ppr at_tc)-            <+> text "is not parameterized over the last type variable")-           2 (text "of the class" <+> quotes (ppr cls))--         at_last_cls_tv_in_kinds_msg at_tc = hang-           (text "the associated type" <+> quotes (ppr at_tc)-            <+> text "contains the last type variable")-          2 (text "of the class" <+> quotes (ppr cls)-            <+> text "in a kind, which is not (yet) allowed")-  DerivErrNewtypeNonDeriveableClass-    -> derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald (DerivErrNotStockDeriveable NoDeriveAnyClassEnabled)-  DerivErrCannotEtaReduceEnough eta_ok-    -> let cant_derive_err = ppUnless eta_ok eta_msg-           eta_msg = text "cannot eta-reduce the representation type enough"-       in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-          cant_derive_err-  DerivErrOnlyAnyClassDeriveable tc _-    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-         (quotes (ppr tc) <+> text "is a type class,"-                          <+> text "and can only have a derived instance"-                          $+$ text "if DeriveAnyClass is enabled")-  DerivErrNotDeriveable _-    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald empty-  DerivErrNotAClass predType-    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-         (quotes (ppr predType) <+> text "is not a class")-  DerivErrNoConstructors rep_tc-    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-         (quotes (pprSourceTyCon rep_tc) <+> text "must have at least one data constructor")-  DerivErrLangExtRequired ext-    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-         (text "You need " <> ppr ext-            <+> text "to derive an instance for this class")-  DerivErrDunnoHowToDeriveForType ty-    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-        (hang (text "Don't know how to derive" <+> quotes (ppr cls))-              2 (text "for type" <+> quotes (ppr ty)))-  DerivErrMustBeEnumType rep_tc-    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-         (sep [ quotes (pprSourceTyCon rep_tc) <+>-                text "must be an enumeration type"-              , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ])--  DerivErrMustHaveExactlyOneConstructor rep_tc-    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-         (quotes (pprSourceTyCon rep_tc) <+> text "must have precisely one constructor")-  DerivErrMustHaveSomeParameters rep_tc-    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-         (text "Data type" <+> quotes (ppr rep_tc) <+> text "must have some type parameters")-  DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta-    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-         (text "Data type" <+> quotes (ppr rep_tc)-           <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta)-  DerivErrBadConstructor _ reasons-    -> let why = vcat $ map renderReason reasons-       in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why-         where-           renderReason = \case-                 DerivErrBadConExistential con-                   -> badCon con $ text "must be truly polymorphic in the last argument of the data type"-                 DerivErrBadConCovariant con-                   -> badCon con $ text "must not use the type variable in a function argument"-                 DerivErrBadConFunTypes con-                   -> badCon con $ text "must not contain function types"-                 DerivErrBadConWrongArg con-                   -> badCon con $ text "must use the type variable only as the last argument of a data type"-                 DerivErrBadConIsGADT con-                   -> badCon con $ text "is a GADT"-                 DerivErrBadConHasExistentials con-                   -> badCon con $ text "has existential type variables in its type"-                 DerivErrBadConHasConstraints con-                   -> badCon con $ text "has constraints in its type"-                 DerivErrBadConHasHigherRankType con-                   -> badCon con $ text "has a higher-rank type"-  DerivErrGenerics reasons-    -> let why = vcat $ map renderReason reasons-       in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why-         where-           renderReason = \case-             DerivErrGenericsMustNotHaveDatatypeContext tc_name-                -> ppr tc_name <+> text "must not have a datatype context"-             DerivErrGenericsMustNotHaveExoticArgs dc-                -> ppr dc <+> text "must not have exotic unlifted or polymorphic arguments"-             DerivErrGenericsMustBeVanillaDataCon dc-                -> ppr dc <+> text "must be a vanilla data constructor"-             DerivErrGenericsMustHaveSomeTypeParams rep_tc-                ->     text "Data type" <+> quotes (ppr rep_tc)-                   <+> text "must have some type parameters"-             DerivErrGenericsMustNotHaveExistentials con-               -> badCon con $ text "must not have existential arguments"-             DerivErrGenericsWrongArgKind con-               -> badCon con $-                    text "applies a type to an argument involving the last parameter"-                 $$ text "but the applied type is not of kind * -> *"-  DerivErrEnumOrProduct this that-    -> let ppr1 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False this-           ppr2 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False that-       in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald-          (ppr1 $$ text "  or" $$ ppr2)--lookupInstanceErrDiagnosticMessage :: Class-                                   -> [Type]-                                   -> LookupInstanceErrReason-                                   -> SDoc-lookupInstanceErrDiagnosticMessage cls tys = \case-  LookupInstErrNotExact-    -> text "Not an exact match (i.e., some variables get instantiated)"-  LookupInstErrFlexiVar-    -> text "flexible type variable:" <+> (ppr $ mkTyConApp (classTyCon cls) tys)-  LookupInstErrNotFound-    -> text "instance not found" <+> (ppr $ mkTyConApp (classTyCon cls) tys)--{- *********************************************************************-*                                                                      *-              Outputable SolverReportErrCtxt (for debugging)-*                                                                      *-**********************************************************************-}--instance Outputable SolverReportErrCtxt where-  ppr (CEC { cec_binds              = bvar-           , cec_defer_type_errors  = dte-           , cec_expr_holes         = eh-           , cec_type_holes         = th-           , cec_out_of_scope_holes = osh-           , cec_warn_redundant     = wr-           , cec_expand_syns        = es-           , cec_suppress           = sup })-    = text "CEC" <+> braces (vcat-         [ text "cec_binds"              <+> equals <+> ppr bvar-         , text "cec_defer_type_errors"  <+> equals <+> ppr dte-         , text "cec_expr_holes"         <+> equals <+> ppr eh-         , text "cec_type_holes"         <+> equals <+> ppr th-         , text "cec_out_of_scope_holes" <+> equals <+> ppr osh-         , text "cec_warn_redundant"     <+> equals <+> ppr wr-         , text "cec_expand_syns"        <+> equals <+> ppr es-         , text "cec_suppress"           <+> equals <+> ppr sup ])--{- *********************************************************************-*                                                                      *-                    Outputting TcSolverReportMsg errors-*                                                                      *-**********************************************************************-}---- | Pretty-print a 'SolverReportWithCtxt', containing a 'TcSolverReportMsg'--- with its enclosing 'SolverReportErrCtxt'.-pprSolverReportWithCtxt :: SolverReportWithCtxt -> SDoc-pprSolverReportWithCtxt (SolverReportWithCtxt { reportContext = ctxt, reportContent = msg })-   = pprTcSolverReportMsg ctxt msg---- | Pretty-print a 'TcSolverReportMsg', with its enclosing 'SolverReportErrCtxt'.-pprTcSolverReportMsg :: SolverReportErrCtxt -> TcSolverReportMsg -> SDoc-pprTcSolverReportMsg _ (BadTelescope telescope skols) =-  hang (text "These kind and type variables:" <+> ppr telescope $$-       text "are out of dependency order. Perhaps try this ordering:")-    2 (pprTyVars sorted_tvs)-  where-    sorted_tvs = scopedSort skols-pprTcSolverReportMsg _ (UserTypeError ty) =-  pprUserTypeErrorTy ty-pprTcSolverReportMsg _ (UnsatisfiableError ty) =-  pprUserTypeErrorTy ty-pprTcSolverReportMsg ctxt (ReportHoleError hole err) =-  pprHoleError ctxt hole err-pprTcSolverReportMsg ctxt-  (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 })-  = vcat ([ pprMismatchMsg ctxt mismatch_msg-          , 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-    -- Assemble the error message: pair up each origin with the corresponding type, e.g.-    --   • FixedRuntimeRep origin msg 1 ...-    --       a :: TYPE r1-    --   • FixedRuntimeRep origin msg 2 ...-    --       b :: TYPE r2-    make_msg :: FixedRuntimeRepErrorInfo -> SDoc-    make_msg (FRR_Info { frr_info_origin =-                           FixedRuntimeRepOrigin-                             { frr_type    = ty-                             , frr_context = frr_ctxt }-                       , frr_info_not_concrete =-                         mb_not_conc }) =-      -- Add bullet points if there is more than one error.-      (if length frr_origs > 1 then (bullet <+>) else id) $-        vcat [ sep [ pprFixedRuntimeRepContext frr_ctxt-                   , text "does not have a fixed runtime representation." ]-             , type_printout ty-             , case mb_not_conc of-                Nothing -> empty-                Just (conc_tv, not_conc) ->-                  unsolved_concrete_eq_explanation conc_tv not_conc ]--    -- Don't print out the type (only the kind), if the type includes-    -- a confusing cast, unless the user passed -fprint-explicit-coercions.-    ---    -- Example:-    ---    --   In T20363, we have a representation-polymorphism error with a type-    --   of the form-    ---    --     ( (# #) |> co ) :: TYPE NilRep-    ---    --   where NilRep is a nullary type family application which reduces to TupleRep '[].-    --   We prefer avoiding showing the cast to the user, but we also don't want to-    --   print the confusing:-    ---    --     (# #) :: TYPE NilRep-    ---    --  So in this case we simply don't print the type, only the kind.-    confusing_cast :: Type -> Bool-    confusing_cast ty =-      case ty of-        CastTy inner_ty _-          -- A confusing cast is one that is responsible-          -- for a representation-polymorphism error.-          -> isConcreteType (typeKind inner_ty)-        _ -> False--    type_printout :: Type -> SDoc-    type_printout ty =-      sdocOption sdocPrintExplicitCoercions $ \ show_coercions ->-        if  confusing_cast ty && not show_coercions-        then vcat [ text "Its kind is:"-                  , nest 2 $ pprWithTYPE (typeKind ty)-                  , text "(Use -fprint-explicit-coercions to see the full type.)" ]-        else vcat [ text "Its type is:"-                  , nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE (typeKind ty) ]--    unsolved_concrete_eq_explanation :: TcTyVar -> Type -> SDoc-    unsolved_concrete_eq_explanation tv not_conc =-          text "Cannot unify" <+> quotes (ppr not_conc)-      <+> text "with the type variable" <+> quotes (ppr tv)-      $$  text "because the former is not a concrete" <+> what <> dot-      where-        ki = tyVarKind tv-        what :: SDoc-        what-          | isRuntimeRepTy ki-          = quotes (text "RuntimeRep")-          | isLevityTy ki-          = quotes (text "Levity")-          | otherwise-          = text "type"-pprTcSolverReportMsg _ (BlockedEquality item) =-  vcat [ hang (text "Cannot use equality for substitution:")-           2 (ppr (errorItemPred item))-       , text "Doing so would be ill-kinded." ]-pprTcSolverReportMsg _ (ExpectingMoreArguments n thing) =-  text "Expecting" <+> speakN (abs n) <+>-    more <+> quotes (ppr thing)-  where-    more-     | n == 1    = text "more argument to"-     | otherwise = text "more arguments to" -- n > 1-pprTcSolverReportMsg ctxt (UnboundImplicitParams (item :| items)) =-  let givens = getUserGivens ctxt-  in if null givens-     then addArising (errorItemCtLoc item) $-            sep [ text "Unbound implicit parameter" <> plural preds-                , nest 2 (pprParendTheta preds) ]-     else pprMismatchMsg ctxt (CouldNotDeduce givens (item :| items) Nothing)-  where-    preds = map errorItemPred (item : items)-pprTcSolverReportMsg _ (AmbiguityPreventsSolvingCt item ambigs) =-  pprAmbiguityInfo (Ambiguity True ambigs) <+>-  pprArising (errorItemCtLoc item) $$-  text "prevents the constraint" <+> quotes (pprParendType $ errorItemPred item)-  <+> text "from being solved."-pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics})-  (CannotResolveInstance item unifiers candidates imp_errs suggs binds)-  =-    vcat-      [ 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 $-                  pprAmbiguityInfo (Ambiguity False (ambig_kvs, ambig_tvs))-              , pprRelevantBindings binds-              , potential_msg ])-      , ppWhen (isNothing mb_patsyn_prov) $-            -- Don't suggest fixes for the provided context of a pattern-            -- synonym; the right fix is to bind more in the pattern-        show_fixes (ctxtFixes has_ambigs pred implics-                    ++ drv_fixes ++ naked_sc_fixes)-      , ppWhen (not (null candidates))-        (hang (text "There are instances for similar types:")-            2 (vcat (map ppr candidates)))-            -- See Note [Report candidate instances]-      , vcat $ map ppr imp_errs-      , vcat $ map ppr suggs ]-  where-    orig          = errorItemOrigin item-    pred          = errorItemPred item-    (clas, tys)   = getClassPredTys pred-    -- See Note [Highlighting ambiguous type variables] in GHC.Tc.Errors-    (ambig_kvs, ambig_tvs) = ambigTkvsOfTy pred-    ambigs = ambig_kvs ++ ambig_tvs-    has_ambigs = not (null ambigs)-    useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics)-         -- useful_givens are the enclosing implications with non-empty givens,-         -- modulo the horrid discardProvCtxtGivens-    lead_with_ambig = not (null ambigs)-                   && not (any isRuntimeUnkSkol ambigs)-                   && not (null unifiers)-                   && null useful_givens--    no_inst_msg :: SDoc-    no_inst_msg-      | lead_with_ambig-      = pprTcSolverReportMsg ctxt $ AmbiguityPreventsSolvingCt item (ambig_kvs, ambig_tvs)-      | otherwise-      = 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-    want_potential (TypeEqOrigin {}) = False-    want_potential _                 = True--    potential_msg-      = ppWhen (not (null unifiers) && want_potential orig) $-          potential_hdr $$-          potentialInstancesErrMsg (PotentialInstances { matches = [], unifiers })--    potential_hdr-      = ppWhen lead_with_ambig $-        text "Probable fix: use a type annotation to specify what"-        <+> pprQuotedList ambig_tvs <+> text "should be."--    mb_patsyn_prov :: Maybe SDoc-    mb_patsyn_prov-      | not lead_with_ambig-      , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig-      = Just (vcat [ text "In other words, a successful match on the pattern"-                   , nest 2 $ ppr pat-                   , text "does not provide the constraint" <+> pprParendType pred ])-      | otherwise = Nothing--    extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys)-               = text "(maybe you haven't applied a function to enough arguments?)"-               | className clas == typeableClassName  -- Avoid mysterious "No instance for (Typeable T)-               , [_,ty] <- tys                        -- Look for (Typeable (k->*) (T k))-               , Just (tc,_) <- tcSplitTyConApp_maybe ty-               , not (isTypeFamilyTyCon tc)-               = hang (text "GHC can't yet do polykinded")-                    2 (text "Typeable" <+>-                       parens (ppr ty <+> dcolon <+> ppr (typeKind ty)))-               | otherwise-               = empty--    drv_fixes = case orig of-                   DerivClauseOrigin                  -> [drv_fix False]-                   StandAloneDerivOrigin              -> [drv_fix True]-                   DerivOriginDC _ _       standalone -> [drv_fix standalone]-                   DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone]-                   _                                  -> []--    drv_fix standalone_wildcard-      | standalone_wildcard-      = text "fill in the wildcard constraint yourself"-      | otherwise-      = hang (text "use a standalone 'deriving instance' declaration,")-           2 (text "so you can specify the instance context yourself")--    -- naked_sc_fix: try to produce a helpful error message for-    -- superclass constraints caught by the subtleties described by-    -- Note [Recursive superclasses] in GHC.TyCl.Instance-    naked_sc_fixes-      | ScOrigin _ NakedSc <- orig  -- A superclass wanted with no instance decls used yet-      , any non_tyvar_preds useful_givens  -- Some non-tyvar givens-      = [vcat [ text "If the constraint looks soluble from a superclass of the instance context,"-              , text "read 'Undecidable instances and loopy superclasses' in the user manual" ]]-      | otherwise = []--    non_tyvar_preds :: UserGiven -> Bool-    non_tyvar_preds = any non_tyvar_pred . ic_given--    non_tyvar_pred :: EvVar -> Bool-    -- Tells if the Given is of form (C ty1 .. tyn), where the tys are not all tyvars-    non_tyvar_pred given = case getClassPredTys_maybe (idType given) of-                             Just (_, tys) -> not (all isTyVarTy tys)-                             Nothing       -> False--pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item matches unifiers) =-  vcat-    [ addArising ct_loc $-        (text "Overlapping instances for"-        <+> pprType (mkClassPred clas tys))-    , ppUnless (null matching_givens) $-                  sep [text "Matching givens (or their superclasses):"-                      , nest 2 (vcat matching_givens)]-    ,  potentialInstancesErrMsg-        (PotentialInstances { matches = NE.toList matches, unifiers })-    ,  ppWhen (null matching_givens && null (NE.tail matches) && null unifiers) $-       -- Intuitively, some given matched the wanted in their-       -- flattened or rewritten (from given equalities) form-       -- but the matcher can't figure that out because the-       -- constraints are non-flat and non-rewritten so we-       -- simply report back the whole given-       -- context. Accelerate Smart.hs showed this problem.-         sep [ text "There exists a (perhaps superclass) match:"-             , nest 2 (vcat (pp_givens useful_givens))]--    ,  ppWhen (null $ NE.tail matches) $-       parens (vcat [ ppUnless (null tyCoVars) $-                        text "The choice depends on the instantiation of" <+>-                          quotes (pprWithCommas ppr tyCoVars)-                    , ppUnless (null famTyCons) $-                        if (null tyCoVars)-                          then-                            text "The choice depends on the result of evaluating" <+>-                              quotes (pprWithCommas ppr famTyCons)-                          else-                            text "and the result of evaluating" <+>-                              quotes (pprWithCommas ppr famTyCons)-                    , ppWhen (null (matching_givens)) $-                      vcat [ text "To pick the first instance above, use IncoherentInstances"-                           , text "when compiling the other instance declarations"]-               ])]-  where-    ct_loc          = errorItemCtLoc item-    orig            = ctLocOrigin ct_loc-    pred            = errorItemPred item-    (clas, tys)     = getClassPredTys pred-    tyCoVars        = tyCoVarsOfTypesList tys-    famTyCons       = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys-    useful_givens   = discardProvCtxtGivens orig (getUserGivensFromImplics implics)-    matching_givens = mapMaybe matchable useful_givens-    matchable implic@(Implic { ic_given = evvars, ic_info = skol_info })-      = case ev_vars_matching of-             [] -> Nothing-             _  -> Just $ hang (pprTheta ev_vars_matching)-                            2 (sep [ text "bound by" <+> ppr skol_info-                                   , text "at" <+>-                                     ppr (getCtLocEnvLoc (ic_env implic)) ])-        where ev_vars_matching = [ pred-                                 | ev_var <- evvars-                                 , let pred = evVarPred ev_var-                                 , any can_match (pred : transSuperClasses pred) ]-              can_match pred-                 = case getClassPredTys_maybe pred of-                     Just (clas', tys') -> clas' == clas-                                          && isJust (tcMatchTys tys tys')-                     Nothing -> False-pprTcSolverReportMsg _ (UnsafeOverlap item match unsafe_overlapped) =-  vcat [ addArising ct_loc (text "Unsafe overlapping instances for"-                  <+> pprType (mkClassPred clas tys))-       , sep [text "The matching instance is:",-              nest 2 (pprInstance match)]-       , vcat [ text "It is compiled in a Safe module and as such can only"-              , text "overlap instances from the same module, however it"-              , text "overlaps the following instances from different" <+>-                text "modules:"-              , nest 2 (vcat [pprInstances $ NE.toList unsafe_overlapped])-              ]-       ]-  where-    ct_loc      = errorItemCtLoc item-    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 (getCtLocEnvLoc (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--pprUntouchableVariable :: TcTyVar -> Implication -> SDoc-pprUntouchableVariable tv (Implic { ic_given = given, ic_info = skol_info, ic_env = env })-  = sep [ quotes (ppr tv) <+> text "is untouchable"-        , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given-        , nest 2 $ text "bound by" <+> ppr skol_info-        , nest 2 $ text "at" <+> ppr (getCtLocEnvLoc env) ]--pprMismatchMsg :: SolverReportErrCtxt -> MismatchMsg -> SDoc-pprMismatchMsg ctxt-  (BasicMismatch { mismatch_ea   = ea-                 , mismatch_item = item-                 , mismatch_ty1  = ty1  -- Expected-                 , mismatch_ty2  = ty2  -- Actual-                 , mismatch_whenMatching = mb_match_txt-                 , mismatch_mb_same_occ  = same_occ_info })-  =  vcat [ addArising (errorItemCtLoc item) msg-          , ea_extra-          , 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 ]--    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--    (want_ea, ea_extra)-      = case ea of-         NoEA        -> (False, empty)-         EA mb_extra -> (True , maybe empty (pprExpectedActualInfo ctxt) mb_extra)-    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 | isConstraintLikeKind 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_item     = item-                  , teq_mismatch_ty1      = ty1   -- These types are the actual types-                  , teq_mismatch_ty2      = ty2   --   that don't match; may be swapped-                  , teq_mismatch_expected = exp   -- These are the context of-                  , teq_mismatch_actual   = act   --   the mis-match-                  , teq_mismatch_what     = mb_thing-                  , teq_mb_same_occ       = mb_same_occ })-  = addArising ct_loc $-    pprWithInvisibleBitsWhen ppr_invis_bits msg-    $$ maybe empty pprSameOccInfo mb_same_occ-  where--    msg | Just (torc, rep) <- sORTKind_maybe exp-        = msg_for_exp_sort torc rep--        | Just nargs_msg <- num_args_msg-        , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig-        = nargs_msg $$ pprMismatchMsg ctxt ea_msg--        | ea_looks_same ty1 ty2 exp act-        , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig-        = pprMismatchMsg ctxt ea_msg--        | otherwise-        = bale_out_msg--      -- bale_out_msg: the mismatched types are /inside/ exp and act-    bale_out_msg = vcat errs-      where-        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 ]-        mismatch_err = mkBasicMismatchMsg NoEA item ty1 ty2--      -- 'expected' is (TYPE rep) or (CONSTRAINT rep)-    msg_for_exp_sort exp_torc exp_rep-      | Just (act_torc, act_rep) <- sORTKind_maybe act-      = -- (TYPE exp_rep) ~ (CONSTRAINT act_rep) etc-        msg_torc_torc act_torc act_rep-      | otherwise-      = -- (TYPE _) ~ Bool, etc-        maybe_num_args_msg $$-        sep [ text "Expected a" <+> ppr_torc exp_torc <> comma-            , text "but" <+> case mb_thing of-                Nothing    -> text "found something with kind"-                Just thing -> quotes (ppr thing) <+> text "has kind"-            , quotes (pprWithTYPE act) ]--      where-        msg_torc_torc act_torc act_rep-          | exp_torc == act_torc-          = msg_same_torc act_torc act_rep-          | otherwise-          = sep [ text "Expected a" <+> ppr_torc exp_torc <> comma-                , text "but" <+> case mb_thing of-                     Nothing    -> text "found a"-                     Just thing -> quotes (ppr thing) <+> text "is a"-                  <+> ppr_torc act_torc ]--        msg_same_torc act_torc act_rep-          | Just exp_doc <- describe_rep exp_rep-          , Just act_doc <- describe_rep act_rep-          = sep [ text "Expected" <+> exp_doc <+> ppr_torc exp_torc <> comma-                , text "but" <+> case mb_thing of-                     Just thing -> quotes (ppr thing) <+> text "is"-                     Nothing    -> text "got"-                  <+> act_doc <+> ppr_torc act_torc ]-        msg_same_torc _ _ = bale_out_msg--    ct_loc = errorItemCtLoc item-    orig   = errorItemOrigin item-    level  = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel-    ppr_invis_bits = shouldPprWithInvisibleBits ty1 ty2 orig--    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 isVisiblePiTyBinder $ fst $ splitPiTys ty--    ppr_torc TypeLike       = text "type";-    ppr_torc ConstraintLike = text "constraint"--    describe_rep :: RuntimeRepType -> Maybe SDoc-    -- describe_rep IntRep            = Just "an IntRep"-    -- describe_rep (BoxedRep Lifted) = Just "a lifted"-    --   etc-    describe_rep rep-      | Just (rr_tc, rr_args) <- splitRuntimeRep_maybe rep-      = case rr_args of-          [lev_ty] | rr_tc `hasKey` boxedRepDataConKey-                   , Just lev <- levityType_maybe lev_ty-                -> case lev of-                      Lifted   -> Just (text "a lifted")-                      Unlifted -> Just (text "a boxed unlifted")-          [] | rr_tc `hasKey` tupleRepDataConTyConKey -> Just (text "a zero-bit")-             | starts_with_vowel rr_occ -> Just (text "an" <+> text rr_occ)-             | otherwise                -> Just (text "a"  <+> text rr_occ)-             where-               rr_occ = occNameString (getOccName rr_tc)--          _ -> Nothing -- Must be TupleRep [r1..rn]-      | otherwise = Nothing--    starts_with_vowel (c:_) = c `elem` ("AEIOU" :: String)-    starts_with_vowel []    = False--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----- | Whether to print explicit kinds (with @-fprint-explicit-kinds@)--- in an 'SDoc' when a type mismatch occurs to due invisible parts of the types.--- See Note [Showing invisible bits of types in error messages]------ This function first checks to see if the 'CtOrigin' argument is a--- 'TypeEqOrigin'. If so, it first checks whether the equality is a visible--- equality; if it's not, definitely print the kinds. Even if the equality is--- a visible equality, check the expected/actual types to see if the types--- have equal visible components. If the 'CtOrigin' is--- not a 'TypeEqOrigin', fall back on the actual mismatched types themselves.-shouldPprWithInvisibleBits :: Type -> Type -> CtOrigin -> Bool-shouldPprWithInvisibleBits _ty1 _ty2 (TypeEqOrigin { uo_actual = act-                                                   , uo_expected = exp-                                                   , uo_visible = vis })-  | not vis   = True                  -- See tests T15870, T16204c-  | otherwise = mayLookIdentical act exp   -- See tests T9171, T9144.-shouldPprWithInvisibleBits ty1 ty2 _ct-  = mayLookIdentical ty1 ty2--{- Note [Showing invisible bits of types in error messages]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It can be terribly confusing to get an error message like (#9171)--    Couldn't match expected type ‘GetParam Base (GetParam Base Int)’-                with actual type ‘GetParam Base (GetParam Base Int)’--The reason may be that the kinds don't match up.  Typically you'll get-more useful information, but not when it's as a result of ambiguity.--To mitigate this, when we find a type or kind mis-match:--* See if normally-visible parts of the type would make the two types-  look different.  This check is made by-  `GHC.Core.TyCo.Compare.mayLookIdentical`--* If not, display the types with their normally-visible parts made visible,-  by setting flags in the `SDocContext":-  Specifically:-    - Display kind arguments: sdocPrintExplicitKinds-    - Don't default away runtime-reps: sdocPrintExplicitRuntimeReps,-           which controls `GHC.Iface.Type.hideNonStandardTypes`-  (NB: foralls are always printed by pprType, it turns out.)--As a result the above error message would instead be displayed as:--    Couldn't match expected type-                  ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’-                with actual type-                  ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’--Which makes it clearer that the culprit is the mismatch between `k2` and `k20`.--Another example of what goes wrong without this: #24553.--}--{- *********************************************************************-*                                                                      *-                 Displaying potential instances-*                                                                      *-**********************************************************************-}---- | Directly display the given matching and unifying instances,--- with a header for each: `Matching instances`/`Potentially matching instances`.-pprPotentialInstances :: (ClsInst -> SDoc) -> PotentialInstances -> SDoc-pprPotentialInstances ppr_inst (PotentialInstances { matches, unifiers }) =-  vcat-    [ ppWhen (not $ null matches) $-       text "Matching instance" <> plural matches <> colon $$-         nest 2 (vcat (map ppr_inst matches))-    , ppWhen (not $ null unifiers) $-        (text "Potentially matching instance" <> plural unifiers <> colon) $$-         nest 2 (vcat (map ppr_inst unifiers))-    ]---- | Display a summary of available instances, omitting those involving--- out-of-scope types, in order to explain why we couldn't solve a particular--- constraint, e.g. due to instance overlap or out-of-scope types.------ To directly display a collection of matching/unifying instances,--- use 'pprPotentialInstances'.-potentialInstancesErrMsg :: PotentialInstances -> SDoc--- See Note [Displaying potential instances]-potentialInstancesErrMsg potentials =-  sdocOption sdocPrintPotentialInstances $ \print_insts ->-  getPprStyle $ \sty ->-    potentials_msg_with_options potentials print_insts sty---- | Display a summary of available instances, omitting out-of-scope ones.------ Use 'potentialInstancesErrMsg' to automatically set the pretty-printing--- options.-potentials_msg_with_options :: PotentialInstances-                            -> Bool -- ^ Whether to print /all/ potential instances-                            -> PprStyle-                            -> SDoc-potentials_msg_with_options-  (PotentialInstances { matches, unifiers })-  show_all_potentials sty-  | null matches && null unifiers-  = empty--  | null show_these_matches && null show_these_unifiers-  = vcat [ not_in_scope_msg empty-         , flag_hint ]--  | otherwise-  = vcat [ pprPotentialInstances-            pprInstance -- print instance + location info-            (PotentialInstances-              { matches  = show_these_matches-              , unifiers = show_these_unifiers })-         , overlapping_but_not_more_specific_msg sorted_matches-         , nest 2 $ vcat-           [ ppWhen (n_in_scope_hidden > 0) $-             text "...plus"-               <+> speakNOf n_in_scope_hidden (text "other")-           , ppWhen (not_in_scopes > 0) $-              not_in_scope_msg (text "...plus")-           , flag_hint ] ]-  where-    n_show_matches, n_show_unifiers :: Int-    n_show_matches  = 3-    n_show_unifiers = 2--    (in_scope_matches, not_in_scope_matches) = partition inst_in_scope matches-    (in_scope_unifiers, not_in_scope_unifiers) = partition inst_in_scope unifiers-    sorted_matches = sortBy fuzzyClsInstCmp in_scope_matches-    sorted_unifiers = sortBy fuzzyClsInstCmp in_scope_unifiers-    (show_these_matches, show_these_unifiers)-       | show_all_potentials = (sorted_matches, sorted_unifiers)-       | otherwise           = (take n_show_matches  sorted_matches-                               ,take n_show_unifiers sorted_unifiers)-    n_in_scope_hidden-      = length sorted_matches + length sorted_unifiers-      - length show_these_matches - length show_these_unifiers--       -- "in scope" means that all the type constructors-       -- are lexically in scope; these instances are likely-       -- to be more useful-    inst_in_scope :: ClsInst -> Bool-    inst_in_scope cls_inst = nameSetAll name_in_scope $-                             orphNamesOfTypes (is_tys cls_inst)--    name_in_scope name-      | pretendNameIsInScope name-      = True -- E.g. (->); see Note [pretendNameIsInScope] in GHC.Builtin.Names-      | Just mod <- nameModule_maybe name-      = qual_in_scope (qualName sty mod (nameOccName name))-      | otherwise-      = True--    qual_in_scope :: QualifyName -> Bool-    qual_in_scope NameUnqual    = True-    qual_in_scope (NameQual {}) = True-    qual_in_scope _             = False--    not_in_scopes :: Int-    not_in_scopes = length not_in_scope_matches + length not_in_scope_unifiers--    not_in_scope_msg herald =-      hang (herald <+> speakNOf not_in_scopes (text "instance")-                     <+> text "involving out-of-scope types")-           2 (ppWhen show_all_potentials $-               pprPotentialInstances-               pprInstanceHdr -- only print the header, not the instance location info-                 (PotentialInstances-                   { matches = not_in_scope_matches-                   , unifiers = not_in_scope_unifiers-                   }))--    flag_hint = ppUnless (show_all_potentials-                         || (equalLength show_these_matches matches-                             && equalLength show_these_unifiers unifiers)) $-                text "(use -fprint-potential-instances to see them all)"---- | Compute a message informing the user of any instances that are overlapped--- but were not discarded because the instance overlapping them wasn't--- strictly more specific.-overlapping_but_not_more_specific_msg :: [ClsInst] -> SDoc-overlapping_but_not_more_specific_msg insts-  -- Only print one example of "overlapping but not strictly more specific",-  -- to avoid information overload.-  | overlap : _ <- overlapping_but_not_more_specific-  = overlap_header $$ ppr_overlapping overlap-  | otherwise-  = empty-    where-      overlap_header :: SDoc-      overlap_header-        | [_] <- overlapping_but_not_more_specific-        = text "An overlapping instance can only be chosen when it is strictly more specific."-        | otherwise-        = text "Overlapping instances can only be chosen when they are strictly more specific."-      overlapping_but_not_more_specific :: [(ClsInst, ClsInst)]-      overlapping_but_not_more_specific-        = nubOrdBy (comparing (is_dfun . fst))-          [ (overlapper, overlappee)-          | these <- groupBy ((==) `on` is_cls_nm) insts-          -- Take all pairs of distinct instances...-          , one:others <- tails these -- if `these = [inst_1, inst_2, ...]`-          , other <- others           -- then we get pairs `(one, other) = (inst_i, inst_j)` with `i < j`-          -- ... such that one instance in the pair overlaps the other...-          , let mb_overlapping-                  | hasOverlappingFlag (overlapMode $ is_flag one)-                  || hasOverlappableFlag (overlapMode $ is_flag other)-                  = [(one, other)]-                  | hasOverlappingFlag (overlapMode $ is_flag other)-                  || hasOverlappableFlag (overlapMode $ is_flag one)-                  = [(other, one)]-                  | otherwise-                  = []-          , (overlapper, overlappee) <- mb_overlapping-          -- ... but the overlapper is not more specific than the overlappee.-          , not (overlapper `more_specific_than` overlappee)-          ]-      more_specific_than :: ClsInst -> ClsInst -> Bool-      is1 `more_specific_than` is2-        = isJust (tcMatchTys (is_tys is1) (is_tys is2))-      ppr_overlapping :: (ClsInst, ClsInst) -> SDoc-      ppr_overlapping (overlapper, overlappee)-        = text "The first instance that follows overlaps the second, but is not more specific than it:"-        $$ nest 2 (vcat $ map pprInstanceHdr [overlapper, overlappee])--{- Note [Displaying potential instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When showing a list of instances for-  - overlapping instances (show ones that match)-  - no such instance (show ones that could match)-we want to give it a bit of structure.  Here's the plan--* Say that an instance is "in scope" if all of the-  type constructors it mentions are lexically in scope.-  These are the ones most likely to be useful to the programmer.--* Show at most n_show in-scope instances,-  and summarise the rest ("plus N others")--* Summarise the not-in-scope instances ("plus 4 not in scope")--* Add the flag -fshow-potential-instances which replaces the-  summary with the full list--}--{- *********************************************************************-*                                                                      *-             Outputting additional solver report information-*                                                                      *-**********************************************************************-}---- | Pretty-print an informational message, to accompany a 'TcSolverReportMsg'.-pprExpectedActualInfo :: SolverReportErrCtxt -> ExpectedActualInfo -> SDoc-pprExpectedActualInfo _ (ExpectedActual { ea_expected = exp, ea_actual = act }) =-  vcat-    [ text "Expected:" <+> ppr exp-    , text "  Actual:" <+> ppr act ]-pprExpectedActualInfo _-  (ExpectedActualAfterTySynExpansion-    { ea_expanded_expected = exp-    , ea_expanded_actual   = act } )-  = vcat-      [ text "Type synonyms expanded:"-      , text "Expected type:" <+> ppr exp-      , text "  Actual type:" <+> ppr act ]--pprCoercibleMsg :: CoercibleMsg -> SDoc-pprCoercibleMsg (UnknownRoles ty) =-  note $ "We cannot know what roles the parameters to" <+> quotes (ppr ty) <+> "have;" $$-           "we must assume that the role is nominal"-pprCoercibleMsg (TyConIsAbstract tc) =-  note $ "The type constructor" <+> quotes (pprSourceTyCon tc) <+> "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)-      then vcat [ hang (text "When matching" <+> sub_whats)-                      2 (vcat [ ppr cty1 <+> dcolon <+>-                               ppr (typeKind cty1)-                             , ppr cty2 <+> dcolon <+>-                               ppr (typeKind cty2) ])-                , supplementary ]-      else text "When matching the kind of" <+> quotes (ppr cty1)-  where-    sub_t_or_k = mb_sub_t_or_k `orElse` TypeLevel-    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 (pprExpectedActualInfo ctxt) infos-        Right msg  -> pprMismatchMsg ctxt msg--pprTyVarInfo :: SolverReportErrCtxt -> TyVarInfo -> SDoc-pprTyVarInfo ctxt (TyVarInfo { thisTyVar = tv1, otherTy = mb_tv2, thisTyVarIsUntouchable = mb_implic })-  = vcat [ mk_msg tv1-         , maybe empty (pprUntouchableVariable tv1) mb_implic-         , 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) =-  note $ quotes (ppr tc) <+> text "is a non-injective type family"--pprSameOccInfo :: SameOccInfo -> SDoc-pprSameOccInfo (SameOcc same_pkg n1 n2) =-  note (ppr_from same_pkg n1 $$ ppr_from same_pkg n2)-  where-    ppr_from same_pkg nm-      | isGoodSrcSpan loc-      = hang (quotes (ppr nm) <+> text "is defined at")-           2 (ppr loc)-      | otherwise  -- Imported things have an UnhelpfulSrcSpan-      = hang (quotes (ppr nm))-           2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod))-                  , ppUnless (same_pkg || pkg == mainUnit) $-                    nest 4 $ text "in package" <+> quotes (ppr pkg) ])-      where-        pkg = moduleUnit mod-        mod = nameModule nm-        loc = nameSrcSpan nm--{- *********************************************************************-*                                                                      *-                  Outputting HoleError messages-*                                                                      *-**********************************************************************-}--pprHoleError :: SolverReportErrCtxt -> Hole -> HoleError -> SDoc-pprHoleError _ (Hole { hole_ty, hole_occ = rdr }) (OutOfScopeHole imp_errs _hints)-  = out_of_scope_msg $$ vcat (map ppr imp_errs)-  where-    herald | isDataOcc (rdrNameOcc rdr) = text "Data constructor not in scope:"-           | otherwise     = text "Variable not in scope:"-    out_of_scope_msg -- Print v :: ty only if the type has structure-      | boring_type = hang herald 2 (ppr rdr)-      | otherwise   = hang herald 2 (pp_rdr_with_type rdr hole_ty)-    boring_type = isTyVarTy hole_ty-pprHoleError ctxt (Hole { hole_ty, hole_occ}) (HoleError sort other_tvs hole_skol_info) =-  vcat [ hole_msg-       , tyvars_msg-       , case sort of { ExprHole {} -> expr_hole_hint; _ -> type_hole_hint } ]--  where--    hole_msg = case sort of-      ExprHole {} ->-        hang (text "Found hole:")-          2 (pp_rdr_with_type hole_occ hole_ty)-      TypeHole ->-        hang (text "Found type wildcard" <+> quotes (ppr hole_occ))-          2 (text "standing for" <+> quotes pp_hole_type_with_kind)-      ConstraintHole ->-        hang (text "Found extra-constraints wildcard standing for")-          2 (quotes $ pprType hole_ty)  -- always kind Constraint--    hole_kind = typeKind hole_ty--    pp_hole_type_with_kind-      | isLiftedTypeKind hole_kind-        || isCoVarType hole_ty -- Don't print the kind of unlifted-                               -- equalities (#15039)-      = pprType hole_ty-      | otherwise-      = pprType hole_ty <+> dcolon <+> pprKind hole_kind--    tyvars = tyCoVarsOfTypeList hole_ty-    tyvars_msg = ppUnless (null tyvars) $-                 text "Where:" <+> (vcat (map loc_msg other_tvs)-                                    $$ pprSkols ctxt hole_skol_info)-                      -- Coercion variables can be free in the-                      -- hole, via kind casts-    expr_hole_hint                       -- Give hint for, say,   f x = _x-         | lengthFS (occNameFS (rdrNameOcc hole_occ)) > 1  -- Don't give this hint for plain "_"-         = text "Or perhaps" <+> quotes (ppr hole_occ)-           <+> text "is mis-spelled, or not in scope"-         | otherwise-         = empty--    type_hole_hint-         | ErrorWithoutFlag <- cec_type_holes ctxt-         = text "To use the inferred type, enable PartialTypeSignatures"-         | otherwise-         = empty--    loc_msg tv-       | isTyVar tv-       = case tcTyVarDetails tv of-           MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable"-           _         -> empty  -- Skolems dealt with already-       | otherwise  -- A coercion variable can be free in the hole type-       = ppWhenOption sdocPrintExplicitCoercions $-           quotes (ppr tv) <+> text "is a coercion variable"--pp_rdr_with_type :: RdrName -> Type -> SDoc-pp_rdr_with_type occ hole_ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty)--{- *********************************************************************-*                                                                      *-                  Outputting ScopeError messages-*                                                                      *-**********************************************************************-}--pprScopeError :: RdrName -> NotInScopeError -> SDoc-pprScopeError rdr_name scope_err =-  case scope_err of-    NotInScope ->-      hang (text "Not in scope:")-        2 (what <+> quotes (ppr rdr_name))-    NotARecordField ->-      hang (text "Not in scope:")-        2 (text "record field" <+> quotes (ppr rdr_name))-    NoExactName name ->-      text "The Name" <+> quotes (ppr name) <+> text "is not in scope."-    SameName gres ->-      assertPpr (length gres >= 2) (text "pprScopeError SameName: fewer than 2 elements" $$ nest 2 (ppr gres))-      $ hang (text "Same Name in multiple name-spaces:")-           2 (vcat (map pp_one sorted_names))-      where-        sorted_names = sortBy (leftmost_smallest `on` nameSrcSpan)-                     $ map greName gres-        pp_one name-          = hang (pprNameSpace (occNameSpace (getOccName name))-                  <+> quotes (ppr name) <> comma)-               2 (text "declared at:" <+> ppr (nameSrcLoc name))-    MissingBinding thing _ ->-      sep [ text "The" <+> thing-               <+> text "for" <+> quotes (ppr rdr_name)-          , nest 2 $ text "lacks an accompanying binding" ]-    NoTopLevelBinding ->-      hang (text "No top-level binding for")-        2 (what <+> quotes (ppr rdr_name) <+> text "in this module")-    UnknownSubordinate doc ->-      quotes (ppr rdr_name) <+> text "is not a (visible)" <+> doc-    NotInScopeTc env ->-      vcat[text "GHC internal error:" <+> quotes (ppr rdr_name) <+>-      text "is not in scope during type checking, but it passed the renamer",-      text "tcl_env of environment:" <+> ppr env]-  where-    what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))--scopeErrorHints :: NotInScopeError -> [GhcHint]-scopeErrorHints scope_err =-  case scope_err of-    NotInScope             -> noHints-    NotARecordField        -> noHints-    NoExactName {}         -> [SuggestDumpSlices]-    SameName {}            -> [SuggestDumpSlices]-    MissingBinding _ hints -> hints-    NoTopLevelBinding      -> noHints-    UnknownSubordinate {}  -> noHints-    NotInScopeTc _         -> noHints--tcSolverReportMsgHints :: SolverReportErrCtxt -> TcSolverReportMsg -> [GhcHint]-tcSolverReportMsgHints ctxt = \case-  BadTelescope {}-    -> noHints-  UserTypeError {}-    -> noHints-  UnsatisfiableError {}-    -> noHints-  ReportHoleError hole err-    -> holeErrorHints hole err-  CannotUnifyVariable mismatch_msg rea-    -> mismatchMsgHints ctxt mismatch_msg ++ cannotUnifyVariableHints rea-  Mismatch { mismatchMsg = mismatch_msg }-    -> mismatchMsgHints ctxt mismatch_msg-  FixedRuntimeRepError {}-    -> noHints-  BlockedEquality {}-    -> noHints-  ExpectingMoreArguments {}-    -> noHints-  UnboundImplicitParams {}-    -> noHints-  AmbiguityPreventsSolvingCt {}-    -> noHints-  CannotResolveInstance {}-    -> noHints-  OverlappingInstances {}-    -> noHints-  UnsafeOverlap {}-   -> noHints--mismatchMsgHints :: SolverReportErrCtxt -> MismatchMsg -> [GhcHint]-mismatchMsgHints ctxt msg =-  maybeToList [ hint | (exp,act) <- mismatchMsg_ExpectedActuals msg-                     , hint <- suggestAddSig ctxt exp act ]--mismatchMsg_ExpectedActuals :: MismatchMsg -> Maybe (Type, Type)-mismatchMsg_ExpectedActuals = \case-  BasicMismatch { mismatch_ty1 = exp, mismatch_ty2 = act } ->-    Just (exp, act)-  KindMismatch { kmismatch_expected = exp, kmismatch_actual = act } ->-    Just (exp, act)-  TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } ->-    Just (exp,act)-  CouldNotDeduce { cnd_extra = cnd_extra }-    | Just (CND_Extra _ exp act) <- cnd_extra-    -> Just (exp, act)-    | otherwise-    -> Nothing--holeErrorHints :: Hole -> HoleError -> [GhcHint]-holeErrorHints _hole = \case-  OutOfScopeHole _ hints-    -> hints-  HoleError {}-    -> noHints--cannotUnifyVariableHints :: CannotUnifyVariableReason -> [GhcHint]-cannotUnifyVariableHints = \case-  CannotUnifyWithPolytype {}-    -> noHints-  OccursCheck {}-    -> noHints-  SkolemEscape {}-    -> noHints-  DifferentTyVars {}-    -> noHints-  RepresentationalEq {}-    -> noHints--suggestAddSig :: SolverReportErrCtxt -> TcType -> TcType -> Maybe GhcHint--- See Note [Suggest adding a type signature]-suggestAddSig ctxt ty1 _ty2-  | bndr : bndrs <- inferred_bndrs-  = Just $ SuggestAddTypeSignatures $ NamedBindings (bndr :| bndrs)-  | otherwise-  = Nothing-  where-    inferred_bndrs =-      case getTyVar_maybe ty1 of-        Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv-        _                          -> []--    -- 'find' returns the binders of an InferSkol for 'tv',-    -- provided there is an intervening implication with-    -- ic_given_eqs /= NoGivenEqs (i.e. a GADT match)-    find [] _ _ = []-    find (implic:implics) seen_eqs tv-       | tv `elem` ic_skols implic-       , InferSkol prs <- ic_info implic-       , seen_eqs-       = map fst prs-       | otherwise-       = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv--{- Note [Suggest adding a type signature]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The OutsideIn algorithm rejects GADT programs that don't have a principal-type, and indeed some that do.  Example:-   data T a where-     MkT :: Int -> T Int--   f (MkT n) = n--Does this have type f :: T a -> a, or f :: T a -> Int?-The error that shows up tends to be an attempt to unify an-untouchable type variable.  So suggestAddSig sees if the offending-type variable is bound by an *inferred* signature, and suggests-adding a declared signature instead.--More specifically, we suggest adding a type sig if we have p ~ ty, and-p is a skolem bound by an InferSkol.  Those skolems were created from-unification variables in simplifyInfer.  Why didn't we unify?  It must-have been because of an intervening GADT or existential, making it-untouchable. Either way, a type signature would help.  For GADTs, it-might make it typeable; for existentials the attempt to write a-signature will fail -- or at least will produce a better error message-next time--This initially came up in #8968, concerning pattern synonyms.--}--{- *********************************************************************-*                                                                      *-                  Outputting ImportError messages-*                                                                      *-**********************************************************************-}--instance Outputable ImportError where-  ppr err = note $ case err of-      MissingModule mod_name -> "No module named" <+> quoted mod_name <+> "is imported"-      ModulesDoNotExport mods occ_name-        | mod NE.:| [] <- mods -> "The module" <+> quoted mod <+> "does not export" <+> quoted occ_name-        | otherwise -> "Neither" <+> quotedListWithNor (map ppr $ NE.toList mods) <+> "export" <+> quoted occ_name-    where-      quoted :: Outputable a => a -> SDoc-      quoted = quotes . ppr--{- *********************************************************************-*                                                                      *-             Suggested fixes for implication constraints-*                                                                      *-**********************************************************************-}---- TODO: these functions should use GhcHint instead.--show_fixes :: [SDoc] -> SDoc-show_fixes []     = empty-show_fixes (f:fs) = sep [ text "Possible fix:"-                        , nest 2 (vcat (f : map (text "or" <+>) fs))]--ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc]-ctxtFixes has_ambig_tvs pred implics-  | not has_ambig_tvs-  , isTyVarClassPred pred   -- Don't suggest adding (Eq T) to the context, say-  , (skol:skols) <- usefulContext implics pred-  , let what | null skols-             , SigSkol (PatSynCtxt {}) _ _ <- skol-             = text "\"required\""-             | otherwise-             = empty-  = [sep [ text "add" <+> pprParendType pred-           <+> text "to the" <+> what <+> text "context of"-         , nest 2 $ ppr_skol skol $$-                    vcat [ text "or" <+> ppr_skol skol-                         | skol <- skols ] ] ]-  | otherwise = []-  where-    ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc)-    ppr_skol (PatSkol (PatSynCon ps)   _) = text "the pattern synonym"  <+> quotes (ppr ps)-    ppr_skol skol_info = ppr skol_info--usefulContext :: [Implication] -> PredType -> [SkolemInfoAnon]--- usefulContext picks out the implications whose context--- the programmer might plausibly augment to solve 'pred'-usefulContext implics pred-  = go implics-  where-    pred_tvs = tyCoVarsOfType pred-    go [] = []-    go (ic : ics)-       | implausible ic = rest-       | otherwise      = ic_info ic : rest-       where-          -- Stop when the context binds a variable free in the predicate-          rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = []-               | otherwise                                 = go ics--    implausible ic-      | null (ic_skols ic)            = True-      | implausible_info (ic_info ic) = True-      | otherwise                     = False--    implausible_info (SigSkol (InfSigCtxt {}) _ _) = True-    implausible_info _                             = False-    -- Do not suggest adding constraints to an *inferred* type signature--pp_givens :: [Implication] -> [SDoc]-pp_givens givens-   = case givens of-         []     -> []-         (g:gs) ->      ppr_given (text "from the context:") g-                 : map (ppr_given (text "or from:")) gs-    where-       ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info })-           = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs))-             -- See Note [Suppress redundant givens during error reporting]-             -- for why we use mkMinimalBySCs above.-                2 (sep [ text "bound by" <+> ppr skol_info-                       , text "at" <+> ppr (getCtLocEnvLoc (ic_env implic)) ])--{- *********************************************************************-*                                                                      *-                       CtOrigin information-*                                                                      *-**********************************************************************-}--levelString :: TypeOrKind -> String-levelString TypeLevel = "type"-levelString KindLevel = "kind"--pprArising :: CtLoc -> SDoc--- Used for the main, top-level error message--- We've done special processing for TypeEq, KindEq, givens-pprArising ct_loc-  | in_generated_code = empty  -- See Note ["Arising from" messages in generated code]-  | suppress_origin   = empty-  | otherwise         = pprCtOrigin orig-  where-    orig = ctLocOrigin ct_loc-    in_generated_code = ctLocEnvInGeneratedCode (ctLocEnv ct_loc)-    suppress_origin-      | isGivenOrigin orig = True-      | otherwise          = case orig of-          TypeEqOrigin {}         -> True -- We've done special processing-          KindEqOrigin {}         -> True -- for TypeEq, KindEq, givens-          AmbiguityCheckOrigin {} -> True -- The "In the ambiguity check" context-                                          -- is sufficient; more would be repetitive-          _ -> False---- Add the "arising from..." part to a message-addArising :: CtLoc -> SDoc -> SDoc-addArising ct_loc msg = hang msg 2 (pprArising ct_loc)--pprWithArising :: [Ct] -> SDoc--- Print something like---    (Eq a) arising from a use of x at y---    (Show a) arising from a use of p at q--- Also return a location for the error message--- Works for Wanted/Derived only-pprWithArising []-  = panic "pprWithArising"-pprWithArising (ct:cts)-  | null cts-  = addArising loc (pprTheta [ctPred ct])-  | otherwise-  = vcat (map ppr_one (ct:cts))-  where-    loc = ctLoc ct-    ppr_one ct' = hang (parens (pprType (ctPred ct')))-                     2 (pprCtLoc (ctLoc ct'))--{- Note ["Arising from" messages in generated code]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider code generated when we desugar code before typechecking;-see Note [Rebindable syntax and XXExprGhcRn].--In this code, constraints may be generated, but we don't want to-say "arising from a call of foo" if 'foo' doesn't appear in the-users code.  We leave the actual CtOrigin untouched (partly because-it is generated in many, many places), but suppress the "Arising from"-message for constraints that originate in generated code.--}---{- *********************************************************************-*                                                                      *-                           SkolemInfo-*                                                                      *-**********************************************************************-}---tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo-tidySkolemInfo env (SkolemInfo u sk_anon) = SkolemInfo u (tidySkolemInfoAnon env sk_anon)-------------------tidySkolemInfoAnon :: TidyEnv -> SkolemInfoAnon -> SkolemInfoAnon-tidySkolemInfoAnon env (DerivSkol ty)         = DerivSkol (tidyType env ty)-tidySkolemInfoAnon env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs-tidySkolemInfoAnon env (InferSkol ids)        = InferSkol (mapSnd (tidyType env) ids)-tidySkolemInfoAnon env (UnifyForAllSkol ty)   = UnifyForAllSkol (tidyType env ty)-tidySkolemInfoAnon _   info                   = info--tidySigSkol :: TidyEnv -> UserTypeCtxt-            -> TcType -> [(Name,TcTyVar)] -> SkolemInfoAnon--- We need to take special care when tidying SigSkol--- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin"-tidySigSkol env cx ty tv_prs-  = SigSkol cx (tidy_ty env ty) tv_prs'-  where-    tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs-    inst_env = mkNameEnv tv_prs'--    tidy_ty env (ForAllTy (Bndr tv vis) ty)-      = ForAllTy (Bndr tv' vis) (tidy_ty env' ty)-      where-        (env', tv') = tidy_tv_bndr env tv--    tidy_ty env ty@(FunTy { ft_mult = w, ft_arg = arg, ft_res = res })-      = -- Look under  c => t and t1 -> t2-        ty { ft_mult = tidy_ty env w-           , ft_arg  = tidyType env arg-           , ft_res  = tidy_ty env res }--    tidy_ty env ty = tidyType env ty--    tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)-    tidy_tv_bndr env@(occ_env, subst) tv-      | Just tv' <- lookupNameEnv inst_env (tyVarName tv)-      = ((occ_env, extendVarEnv subst tv tv'), tv')--      | otherwise-      = tidyVarBndr env tv--pprSkols :: SolverReportErrCtxt -> [(SkolemInfoAnon, [TcTyVar])] -> SDoc-pprSkols ctxt zonked_ty_vars-  =-      let tidy_ty_vars = map (bimap (tidySkolemInfoAnon (cec_tidy ctxt)) id) zonked_ty_vars-      in vcat (map pp_one tidy_ty_vars)-  where--    no_msg = text "No skolem info - we could not find the origin of the following variables" <+> ppr zonked_ty_vars-       $$ text "This should not happen, please report it as a bug following the instructions at:"-       $$ text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug"---    pp_one (UnkSkol cs, tvs)-      = vcat [ hang (pprQuotedList tvs)-                 2 (is_or_are tvs "a" "(rigid, skolem)")-             , nest 2 (text "of unknown origin")-             , nest 2 (text "bound at" <+> ppr (skolsSpan tvs))-             , no_msg-             , prettyCallStackDoc cs-             ]-    pp_one (RuntimeUnkSkol, tvs)-      = hang (pprQuotedList tvs)-           2 (is_or_are tvs "an" "unknown runtime")-    pp_one (skol_info, tvs)-      = vcat [ hang (pprQuotedList tvs)-                  2 (is_or_are tvs "a"  "rigid" <+> text "bound by")-             , nest 2 (pprSkolInfo skol_info)-             , nest 2 (text "at" <+> ppr (skolsSpan tvs)) ]--    is_or_are [_] article adjective = text "is" <+> text article <+> text adjective-                                      <+> text "type variable"-    is_or_are _   _       adjective = text "are" <+> text adjective-                                      <+> text "type variables"--skolsSpan :: [TcTyVar] -> SrcSpan-skolsSpan skol_tvs = foldr1 combineSrcSpans (map getSrcSpan skol_tvs)--{- *********************************************************************-*                                                                      *-                Utilities for expected/actual messages-*                                                                      *-**********************************************************************-}--mk_supplementary_ea_msg :: SolverReportErrCtxt -> TypeOrKind-                        -> 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)-  = mk_ea_msg ctxt Nothing level orig-  | otherwise-  = Left []--ea_looks_same :: Type -> Type -> Type -> Type -> Bool--- True if the faulting types (ty1, ty2) look the same as--- the expected/actual types (exp, act).--- If so, we don't want to redundantly report the latter-ea_looks_same ty1 ty2 exp act-  = (act `looks_same` ty1 && exp `looks_same` ty2) ||-    (exp `looks_same` ty1 && act `looks_same` ty2)-  where-    looks_same t1 t2 = t1 `pickyEqType` t2-                    || t1 `eqType` liftedTypeKind && t2 `eqType` liftedTypeKind-      -- pickyEqType is sensitive to synonyms, so only replies True-      -- when the types really look the same.  However,-      -- (TYPE 'LiftedRep) and Type both print the same way.--mk_ea_msg :: SolverReportErrCtxt -> Maybe ErrorItem -> TypeOrKind-          -> 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)-mk_ea_msg ctxt at_top level-  (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing })-  | Just thing <- mb_thing-  , KindLevel <- level-  = Right $ KindMismatch { kmismatch_what     = thing-                         , kmismatch_expected = exp-                         , kmismatch_actual   = act }-  | Just item <- at_top-  , 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-    then [ea,ea_expanded]-    else [ea]--  where-    ea = ExpectedActual { ea_expected = exp, ea_actual = act }-    ea_expanded =-      ExpectedActualAfterTySynExpansion-        { ea_expanded_expected = expTy1-        , ea_expanded_actual   = expTy2 }--    expanded_syns = cec_expand_syns ctxt-                 && not (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act)-    (expTy1, expTy2) = expandSynonymsToMatch exp act-mk_ea_msg _ _ _ _ = Left []--{- Note [Expanding type synonyms to make types similar]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--In type error messages, if -fprint-expanded-types is used, we want to expand-type synonyms to make expected and found types as similar as possible, but we-shouldn't expand types too much to make type messages even more verbose and-harder to understand. The whole point here is to make the difference in expected-and found types clearer.--`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms-only as much as necessary. Given two types t1 and t2:--  * If they're already same, it just returns the types.--  * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are-    type constructors), it expands C1 and C2 if they're different type synonyms.-    Then it recursively does the same thing on expanded types. If C1 and C2 are-    same, then it applies the same procedure to arguments of C1 and arguments of-    C2 to make them as similar as possible.--    Most important thing here is to keep number of synonym expansions at-    minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3,-    Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and-    `T (T3, T3, Bool)`.--  * Otherwise types don't have same shapes and so the difference is clearly-    visible. It doesn't do any expansions and show these types.--Note that we only expand top-layer type synonyms. Only when top-layer-constructors are the same we start expanding inner type synonyms.--Suppose top-layer type synonyms of t1 and t2 can expand N and M times,-respectively. If their type-synonym-expanded forms will meet at some point (i.e.-will have same shapes according to `sameShapes` function), it's possible to find-where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M))-comparisons. We first collect all the top-layer expansions of t1 and t2 in two-lists, then drop the prefix of the longer list so that they have same lengths.-Then we search through both lists in parallel, and return the first pair of-types that have same shapes. Inner types of these two types with same shapes-are then expanded using the same algorithm.--In case they don't meet, we return the last pair of types in the lists, which-has top-layer type synonyms completely expanded. (in this case the inner types-are not expanded at all, as the current form already shows the type error)--}---- | Expand type synonyms in given types only enough to make them as similar as--- possible. Returned types are the same in terms of used type synonyms.------ To expand all synonyms, see 'Type.expandTypeSynonyms'.------ See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for--- some examples of how this should work.-expandSynonymsToMatch :: Type -> Type -> (Type, Type)-expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret)-  where-    (ty1_ret, ty2_ret) = go ty1 ty2--    -- Returns (type synonym expanded version of first type,-    --          type synonym expanded version of second type)-    go :: Type -> Type -> (Type, Type)-    go t1 t2-      | t1 `pickyEqType` t2 =-        -- Types are same, nothing to do-        (t1, t2)--    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)-      | tc1 == tc2-      , tys1 `equalLength` tys2 =-        -- Type constructors are same. They may be synonyms, but we don't-        -- expand further. The lengths of tys1 and tys2 must be equal;-        -- for example, with type S a = a, we don't want-        -- to zip (S Monad Int) and (S Bool).-        let (tys1', tys2') =-              unzip (zipWithEqual "expandSynonymsToMatch" go tys1 tys2)-         in (TyConApp tc1 tys1', TyConApp tc2 tys2')--    go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) =-      let (t1_1', t2_1') = go t1_1 t2_1-          (t1_2', t2_2') = go t1_2 t2_2-       in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2')--    go ty1@(FunTy _ w1 t1_1 t1_2) ty2@(FunTy _ w2 t2_1 t2_2) | w1 `eqType` w2 =-      let (t1_1', t2_1') = go t1_1 t2_1-          (t1_2', t2_2') = go t1_2 t2_2-       in ( ty1 { ft_arg = t1_1', ft_res = t1_2' }-          , ty2 { ft_arg = t2_1', ft_res = t2_2' })--    go (ForAllTy b1 t1) (ForAllTy b2 t2) =-      -- NOTE: We may have a bug here, but we just can't reproduce it easily.-      -- See D1016 comments for details and our attempts at producing a test-      -- case. Short version: We probably need RnEnv2 to really get this right.-      let (t1', t2') = go t1 t2-       in (ForAllTy b1 t1', ForAllTy b2 t2')--    go (CastTy ty1 _) ty2 = go ty1 ty2-    go ty1 (CastTy ty2 _) = go ty1 ty2--    go t1 t2 =-      -- See Note [Expanding type synonyms to make types similar] for how this-      -- works-      let-        t1_exp_tys = t1 : tyExpansions t1-        t2_exp_tys = t2 : tyExpansions t2-        t1_exps    = length t1_exp_tys-        t2_exps    = length t2_exp_tys-        dif        = abs (t1_exps - t2_exps)-      in-        followExpansions $-          zipEqual "expandSynonymsToMatch.go"-            (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys)-            (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys)--    -- Expand the top layer type synonyms repeatedly, collect expansions in a-    -- list. The list does not include the original type.-    ---    -- Example, if you have:-    ---    --   type T10 = T9-    --   type T9  = T8-    --   ...-    --   type T0  = Int-    ---    -- `tyExpansions T10` returns [T9, T8, T7, ..., Int]-    ---    -- This only expands the top layer, so if you have:-    ---    --   type M a = Maybe a-    ---    -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded)-    tyExpansions :: Type -> [Type]-    tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` coreView t)--    -- Drop the type pairs until types in a pair look alike (i.e. the outer-    -- constructors are the same).-    followExpansions :: [(Type, Type)] -> (Type, Type)-    followExpansions [] = pprPanic "followExpansions" empty-    followExpansions [(t1, t2)]-      | sameShapes t1 t2 = go t1 t2 -- expand subtrees-      | otherwise        = (t1, t2) -- the difference is already visible-    followExpansions ((t1, t2) : tss)-      -- Traverse subtrees when the outer shapes are the same-      | sameShapes t1 t2 = go t1 t2-      -- Otherwise follow the expansions until they look alike-      | otherwise = followExpansions tss--    sameShapes :: Type -> Type -> Bool-    sameShapes AppTy{}          AppTy{}          = True-    sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2-    sameShapes (FunTy {})       (FunTy {})       = True-    sameShapes (ForAllTy {})    (ForAllTy {})    = True-    sameShapes (CastTy ty1 _)   ty2              = sameShapes ty1 ty2-    sameShapes ty1              (CastTy ty2 _)   = sameShapes ty1 ty2-    sameShapes _                _                = False--{--************************************************************************-*                                                                      *-\subsection{Contexts for renaming errors}-*                                                                      *-************************************************************************--}--inHsDocContext :: HsDocContext -> SDoc-inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt--pprHsDocContext :: HsDocContext -> SDoc-pprHsDocContext (GenericCtx doc)      = doc-pprHsDocContext (TypeSigCtx doc)      = text "the type signature for" <+> doc-pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc-pprHsDocContext PatCtx                = text "a pattern type-signature"-pprHsDocContext SpecInstSigCtx        = text "a SPECIALISE instance pragma"-pprHsDocContext DefaultDeclCtx        = text "a `default' declaration"-pprHsDocContext DerivDeclCtx          = text "a deriving declaration"-pprHsDocContext (RuleCtx name)        = text "the rewrite rule" <+> doubleQuotes (ftext name)-pprHsDocContext (TyDataCtx tycon)     = text "the data type declaration for" <+> quotes (ppr tycon)-pprHsDocContext (FamPatCtx tycon)     = text "a type pattern of family instance for" <+> quotes (ppr tycon)-pprHsDocContext (TySynCtx name)       = text "the declaration for type synonym" <+> quotes (ppr name)-pprHsDocContext (TyFamilyCtx name)    = text "the declaration for type family" <+> quotes (ppr name)-pprHsDocContext (ClassDeclCtx name)   = text "the declaration for class" <+> quotes (ppr name)-pprHsDocContext ExprWithTySigCtx      = text "an expression type signature"-pprHsDocContext TypBrCtx              = text "a Template-Haskell quoted type"-pprHsDocContext HsTypeCtx             = text "a type argument"-pprHsDocContext HsTypePatCtx          = text "a type argument in a pattern"-pprHsDocContext GHCiCtx               = text "GHCi input"-pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty)-pprHsDocContext ClassInstanceCtx      = text "GHC.Tc.Gen.Splice.reifyInstances"--pprHsDocContext (ForeignDeclCtx name)-   = text "the foreign declaration for" <+> quotes (ppr name)-pprHsDocContext (ConDeclCtx [name])-   = text "the definition of data constructor" <+> quotes (ppr name)-pprHsDocContext (ConDeclCtx names)-   = text "the definition of data constructors" <+> interpp'SP names--pprConversionFailReason :: ConversionFailReason -> SDoc-pprConversionFailReason = \case-  IllegalOccName ctxt_ns occ ->-    text "Illegal" <+> pprNameSpace ctxt_ns-    <+> text "name:" <+> quotes (text occ)-  SumAltArityExceeded alt arity ->-    text "Sum alternative" <+> int alt-    <+> text "exceeds its arity," <+> int arity-  IllegalSumAlt alt ->-    vcat [ text "Illegal sum alternative:" <+> int alt-         , nest 2 $ text "Sum alternatives must start from 1" ]-  IllegalSumArity arity ->-    vcat [ text "Illegal sum arity:" <+> int arity-         , nest 2 $ text "Sums must have an arity of at least 2" ]-  MalformedType typeOrKind ty ->-    text "Malformed " <> text ty_str <+> text (show ty)-    where ty_str = case typeOrKind of-                     TypeLevel -> "type"-                     KindLevel -> "kind"-  IllegalLastStatement do_or_lc stmt ->-    vcat [ text "Illegal last statement of" <+> pprAHsDoFlavour do_or_lc <> colon-         , nest 2 $ ppr stmt-         , text "(It should be an expression.)" ]-  KindSigsOnlyAllowedOnGADTs ->-    text "Kind signatures are only allowed on GADTs"-  IllegalDeclaration declDescr bad_decls ->-    sep [ text "Illegal" <+> what <+> text "in" <+> descrDoc <> colon-        , nest 2 bads ]-    where-      (what, bads) = case bad_decls of-        IllegalDecls (NE.toList -> decls) ->-            (text "declaration" <> plural decls, vcat $ map ppr decls)-        IllegalFamDecls (NE.toList -> decls) ->-            ( text "family declaration" <> plural decls, vcat $ map ppr decls)-      descrDoc = text $ case declDescr of-                   InstanceDecl -> "an instance declaration"-                   WhereClause -> "a where clause"-                   LetBinding -> "a let expression"-                   LetExpression -> "a let expression"-                   ClssDecl -> "a class declaration"-  CannotMixGADTConsWith98Cons ->-    text "Cannot mix GADT constructors with Haskell 98"-    <+> text "constructors"-  EmptyStmtListInDoBlock ->-    text "Empty stmt list in do-block"-  NonVarInInfixExpr ->-    text "Non-variable expression is not allowed in an infix expression"-  MultiWayIfWithoutAlts ->-    text "Multi-way if-expression with no alternatives"-  CasesExprWithoutAlts ->-    text "\\cases expression with no alternatives"-  ImplicitParamsWithOtherBinds ->-    text "Implicit parameters mixed with other bindings"-  InvalidCCallImpent from ->-    text (show from) <+> text "is not a valid ccall impent"-  RecGadtNoCons ->-    quotes (text "RecGadtC") <+> text "must have at least one constructor name"-  GadtNoCons ->-    quotes (text "GadtC") <+> text "must have at least one constructor name"-  InvalidTypeInstanceHeader tys ->-    text "Invalid type instance header:"-    <+> text (show tys)-  InvalidTyFamInstLHS lhs ->-    text "Invalid type family instance LHS:"-    <+> text (show lhs)-  InvalidImplicitParamBinding ->-    text "Implicit parameter binding only allowed in let or where"-  DefaultDataInstDecl adts ->-    (text "Default data instance declarations"-    <+> text "are not allowed:")-      $$ ppr adts-  FunBindLacksEquations nm ->-    text "Function binding for"-    <+> quotes (text (TH.pprint nm))-    <+> text "has no equations"--pprTyThingUsedWrong :: WrongThingSort -> TcTyThing -> Name -> SDoc-pprTyThingUsedWrong sort thing name =-  pprTcTyThingCategory thing <+> quotes (ppr name) <+>-  text "used as a" <+> pprWrongThingSort sort--pprWrongThingSort :: WrongThingSort -> SDoc-pprWrongThingSort =-  text . \case-    WrongThingType -> "type"-    WrongThingDataCon -> "data constructor"-    WrongThingPatSyn -> "pattern synonym"-    WrongThingConLike -> "constructor-like thing"-    WrongThingClass -> "class"-    WrongThingTyCon -> "type constructor"-    WrongThingAxiom -> "axiom"--pprStageCheckReason :: StageCheckReason -> SDoc-pprStageCheckReason = \case-  StageCheckInstance _ t ->-    text "instance for" <+> quotes (ppr t)-  StageCheckSplice t ->-    quotes (ppr t)--pprUninferrableTyVarCtx :: UninferrableTyVarCtx -> SDoc-pprUninferrableTyVarCtx = \case-  UninfTyCtx_ClassContext theta ->-    sep [ text "the class context:", pprTheta theta ]-  UninfTyCtx_DataContext theta ->-    sep [ text "the datatype context:", pprTheta theta ]-  UninfTyCtx_ProvidedContext theta ->-    sep [ text "the provided context:" , pprTheta theta ]-  UninfTyCtx_TyFamRhs rhs_ty ->-    sep [ text "the type family equation right-hand side:" , ppr rhs_ty ]-  UninfTyCtx_TySynRhs rhs_ty ->-    sep [ text "the type synonym right-hand side:" , ppr rhs_ty ]-  UninfTyCtx_Sig exp_kind full_hs_ty ->-    hang (text "the kind" <+> ppr exp_kind) 2-         (text "of the type signature:" <+> ppr full_hs_ty)--pprPatSynInvalidRhsReason :: PatSynInvalidRhsReason -> SDoc-pprPatSynInvalidRhsReason = \case-  PatSynNotInvertible p ->-    text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"-  PatSynUnboundVar var ->-    quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym"--pprBadFieldAnnotationReason :: BadFieldAnnotationReason -> SDoc-pprBadFieldAnnotationReason = \case-  LazyFieldsDisabled ->-    text "Lazy field annotations (~) are disabled"-  UnpackWithoutStrictness ->-    text "UNPACK pragma lacks '!'"-  BackpackUnpackAbstractType ->-    text "Ignoring unusable UNPACK pragma"--pprSuperclassCycleDetail :: SuperclassCycleDetail -> SDoc-pprSuperclassCycleDetail = \case-  SCD_HeadTyVar pred ->-    hang (text "one of whose superclass constraints is headed by a type variable:")-       2 (quotes (ppr pred))-  SCD_HeadTyFam pred ->-    hang (text "one of whose superclass constraints is headed by a type family:")-       2 (quotes (ppr pred))-  SCD_Superclass cls ->-    text "one of whose superclasses is" <+> quotes (ppr cls)--pprRoleValidationFailedReason :: Role -> RoleValidationFailedReason -> SDoc-pprRoleValidationFailedReason role = \case-  TyVarRoleMismatch tv role' ->-    text "type variable" <+> quotes (ppr tv) <+>-    text "cannot have role" <+> ppr role <+>-    text "because it was assigned role" <+> ppr role'-  TyVarMissingInEnv tv ->-    text "type variable" <+> quotes (ppr tv) <+> text "missing in environment"-  BadCoercionRole co ->-    text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role--pprDisabledClassExtension :: Class -> DisabledClassExtension -> SDoc-pprDisabledClassExtension cls = \case-  MultiParamDisabled n ->-    text howMany <+> text "parameters for class" <+> quotes (ppr cls)-    where-      howMany | n == 0 = "No"-              | otherwise = "Too many"-  FunDepsDisabled ->-    text "Fundeps in class" <+> quotes (ppr cls)-  ConstrainedClassMethodsDisabled sel_id pred ->-    vcat [ hang (text "Constraint" <+> quotes (ppr pred)-                 <+> text "in the type of" <+> quotes (ppr sel_id))-              2 (text "constrains only the class type variables")]--pprImportLookup :: ImportLookupReason -> SDoc-pprImportLookup = \case-  ImportLookupBad k iface decl_spec ie _ps ->-    let-      pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc-      pprImpDeclSpec iface decl_spec =-        quotes (ppr (moduleName $ is_mod decl_spec)) <+> case mi_boot iface of-            IsBoot  -> text "(hi-boot interface)"-            NotBoot -> empty-      withContext msgs =-        hang (text "In the import of" <+> pprImpDeclSpec iface decl_spec <> colon)-          2 (vcat msgs)-    in case k of-      BadImportNotExported _ ->-        vcat-          [ text "Module" <+> pprImpDeclSpec iface decl_spec <+>-            text "does not export" <+> quotes (ppr ie) <> dot-          ]-      BadImportAvailVar ->-        withContext-          [ text "an item called"-              <+> quotes val <+> text "is exported, but it is not a type."-          ]-        where-          val_occ = rdrNameOcc $ ieName ie-          val = parenSymOcc val_occ (ppr val_occ)-      BadImportAvailTyCon {} ->-        withContext-          [ text "an item called"-            <+> quotes tycon <+> text "is exported, but it is a type."-          ]-        where-          tycon_occ = rdrNameOcc $ ieName ie-          tycon = parenSymOcc tycon_occ (ppr tycon_occ)-      BadImportNotExportedSubordinates ns ->-        withContext-          [ text "an item called" <+> quotes sub <+> text "is exported, but it does not export any children"-          , text "(constructors, class methods or field names) called"-          <+> pprWithCommas (quotes . ppr) ns <> dot-          ]-          where-            sub_occ = rdrNameOcc $ ieName ie-            sub = parenSymOcc sub_occ (ppr sub_occ)-      BadImportAvailDataCon dataType_occ ->-        withContext-          [ text "an item called" <+> quotes datacon-          , text "is exported, but it is a data constructor of"-          , quotes dataType <> dot-          ]-          where-            datacon_occ = rdrNameOcc $ ieName ie-            datacon = parenSymOcc datacon_occ (ppr datacon_occ)-            dataType = parenSymOcc dataType_occ (ppr dataType_occ)-  ImportLookupQualified rdr ->-    hang (text "Illegal qualified name in import item:")-       2 (ppr rdr)-  ImportLookupIllegal ->-    text "Illegal import item"-  ImportLookupAmbiguous rdr gres ->-    hang (text "Ambiguous name" <+> quotes (ppr rdr) <+> text "in import item. It could refer to:")-       2 (vcat (map (ppr . greOccName) gres))--pprUnusedImport :: ImportDecl GhcRn -> UnusedImportReason -> SDoc-pprUnusedImport decl = \case-  UnusedImportNone ->-    vcat [ pp_herald <+> quotes pp_mod <+> text "is redundant"-         , nest 2 (text "except perhaps to import instances from"-                   <+> quotes pp_mod)-         , text "To import instances alone, use:"-           <+> text "import" <+> pp_mod <> parens empty ]-  UnusedImportSome sort_unused ->-    sep [ pp_herald <+> quotes (pprWithCommas pp_unused sort_unused)-        , text "from module" <+> quotes pp_mod <+> text "is redundant"]-  where-    pp_mod = ppr (unLoc (ideclName decl))-    pp_herald = text "The" <+> pp_qual <+> text "import of"-    pp_qual-      | isImportDeclQualified (ideclQualified decl) = text "qualified"-      | otherwise                                   = empty-    pp_unused = \case-      UnusedImportNameRegular n ->-        pprNameUnqualified n-      UnusedImportNameRecField par fld_occ ->-        case par of-          ParentIs p -> pprNameUnqualified p <> parens (ppr fld_occ)-          NoParent   -> ppr fld_occ--pprUnusedName :: OccName -> UnusedNameProv -> SDoc-pprUnusedName name reason =-  sep [ msg <> colon-      , nest 2 $ pprNonVarNameSpace (occNameSpace name)-                 <+> quotes (ppr name)]-  where-    msg = case reason of-      UnusedNameTopDecl ->-        defined-      UnusedNameImported mod ->-        text "Imported from" <+> quotes (ppr mod) <+> text "but not used"-      UnusedNameTypePattern ->-        defined <+> text "on the right hand side"-      UnusedNameMatch ->-        defined-      UnusedNameLocalBind ->-        defined-    defined = text "Defined but not used"---- When printing the name, take care to qualify it in the same--- way as the provenance reported by pprNameProvenance, namely--- the head of 'gre_imp'.  Otherwise we get confusing reports like---   Ambiguous occurrence ‘null’---   It could refer to either ‘T15487a.null’,---                            imported from ‘Prelude’ at T15487.hs:1:8-13---                     or ...--- See #15487-pprAmbiguousGreName :: GlobalRdrEnv -> GlobalRdrElt -> SDoc-pprAmbiguousGreName gre_env gre-  | IAmRecField fld_info <- greInfo gre-  = sep [ text "the field" <+> quotes (ppr occ) <+> parent_info fld_info <> comma-        , pprNameProvenance gre ]-  | otherwise-  = sep [ quotes (pp_qual <> dot <> ppr occ) <> comma-        , pprNameProvenance gre ]--  where-    occ = greOccName gre-    parent_info fld_info =-      case first_con of-        PatSynName  ps -> text "of pattern synonym" <+> quotes (ppr ps)-        DataConName {} ->-          case greParent gre of-            ParentIs par-              -- For a data family, only reporting the family TyCon can be-              -- unhelpful (see T23301). So we give a bit of additional-              -- info in that case.-              | Just par_gre <- lookupGRE_Name gre_env par-              , IAmTyCon tc_flav <- greInfo par_gre-              , OpenFamilyFlavour IAmData _ <- tc_flav-              -> vcat [ ppr_cons-                      , text "in a data family instance of" <+> quotes (ppr par) ]-              | otherwise-              -> text "of record" <+> quotes (ppr par)-            NoParent -> ppr_cons-      where-        cons :: [ConLikeName]-        cons = nonDetEltsUniqSet $ recFieldCons fld_info-        first_con :: ConLikeName-        first_con = head cons-        ppr_cons :: SDoc-        ppr_cons = hsep [ text "belonging to data constructor"-                        , quotes (ppr $ nameOccName $ conLikeName_Name first_con)-                        , if length cons > 1 then parens (text "among others") else empty-                        ]-    pp_qual-        | gre_lcl gre-        = ppr (nameModule $ greName gre)-        | Just imp  <- headMaybe $ gre_imp gre-            -- This 'imp' is the one that-            -- pprNameProvenance chooses-        , ImpDeclSpec { is_as = mod } <- is_decl imp-        = ppr mod-        | otherwise-        = pprPanic "addNameClassErrRn" (ppr gre)-          -- Invariant: either 'lcl' is True or 'iss' is non-empty--pprNonCanonicalDefinition :: LHsSigType GhcRn-                          -> NonCanonicalDefinition-                          -> SDoc-pprNonCanonicalDefinition inst_ty = \case-  NonCanonicalMonoid sub -> case sub of-    NonCanonical_Sappend ->-      msg1 "(<>)" "mappend"-    NonCanonical_Mappend ->-      msg2 "mappend" "(<>)"-  NonCanonicalMonad sub -> case sub of-    NonCanonical_Pure ->-      msg1 "pure" "return"-    NonCanonical_ThenA ->-      msg1 "(*>)" "(>>)"-    NonCanonical_Return ->-      msg2 "return" "pure"-    NonCanonical_ThenM ->-      msg2 "(>>)" "(*>)"-  where-    msg1 :: String -> String -> SDoc-    msg1 lhs rhs =-      vcat [ text "Noncanonical" <+>-            quotes (text (lhs ++ " = " ++ rhs)) <+>-            text "definition detected"-          , inst-          ]--    msg2 :: String -> String -> SDoc-    msg2 lhs rhs =-      vcat [ text "Noncanonical" <+>-            quotes (text lhs) <+>-            text "definition detected"-          , inst-          , quotes (text lhs) <+>-            text "will eventually be removed in favour of" <+>-            quotes (text rhs)-          ]--    inst = instDeclCtxt1 inst_ty--    -- stolen from GHC.Tc.TyCl.Instance-    instDeclCtxt1 :: LHsSigType GhcRn -> SDoc-    instDeclCtxt1 hs_inst_ty-      = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))--    inst_decl_ctxt :: SDoc -> SDoc-    inst_decl_ctxt doc = hang (text "in the instance declaration for")-                         2 (quotes doc <> text ".")--suggestNonCanonicalDefinition :: NonCanonicalDefinition -> [GhcHint]-suggestNonCanonicalDefinition reason =-  [action doc]-  where-    action = case reason of-      NonCanonicalMonoid sub -> case sub of-        NonCanonical_Sappend -> move sappendName mappendName-        NonCanonical_Mappend -> remove mappendName sappendName-      NonCanonicalMonad sub -> case sub of-        NonCanonical_Pure -> move pureAName returnMName-        NonCanonical_ThenA -> move thenAName thenMName-        NonCanonical_Return -> remove returnMName pureAName-        NonCanonical_ThenM -> remove thenMName thenAName--    move = SuggestMoveNonCanonicalDefinition-    remove = SuggestRemoveNonCanonicalDefinition--    doc = case reason of-      NonCanonicalMonoid _ -> doc_monoid-      NonCanonicalMonad _ -> doc_monad--    doc_monoid =-      "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid"-    doc_monad =-      "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return"--suggestDefaultDeclaration :: Class-> [Type] -> [[Type]] -> [GhcHint]-suggestDefaultDeclaration cls prefix seqs =-  [SuggestDefaultDeclaration cls $ supersequence (prefix : seqs)]-  where-    -- Not exactly the shortest possible supersequence, but it preserves-    -- the head sequence as the prefix of the result which is a requirement.-    supersequence :: [[Type]] -> [Type]-    supersequence [] = []-    supersequence ([] : seqs) = supersequence seqs-    supersequence ((x : xs) : seqs) =-      x : supersequence (xs : (dropHead x <$> seqs))-    dropHead x ys@(y : ys')-      | tcEqType x y = ys'-      | otherwise = ys-    dropHead _ [] = []------------------------------------------------------------------------------------- hs-boot mismatch errors--pprBootMismatch :: HsBootOrSig -> BootMismatch -> SDoc-pprBootMismatch boot_or_sig = \case-  MissingBootThing nm err ->-    let def_or_exp = case err of-          MissingBootDefinition -> text "defined in"-          MissingBootExport     -> text "exported by"-    in quotes (ppr nm) <+> text "is exported by the"-       <+> ppr_boot_or_sig <> comma-       <+> text "but not"-       <+> def_or_exp <+> text "the implementing module."-  MissingBootInstance boot_dfun ->-    hang (text "instance" <+> ppr (idType boot_dfun))-       2 (text "is defined in the" <+> ppr ppr_boot_or_sig <> comma <+>-          text "but not in the implementing module.")-  BadReexportedBootThing name name' ->-    withUserStyle alwaysQualify AllTheWay $ vcat-        [ text "The" <+> ppr_boot_or_sig-           <+> text "(re)exports" <+> quotes (ppr name)-        , text "but the implementing module exports a different identifier" <+> quotes (ppr name')-        ]-  BootMismatch boot_thing real_thing err ->-    vcat-      [ ppr real_thing <+>-        text "has conflicting definitions in the module"-      , text "and its" <+> ppr_boot_or_sig <> dot,-                    text "Main module:" <+> real_doc-      , (case boot_or_sig of-          HsBoot -> text "  Boot file:"-          Hsig   -> text "  Hsig file:") <+> boot_doc-      , pprBootMismatchWhat boot_or_sig err-      ]-      where-        to_doc-          = pprTyThingInContext $-            showToHeader-              { ss_forall =-                  case boot_or_sig of-                    HsBoot -> ShowForAllMust-                    Hsig   -> ShowForAllWhen }--        real_doc = to_doc real_thing-        boot_doc = to_doc boot_thing--  where-    ppr_boot_or_sig = case boot_or_sig of-      HsBoot -> text "hs-boot file"-      Hsig   -> text "hsig file"---pprBootMismatchWhat :: HsBootOrSig -> BootMismatchWhat -> SDoc-pprBootMismatchWhat boot_or_sig = \case-  BootMismatchedIdTypes {} ->-    text "The two types are different."-  BootMismatchedTyCons tc1 tc2 errs ->-    vcat $ map (pprBootTyConMismatch boot_or_sig tc1 tc2) (NE.toList errs)--pprBootTyConMismatch :: HsBootOrSig -> TyCon -> TyCon-                     -> BootTyConMismatch -> SDoc-pprBootTyConMismatch boot_or_sig tc1 tc2 = \case-  TyConKindMismatch ->-    text "The types have different kinds."-  TyConRoleMismatch sub_type ->-    if sub_type-    then-      text "The roles are not compatible:" $$-      text "Main module:" <+> ppr (tyConRoles tc1) $$-      text "  Hsig file:" <+> ppr (tyConRoles tc2)-    else-      text "The roles do not match." $$-      if boot_or_sig == HsBoot-      then note $ "Roles on abstract types default to" <+> quotes "representational" <+> "in hs-boot files"-      else empty-  TyConSynonymMismatch {} -> empty -- nothing interesting to say-  TyConFlavourMismatch fam_flav1 fam_flav2 ->-    whenPprDebug $-      text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+>-      text "do not match"-  TyConAxiomMismatch ax_errs ->-    pprBootListMismatches (text "Type family equations do not match:")-      pprTyConAxiomMismatch ax_errs-  TyConInjectivityMismatch {} ->-    text "Injectivity annotations do not match"-  TyConMismatchedClasses _ _ err ->-    pprBootClassMismatch boot_or_sig err-  TyConMismatchedData _rhs1 _rhs2 err ->-    pprBootDataMismatch err-  SynAbstractData err ->-    pprSynAbstractDataError err-  TyConsVeryDifferent ->-    empty -- should be obvious to the user what the problem is--pprSynAbstractDataError :: SynAbstractDataError -> SDoc-pprSynAbstractDataError = \case-  SynAbsDataTySynNotNullary ->-    text "Illegal parameterized type synonym in implementation of abstract data."-  SynAbstractDataInvalidRHS bad_sub_tys ->-    let msgs = mapMaybe pprInvalidAbstractSubTy (NE.toList bad_sub_tys)-    in  case msgs of-      []     -> herald <> dot-      msg:[] -> hang (herald <> colon)-                   2 msg-      _      -> hang (herald <> colon)-                   2 (vcat $ map (<+> bullet) msgs)--  where-    herald = text "Illegal implementation of abstract data"-    pprInvalidAbstractSubTy = \case-      TyConApp tc _-        -> assertPpr (isTypeFamilyTyCon tc) (ppr tc) $-           Just $ text "Invalid type family" <+> quotes (ppr tc) <> dot-      ty@(ForAllTy {})-        -> Just $ text "Invalid polymorphic type" <> colon <+> ppr ty <> dot-      ty@(FunTy af _ _ _)-        | not (af == FTF_T_T)-        -> Just $ text "Invalid qualified type" <> colon <+> ppr ty <> dot-      _ -> Nothing--pprTyConAxiomMismatch :: BootListMismatch CoAxBranch BootAxiomBranchMismatch -> SDoc-pprTyConAxiomMismatch = \case-  MismatchedLength ->-    text "The number of equations differs."-  MismatchedThing i br1 br2 err ->-    hang (text "The" <+> speakNth (i+1) <+> text "equations do not match.")-       2 (pprCoAxBranchMismatch br1 br2 err)--pprCoAxBranchMismatch :: CoAxBranch -> CoAxBranch -> BootAxiomBranchMismatch -> SDoc-pprCoAxBranchMismatch _br1 _br2 err =-  text "The" <+> what <+> text "don't match."-  where-    what = case err of-      MismatchedAxiomBinders -> text "variables bound in the equation"-      MismatchedAxiomLHS     -> text "equation left-hand sides"-      MismatchedAxiomRHS     -> text "equation right-hand sides"--pprBootListMismatches :: SDoc -- ^ herald-                      -> (BootListMismatch item err -> SDoc)-                      -> BootListMismatches item err -> SDoc-pprBootListMismatches herald ppr_one errs =-  hang herald 2 msgs-  where-    msgs = case errs of-      err :| [] -> ppr_one err-      _         -> vcat $ map ((bullet <+>) . ppr_one) $ NE.toList errs--pprBootClassMismatch :: HsBootOrSig -> BootClassMismatch -> SDoc-pprBootClassMismatch boot_or_sig = \case-  MismatchedMethods errs ->-    pprBootListMismatches (text "The class methods do not match:")-      pprBootClassMethodListMismatch errs-  MismatchedATs at_errs ->-    pprBootListMismatches (text "The associated types do not match:")-      (pprATMismatch boot_or_sig) at_errs-  MismatchedFunDeps ->-    text "The functional dependencies do not match."-  MismatchedSuperclasses ->-    text "The superclass constraints do not match."-  MismatchedMinimalPragmas ->-    text "The MINIMAL pragmas are not compatible."--pprATMismatch :: HsBootOrSig -> BootListMismatch ClassATItem BootATMismatch -> SDoc-pprATMismatch boot_or_sig = \case-  MismatchedLength ->-    text "The number of associated type defaults differs."-  MismatchedThing i at1 at2 err ->-    pprATMismatchErr boot_or_sig i at1 at2 err--pprATMismatchErr :: HsBootOrSig -> Int -> ClassATItem -> ClassATItem -> BootATMismatch -> SDoc-pprATMismatchErr boot_or_sig i (ATI tc1 _) (ATI tc2 _) = \case-  MismatchedTyConAT err ->-    hang (text "The associated types differ:")-       2 $ pprBootTyConMismatch boot_or_sig tc1 tc2 err-  MismatchedATDefaultType ->-    text "The types of the" <+> speakNth (i+1) <+>-    text "associated type default differ."--pprBootClassMethodListMismatch :: BootListMismatch ClassOpItem BootMethodMismatch -> SDoc-pprBootClassMethodListMismatch = \case-  MismatchedLength ->-    text "The number of class methods differs."-  MismatchedThing _ op1 op2 err ->-    pprBootClassMethodMismatch op1 op2 err--pprBootClassMethodMismatch :: ClassOpItem -> ClassOpItem -> BootMethodMismatch -> SDoc-pprBootClassMethodMismatch (op1, _) (op2, _) = \case-  MismatchedMethodNames ->-    text "The method names" <+> quotes pname1 <+> text "and"-                            <+> quotes pname2 <+> text "differ."-  MismatchedMethodTypes {} ->-    text "The types of" <+> pname1 <+> text "are different."-  MismatchedDefaultMethods subtype_check ->-    if subtype_check-    then-      text "The default methods associated with" <+> pname1 <+>-      text "are not compatible."-    else-      text "The default methods associated with" <+> pname1 <+>-      text "are different."-  where-    nm1 = idName op1-    nm2 = idName op2-    pname1 = quotes (ppr nm1)-    pname2 = quotes (ppr nm2)--pprBootDataMismatch :: BootDataMismatch -> SDoc-pprBootDataMismatch = \case-  MismatchedNewtypeVsData ->-    text "Cannot match a" <+> quotes (text "data") <+>-    text "definition with a" <+> quotes (text "newtype") <+>-    text "definition."-  MismatchedConstructors dc_errs ->-    pprBootListMismatches (text "The constructors do not match:")-      pprBootDataConMismatch dc_errs-  MismatchedDatatypeContexts {} ->-    text "The datatype contexts do not match."--pprBootDataConMismatch :: BootListMismatch DataCon BootDataConMismatch-                       -> SDoc-pprBootDataConMismatch = \case-  MismatchedLength ->-    text "The number of constructors differs."-  MismatchedThing _ dc1 dc2 err ->-    pprBootDataConMismatchErr dc1 dc2 err--pprBootDataConMismatchErr :: DataCon -> DataCon -> BootDataConMismatch -> SDoc-pprBootDataConMismatchErr dc1 dc2 = \case-  MismatchedDataConNames ->-    text "The names" <+> pname1 <+> text "and" <+> pname2 <+> text "differ."-  MismatchedDataConFixities ->-    text "The fixities of" <+> pname1 <+> text "differ."-  MismatchedDataConBangs ->-    text "The strictness annotations for" <+> pname1 <+> text "differ."-  MismatchedDataConFieldLabels ->-    text "The record label lists for" <+> pname1 <+> text "differ."-  MismatchedDataConTypes ->-    text "The types for" <+> pname1 <+> text "differ."-  where-     name1 = dataConName dc1-     name2 = dataConName dc2-     pname1 = quotes (ppr name1)-     pname2 = quotes (ppr name2)------------------------------------------------------------------------------------- Illegal instance errors--pprIllegalInstance :: IllegalInstanceReason -> SDoc-pprIllegalInstance = \case-  IllegalClassInstance head_ty reason ->-    pprIllegalClassInstanceReason head_ty reason-  IllegalFamilyInstance reason ->-    pprIllegalFamilyInstance reason-  IllegalFamilyApplicationInInstance inst_ty invis_arg tf_tc tf_args ->-    pprWithInvisibleBitsWhen invis_arg $-      hang (text "Illegal type synonym family application"-              <+> quotes (ppr tf_ty) <+> text "in instance" <> colon)-         2 (ppr inst_ty)-      where-        tf_ty = mkTyConApp tf_tc tf_args--pprIllegalClassInstanceReason :: TypedThing -> IllegalClassInstanceReason -> SDoc-pprIllegalClassInstanceReason head_ty = \case-  IllegalInstanceHead reason ->-    pprIllegalInstanceHeadReason head_ty reason-  IllegalHasFieldInstance has_field_err ->-    with_illegal_instance_header head_ty $-      pprIllegalHasFieldInstance has_field_err-  IllegalSpecialClassInstance cls because_safeHaskell ->-    text "Class" <+> quotes (ppr $ className cls)-    <+> text "does not support user-specified instances"-    <> safeHaskell_msg-      where-        safeHaskell_msg-          | because_safeHaskell-          = text " when Safe Haskell is enabled."-          | otherwise-          = dot-  IllegalInstanceFailsCoverageCondition cls coverage_failure ->-    with_illegal_instance_header head_ty $-      pprNotCovered cls coverage_failure--pprIllegalInstanceHeadReason :: TypedThing-                             -> IllegalInstanceHeadReason -> SDoc-pprIllegalInstanceHeadReason head_ty = \case-  InstHeadTySynArgs -> with_illegal_instance_header head_ty $-    text "All instance types must be of the form (T t1 ... tn)" $$-    text "where T is not a synonym."-  InstHeadNonTyVarArgs -> with_illegal_instance_header head_ty $ vcat [-    text "All instance types must be of the form (T a1 ... an)",-    text "where a1 ... an are *distinct type variables*,",-    text "and each type variable appears at most once in the instance head."]-  InstHeadMultiParam -> with_illegal_instance_header head_ty $ parens $-    text "Only one type can be given in an instance head."-  InstHeadAbstractClass clas ->-    text "Cannot define instance for abstract class" <+>-    quotes (ppr (className clas))-  InstHeadNonClass bad_head ->-    vcat [ text "Illegal" <+> what_illegal <> dot-         , text "Instance heads must be of the form"-         , nest 2 $ text "C ty_1 ... ty_n"-         , text "where" <+> quotes (char 'C') <+> text "is a class."-         ]-    where-      what_illegal = case bad_head of-        Just tc ->-          text "instance for" <+> ppr (tyConFlavour tc) <+> quotes (ppr $ tyConName tc)-        Nothing ->-          text "head of an instance declaration:" <+> quotes (ppr head_ty)--with_illegal_instance_header :: TypedThing -> SDoc -> SDoc-with_illegal_instance_header head_ty msg =-  hang (hang (text "Illegal instance declaration for")-           2 (quotes (ppr head_ty)) <> colon)-      2 msg--pprIllegalHasFieldInstance :: IllegalHasFieldInstance -> SDoc-pprIllegalHasFieldInstance = \case-  IllegalHasFieldInstanceNotATyCon-    -> text "Record data type must be specified."-  IllegalHasFieldInstanceFamilyTyCon-    -> text "Record data type may not be a data family."-  IllegalHasFieldInstanceTyConHasField tc lbl-    -> quotes (ppr tc) <+> text "already has a field" <+> quotes (ppr lbl) <> dot-  IllegalHasFieldInstanceTyConHasFields tc lbl-    -> sep [ ppr_tc <+> text "has fields, and the type" <+> quotes (ppr lbl)-           , text "could unify with one of the field labels of" <+> ppr_tc <> dot ]-    where ppr_tc = quotes (ppr tc)--pprNotCovered :: Class -> CoverageProblem -> SDoc-pprNotCovered clas-  CoverageProblem-  { not_covered_fundep        = fd-  , not_covered_fundep_inst   = (ls, rs)-  , not_covered_invis_vis_tvs = undetermined_tvs-  , not_covered_liberal       = which_cc_failed-  } =-  pprWithInvisibleBitsWhen (isEmptyVarSet $ pSnd undetermined_tvs) $-    vcat [ sep [ text "The"-                  <+> ppWhen liberal (text "liberal")-                  <+> text "coverage condition fails in class"-                  <+> quotes (ppr clas)-                , nest 2 $ text "for functional dependency:"-                  <+> quotes (pprFunDep fd) ]-          , sep [ text "Reason: lhs type" <> plural ls <+> pprQuotedList ls-                , nest 2 $-                  (if isSingleton ls-                  then text "does not"-                  else text "do not jointly")-                  <+> text "determine rhs type" <> plural rs-                  <+> pprQuotedList rs ]-          , text "Un-determined variable" <> pluralVarSet undet_set <> colon-                  <+> pprVarSet undet_set (pprWithCommas ppr)-          ]-  where-    liberal = case which_cc_failed of-                   FailedLICC   -> True-                   FailedICC {} -> False-    undet_set = fold undetermined_tvs--illegalInstanceHints :: IllegalInstanceReason -> [GhcHint]-illegalInstanceHints = \case-  IllegalClassInstance _ reason ->-    illegalClassInstanceHints reason-  IllegalFamilyInstance reason ->-    illegalFamilyInstanceHints reason-  IllegalFamilyApplicationInInstance {} ->-    noHints--illegalInstanceReason :: IllegalInstanceReason -> DiagnosticReason-illegalInstanceReason = \case-  IllegalClassInstance _ reason ->-    illegalClassInstanceReason reason-  IllegalFamilyInstance reason ->-    illegalFamilyInstanceReason reason-  IllegalFamilyApplicationInInstance {} ->-    ErrorWithoutFlag--illegalClassInstanceHints :: IllegalClassInstanceReason -> [GhcHint]-illegalClassInstanceHints = \case-  IllegalInstanceHead reason ->-    illegalInstanceHeadHints reason-  IllegalHasFieldInstance has_field_err ->-    illegalHasFieldInstanceHints has_field_err-  IllegalSpecialClassInstance {} -> noHints-  IllegalInstanceFailsCoverageCondition _ coverage_failure ->-    failedCoverageConditionHints coverage_failure---illegalClassInstanceReason :: IllegalClassInstanceReason -> DiagnosticReason-illegalClassInstanceReason = \case-  IllegalInstanceHead reason ->-    illegalInstanceHeadReason reason-  IllegalHasFieldInstance has_field_err ->-    illegalHasFieldInstanceReason has_field_err-  IllegalSpecialClassInstance {} -> ErrorWithoutFlag-  IllegalInstanceFailsCoverageCondition _ coverage_failure ->-    failedCoverageConditionReason coverage_failure--illegalInstanceHeadHints :: IllegalInstanceHeadReason -> [GhcHint]-illegalInstanceHeadHints = \case-  InstHeadTySynArgs ->-    [suggestExtension LangExt.TypeSynonymInstances]-  InstHeadNonTyVarArgs ->-    [suggestExtension LangExt.FlexibleInstances]-  InstHeadMultiParam ->-    [suggestExtension LangExt.MultiParamTypeClasses]-  InstHeadAbstractClass {} ->-    noHints-  InstHeadNonClass {} ->-    noHints--illegalInstanceHeadReason :: IllegalInstanceHeadReason -> DiagnosticReason-illegalInstanceHeadReason = \case-  -- These are serious-  InstHeadAbstractClass {} ->-    ErrorWithoutFlag-  InstHeadNonClass {} ->-    ErrorWithoutFlag--  -- These are less serious (enable an extension)-  InstHeadTySynArgs ->-    ErrorWithoutFlag-  InstHeadNonTyVarArgs ->-    ErrorWithoutFlag-  InstHeadMultiParam ->-    ErrorWithoutFlag--illegalHasFieldInstanceHints :: IllegalHasFieldInstance -> [GhcHint]-illegalHasFieldInstanceHints = \case-  IllegalHasFieldInstanceNotATyCon-    -> noHints-  IllegalHasFieldInstanceFamilyTyCon-    -> noHints-  IllegalHasFieldInstanceTyConHasField {}-    -> noHints-  IllegalHasFieldInstanceTyConHasFields {}-    -> noHints--illegalHasFieldInstanceReason :: IllegalHasFieldInstance -> DiagnosticReason-illegalHasFieldInstanceReason = \case-  IllegalHasFieldInstanceNotATyCon-    -> ErrorWithoutFlag-  IllegalHasFieldInstanceFamilyTyCon-    -> ErrorWithoutFlag-  IllegalHasFieldInstanceTyConHasField {}-    -> ErrorWithoutFlag-  IllegalHasFieldInstanceTyConHasFields {}-    -> ErrorWithoutFlag--failedCoverageConditionHints :: CoverageProblem -> [GhcHint]-failedCoverageConditionHints (CoverageProblem { not_covered_liberal = failed_cc })-  = case failed_cc of-      FailedLICC -> noHints-      FailedICC { alsoFailedLICC = failed_licc } ->-        -- Turning on UndecidableInstances makes the check liberal,-        -- so if the liberal check passes, suggest enabling UndecidableInstances.-        if failed_licc-        then noHints-        else [suggestExtension LangExt.UndecidableInstances]--failedCoverageConditionReason :: CoverageProblem -> DiagnosticReason-failedCoverageConditionReason _ = ErrorWithoutFlag--pprIllegalFamilyInstance :: IllegalFamilyInstanceReason -> SDoc-pprIllegalFamilyInstance = \case-  InvalidAssoc reason -> pprInvalidAssoc reason-  NotAFamilyTyCon ty_or_data tc ->-    vcat [ text "Illegal family instance for" <+> quotes (ppr tc)-         , nest 2 $ parens (quotes (ppr tc) <+> text "is not a" <+> what) ]-    where-      what = ppr ty_or_data <+> text "family"-  NotAnOpenFamilyTyCon tc ->-    text "Illegal instance for closed family" <+> quotes (ppr tc)-  FamilyCategoryMismatch tc ->-    text "Wrong category of family instance; declaration was for a" <+> what <> dot-    where-      what = case tyConFlavour tc of-        OpenFamilyFlavour IAmData _ -> text "data family"-        _                           -> text "type family"-  FamilyArityMismatch _ max_args ->-    text "Number of parameters must match family declaration; expected"-    <+> ppr max_args <> dot-  TyFamNameMismatch fam_tc_name eqn_tc_name ->-    hang (text "Mismatched type name in type family instance.")-       2 (vcat [ text "Expected:" <+> ppr fam_tc_name-               , text "  Actual:" <+> ppr eqn_tc_name ])-  FamInstRHSOutOfScopeTyVars mb_dodgy (NE.toList -> tvs) ->-    hang (text "Out of scope type variable" <> plural tvs-         <+> pprWithCommas (quotes . ppr) tvs-         <+> text "in the RHS of a family instance.")-       2 (text "All such variables must be bound on the LHS.")-    $$ mk_extra-    where-    -- mk_extra: #7536: give a decent error message for-    --         type T a = Int-    --         type instance F (T a) = a-    mk_extra = case mb_dodgy of-      Nothing -> empty-      Just (fam_tc, pats, dodgy_tvs) ->-        ppWhen (any (`elemVarSetByKey` dodgy_tvs) (fmap nameUnique tvs)) $-          hang (text "The real LHS (expanding synonyms) is:")-             2 (pprTypeApp fam_tc (map expandTypeSynonyms pats))-  FamInstLHSUnusedBoundTyVars (NE.toList -> bad_qtvs) ->-    vcat [ not_bound_msg, not_used_msg, dodgy_msg ]-    where--      -- Filter to only keep user-written variables,-      -- unless none were user-written in which case we report all of them-      -- (as we need to report an error).-      filter_user tvs-        = map ifiqtv-        $ case filter ifiqtv_user_written tvs of { [] -> tvs ; qvs -> qvs }--      (not_bound, not_used, dodgy)-        = case foldr acc_tv ([], [], []) bad_qtvs of-            (nb, nu, d) -> (filter_user nb, filter_user nu, filter_user d)--      acc_tv tv (nb, nu, d) = case ifiqtv_reason tv of-        InvalidFamInstQTvNotUsedInRHS   -> (nb, tv : nu, d)-        InvalidFamInstQTvNotBoundInPats -> (tv : nb, nu, d)-        InvalidFamInstQTvDodgy          -> (nb, nu, tv : d)--      -- Error message for type variables not bound in LHS patterns.-      not_bound_msg-        | null not_bound-        = empty-        | otherwise-        = vcat [ text "The type variable" <> plural not_bound <+> pprQuotedList not_bound-            <+> isOrAre not_bound <+> text "bound by a forall,"-              , text "but" <+> doOrDoes not_bound <+> text "not appear in any of the LHS patterns of the family instance." ]--      -- Error message for type variables bound by a forall but not used-      -- in the RHS.-      not_used_msg =-        if null not_used-        then empty-        else text "The type variable" <> plural not_used <+> pprQuotedList not_used-             <+> isOrAre not_used <+> text "bound by a forall," $$-             text "but" <+> itOrThey not_used <+>-             isOrAre not_used <> text "n't used in the family instance."--      -- Error message for dodgy type variables.-      -- See Note [Dodgy binding sites in type family instances] in GHC.Tc.Validity.-      dodgy_msg-        | null dodgy-        = empty-        | otherwise-        = hang (text "Dodgy type variable" <> plural dodgy <+> pprQuotedList dodgy-               <+> text "in the LHS of a family instance:")-             2 (text "the type variable" <> plural dodgy <+> pprQuotedList dodgy-                <+> text "syntactically appear" <> singular dodgy <+> text "in LHS patterns,"-               $$ text "but" <+> itOrThey dodgy <+> doOrDoes dodgy <> text "n't appear in an injective position.")---illegalFamilyInstanceHints :: IllegalFamilyInstanceReason -> [GhcHint]-illegalFamilyInstanceHints = \case-  InvalidAssoc rea -> invalidAssocHints rea-  NotAFamilyTyCon {} -> noHints-  NotAnOpenFamilyTyCon {} -> noHints-  FamilyCategoryMismatch {} -> noHints-  FamilyArityMismatch {} -> noHints-  TyFamNameMismatch {} -> noHints-  FamInstRHSOutOfScopeTyVars {} -> noHints-  FamInstLHSUnusedBoundTyVars {} -> noHints--illegalFamilyInstanceReason :: IllegalFamilyInstanceReason -> DiagnosticReason-illegalFamilyInstanceReason = \case-  InvalidAssoc rea -> invalidAssocReason rea-  NotAFamilyTyCon {} -> ErrorWithoutFlag-  NotAnOpenFamilyTyCon {} -> ErrorWithoutFlag-  FamilyCategoryMismatch {} -> ErrorWithoutFlag-  FamilyArityMismatch {} -> ErrorWithoutFlag-  TyFamNameMismatch {} -> ErrorWithoutFlag-  FamInstRHSOutOfScopeTyVars {} -> ErrorWithoutFlag-  FamInstLHSUnusedBoundTyVars {} -> ErrorWithoutFlag--pprInvalidAssoc :: InvalidAssoc -> SDoc-pprInvalidAssoc = \case-  InvalidAssocInstance rea -> pprInvalidAssocInstance rea-  InvalidAssocDefault  rea -> pprInvalidAssocDefault  rea--pprInvalidAssocInstance :: InvalidAssocInstance -> SDoc-pprInvalidAssocInstance = \case-  AssocInstanceMissing name ->-    text "No explicit" <+> text "associated type"-    <+> text "or default declaration for"-    <+> quotes (ppr name)-  AssocInstanceNotInAClass fam_tc ->-    text "Associated type" <+> quotes (ppr fam_tc) <+>-    text "must be inside a class instance"-  AssocNotInThisClass cls fam_tc ->-    hsep [ text "Class", quotes (ppr cls)-         , text "does not have an associated type", quotes (ppr fam_tc) ]-  AssocNoClassTyVar cls fam_tc ->-    sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc)))-        , text "mentions none of the type or kind variables of the class" <+>-                quotes (ppr cls <+> hsep (map ppr (classTyVars cls)))]-  AssocTyVarsDontMatch vis fam_tc exp_tys act_tys ->-    pprWithInvisibleBitsWhen (isInvisibleForAllTyFlag vis) $-    vcat [ text "Type indexes must match class instance head"-         , text "Expected:" <+> pp exp_tys-         , text "  Actual:" <+> pp act_tys ]-    where-      pp tys = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $-               toIfaceTcArgs fam_tc tys--pprInvalidAssocDefault :: InvalidAssocDefault -> SDoc-pprInvalidAssocDefault = \case-  AssocDefaultNotAssoc cls tc ->-    hsep [ text "Class", quotes (ppr cls)-         , text "does not have an associated type", quotes (ppr tc) ]-  AssocMultipleDefaults name ->-      text "More than one default declaration for" <+> quotes (ppr name)-  AssocDefaultBadArgs fam_tc pat_tys bad_arg ->-    let (pat_vis, main_msg) = case bad_arg of-          AssocDefaultNonTyVarArg (pat_ty, pat_vis) ->-            (pat_vis,-             text "Illegal argument" <+> quotes (ppr pat_ty) <+> text "in:")-          AssocDefaultDuplicateTyVars dups ->-            let (pat_tv, pat_vis) = NE.head dups-            in (pat_vis,-                text "Illegal duplicate variable" <+> quotes (ppr pat_tv) <+> text "in:")-    in pprWithInvisibleBitsWhen (isInvisibleForAllTyFlag pat_vis) $-         hang main_msg-            2 (vcat [ppr_eqn, suggestion])-    where-      ppr_eqn :: SDoc-      ppr_eqn =-        quotes (text "type" <+> ppr (mkTyConApp fam_tc pat_tys)-                <+> equals <+> text "...")--      suggestion :: SDoc-      suggestion = text "The arguments to" <+> quotes (ppr fam_tc)-               <+> text "must all be distinct type variables."--invalidAssocHints :: InvalidAssoc -> [GhcHint]-invalidAssocHints = \case-  InvalidAssocInstance rea -> invalidAssocInstanceHints rea-  InvalidAssocDefault  rea -> invalidAssocDefaultHints  rea--invalidAssocInstanceHints :: InvalidAssocInstance -> [GhcHint]-invalidAssocInstanceHints = \case-  AssocInstanceMissing {} -> noHints-  AssocInstanceNotInAClass {} -> noHints-  AssocNotInThisClass {} -> noHints-  AssocNoClassTyVar {} -> noHints-  AssocTyVarsDontMatch {} -> noHints--invalidAssocDefaultHints :: InvalidAssocDefault -> [GhcHint]-invalidAssocDefaultHints = \case-  AssocDefaultNotAssoc {} -> noHints-  AssocMultipleDefaults {} -> noHints-  AssocDefaultBadArgs _ _ bad ->-    assocDefaultBadArgHints bad--assocDefaultBadArgHints :: AssocDefaultBadArgs -> [GhcHint]-assocDefaultBadArgHints = \case-  AssocDefaultNonTyVarArg {} -> noHints-  AssocDefaultDuplicateTyVars {} -> noHints--invalidAssocReason :: InvalidAssoc -> DiagnosticReason-invalidAssocReason = \case-  InvalidAssocInstance rea -> invalidAssocInstanceReason rea-  InvalidAssocDefault  rea -> invalidAssocDefaultReason  rea--invalidAssocInstanceReason :: InvalidAssocInstance -> DiagnosticReason-invalidAssocInstanceReason = \case-  AssocInstanceMissing {} -> WarningWithFlag (Opt_WarnMissingMethods)-  AssocInstanceNotInAClass {} -> ErrorWithoutFlag-  AssocNotInThisClass {} -> ErrorWithoutFlag-  AssocNoClassTyVar {} -> ErrorWithoutFlag-  AssocTyVarsDontMatch {} -> ErrorWithoutFlag--invalidAssocDefaultReason :: InvalidAssocDefault -> DiagnosticReason-invalidAssocDefaultReason = \case-  AssocDefaultNotAssoc {} -> ErrorWithoutFlag-  AssocMultipleDefaults {} -> ErrorWithoutFlag-  AssocDefaultBadArgs _ _ rea ->-    assocDefaultBadArgReason rea--assocDefaultBadArgReason :: AssocDefaultBadArgs -> DiagnosticReason-assocDefaultBadArgReason = \case-  AssocDefaultNonTyVarArg {} -> ErrorWithoutFlag-  AssocDefaultDuplicateTyVars {} -> ErrorWithoutFlag------------------------------------------------------------------------------------- Template Haskell quotes and splices--pprTHError :: THError -> DecoratedSDoc-pprTHError = \case-  THSyntaxError err -> pprTHSyntaxError err-  THNameError   err -> pprTHNameError   err-  THReifyError  err -> pprTHReifyError  err-  TypedTHError  err -> pprTypedTHError  err-  THSpliceFailed rea -> pprSpliceFailReason rea-  AddTopDeclsError err -> pprAddTopDeclsError err--  IllegalStaticFormInSplice e ->-    mkSimpleDecorated $-      sep [ text "static forms cannot be used in splices:"-          , nest 2 $ ppr e-          ]--  FailedToLookupThInstName th_type reason ->-    mkSimpleDecorated $-    case reason of-      NoMatchesFound ->-        text "Couldn't find any instances of"-          <+> text (TH.pprint th_type)-          <+> text "to add documentation to"-      CouldNotDetermineInstance ->-        text "Couldn't work out what instance"-          <+> text (TH.pprint th_type)-          <+> text "is supposed to be"--  AddInvalidCorePlugin plugin ->-    mkSimpleDecorated $-      hang (text "addCorePlugin: invalid plugin module" <+> quotes (text plugin) )-         2 (text "Plugins in the current package can't be specified.")--  AddDocToNonLocalDefn doc_loc ->-    mkSimpleDecorated $-      text "Can't add documentation to" <+> ppr_loc doc_loc <> comma <+>-      text "as it isn't inside the current module."-      where-        ppr_loc (TH.DeclDoc n) = text $ TH.pprint n-        ppr_loc (TH.ArgDoc n _) = text $ TH.pprint n-        ppr_loc (TH.InstDoc t) = text $ TH.pprint t-        ppr_loc TH.ModuleDoc = text "the module header"--  ReportCustomQuasiError _ msg -> mkSimpleDecorated $ text msg--pprTHSyntaxError :: THSyntaxError -> DecoratedSDoc-pprTHSyntaxError = mkSimpleDecorated . \case-  IllegalTHQuotes expr ->-    text "Syntax error on" <+> ppr expr-      -- The error message context will say-      -- "In the Template Haskell quotation", so no need to repeat that here.-  BadImplicitSplice ->-    sep [ text "Parse error: module header, import declaration"-        , text "or top-level declaration expected." ]-    -- The compiler should not mention TemplateHaskell, as the common case-    -- is that this is a simple beginner error, for example:-    ---    -- module M where-    --   f :: Int -> Int; f x = x-    --   xyzzy-    --   g y = f y + 1-    ---    -- It's unlikely that 'xyzzy' above was intended to be a Template Haskell-    -- splice; instead it's probably something mistakenly left in the code.-    -- See #12146 for discussion.--  IllegalTHSplice ->-    text "Unexpected top-level splice."-  MismatchedSpliceType splice_type inner_splice_or_bracket ->-    inner <+> text "may not appear in" <+> outer <> dot-      where-        (inner, outer) = case inner_splice_or_bracket of-          IsSplice -> case splice_type of-            Typed   -> (text "Typed splices"  , text "untyped brackets")-            Untyped -> (text "Untyped splices", text "typed brackets")-          IsBracket ->-            case splice_type of-            Typed   -> (text "Untyped brackets", text "typed splices")-            Untyped -> (text "Typed brackets"  , text "untyped splices")-  NestedTHBrackets ->-    text "Template Haskell brackets cannot be nested" <+>-    text "(without intervening splices)"--pprTHNameError :: THNameError -> DecoratedSDoc-pprTHNameError = \case-  NonExactName name ->-    mkSimpleDecorated $-      hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.")-         2 (text "Probable cause: you used mkName instead of newName to generate a binding.")-  QuotedNameWrongStage quote ->-    mkSimpleDecorated $-      sep [ text "Stage error: the non-top-level quoted name" <+> ppr quote-          , text "must be used at the same stage at which it is bound." ]--pprTHReifyError :: THReifyError -> DecoratedSDoc-pprTHReifyError = \case-  CannotReifyInstance ty-    -> mkSimpleDecorated $-       hang (text "reifyInstances:" <+> quotes (ppr ty))-          2 (text "is not a class constraint or type family application")-  CannotReifyOutOfScopeThing th_name-    -> mkSimpleDecorated $-       quotes (text (TH.pprint th_name)) <+>-               text "is not in scope at a reify"-             -- Ugh! Rather an indirect way to display the name-  CannotReifyThingNotInTypeEnv name-    -> mkSimpleDecorated $-       quotes (ppr name) <+> text "is not in the type environment at a reify"-  NoRolesAssociatedWithThing thing-    -> mkSimpleDecorated $-       text "No roles associated with" <+> (ppr thing)-  CannotRepresentType sort ty-    -> mkSimpleDecorated $-       hsep [text "Can't represent" <+> sort_doc <+>-             text "in Template Haskell:",-               nest 2 (ppr ty)]-     where-       sort_doc = text $-         case sort of-           LinearInvisibleArgument -> "linear invisible argument"-           CoercionsInTypes -> "coercions in types"--pprTypedTHError :: TypedTHError -> DecoratedSDoc-pprTypedTHError = \case-  SplicePolymorphicLocalVar ident-    -> mkSimpleDecorated $-         text "Can't splice the polymorphic local variable" <+> quotes (ppr ident)-  TypedTHWithPolyType ty-    -> mkSimpleDecorated $-      vcat [ text "Illegal polytype:" <+> ppr ty-           , text "The type of a Typed Template Haskell expression must" <+>-             text "not have any quantification." ]--pprSpliceFailReason :: SpliceFailReason -> DecoratedSDoc-pprSpliceFailReason = \case-  SpliceThrewException phase _exn exn_msg expr show_code ->-    mkSimpleDecorated $-      vcat [ text "Exception when trying to" <+> text phaseStr <+> text "compile-time code:"-           , nest 2 (text exn_msg)-           , if show_code then text "Code:" <+> ppr expr else empty]-    where phaseStr =-            case phase of-              SplicePhase_Run -> "run"-              SplicePhase_CompileAndLink -> "compile and link"-  RunSpliceFailure err -> pprRunSpliceFailure Nothing err--pprAddTopDeclsError :: AddTopDeclsError -> DecoratedSDoc-pprAddTopDeclsError = \case-  InvalidTopDecl _decl ->-    mkSimpleDecorated $-      sep [ text "Only function, value, annotation, and foreign import declarations"-          , text "may be added with" <+> quotes (text "addTopDecls") <> dot ]-  AddTopDeclsUnexpectedDeclarationSplice {} ->-    mkSimpleDecorated $-      text "Declaration splices are not permitted" <+>-      text "inside top-level declarations added with" <+>-      quotes (text "addTopDecls") <> dot-  AddTopDeclsRunSpliceFailure err ->-    pprRunSpliceFailure (Just "addTopDecls") err--pprRunSpliceFailure :: Maybe String -> RunSpliceFailReason -> DecoratedSDoc-pprRunSpliceFailure mb_calling_fn (ConversionFail what reason) =-  mkSimpleDecorated . add_calling_fn . addSpliceInfo $-    pprConversionFailReason reason-  where-    add_calling_fn rest =-      case mb_calling_fn of-        Just calling_fn ->-          hang (text "Error in a declaration passed to" <+> quotes (text calling_fn) <> colon)-             2 rest-        Nothing -> rest-    addSpliceInfo = case what of-      ConvDec  d -> addSliceInfo' "declaration" d-      ConvExp  e -> addSliceInfo' "expression" e-      ConvPat  p -> addSliceInfo' "pattern" p-      ConvType t -> addSliceInfo' "type" t-    addSliceInfo' what item reasonErr = reasonErr $$ descr-      where-            -- Show the item in pretty syntax normally,-            -- but with all its constructors if you say -dppr-debug-        descr = hang (text "When splicing a TH" <+> text what <> colon)-                   2 (getPprDebug $ \case-                       True  -> text (show item)-                       False -> text (TH.pprint item))--thErrorReason :: THError -> DiagnosticReason-thErrorReason = \case-  THSyntaxError err -> thSyntaxErrorReason err-  THNameError   err -> thNameErrorReason   err-  THReifyError  err -> thReifyErrorReason  err-  TypedTHError  err -> typedTHErrorReason  err-  THSpliceFailed rea -> spliceFailedReason rea-  AddTopDeclsError err -> addTopDeclsErrorReason err--  IllegalStaticFormInSplice {} -> ErrorWithoutFlag-  FailedToLookupThInstName {}  -> ErrorWithoutFlag-  AddInvalidCorePlugin {}      -> ErrorWithoutFlag-  AddDocToNonLocalDefn {}      -> ErrorWithoutFlag-  ReportCustomQuasiError is_error _ ->-    if is_error-    then ErrorWithoutFlag-    else WarningWithoutFlag--thSyntaxErrorReason :: THSyntaxError -> DiagnosticReason-thSyntaxErrorReason = \case-  IllegalTHQuotes{}      -> ErrorWithoutFlag-  BadImplicitSplice      -> ErrorWithoutFlag-  IllegalTHSplice{}      -> ErrorWithoutFlag-  NestedTHBrackets{}     -> ErrorWithoutFlag-  MismatchedSpliceType{} -> ErrorWithoutFlag--thNameErrorReason :: THNameError -> DiagnosticReason-thNameErrorReason = \case-  NonExactName {}         -> ErrorWithoutFlag-  QuotedNameWrongStage {} -> ErrorWithoutFlag--thReifyErrorReason :: THReifyError -> DiagnosticReason-thReifyErrorReason = \case-  CannotReifyInstance {}          -> ErrorWithoutFlag-  CannotReifyOutOfScopeThing {}   -> ErrorWithoutFlag-  CannotReifyThingNotInTypeEnv {} -> ErrorWithoutFlag-  NoRolesAssociatedWithThing {}   -> ErrorWithoutFlag-  CannotRepresentType {}          -> ErrorWithoutFlag--typedTHErrorReason :: TypedTHError -> DiagnosticReason-typedTHErrorReason = \case-  SplicePolymorphicLocalVar {} -> ErrorWithoutFlag-  TypedTHWithPolyType {}       -> ErrorWithoutFlag--spliceFailedReason :: SpliceFailReason -> DiagnosticReason-spliceFailedReason = \case-  SpliceThrewException {} -> ErrorWithoutFlag-  RunSpliceFailure {}     -> ErrorWithoutFlag--addTopDeclsErrorReason :: AddTopDeclsError -> DiagnosticReason-addTopDeclsErrorReason = \case-  InvalidTopDecl {}-    -> ErrorWithoutFlag-  AddTopDeclsUnexpectedDeclarationSplice {}-    -> ErrorWithoutFlag-  AddTopDeclsRunSpliceFailure {}-    -> ErrorWithoutFlag--thErrorHints :: THError -> [GhcHint]-thErrorHints = \case-  THSyntaxError err -> thSyntaxErrorHints err-  THNameError   err -> thNameErrorHints   err-  THReifyError  err -> thReifyErrorHints  err-  TypedTHError  err -> typedTHErrorHints  err-  THSpliceFailed rea -> spliceFailedHints rea-  AddTopDeclsError err -> addTopDeclsErrorHints err--  IllegalStaticFormInSplice {} -> noHints-  FailedToLookupThInstName {}  -> noHints-  AddInvalidCorePlugin {}      -> noHints-  AddDocToNonLocalDefn {}      -> noHints-  ReportCustomQuasiError {}    -> noHints--thSyntaxErrorHints :: THSyntaxError -> [GhcHint]-thSyntaxErrorHints = \case-  IllegalTHQuotes{}-    -> [suggestExtension LangExt.TemplateHaskellQuotes]-  BadImplicitSplice {}-    -> noHints -- NB: don't suggest TemplateHaskell-               -- see comments on BadImplicitSplice in pprTHSyntaxError-  IllegalTHSplice{}-    -> [suggestExtension LangExt.TemplateHaskell]-  NestedTHBrackets{}-    -> noHints-  MismatchedSpliceType{}-    -> noHints--thNameErrorHints :: THNameError -> [GhcHint]-thNameErrorHints = \case-  NonExactName {}         -> noHints-  QuotedNameWrongStage {} -> noHints--thReifyErrorHints :: THReifyError -> [GhcHint]-thReifyErrorHints = \case-  CannotReifyInstance {}          -> noHints-  CannotReifyOutOfScopeThing {}   -> noHints-  CannotReifyThingNotInTypeEnv {} -> noHints-  NoRolesAssociatedWithThing {}   -> noHints-  CannotRepresentType {}          -> noHints--typedTHErrorHints :: TypedTHError -> [GhcHint]-typedTHErrorHints = \case-  SplicePolymorphicLocalVar {} -> noHints-  TypedTHWithPolyType {}       -> noHints--spliceFailedHints :: SpliceFailReason -> [GhcHint]-spliceFailedHints = \case-  SpliceThrewException {} -> noHints-  RunSpliceFailure {}     -> noHints--addTopDeclsErrorHints :: AddTopDeclsError -> [GhcHint]-addTopDeclsErrorHints = \case-  InvalidTopDecl {}-    -> noHints-  AddTopDeclsUnexpectedDeclarationSplice {}-    -> noHints-  AddTopDeclsRunSpliceFailure {}-    -> noHints------------------------------------------------------------------------------------pprPatersonCondFailure ::-  PatersonCondFailure -> PatersonCondFailureContext -> Type -> Type -> SDoc-pprPatersonCondFailure (PCF_TyVar tvs) InInstanceDecl lhs rhs =-  hang (occMsg tvs)-    2 (sep [ text "in the constraint" <+> quotes (ppr lhs)-         , text "than in the instance head" <+> quotes (ppr rhs) ])-  where-    occMsg tvs = text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs)-                 <+> pp_occurs <+> text "more often"-    pp_occurs | isSingleton tvs = text "occurs"-              | otherwise       = text "occur"-pprPatersonCondFailure (PCF_TyVar tvs) InTyFamEquation lhs rhs =-  hang (occMsg tvs)-    2 (sep [ text "in the type-family application" <+> quotes (ppr rhs)-         , text "than in the LHS of the family instance" <+> quotes (ppr lhs) ])-  where-    occMsg tvs = text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs)-                 <+> pp_occurs <+> text "more often"-    pp_occurs | isSingleton tvs = text "occurs"-              | otherwise       = text "occur"-pprPatersonCondFailure PCF_Size InInstanceDecl lhs rhs =-  hang (text "The constraint" <+> quotes (ppr lhs))-    2 (sep [ text "is no smaller than", pp_rhs ])-  where pp_rhs = text "the instance head" <+> quotes (ppr rhs)-pprPatersonCondFailure PCF_Size InTyFamEquation lhs rhs =-  hang (text "The type-family application" <+> quotes (ppr rhs))-    2 (sep [ text "is no smaller than", pp_lhs ])-  where pp_lhs = text "the LHS of the family instance" <+> quotes (ppr lhs)-pprPatersonCondFailure  (PCF_TyFam tc) InInstanceDecl lhs _rhs =-  hang (text "Illegal use of type family" <+> quotes (ppr tc))-    2 (text "in the constraint" <+> quotes (ppr lhs))-pprPatersonCondFailure  (PCF_TyFam tc) InTyFamEquation _lhs rhs =-  hang (text "Illegal nested use of type family" <+> quotes (ppr tc))-    2 (text "in the arguments of the type-family application" <+> quotes (ppr rhs))------------------------------------------------------------------------------------defaultTypesAndImport :: ClassDefaults -> SDoc-defaultTypesAndImport ClassDefaults{cd_types, cd_module = Just cdm} =-  hang (parens $ pprWithCommas ppr cd_types)-     2 (text "imported from" <+> ppr cdm)-defaultTypesAndImport ClassDefaults{cd_types} = parens (pprWithCommas ppr cd_types)------------------------------------------------------------------------------------pprZonkerMessage :: ZonkerMessage -> SDoc-pprZonkerMessage = \case-  ZonkerCannotDefaultConcrete frr ->-    ppr (frr_context frr) $$-    text "cannot be assigned a fixed runtime representation," <+>-    text "not even by defaulting."--zonkerMessageHints :: ZonkerMessage -> [GhcHint]-zonkerMessageHints = \case-  ZonkerCannotDefaultConcrete {} -> [SuggestAddTypeSignatures UnnamedBinding]--zonkerMessageReason :: ZonkerMessage -> DiagnosticReason-zonkerMessageReason = \case-  ZonkerCannotDefaultConcrete {} -> ErrorWithoutFlag------------------------------------------------------------------------------------pprTypeSyntaxName :: TypeSyntax -> SDoc-pprTypeSyntaxName TypeKeywordSyntax     = "keyword" <+> quotes "type"-pprTypeSyntaxName ForallTelescopeSyntax = "forall telescope"-pprTypeSyntaxName ContextArrowSyntax    = "context arrow (=>)"-pprTypeSyntaxName FunctionArrowSyntax   = "function type arrow (->)"+  , pprErrCtxtMsg+  --+  , tidySkolemInfo+  , tidySkolemInfoAnon+  --+  , pprHsDocContext+  , inHsDocContext+  , TcRnMessageOpts(..)+  , pprTyThingUsedWrong+  , pprUntouchableVariable++  --+  , mismatchMsg_ExpectedActuals++  -- | Useful when overriding message printing.+  , messageWithInfoDiagnosticMessage+  , messageWithHsDocContext+  )+  where++import GHC.Prelude++import qualified GHC.Boot.TH.Syntax as TH+-- In stage1: import "ghc-boot-th-next" qualified GHC.Boot.TH.Syntax as TH+-- In stage2: import "ghc-boot-th"      qualified GHC.Boot.TH.Syntax as TH+--            which is a rexport of+--            import "ghc-internal"     qualified GHC.Internal.TH.Syntax as TH+import qualified GHC.Boot.TH.Ppr as TH++import GHC.Builtin.Names+import GHC.Builtin.Types ( boxedRepDataConTyCon, tYPETyCon, pretendNameIsInScope )++import GHC.Types.Name.Reader+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Warnings++import GHC.Core.Coercion+import GHC.Core.Unify     ( tcMatchTys )+import GHC.Core.TyCon+import GHC.Core.Class+import GHC.Core.DataCon+import GHC.Core.Coercion.Axiom (CoAxBranch, coAxiomTyCon, coAxiomSingleBranch)+import GHC.Core.ConLike+import GHC.Core.FamInstEnv ( FamInst(..), famInstAxiom, pprFamInst )+import GHC.Core.InstEnv+import GHC.Core.TyCo.Rep (Type(..))+import GHC.Core.TyCo.Ppr (pprWithInvisibleBitsWhen, pprSourceTyCon,+                          pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType, pprForAll)+import GHC.Core.PatSyn ( patSynName, pprPatSynType )+import GHC.Core.TyCo.Tidy+import GHC.Core.Predicate+import GHC.Core.Type+import GHC.Core.FVs( orphNamesOfTypes )+import GHC.CoreToIface++import GHC.Driver.Flags+import GHC.Driver.Backend+import GHC.Hs hiding (HoleError)++import GHC.Tc.Errors.Types+import GHC.Tc.Errors.Hole.FitTypes+import GHC.Tc.Types.BasicTypes+import GHC.Tc.Types.Constraint+import GHC.Tc.Types.ErrCtxt+import GHC.Tc.Types.Origin hiding ( Position(..) )+import GHC.Tc.Types.CtLoc+import GHC.Tc.Types.Rank (Rank(..))+import GHC.Tc.Types.TH+import GHC.Tc.Utils.TcType++import GHC.Types.DefaultEnv (ClassDefaults(ClassDefaults, cd_types, cd_provenance), DefaultProvenance (..))+import GHC.Types.Error+import GHC.Types.Error.Codes+import GHC.Types.Hint+import GHC.Types.Hint.Ppr ( pprSigLike ) -- & Outputable GhcHint+import GHC.Types.Basic+import GHC.Types.Id+import GHC.Types.Id.Info ( RecSelParent(..) )+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.SourceFile+import GHC.Types.SrcLoc+import GHC.Types.TyThing+import GHC.Types.TyThing.Ppr ( pprTyThingInContext )+import GHC.Types.Unique.Set ( nonDetEltsUniqSet )+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Fixity (defaultFixity)++import GHC.Iface.Errors.Types+import GHC.Iface.Errors.Ppr+import GHC.Iface.Syntax++import GHC.Unit.State+import GHC.Unit.Module++import GHC.Data.Bag+import GHC.Data.FastString+import GHC.Data.List.SetOps ( nubOrdBy )+import GHC.Data.Maybe+import GHC.Data.Pair+import GHC.Settings.Constants (mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE)+import GHC.Utils.Lexeme+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++import qualified GHC.LanguageExtensions as LangExt++import GHC.Data.BooleanFormula (pprBooleanFormulaNice)++import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+import qualified Data.Set as Set+import Data.Foldable ( fold )+import Data.Function (on)+import Data.List ( groupBy, sortBy, tails+                 , partition, unfoldr )+import Data.Ord ( comparing )+import Data.Bifunctor+import GHC.Tc.Errors.Types.PromotionErr (pprTermLevelUseCtxt)+++defaultTcRnMessageOpts :: TcRnMessageOpts+defaultTcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext = True+                                         , tcOptsIfaceOpts = defaultDiagnosticOpts @IfaceMessage }++instance HasDefaultDiagnosticOpts TcRnMessageOpts where+  defaultOpts = defaultTcRnMessageOpts++instance Diagnostic TcRnMessage where+  type DiagnosticOpts TcRnMessage = TcRnMessageOpts+  diagnosticMessage opts = \case+    TcRnUnknownMessage (UnknownDiagnostic f _ m)+      -> diagnosticMessage (f opts) m+    TcRnMessageWithInfo unit_state msg_with_info+      -> case msg_with_info of+           TcRnMessageDetailed err_info msg+             -> messageWithInfoDiagnosticMessage unit_state err_info+                  (tcOptsShowContext opts)+                  (diagnosticMessage opts msg)+    TcRnWithHsDocContext ctxt msg+      -> messageWithHsDocContext opts ctxt (diagnosticMessage opts msg)+    TcRnSolverReport msg _reason+      -> mkSimpleDecorated $ pprSolverReportWithCtxt msg+    TcRnSolverDepthError ty depth -> mkSimpleDecorated msg+      where+        msg =+          vcat [ text "Reduction stack overflow; size =" <+> ppr depth+               , hang (text "When simplifying the following type:")+                    2 (ppr ty) ]+    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 contra+      -> mkSimpleDecorated $+         hang (text "Inaccessible code in")+           2 (ppr (ic_info implic))+         $$ pprSolverReportWithCtxt contra+    TcRnInaccessibleCoAxBranch fam_tc cur_branch+      -> mkSimpleDecorated $+          text "Type family instance equation is overlapped:" $$+          nest 2 (pprCoAxBranchUser fam_tc cur_branch)+    TcRnTypeDoesNotHaveFixedRuntimeRep ty prov err_ctxt+      -> mkDecorated $+          (pprTypeDoesNotHaveFixedRuntimeRep ty prov)+          : map pprErrCtxtMsg err_ctxt+    TcRnImplicitLift id_or_name err_ctxt+      -> mkDecorated $+           ( text "The variable" <+> quotes (ppr id_or_name) <+>+             text "is implicitly lifted in the TH quotation"+           ) : map pprErrCtxtMsg err_ctxt+    TcRnUnusedPatternBinds bind+      -> mkDecorated [hang (text "This pattern-binding binds no variables:") 2 (ppr bind)]+    TcRnDodgyImports (DodgyImportsEmptyParent gre)+      -> mkDecorated [dodgy_msg (text "import") gre (dodgy_msg_insert gre)]+    TcRnDodgyImports (DodgyImportsHiding reason)+      -> mkSimpleDecorated $+         pprImportLookup reason+    TcRnDodgyExports gre+      -> mkDecorated [dodgy_msg (text "export") gre (dodgy_msg_insert gre)]+    TcRnMissingImportList ie+      -> mkDecorated [ text "The import item" <+> quotes (ppr ie) <+>+                       text "does not have an explicit import list"+                     ]+    TcRnUnsafeDueToPlugin+      -> mkDecorated [text "Use of plugins makes the module unsafe"]+    TcRnModMissingRealSrcSpan mod+      -> mkDecorated [text "Module does not have a RealSrcSpan:" <+> ppr mod]+    TcRnIdNotExportedFromModuleSig name mod+      -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+>+                       text "does not exist in the signature for" <+> ppr mod+                     ]+    TcRnIdNotExportedFromLocalSig name+      -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+>+                       text "does not exist in the local signature."+                     ]+    TcRnShadowedName occ provenance+      -> let shadowed_locs = case provenance of+               ShadowedNameProvenanceLocal n     -> [text "bound at" <+> ppr n]+               ShadowedNameProvenanceGlobal gres -> map pprNameProvenance gres+         in mkSimpleDecorated $+            sep [text "This binding for" <+> quotes (ppr occ)+             <+> text "shadows the existing binding" <> plural shadowed_locs,+                   nest 2 (vcat shadowed_locs)]+    TcRnInvalidWarningCategory cat+      -> mkSimpleDecorated $+           vcat [text "Warning category" <+> quotes (ppr cat) <+> text "is not valid",+                 text "(user-defined category names must begin with" <+> quotes (text "x-"),+                 text "and contain only letters, numbers, apostrophes and dashes)" ]+    TcRnDuplicateWarningDecls d rdr_name+      -> mkSimpleDecorated $+           vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),+                 text "also at " <+> ppr (getLocA d)]+    TcRnSimplifierTooManyIterations simples limit wc+      -> mkSimpleDecorated $+           hang (text "solveWanteds: too many iterations"+                   <+> parens (text "limit =" <+> ppr limit))+                2 (vcat [ text "Unsolved:" <+> ppr wc+                        , text "Simples:"  <+> ppr simples+                        ])+    TcRnIllegalPatSynDecl rdrname+      -> mkSimpleDecorated $+           hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname))+              2 (text "Pattern synonym declarations are only valid at top level")+    TcRnLinearPatSyn ty+      -> mkSimpleDecorated $+           hang (text "Pattern synonyms do not support linear fields (GHC #18806):") 2 (ppr ty)+    TcRnEmptyRecordUpdate+      -> mkSimpleDecorated $ text "Empty record update"+    TcRnIllegalFieldPunning fld+      -> mkSimpleDecorated $ text "Illegal use of punning for field" <+> quotes (ppr fld)+    TcRnIllegalWildcardsInRecord fld_part+      -> mkSimpleDecorated $ text "Illegal `..' in record" <+> pprRecordFieldPart fld_part+    TcRnIllegalWildcardInType mb_name bad+      -> mkSimpleDecorated $ case bad of+          WildcardNotLastInConstraint ->+            hang notAllowed 2 constraint_hint_msg+          ExtraConstraintWildcardNotAllowed allow_sole ->+            case allow_sole of+              SoleExtraConstraintWildcardNotAllowed ->+                notAllowed+              SoleExtraConstraintWildcardAllowed ->+                hang notAllowed 2 sole_msg+          WildcardsNotAllowedAtAll ->+            notAllowed+          WildcardBndrInForallTelescope ->+            notAllowed+          WildcardBndrInTyFamResultVar ->+            notAllowed+      where+        notAllowed, what, wildcard, how :: SDoc+        notAllowed = what <+> quotes wildcard <+> how+        wildcard = case mb_name of+          Nothing   -> pprAnonWildCard+          Just name -> ppr name+        what+          | Just _ <- mb_name+          = text "Named wildcard"+          | ExtraConstraintWildcardNotAllowed {} <- bad+          = text "Extra-constraint wildcard"+          | WildcardBndrInForallTelescope {} <- bad+          = text "Wildcard binder"+          | WildcardBndrInTyFamResultVar {} <- bad+          = text "Wildcard binder"+          | otherwise+          = text "Wildcard"+        how = case bad of+          WildcardNotLastInConstraint+            -> text "not allowed in a constraint"+          WildcardBndrInForallTelescope+            -> text "not allowed in a forall telescope"+          WildcardBndrInTyFamResultVar+            -> text "not allowed in a type family result"+          _ -> text "not allowed"+        constraint_hint_msg :: SDoc+        constraint_hint_msg+          | Just _ <- mb_name+          = vcat [ text "Extra-constraint wildcards must be anonymous"+                 , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]+          | otherwise+          = vcat [ text "except as the last top-level constraint of a type signature"+                 , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]+        sole_msg :: SDoc+        sole_msg =+          vcat [ text "except as the sole constraint"+               , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ]+    TcRnIllegalNamedWildcardInTypeArgument rdr+      -> mkSimpleDecorated $+           hang (text "Illegal named wildcard in a required type argument:")+                2 (quotes (ppr rdr))+    TcRnIllegalImplicitTyVarInTypeArgument rdr+      -> mkSimpleDecorated $+            hang (text "Illegal implicitly quantified type variable in a required type argument:")+                2 (quotes (ppr rdr))+    TcRnIllegalPunnedVarOccInTypeArgument n1 n2+      -> mkSimpleDecorated $ hang msg 2 info+         where+           msg  = vcat [ text "Illegal punned variable occurrence in a required type argument."+                       , text "The name" <+> quotes (ppr n1) <+> text "could refer to:" ]+           info = vcat [ quotes (ppr n1) <+> pprResolvedNameProvenance n1+                       , quotes (ppr n2) <+> pprResolvedNameProvenance n2 ]+    TcRnDuplicateFieldName fld_part dups+      -> mkSimpleDecorated $+           hsep [ text "Duplicate field name"+                , quotes (ppr (rdrNameOcc $ NE.head dups))+                , text "in record", pprRecordFieldPart fld_part ]+    TcRnIllegalViewPattern pat+      -> mkSimpleDecorated $ vcat [text "Illegal view pattern: " <+> ppr pat]+    TcRnCharLiteralOutOfRange c+      -> mkSimpleDecorated $ text "character literal out of range: '\\" <> char c  <> char '\''+    TcRnIllegalWildcardsInConstructor con+      -> mkSimpleDecorated $+           vcat [ text "Illegal `{..}' notation for constructor" <+> quotes (ppr con)+                , nest 2 (text "Record wildcards may not be used for constructors with unlabelled fields.")+                , nest 2 (text "Possible fix: Remove the `{..}' and add a match for each field of the constructor.")+                ]+    TcRnIgnoringAnnotations anns+      -> mkSimpleDecorated $+           text "Ignoring ANN annotation" <> plural anns <> comma+           <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi"+    TcRnAnnotationInSafeHaskell+      -> mkSimpleDecorated $+           vcat [ text "Annotations are not compatible with Safe Haskell."+                , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ]+    TcRnInvalidTypeApplication fun_ty hs_ty+      -> mkSimpleDecorated $+           text "Cannot apply expression of type" <+> quotes (ppr fun_ty) $$+           text "to a visible type argument" <+> quotes (ppr hs_ty)+    TcRnTagToEnumMissingValArg+      -> mkSimpleDecorated $+           text "tagToEnum# must appear applied to one value argument"+    TcRnTagToEnumUnspecifiedResTy ty+      -> mkSimpleDecorated $+           hang (text "Bad call to tagToEnum# at type" <+> ppr ty)+              2 (vcat [ text "Specify the type by giving a type signature"+                      , text "e.g. (tagToEnum# x) :: Bool" ])+    TcRnTagToEnumResTyNotAnEnum ty+      -> mkSimpleDecorated $+           hang (text "Bad call to tagToEnum# at type" <+> ppr ty)+              2 (text "Result type must be an enumeration type")+    TcRnTagToEnumResTyTypeData ty+      -> mkSimpleDecorated $+           hang (text "Bad call to tagToEnum# at type" <+> ppr ty)+              2 (text "Result type cannot be headed by a `type data` type")+    TcRnArrowIfThenElsePredDependsOnResultTy+      -> mkSimpleDecorated $+           text "Predicate type of `ifThenElse' depends on result type"+    TcRnIllegalHsBootOrSigDecl boot_or_sig decls+      -> mkSimpleDecorated $+           text "Illegal" <+> what <+> text "in" <+> whr <> dot+        where+          what = case decls of+            BootBindsPs      {} -> text "binding"+            BootBindsRn      {} -> text "binding"+            BootInstanceSigs {} -> text "instance body"+            BootFamInst      {} -> text "family instance"+            BootSpliceDecls  {} -> text "splice"+            BootForeignDecls {} -> text "foreign declaration"+            BootDefaultDecls {} -> text "default declaration"+            BootRuleDecls    {} -> text "RULE pragma"+          whr = case boot_or_sig of+            HsBoot -> text "an hs-boot file"+            Hsig   -> text "a backpack signature file"+    TcRnBootMismatch boot_or_sig err ->+      mkSimpleDecorated $ pprBootMismatch boot_or_sig err+    TcRnRecursivePatternSynonym binds+      -> mkSimpleDecorated $+            hang (text "Recursive pattern synonym definition with following bindings:")+               2 (vcat $ map pprLBind binds)+          where+            pprLoc loc = parens (text "defined at" <+> ppr loc)+            pprLBind :: CollectPass GhcRn => GenLocated (EpAnn a) (HsBindLR GhcRn idR) -> SDoc+            pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind)+                                        <+> pprLoc (locA loc)+    TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty+      -> mkSimpleDecorated $+           hang (text "Couldn't match" <+> quotes (ppr n1)+                   <+> text "with" <+> quotes (ppr n2))+                2 (hang (text "both bound by the partial type signature:")+                        2 (ppr fn_name <+> dcolon <+> ppr hs_ty))+    TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty+      -> mkSimpleDecorated $+           hang (text "Can't quantify over" <+> quotes (ppr n))+                2 (vcat [ hang (text "bound by the partial type signature:")+                             2 (ppr fn_name <+> dcolon <+> ppr hs_ty)+                        , extra ])+      where+        extra | Just rhs_ty <- m_unif_ty+              = sep [ quotes (ppr n), text "should really be", quotes (ppr rhs_ty) ]+              | otherwise+              = empty+    TcRnMissingSignature what _ ->+      mkSimpleDecorated $+      case what of+        MissingPatSynSig p ->+          hang (text "Pattern synonym with no type signature:")+            2 (text "pattern" <+> pprPrefixName (patSynName p) <+> dcolon <+> pprPatSynType p)+        MissingTopLevelBindingSig name ty ->+          hang (text "Top-level binding with no type signature:")+            2 (pprPrefixName name <+> dcolon <+> pprSigmaType ty)+        MissingTyConKindSig tc cusks_enabled ->+          hang msg+            2 (text "type" <+> pprPrefixName (tyConName tc) <+> dcolon <+> pprKind (tyConKind tc))+          where+            msg | cusks_enabled+                = text "Top-level type constructor with no standalone kind signature or CUSK:"+                | otherwise+                = text "Top-level type constructor with no standalone kind signature:"++    TcRnPolymorphicBinderMissingSig n ty+      -> mkSimpleDecorated $+           sep [ text "Polymorphic local binding with no type signature:"+               , nest 2 $ pprPrefixName n <+> dcolon <+> ppr ty ]+    TcRnOverloadedSig sig+      -> mkSimpleDecorated $+           hang (text "Overloaded signature conflicts with monomorphism restriction")+              2 (ppr sig)+    TcRnTupleConstraintInst _+      -> mkSimpleDecorated $ text "You can't specify an instance for a tuple constraint"+    TcRnUserTypeError ty+      -> mkSimpleDecorated (pprUserTypeErrorTy ty)+    TcRnConstraintInKind ty+      -> mkSimpleDecorated $+           text "Illegal constraint in a kind:" <+> pprType ty+    TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum ty+      -> mkSimpleDecorated $+           sep [ text "Illegal unboxed" <+> what <+> text "type as function argument:"+               , pprType ty ]+        where+          what = case tuple_or_sum of+            UnboxedTupleType -> text "tuple"+            UnboxedSumType   -> text "sum"+    TcRnLinearFuncInKind ty+      -> mkSimpleDecorated $+           text "Illegal linear function in a kind:" <+> pprType ty+    TcRnForAllEscapeError ty kind+      -> mkSimpleDecorated $ vcat+           [ hang (text "Quantified type's kind mentions quantified type variable")+                2 (text "type:" <+> quotes (ppr ty))+           , hang (text "where the body of the forall has this kind:")+                2 (quotes (pprKind kind)) ]+    TcRnSimplifiableConstraint pred what+      -> mkSimpleDecorated $ vcat+           [ hang (text "The constraint" <+> quotes (pprType pred) <+> text "matches")+                2 (ppr what)+           , hang (text "This makes type inference for inner bindings fragile;")+                2 (text "either use MonoLocalBinds, or simplify it using the instance") ]+    TcRnArityMismatch thing thing_arity nb_args+      -> mkSimpleDecorated $+           hsep [ text "The" <+> what, quotes (ppr $ getName thing), text "should have"+                , n_arguments <> comma, text "but has been given"+                , if nb_args == 0 then text "none" else int nb_args+                ]+          where+            what = case thing of+              ATyCon tc -> ppr (tyConFlavour tc)+              _         -> text (tyThingCategory thing)+            n_arguments | thing_arity == 0 = text "no arguments"+                        | thing_arity == 1 = text "1 argument"+                        | True          = hsep [int thing_arity, text "arguments"]+    TcRnIllegalInstance reason ->+      mkSimpleDecorated $ pprIllegalInstance reason+    TcRnVDQInTermType mb_ty+      -> mkSimpleDecorated $+             case mb_ty of+               Nothing -> main_msg+               Just ty -> hang (main_msg <> char ':') 2 (pprType ty)+      where+        main_msg =+          text "Illegal visible, dependent quantification" <+>+          text "in the type of a term"+    TcRnBadQuantPredHead ty+      -> mkSimpleDecorated $+           hang (text "Quantified predicate must have a class or type variable head:")+              2 (pprType ty)+    TcRnIllegalTupleConstraint ty+      -> mkSimpleDecorated $+           text "Illegal tuple constraint:" <+> pprType ty+    TcRnNonTypeVarArgInConstraint ty+      -> mkSimpleDecorated $+           hang (text "Non type-variable argument")+              2 (text "in the constraint:" <+> pprType ty)+    TcRnIllegalImplicitParam ty+      -> mkSimpleDecorated $+           text "Illegal implicit parameter" <+> quotes (pprType ty)+    TcRnIllegalConstraintSynonymOfKind kind+      -> mkSimpleDecorated $+           text "Illegal constraint synonym of kind:" <+> quotes (pprKind kind)+    TcRnOversaturatedVisibleKindArg ty+      -> mkSimpleDecorated $+           text "Illegal oversaturated visible kind argument:" <+>+           quotes (char '@' <> pprParendType ty)+    TcRnForAllRankErr rank ty+      -> let herald = case tcSplitForAllTyVars ty of+               ([], _) -> text "Illegal qualified type:"+               _       -> text "Illegal polymorphic type:"+             extra = case rank of+               MonoTypeConstraint -> text "A constraint must be a monotype"+               _                  -> empty+         in mkSimpleDecorated $ vcat [hang herald 2 (pprType ty), extra]+    TcRnMonomorphicBindings bindings+      -> let pp_bndrs = pprBindings bindings+         in mkSimpleDecorated $+              sep [ text "The Monomorphism Restriction applies to the binding"+                  <> plural bindings+                  , text "for" <+> pp_bndrs ]+    TcRnOrphanInstance (Left cls_inst)+      -> mkSimpleDecorated $+           hang (text "Orphan class instance:")+              2 (pprInstanceHdr cls_inst)+    TcRnOrphanInstance (Right fam_inst)+      -> mkSimpleDecorated $+           hang (text "Orphan family instance:")+              2 (pprFamInst fam_inst)+    TcRnFunDepConflict unit_state sorted+      -> let herald = text "Functional dependencies conflict between instance declarations:"+         in mkSimpleDecorated $+              pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted))+    TcRnDupInstanceDecls unit_state sorted+      -> let herald = text "Duplicate instance declarations:"+         in mkSimpleDecorated $+              pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted))+    TcRnConflictingFamInstDecls sortedNE+      -> let sorted = NE.toList sortedNE+         in mkSimpleDecorated $+              hang (text "Conflicting family instance declarations:")+                 2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)+                         | fi <- sorted+                         , let ax = famInstAxiom fi ])+    TcRnFamInstNotInjective rea fam_tc (eqn1 NE.:| rest_eqns)+      -> let (herald, show_kinds) = case rea of+               InjErrRhsBareTyVar tys ->+                 (injectivityErrorHerald $$+                  text "RHS of injective type family equation is a bare" <+>+                  text "type variable" $$+                  text "but these LHS type and kind patterns are not bare" <+>+                  text "variables:" <+> pprQuotedList tys, False)+               InjErrRhsCannotBeATypeFam ->+                 (injectivityErrorHerald $$+                   text "RHS of injective type family equation cannot" <+>+                   text "be a type family:", False)+               InjErrRhsOverlap ->+                  (text "Type family equation right-hand sides overlap; this violates" $$+                   text "the family's injectivity annotation:", False)+               InjErrCannotInferFromRhs tvs has_kinds _ ->+                 let show_kinds = has_kinds == YesHasKinds+                     what = if show_kinds then text "Type/kind" else text "Type"+                     body = sep [ what <+> text "variable" <>+                                  pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort)+                                , text "cannot be inferred from the right-hand side." ]+                     in (injectivityErrorHerald $$ body $$ text "In the type family equation:", show_kinds)++         in mkSimpleDecorated $ pprWithInvisibleBitsWhen show_kinds $+              hang herald+                2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns)))+    TcRnBangOnUnliftedType ty+      -> mkSimpleDecorated $+           text "Strictness flag has no effect on unlifted type" <+> quotes (ppr ty)+    TcRnLazyBangOnUnliftedType ty+      -> mkSimpleDecorated $+           text "Lazy flag has no effect on unlifted type" <+> quotes (ppr ty)+    TcRnMultipleDefaultDeclarations cls dup_things+      -> mkSimpleDecorated $+           hang (text "Multiple default declarations for class" <+> quotes (ppr cls))+              2 (pp dup_things)+         where+           pp :: ClassDefaults -> SDoc+           pp (ClassDefaults { cd_provenance = prov })+             = case prov of+                DP_Local { defaultDeclLoc = loc, defaultDeclH98 = isH98 }+                  -> let+                        what =+                          if isH98+                          then text "default declaration"+                          else text "named default declaration"+                     in text "conflicting" <+> what <+> text "at:" <+> ppr loc+                _ -> empty -- doesn't happen, as local defaults override imported and built-in defaults+    TcRnBadDefaultType ty deflt_clss+      -> mkSimpleDecorated $+           hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of")+              2 (foldr1 (\a b -> a <+> text "or" <+> b) (NE.map (quotes. ppr) deflt_clss))+    TcRnPatSynBundledWithNonDataCon+      -> mkSimpleDecorated $+           text "Pattern synonyms can be bundled only with datatypes."+    TcRnPatSynBundledWithWrongType expected_res_ty res_ty+      -> mkSimpleDecorated $+           text "Pattern synonyms can only be bundled with matching type constructors"+               $$ text "Couldn't match expected type of"+               <+> quotes (ppr expected_res_ty)+               <+> text "with actual type of"+               <+> quotes (ppr res_ty)+    TcRnDupeModuleExport mod+      -> mkSimpleDecorated $+           hsep [ text "Duplicate"+                , quotes (text "Module" <+> ppr mod)+                , text "in export list" ]+    TcRnExportedModNotImported mod+      -> mkSimpleDecorated+       $ formatExportItemError+           (text "module" <+> ppr mod)+           "is not imported"+    TcRnNullExportedModule mod+      -> mkSimpleDecorated+       $ formatExportItemError+           (text "module" <+> ppr mod)+           "exports nothing"+    TcRnMissingExportList mod+      -> mkSimpleDecorated+       $ formatExportItemError+           (text "module" <+> ppr mod)+           "is missing an export list"+    TcRnExportHiddenComponents export_item+      -> mkSimpleDecorated+       $ formatExportItemError+           (ppr export_item)+           "attempts to export constructors or class methods that are not visible here"+    TcRnExportHiddenDefault export_item+      -> mkSimpleDecorated+       $ formatExportItemError+           (ppr export_item)+           "attempts to export a default class declaration that is not visible here"+    TcRnDuplicateExport gre ie1 ie2+      -> mkSimpleDecorated $+           hsep [ quotes (ppr $ greName gre)+                , text "is exported by", quotes (ppr ie1)+                , text "and",            quotes (ppr ie2) ]+    TcRnDuplicateNamedDefaultExport nm ie1 ie2+      -> mkSimpleDecorated $+           hsep [ text "The named default declaration for" <+> quotes (ppr nm)+                , text "is exported by", quotes (ppr ie1)+                , text "and",            quotes (ppr ie2) ]+    TcRnExportedParentChildMismatch parent_name ty_thing child parent_names+      -> mkSimpleDecorated $+           text "The type constructor" <+> quotes (ppr parent_name)+                 <+> text "is not the parent of the" <+> text what_is+                 <+> quotes thing <> char '.'+                 $$ text (capitalise what_is)+                    <> text "s can only be exported with their parent type constructor."+                 $$ (case parents of+                       [] -> empty+                       [_] -> text "Parent:"+                       _  -> text "Parents:") <+> fsep (punctuate comma parents)+      where+        pp_category :: TyThing -> String+        pp_category (AnId i)+          | isRecordSelector i = "record selector"+        pp_category i = tyThingCategory i+        what_is = pp_category ty_thing+        thing = ppr $ nameOccName child+        parents = map ppr parent_names+    TcRnConflictingExports occ child_gre1 ie1 child_gre2 ie2+      -> mkSimpleDecorated $+           vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon+                , ppr_export child_gre1 ie1+                , ppr_export child_gre2 ie2+                ]+      where+        ppr_export gre ie =+          nest 3 $+            hang (quotes (ppr ie) <+> text "exports" <+> quotes (ppr $ greName gre))+               2 (pprNameProvenance gre)+    TcRnDuplicateFieldExport (gre, ie1) gres_ies ->+      mkSimpleDecorated $+           vcat ( hsep [ text "Duplicate record field"+                       , quotes (ppr $ greOccName gre)+                       , text "in export list" <> colon ]+                : map ppr_export ((gre,ie1) : NE.toList gres_ies)+                )+      where+        ppr_export (gre,ie) =+          nest 3 $+            hang (sep [ quotes (ppr ie) <+> text "exports the field" <+> quotes (ppr $ greName gre)+                       , text "belonging to the constructor" <> plural fld_cons <+> pprQuotedList fld_cons ])+               2 (pprNameProvenance gre)+          where+            fld_cons :: [ConLikeName]+            fld_cons = nonDetEltsUniqSet $ recFieldCons $ fieldGREInfo gre+    TcRnAmbiguousFieldInUpdate (gre1, gre2, gres)+      -> mkSimpleDecorated $+          vcat [ text "Ambiguous record field" <+> fld <> dot+               , hang (text "It could refer to any of the following:")+                  2 $ vcat (map pprSugg (gre1 : gre2 : gres))+               ]+        where+          fld = quotes $ ppr (occNameFS $ greOccName gre1)+          pprSugg gre = vcat [ bullet <+> pprGRE gre <> comma+                             , nest 2 (pprNameProvenance gre) ]+          pprGRE gre = case greInfo gre of+            IAmRecField {}+              | ParentIs { par_is = parent } <- greParent gre+              -> text "record field" <+> fld <+> text "of" <+> quotes (ppr parent)+            _ -> text "variable" <+> fld+    TcRnAmbiguousRecordUpdate _rupd tc+      -> mkSimpleDecorated $+          vcat [ text "Ambiguous record update with parent" <+> what <> dot+               , hsep [ text "This type-directed disambiguation mechanism"+                      , text "will not be supported by -XDuplicateRecordFields in future releases of GHC." ]+               , text "Consider disambiguating using module qualification instead."+               ]+        where+          what :: SDoc+          what = text "type constructor" <+> quotes (ppr $ RecSelData tc)+    TcRnMissingFields con fields+      -> mkSimpleDecorated $ vcat [header, nest 2 rest]+         where+           rest | null fields = empty+                | otherwise   = vcat (fmap pprField fields)+           header = text "Fields of" <+> quotes (ppr con) <+>+                    text "not initialised" <>+                    if null fields then empty else colon+    TcRnFieldUpdateInvalidType prs+      -> mkSimpleDecorated $+           hang (text "Record update for insufficiently polymorphic field"+                   <> plural prs <> colon)+              2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])+    TcRnMissingStrictFields con fields+      -> mkSimpleDecorated $ vcat [header, nest 2 rest]+         where+           rest | null fields = empty  -- Happens for non-record constructors+                                       -- with strict fields+                | otherwise   = vcat (fmap pprField fields)++           header = text "Constructor" <+> quotes (ppr con) <+>+                    text "does not have the required strict field(s)" <>+                    if null fields then empty else colon+    TcRnBadRecordUpdate upd_flds reason+      -> case reason of+          NoConstructorHasAllFields { conflictingFields = conflicts }+            | [fld] <- conflicts+            -> mkSimpleDecorated $+                vcat [ header+                     , text "No constructor in scope has the field" <+> quotes (ppr fld) ]+            | otherwise+            ->+              mkSimpleDecorated $+                vcat [ header+                     , hang (text "No constructor in scope has all of the following fields:")+                        2 (pprQuotedList conflicts) ]+            where+              header :: SDoc+              header = text "Invalid record update."+          MultiplePossibleParents (par1, par2, pars) ->+            mkSimpleDecorated $+              vcat [ hang (text "Ambiguous record update with field" <> plural upd_flds)+                       2 ppr_flds+                   , hang (thisOrThese upd_flds <+> text "field" <> plural upd_flds <+> what_parent)+                       2 (quotedListWithAnd (map ppr (par1:par2:pars))) ]+            where+              ppr_flds, what_parent, which :: SDoc+              ppr_flds = quotedListWithAnd $ map ppr upd_flds+              what_parent = case par1 of+                RecSelData   {} -> text "appear" <> singular upd_flds+                                <+> text "in" <+> which <+> text "datatypes"+                RecSelPatSyn {} -> isOrAre upd_flds <+> text "associated with"+                                <+> which <+> text "pattern synonyms"+              which = case pars of+                [] -> text "both"+                _  -> text "all of the"+          InvalidTyConParent tc pars ->+            mkSimpleDecorated $+              vcat [ hang (text "No data constructor of" <+> what $$ text "has all of the fields:")+                      2 (pprQuotedList upd_flds)+                   , pat_syn_msg ]+            where+              what = text "type constructor" <+> quotes (ppr (RecSelData tc))+              pat_syn_msg+                | any (\case { RecSelPatSyn {} -> True; _ -> False}) pars+                = note "Type-directed disambiguation is not supported for pattern synonym record fields"+                | otherwise+                = empty+    TcRnStaticFormNotClosed name reason+      -> mkSimpleDecorated $+           quotes (ppr name)+             <+> text "is used in a static form but it is not closed"+             <+> text "because it"+             $$ sep (causes reason)+         where+          causes :: NotClosedReason -> [SDoc]+          causes NotLetBoundReason = [text "is not let-bound."]+          causes (NotTypeClosed vs) =+            [ text "has a non-closed type because it contains the"+            , text "type variables:" <+>+              pprVarSet vs (hsep . punctuate comma . map (quotes . ppr))+            ]+          causes (NotClosed n reason) =+            let msg = text "uses" <+> quotes (ppr n) <+> text "which"+             in case reason of+                  NotClosed _ _ -> msg : causes reason+                  _   -> let (xs0, xs1) = splitAt 1 $ causes reason+                          in fmap (msg <+>) xs0 ++ xs1+    TcRnUselessTypeable+      -> mkSimpleDecorated $+           text "Deriving" <+> quotes (ppr typeableClassName) <+>+           text "has no effect: all types now auto-derive Typeable"+    TcRnDerivingDefaults cls+      -> mkSimpleDecorated $ sep+                     [ text "Both DeriveAnyClass and"+                       <+> text "GeneralizedNewtypeDeriving are enabled"+                     , text "Defaulting to the DeriveAnyClass strategy"+                       <+> text "for instantiating" <+> ppr cls+                     ]+    TcRnNonUnaryTypeclassConstraint ctxt ct+      -> mkSimpleDecorated $+           quotes (ppr ct)+           <+> text "is not a unary constraint, as expected by"+           <+> pprUserTypeCtxt ctxt+    TcRnPartialTypeSignatures _ theta+      -> mkSimpleDecorated $+           text "Found type wildcard" <+> quotes (char '_')+                       <+> text "standing for" <+> quotes (pprTheta theta)+    TcRnCannotDeriveInstance cls cls_tys mb_strat newtype_deriving reason+      -> mkSimpleDecorated $+           derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving True reason+    TcRnLookupInstance cls tys reason+      -> mkSimpleDecorated $+          text "Couldn't match instance:" <+>+           lookupInstanceErrDiagnosticMessage cls tys reason+    TcRnLazyGADTPattern+      -> mkSimpleDecorated $+           hang (text "An existential or GADT data constructor cannot be used")+              2 (text "inside a lazy (~) pattern")+    TcRnArrowProcGADTPattern+      -> mkSimpleDecorated $+           text "Proc patterns cannot use existential or GADT data constructors"+    TcRnTypeEqualityOutOfScope+      -> mkDecorated+           [ text "The" <+> quotes (text "~") <+> text "operator is out of scope." $$+             text "Assuming it to stand for an equality constraint."+           , note $ quotes "~" <+> "used to be built-in syntax but now is a regular type operator" $$+                      "exported from Data.Type.Equality and Prelude." $$+                      "If you are using a custom Prelude, consider re-exporting it"+           , text "This will become an error in a future GHC release." ]+    TcRnTypeEqualityRequiresOperators+      -> mkSimpleDecorated $+            fsep [ text "The use of" <+> quotes (text "~")+                                     <+> text "without TypeOperators",+                   text "will become an error in a future GHC release." ]+    TcRnIllegalTypeOperator overall_ty op+      -> mkSimpleDecorated $+           text "Illegal operator" <+> quotes (ppr op) <+>+           text "in type" <+> quotes (ppr overall_ty)+    TcRnIllegalTypeOperatorDecl name+      -> mkSimpleDecorated $+        text "Illegal declaration of a type or class operator" <+> quotes (ppr name)+    TcRnGADTMonoLocalBinds+      -> mkSimpleDecorated $+            fsep [ text "Pattern matching on GADTs without MonoLocalBinds"+                 , text "is fragile." ]+    TcRnIncorrectNameSpace name _in_th_tick+      -> mkSimpleDecorated $+           text "The" <+> what <+> text "does not live in" <+> other_ns+        where+          -- the other (opposite) namespace+          other_ns | isValNameSpace ns = text "the type-level namespace"+                   | otherwise         = text "the term-level namespace"+          ns = nameNameSpace name+          what = pprNameSpace ns <+> quotes (ppr name)+    TcRnNotInScope err name+      -> mkSimpleDecorated $ pprScopeError name err+    TcRnTermNameInType name+      -> mkSimpleDecorated $+           quotes (ppr name) <+>+             (text "is a term-level binding") $+$+             (text " and can not be used at the type level.")+    TcRnUntickedPromotedThing thing+      -> mkSimpleDecorated $+         text "Unticked promoted" <+> what+           where+             what :: SDoc+             what = case thing of+               UntickedExplicitList -> text "list" <> dot+               UntickedConstructor fixity nm ->+                 let con      = pprUntickedConstructor fixity nm+                     bare_sym = isBareSymbol fixity nm+                 in text "constructor:" <+> con <> if bare_sym then empty else dot+    TcRnIllegalBuiltinSyntax sig rdr_name+      -> mkSimpleDecorated $+           hsep [text "Illegal", pprSigLike sig, text "of built-in syntax:", ppr rdr_name]+    TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty+      -> mkSimpleDecorated $+           hang (hsep $ [ text "Defaulting" ]+                     +++                     (case tidy_tv of+                         Nothing -> []+                         Just tv -> [text "the type variable"+                                    , quotes (ppr tv)])+                     +++                     [ text "to type"+                     , quotes (ppr default_ty)+                     , text "in the following constraint" <> plural tidy_wanteds ])+             2+             (pprWithArising tidy_wanteds)+    TcRnWarnClashingDefaultImports cls Nothing imports+      -> mkSimpleDecorated $+           hang (text "Clashing imported defaults for class" <+> quotes (ppr cls) <> colon)+              2 (vcat $ defaultTypesAndImport <$> NE.toList imports)+    TcRnWarnClashingDefaultImports cls (Just local) imports+      -> mkSimpleDecorated $+           sep [ hang (text "Imported defaults for class" <+> quotes (ppr cls) <> colon)+                    2 (vcat $ defaultTypesAndImport <$> NE.toList imports)+               , hang (text "are not subsumed by the local `default` declaration")+                    2 (parens $ pprWithCommas ppr local)+               ]++    TcRnForeignImportPrimExtNotSet _decl+      -> mkSimpleDecorated $+           text "`foreign import prim' requires GHCForeignImportPrim."++    TcRnForeignImportPrimSafeAnn _decl+      -> mkSimpleDecorated $+           text "The safe/unsafe annotation should not be used with `foreign import prim'."++    TcRnForeignFunctionImportAsValue _decl+      -> mkSimpleDecorated $+           text "`value' imports cannot have function types"++    TcRnFunPtrImportWithoutAmpersand _decl+      -> mkSimpleDecorated $+           text "possible missing & in foreign import of FunPtr"++    TcRnIllegalForeignDeclBackend _decl _backend expectedBknds+      -> mkSimpleDecorated $+         fsep (text "Illegal foreign declaration: requires one of these back ends:" :+               commafyWith (text "or") (map (text . backendDescription) expectedBknds))++    TcRnUnsupportedCallConv _decl unsupportedCC+      -> mkSimpleDecorated $+           case unsupportedCC of+             StdCallConvUnsupported ->+               text "the 'stdcall' calling convention is unsupported on this platform,"+               $$ text "treating as ccall"+             PrimCallConvUnsupported ->+               text "The `prim' calling convention can only be used with `foreign import'"+             JavaScriptCallConvUnsupported ->+               text "The `javascript' calling convention is unsupported on this platform"++    TcRnIllegalForeignType mArgOrResult reason+      -> mkSimpleDecorated $ hang msg 2 extra+      where+        arg_or_res = case mArgOrResult of+          Nothing -> empty+          Just Arg -> text "argument"+          Just Result -> text "result"+        msg = hsep [ text "Unacceptable", arg_or_res+                   , text "type in foreign declaration:"]+        extra =+          case reason of+            TypeCannotBeMarshaled ty why ->+              let innerMsg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call"+               in case why of+                NotADataType ->+                  quotes (ppr ty) <+> text "is not a data type"+                NewtypeDataConNotInScope _ [] ->+                  hang innerMsg 2 $ text "because its data constructor is not in scope"+                NewtypeDataConNotInScope tc _ ->+                  hang innerMsg 2 $+                    text "because the data constructor for"+                    <+> quotes (ppr tc) <+> text "is not in scope"+                UnliftedFFITypesNeeded ->+                  innerMsg $$ text "UnliftedFFITypes is required to marshal unlifted types"+                NotABoxedMarshalableTyCon -> innerMsg+                ForeignLabelNotAPtr ->+                  innerMsg $$ text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)"+                NotSimpleUnliftedType ->+                  innerMsg $$ text "foreign import prim only accepts simple unlifted types"+                NotBoxedKindAny ->+                  text "Expected kind" <+> quotes (text "Type") <+> text "or" <+> quotes (text "UnliftedType") <> comma $$+                  text "but" <+> quotes (ppr ty) <+> text "has kind" <+> quotes (ppr (typeKind ty))+            ForeignDynNotPtr expected ty ->+              vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma, text "  Actual:" <+> ppr ty ]+            SafeHaskellMustBeInIO ->+              text "Safe Haskell is on, all FFI imports must be in the IO monad"+            IOResultExpected ->+              text "IO result type expected"+            UnexpectedNestedForall ->+              text "Unexpected nested forall"+            LinearTypesNotAllowed ->+              text "Linear types are not supported in FFI declarations, see #18472"+            OneArgExpected ->+              text "One argument expected"+            AtLeastOneArgExpected ->+              text "At least one argument expected"+    TcRnInvalidCIdentifier target+      -> mkSimpleDecorated $+           sep [quotes (ppr target) <+> text "is not a valid C identifier"]+    TcRnExpectedValueId thing+      -> mkSimpleDecorated $+           ppr thing <+> text "used where a value identifier was expected"+    TcRnRecSelectorEscapedTyVar lbl+      -> mkSimpleDecorated $+           text "Cannot use record selector" <+> quotes (ppr lbl) <+>+           text "as a function due to escaped type variables"+    TcRnPatSynNotBidirectional name+      -> mkSimpleDecorated $+           text "non-bidirectional pattern synonym"+           <+> quotes (ppr name) <+> text "used in an expression"+    TcRnIllegalDerivingItem hs_ty+      -> mkSimpleDecorated $+           text "Illegal deriving item" <+> quotes (ppr hs_ty)+    TcRnIllegalDefaultClass nm+      -> mkSimpleDecorated $+           text "Illegal named default declaration for non-class" <+> quotes (ppr nm)+    TcRnIllegalNamedDefault hs_decl+      -> mkSimpleDecorated $ text "Illegal named default declaration" <+> quotes (ppr hs_decl)+    TcRnUnexpectedAnnotation ty bang+      -> mkSimpleDecorated $+           let err = case bang of+                 HsSrcBang _ SrcUnpack   _       -> "UNPACK"+                 HsSrcBang _ SrcNoUnpack _       -> "NOUNPACK"+                 HsSrcBang _ NoSrcUnpack SrcLazy -> "laziness (~)"+                 HsSrcBang _ _           _       -> "strictness (!)"+            in text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$+               text err <+> text "annotation can only appear on the arguments of a data constructor type"+    TcRnIllegalRecordSyntax ty+      -> mkSimpleDecorated $+           text "Record syntax is illegal here:" <+> ppr ty++    TcRnInvalidVisibleKindArgument arg ty+      -> mkSimpleDecorated $+           text "Cannot apply function of kind" <+> quotes (ppr ty)+             $$ text "to visible kind argument" <+> quotes (ppr arg)+    TcRnTooManyBinders ki bndrs+      -> mkSimpleDecorated $+           hang (text "Not a function kind:")+              4 (ppr ki) $$+           hang (text "but extra binders found:")+              4 (fsep (map ppr bndrs))+    TcRnDifferentNamesForTyVar n1 n2+      -> mkSimpleDecorated $+           hang (text "Different names for the same type variable:") 2 info+         where+           info | nameOccName n1 /= nameOccName n2+                = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2)+                | otherwise -- Same OccNames! See C2 in+                            -- Note [Swizzling the tyvars before generaliseTcTyCon]+                = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1)+                       , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ]++    TcRnDisconnectedTyVar n+      -> mkSimpleDecorated $+           hang (text "Scoped type variable only appears non-injectively in declaration header:")+              2 (quotes (ppr n) <+> text "bound at" <+> ppr (getSrcLoc n))++    TcRnInvalidReturnKind data_sort allowed_kind kind _suggested_ext+      -> mkSimpleDecorated $+           sep [ ppDataSort data_sort <+>+                 text "has non-" <>+                 allowed_kind_tycon+               , (if is_data_family then text "and non-variable" else empty) <+>+                 text "return kind" <+> quotes (ppr kind)+               ]+         where+          is_data_family =+            case data_sort of+              DataDeclSort{}     -> False+              DataInstanceSort{} -> False+              DataFamilySort     -> True+          allowed_kind_tycon =+            case allowed_kind of+              AnyTYPEKind  -> ppr tYPETyCon+              AnyBoxedKind -> ppr boxedRepDataConTyCon+              LiftedKind   -> ppr liftedTypeKind+    TcRnClassKindNotConstraint _kind+      -> mkSimpleDecorated $+           text "Kind signature on a class must end with" <+> ppr constraintKind $$+           text "unobscured by type families"+    TcRnUnpromotableThing name err+      -> mkSimpleDecorated $+           (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here")+                        2 (parens reason))+        where+          reason = case err of+                     ConstrainedDataConPE theta+                                    -> text "it has an unpromotable context"+                                       <+> quotes (pprTheta theta)++                     FamDataConPE   -> text "it comes from a data family instance"+                     PatSynPE       -> text "pattern synonyms cannot be promoted"+                     RecDataConPE   -> same_rec_group_msg+                     ClassPE        -> same_rec_group_msg+                     TyConPE        -> same_rec_group_msg+                     TermVariablePE -> text "term variables cannot be promoted"+                     TypeVariablePE -> text "type variables bound in a kind signature cannot be used in the type"+          same_rec_group_msg = text "it is defined and used in the same recursive group"+    TcRnIllegalTermLevelUse simple_msg rdr name err+      -> mkSimpleDecorated $+           if simple_msg+           then+              vcat [ expecting_what <+> text "out of scope:" <+> quotes (ppr rdr) <> dot+                   , "NB: the" <+> text (teCategory err) <+> quotes (ppr qnm) <+> "cannot appear in this position."+                   ]+           else+             text "Illegal term-level use of the" <+>+               text (teCategory err) <+> quotes (ppr qnm)+          where+            expecting_what = case err of+              TyVarTE -> "Term variable"+              ClassTE -> "Data constructor"+              TyConTE -> "Data constructor"+            qnm = WithUserRdr rdr name+    TcRnMatchesHaveDiffNumArgs argsContext (MatchArgMatches match1 bad_matches)+      -> mkSimpleDecorated $+           (vcat [ pprMatchContextNouns argsContext <+>+                   text "have different numbers of arguments"+                 , nest 2 (ppr (getLocA match1))+                 , nest 2 (ppr (getLocA (NE.head bad_matches)))])+    TcRnCannotBindScopedTyVarInPatSig sig_tvs+      -> mkSimpleDecorated $+           hang (text "You cannot bind scoped type variable"+                  <> plural (NE.toList sig_tvs)+                 <+> pprQuotedList (map fst $ NE.toList sig_tvs))+              2 (text "in a pattern binding signature")+    TcRnCannotBindTyVarsInPatBind _offenders+      -> mkSimpleDecorated $+           text "Binding type variables is not allowed in pattern bindings"+    TcRnMultipleInlinePragmas poly_id fst_inl_prag inl_prags+      -> mkSimpleDecorated $+           hang (text "Multiple INLINE pragmas for" <+> ppr poly_id)+             2 (vcat (text "Ignoring all but the first"+                      : map pp_inl (fst_inl_prag : NE.toList inl_prags)))+         where+           pp_inl (L loc prag) = ppr prag <+> parens (ppr loc)+    TcRnUnexpectedPragmas poly_id bad_sigs+      -> mkSimpleDecorated $+           hang (text "Discarding unexpected pragmas for" <+> ppr poly_id)+              2 (vcat (map (ppr . getLoc) $ NE.toList bad_sigs))+    TcRnNonOverloadedSpecialisePragma fun_name+       -> mkSimpleDecorated $+            text "SPECIALISE pragma for non-overloaded function"+              <+> quotes (ppr fun_name)+    TcRnSpecialiseNotVisible name+      -> mkSimpleDecorated $+         text "You cannot SPECIALISE" <+> quotes (ppr name)+           <+> text "because its definition is not visible in this module"+    TcRnPragmaWarning+      { pragma_warning_info = PragmaWarningInstance{pwarn_dfunid, pwarn_ctorig}+      , pragma_warning_msg }+      -> mkSimpleDecorated $+        sep [ hang (text "In the use of")+                 2 (pprDFunId pwarn_dfunid)+            , ppr pwarn_ctorig+            , pprWarningTxtForMsg pragma_warning_msg+         ]+    TcRnPragmaWarning+      { pragma_warning_info = PragmaWarningDefault{pwarn_class, pwarn_impmod}+      , pragma_warning_msg }+      -> mkSimpleDecorated $+        sep [ sep [ text "In the use of class"+                    <+> ppr pwarn_class+                    <+> text "defaults imported from"+                    <+> ppr pwarn_impmod <> colon ]+            , pprWarningTxtForMsg pragma_warning_msg+         ]+    TcRnPragmaWarning {pragma_warning_info, pragma_warning_msg}+      -> mkSimpleDecorated $+        sep [ sep [ text "In the use of"+                <+> pprNonVarNameSpace (occNameSpace occ_name)+                <+> quotes (ppr occ_name)+                , parens imp_msg <> colon ]+          , pprWarningTxtForMsg pragma_warning_msg ]+          where+            occ_name = pwarn_occname pragma_warning_info+            imp_mod = pwarn_impmod pragma_warning_info+            imp_msg  = text "imported from" <+> ppr imp_mod <> extra+            extra | PragmaWarningName {pwarn_declmod = decl_mod} <- pragma_warning_info+                  , imp_mod /= decl_mod = text ", but defined in" <+> ppr decl_mod+                  | otherwise = empty+    TcRnDifferentExportWarnings name locs+      -> mkSimpleDecorated $ vcat [quotes (ppr name) <+> text "exported with different error messages",+                                   text "at" <+> vcat (map ppr $ sortBy leftmost_smallest $ NE.toList locs)]+    TcRnIncompleteExportWarnings name locs+      -> mkSimpleDecorated $ vcat [quotes (ppr name) <+> text "will not have its export warned about",+                                   text "missing export warning at" <+> vcat (map ppr $ sortBy leftmost_smallest $ NE.toList locs)]+    TcRnIllegalHsigDefaultMethods name meths+      -> mkSimpleDecorated $+        text "Illegal default method" <> plural (NE.toList meths) <+> text "in class definition of" <+> ppr name <+> text "in hsig file"+    TcRnHsigFixityMismatch real_thing real_fixity sig_fixity+      ->+      let ppr_fix f = ppr f <+> if f == defaultFixity then parens (text "default") else empty+      in mkSimpleDecorated $+        vcat [ppr real_thing <+> text "has conflicting fixities in the module",+              text "and its hsig file",+              text "Main module:" <+> ppr_fix real_fixity,+              text "Hsig file:" <+> ppr_fix sig_fixity]+    TcRnHsigShapeMismatch (HsigShapeSortMismatch info1 info2)+      -> mkSimpleDecorated $+            text "While merging export lists, could not combine"+            <+> ppr info1 <+> text "with" <+> ppr info2+            <+> parens (text "one is a type, the other is a plain identifier")+    TcRnHsigShapeMismatch (HsigShapeNotUnifiable name1 name2 notHere)+      ->+      let extra = if notHere+                  then text "Neither name variable originates from the current signature."+                  else empty+      in mkSimpleDecorated $+        text "While merging export lists, could not unify"+        <+> ppr name1 <+> text "with" <+> ppr name2 $$ extra+    TcRnHsigMissingModuleExport occ unit_state impl_mod+      -> mkSimpleDecorated $+            quotes (ppr occ)+        <+> text "is exported by the hsig file, but not exported by the implementing module"+        <+> quotes (pprWithUnitState unit_state $ ppr impl_mod)+    TcRnBadGenericMethod clas op+      -> mkSimpleDecorated $+        hsep [text "Class", quotes (ppr clas),+          text "has a generic-default signature without a binding", quotes (ppr op)]+    TcRnWarningMinimalDefIncomplete mindef+      -> mkSimpleDecorated $+        vcat [ text "The MINIMAL pragma does not require:"+          , nest 2 (pprBooleanFormulaNice mindef)+          , text "but there is no default implementation." ]+    TcRnDefaultMethodForPragmaLacksBinding sel_id prag+      -> mkSimpleDecorated $+        text "The" <+> hsSigDoc prag <+> text "for default method"+          <+> quotes (ppr sel_id)+          <+> text "lacks an accompanying binding"+    TcRnIgnoreSpecialisePragmaOnDefMethod sel_name+      -> mkSimpleDecorated $+        text "Ignoring SPECIALISE pragmas on default method"+          <+> quotes (ppr sel_name)+    TcRnBadMethodErr{badMethodErrClassName, badMethodErrMethodName}+      -> mkSimpleDecorated $+        hsep [text "Class", quotes (ppr badMethodErrClassName),+          text "does not have a method", quotes (ppr badMethodErrMethodName)]+    TcRnIllegalTypeData+      -> mkSimpleDecorated $+        text "Illegal type-level data declaration"+    TcRnTypeDataForbids feature+      -> mkSimpleDecorated $+        ppr feature <+> text "are not allowed in type data declarations."++    TcRnIllegalNewtype con show_linear_types reason+      -> mkSimpleDecorated $+        vcat [msg, additional]+        where+          (msg,additional) =+            case reason of+              DoesNotHaveSingleField n_flds ->+                (sep [+                  text "A newtype constructor must have exactly one field",+                  nest 2 $+                    text "but" <+> quotes (ppr con) <+> text "has" <+> speakN n_flds+                ],+                ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con))+              IsNonLinear ->+                (text "A newtype constructor must be linear",+                ppr con <+> dcolon <+> ppr (dataConDisplayType True con))+              IsGADT ->+                (text "A newtype must not be a GADT",+                ppr con <+> dcolon <+> pprWithInvisibleBitsWhen sneaky_eq_spec+                                       (ppr $ dataConDisplayType show_linear_types con))+              HasConstructorContext ->+                (text "A newtype constructor must not have a context in its type",+                ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con))+              HasExistentialTyVar ->+                (text "A newtype constructor must not have existential type variables",+                ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con))+              HasStrictnessAnnotation ->+                (text "A newtype constructor must not have a strictness annotation", empty)++          -- Is the data con a "covert" GADT?  See Note [isCovertGadtDataCon]+          -- in GHC.Core.DataCon+          sneaky_eq_spec = isCovertGadtDataCon con+    TcRnOrPatBindsVariables bndrs -> mkSimpleDecorated $+      text "An or-pattern may not bind term or type variables such as"+        <+> quotedListWithOr (map ppr (NE.toList bndrs))+    TcRnUnsatisfiedMinimalDef mindef+      -> mkSimpleDecorated $+        vcat [text "No explicit implementation for"+              ,nest 2 $ pprBooleanFormulaNice mindef+             ]+    TcRnMisplacedInstSig name hs_ty+      -> mkSimpleDecorated $+        vcat [ hang (text "Illegal type signature in instance declaration:")+                  2 (hang (pprPrefixName name)+                        2 (dcolon <+> ppr hs_ty))+             ]+    TcRnNoRebindableSyntaxRecordDot -> mkSimpleDecorated $+      text "RebindableSyntax is required if OverloadedRecordUpdate is enabled."+    TcRnNoFieldPunsRecordDot -> mkSimpleDecorated $+      text "For this to work enable NamedFieldPuns"+    TcRnIllegalStaticExpression e -> mkSimpleDecorated $+        text "Illegal static expression:" <+> ppr e+    TcRnListComprehensionDuplicateBinding n -> mkSimpleDecorated $+        (text "Duplicate binding in parallel list comprehension for:"+          <+> quotes (ppr n))+    TcRnEmptyStmtsGroup cause -> mkSimpleDecorated  $ case cause of+      EmptyStmtsGroupInParallelComp ->+        text "Empty statement group in parallel comprehension"+      EmptyStmtsGroupInTransformListComp ->+        text "Empty statement group preceding 'group' or 'then'"+      EmptyStmtsGroupInDoNotation ctxt ->+        text "Empty" <+> pprHsDoFlavour ctxt+      EmptyStmtsGroupInArrowNotation ->+        text "Empty 'do' block in an arrow command"+    TcRnLastStmtNotExpr ctxt (UnexpectedStatement stmt) ->+      mkSimpleDecorated $ hang last_error 2 (ppr stmt)+      where+        last_error =+          text "The last statement in" <+> pprAStmtContext ctxt+          <+> text "must be an expression"+    TcRnUnexpectedStatementInContext ctxt (UnexpectedStatement stmt) _ -> mkSimpleDecorated $+       sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement"+                       , text "in" <+> pprAStmtContext ctxt ]+    TcRnIllegalTupleSection -> mkSimpleDecorated $+      text "Illegal tuple section"+    TcRnIllegalImplicitParameterBindings eBinds -> mkSimpleDecorated $+        either msg msg eBinds+      where+        msg binds = hang+          (text "Implicit-parameter bindings illegal in an mdo expression")+          2 (ppr binds)+    TcRnSectionWithoutParentheses expr -> mkSimpleDecorated $+      hang (text "A section must be enclosed in parentheses")+         2 (text "thus:" <+> (parens (ppr expr)))+    TcRnMissingRoleAnnotation name roles -> mkSimpleDecorated $+      hang (text "Missing role annotation" <> colon)+         2 (text "type role" <+> ppr name <+> hsep (map ppr roles))++    TcRnIllformedTypePattern p+      -> mkSimpleDecorated $+          hang (text "Ill-formed type pattern:") 2 (ppr p)+    TcRnIllegalTypePattern+      -> mkSimpleDecorated $+          text "Illegal type pattern." $$+          text "A type pattern must be checked against a visible forall."+    TcRnIllformedTypeArgument e+      -> mkSimpleDecorated $+          hang (text "Ill-formed type argument:") 2 (ppr e)+    TcRnIllegalTypeExpr syntax -> mkSimpleDecorated $+      vcat [ text "Illegal" <+> pprTypeSyntaxName syntax+           , text "Type syntax may only be used in a required type argument,"+           , text "i.e. to instantiate a visible forall." ]++    TcRnCapturedTermName tv_name shadowed_term_names+      -> mkSimpleDecorated $+        text "The type variable" <+> quotes (ppr tv_name) <+>+          text "is implicitly quantified," $+$+          text "even though another variable of the same name is in scope:" $+$+          nest 2 var_names $+$+          text "This is not compatible with the RequiredTypeArguments extension."+        where+          var_names = case shadowed_term_names of+              Left gbl_names -> vcat (map (\name -> quotes (ppr $ greName name) <+> pprNameProvenance name) gbl_names)+              Right lcl_name -> quotes (ppr lcl_name) <+> text "defined at"+                <+> ppr (nameSrcLoc lcl_name)+    TcRnBindingOfExistingName name -> mkSimpleDecorated $+      text "Illegal binding of an existing name:" <+> ppr name+    TcRnMultipleFixityDecls loc rdr_name -> mkSimpleDecorated $+      vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name),+            text "also at " <+> ppr loc]+    TcRnIllegalPatternSynonymDecl -> mkSimpleDecorated $+      text "Illegal pattern synonym declaration"+    TcRnIllegalClassBinding dsort bind -> mkSimpleDecorated $+      vcat [ what <+> text "not allowed in" <+> decl_sort+              , nest 2 (ppr bind) ]+      where+        decl_sort = case dsort of+          ClassDeclSort -> text "class declaration:"+          InstanceDeclSort -> text "instance declaration:"+        what = case bind of+                  PatBind {}    -> text "Pattern bindings (except simple variables)"+                  PatSynBind {} -> text "Pattern synonyms"+                                   -- Associated pattern synonyms are not implemented yet+                  _ -> pprPanic "rnMethodBind" (ppr bind)++    TcRnOrphanCompletePragma -> mkSimpleDecorated $+      text "Orphan COMPLETE pragmas not supported" $$+      text "A COMPLETE pragma must mention at least one data constructor" $$+      text "or pattern synonym defined in the same module."+    TcRnEmptyCase ctxt reason -> mkSimpleDecorated $+      case reason of+        EmptyCaseWithoutFlag ->+          text "Empty list of alternatives in" <+> pp_ctxt+        EmptyCaseDisallowedCtxt ->+          text "Empty list of alternatives is not allowed in" <+> pp_ctxt+        EmptyCaseForall tvb ->+          vcat [ text "Empty list of alternatives in" <+> pp_ctxt+               , hang (text "checked against a forall-type:")+                      2 (pprForAll [tvb] <+> text "...")+               ]+        where+          pp_ctxt = case ctxt of+            CaseAlt                                -> text "case expression"+            LamAlt LamCase                         -> text "\\case expression"+            LamAlt LamCases                        -> text "\\cases expression"+            ArrowMatchCtxt (ArrowLamAlt LamSingle) -> text "kappa abstraction"+            ArrowMatchCtxt (ArrowLamAlt LamCase)   -> text "\\case command"+            ArrowMatchCtxt (ArrowLamAlt LamCases)  -> text "\\cases command"+            ArrowMatchCtxt ArrowCaseAlt            -> text "case command"+            ctxt                                   -> text "(unexpected)" <+> pprMatchContextNoun ctxt+    TcRnNonStdGuards (NonStandardGuards guards) -> mkSimpleDecorated $+      text "accepting non-standard pattern guards" $$+      nest 4 (interpp'SP guards)+    TcRnDuplicateSigDecl pairs@((L _ name, sig) :| _) -> mkSimpleDecorated $+      vcat [ text "Duplicate" <+> what_it_is+            <> text "s for" <+> quotes (ppr name)+          , text "at" <+> vcat (map ppr $ sortBy leftmost_smallest+                                        $ map (getLocA . fst)+                                        $ NE.toList pairs)+          ]+      where+        what_it_is = hsSigDoc sig+    TcRnMisplacedSigDecl sig -> mkSimpleDecorated $+      sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig]+    TcRnUnexpectedDefaultSig sig -> mkSimpleDecorated $+      hang (text "Unexpected default signature:")+         2 (ppr sig)+    TcRnDuplicateMinimalSig sig1 sig2 otherSigs -> mkSimpleDecorated $+      vcat [ text "Multiple minimal complete definitions"+           , text "at" <+> vcat (map ppr $ sortBy leftmost_smallest $ map getLocA sigs)+           , text "Combine alternative minimal complete definitions with `|'" ]+      where+        sigs = sig1 : sig2 : otherSigs+    TcRnSpecSigShape spec_e -> mkSimpleDecorated $+      hang (text "Illegal form of SPECIALISE pragma:")+         2 (ppr spec_e)+    TcRnUnexpectedStandaloneDerivingDecl -> mkSimpleDecorated $+      text "Illegal standalone deriving declaration"+    TcRnUnusedVariableInRuleDecl name var -> mkSimpleDecorated $+      sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,+          text "Forall'd variable" <+> quotes (ppr var) <+>+                  text "does not appear on left hand side"]+    TcRnUnexpectedStandaloneKindSig -> mkSimpleDecorated $+      text "Illegal standalone kind signature"+    TcRnIllegalRuleLhs errReason name lhs bad_e -> mkSimpleDecorated $+      sep [text "Rule" <+> pprRuleName name <> colon,+           nest 2 (vcat [err,+                         text "in left-hand side:" <+> ppr lhs])]+      $$+      text "LHS must be of form (f e1 .. en) where f is not forall'd"+      where+        err = case errReason of+          UnboundVariable uv nis -> pprScopeError uv nis+          IllegalExpression -> text "Illegal expression:" <+> ppr bad_e+    TcRnRuleLhsEqualities ruleName _lhs cts -> mkSimpleDecorated $+      text "Discarding RULE" <+> doubleQuotes (ftext ruleName) <> dot+      $$+      hang+        (sep [ text "The LHS of this rule gave rise to equality constraints"+             , text "that GHC was unable to quantify over:" ]+        )+        4 (pprWithArising $ NE.toList cts)+      $$+      text "NB: this warning will become an error starting from GHC 9.18"+    TcRnDuplicateRoleAnnot list -> mkSimpleDecorated $+      hang (text "Duplicate role annotations for" <+>+            quotes (ppr $ roleAnnotDeclName first_decl) <> colon)+        2 (vcat $ map pp_role_annot $ NE.toList sorted_list)+      where+        sorted_list = NE.sortBy cmp_loc list+        ((L _ first_decl) :| _) = sorted_list++        pp_role_annot (L loc decl) = hang (ppr decl)+                                        4 (text "-- written at" <+> ppr (locA loc))++        cmp_loc = leftmost_smallest `on` getLocA+    TcRnDuplicateKindSig list -> mkSimpleDecorated $+      hang (text "Duplicate standalone kind signatures for" <+>+            quotes (ppr $ standaloneKindSigName first_decl) <> colon)+        2 (vcat $ map pp_kisig $ NE.toList sorted_list)+      where+        sorted_list = NE.sortBy cmp_loc list+        ((L _ first_decl) :| _) = sorted_list++        pp_kisig (L loc decl) =+          hang (ppr decl) 4 (text "-- written at" <+> ppr (locA loc))++        cmp_loc = leftmost_smallest `on` getLocA+    TcRnIllegalDerivStrategy ds -> mkSimpleDecorated $+      text "Illegal deriving strategy" <> colon <+> derivStrategyName ds+    TcRnIllegalMultipleDerivClauses -> mkSimpleDecorated $+      text "Illegal use of multiple, consecutive deriving clauses"+    TcRnNoDerivStratSpecified{} -> mkSimpleDecorated $ text+      "No deriving strategy specified. Did you want stock, newtype, or anyclass?"+    TcRnStupidThetaInGadt{} -> mkSimpleDecorated $+      vcat [text "No context is allowed on a GADT-style data declaration",+            text "(You can put a context on each constructor, though.)"]+    TcRnShadowedTyVarNameInFamResult resName -> mkSimpleDecorated $+       hsep [ text "Type variable", quotes (ppr resName) <> comma+            , text "naming a type family result,"+            ] $$+      text "shadows an already bound type variable"+    TcRnIncorrectTyVarOnLhsOfInjCond resName injFrom -> mkSimpleDecorated $+        vcat [ text $ "Incorrect type variable on the LHS of "+                   ++ "injectivity condition"+      , nest 5+      ( vcat [ text "Expected :" <+> ppr resName+             , text "Actual   :" <+> ppr injFrom ])]+    TcRnUnknownTyVarsOnRhsOfInjCond errorVars -> mkSimpleDecorated $+      hsep [ text "Unknown type variable" <> plural errorVars+           , text "on the RHS of injectivity condition:"+           , interpp'SP errorVars ]+    TcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt _reason+      -> pprTcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt+    TcRnBadlyLevelledType name bind_lvls use_lvl+      -> mkSimpleDecorated $+         text "Badly levelled type:" <+> ppr name <+>+         fsep [text "is bound at" <+> pprThBindLevel bind_lvls,+               text "but used at level" <+> ppr use_lvl]+    TcRnTyThingUsedWrong sort thing name+      -> mkSimpleDecorated $+         pprTyThingUsedWrong sort thing name+    TcRnCannotDefaultKindVar var knd ->+      mkSimpleDecorated $+      (vcat [ text "Cannot default kind variable" <+> quotes (ppr var)+            , text "of kind:" <+> ppr knd+            , text "Perhaps enable PolyKinds or add a kind signature" ])+    TcRnUninferrableTyVar tidied_tvs context ->+      mkSimpleDecorated $+      pprWithInvisibleBitsWhen True $+      vcat [ text "Uninferrable type variable"+              <> plural tidied_tvs+              <+> pprWithCommas pprTyVar tidied_tvs+              <+> text "in"+            , pprUninferrableTyVarCtx context ]+    TcRnSkolemEscape escapees tv orig_ty ->+      mkSimpleDecorated $+      pprWithInvisibleBitsWhen True $+      vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees+                , quotes $ pprTyVars escapees+                , text "would escape" <+> itsOrTheir escapees <+> text "scope"+                ]+          , sep [ text "if I tried to quantify"+                , pprTyVar tv+                , text "in this type:"+                ]+          , nest 2 (pprTidiedType orig_ty)+          , text "(Indeed, I sometimes struggle even printing this correctly,"+          , text " due to its ill-scoped nature.)"+          ]+    TcRnPatSynEscapedCoercion arg bad_co_ne -> mkSimpleDecorated $+      vcat [ text "Iceland Jack!  Iceland Jack! Stop torturing me!"+           , hang (text "Pattern-bound variable")+                2 (ppr arg <+> dcolon <+> ppr (idType arg))+           , nest 2 $+             hang (text "has a type that mentions pattern-bound coercion"+                   <> plural bad_co_list <> colon)+                2 (pprWithCommas ppr bad_co_list)+           , text "Hint: use -fprint-explicit-coercions to see the coercions"+           , text "Probable fix: add a pattern signature" ]+      where+        bad_co_list = NE.toList bad_co_ne+    TcRnPatSynExistentialInResult name pat_ty bad_tvs -> mkSimpleDecorated $+      hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma+                , text "namely" <+> quotes (ppr pat_ty) ])+        2 (text "mentions existential type variable" <> plural bad_tvs+           <+> pprQuotedList bad_tvs)+    TcRnPatSynArityMismatch name decl_arity missing -> mkSimpleDecorated $+      hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has"+            <+> speakNOf decl_arity (text "argument"))+         2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")+    TcRnPatSynInvalidRhs ps_name lpat _ reason -> mkSimpleDecorated $+      vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"+                   <+> quotes (ppr ps_name) <> colon)+                2 (pprPatSynInvalidRhsReason reason)+           , text "RHS pattern:" <+> ppr lpat ]+    TcRnTyFamDepsDisabled -> mkSimpleDecorated $+      text "Illegal injectivity annotation"+    TcRnAbstractClosedTyFamDecl -> mkSimpleDecorated $+      text "You may define an abstract closed type family" $$+      text "only in a .hs-boot file"+    TcRnPartialFieldSelector fld -> mkSimpleDecorated $+      vcat [ sep [ text "Definition of partial record field" <> colon+                 , nest 2 $ quotes (ppr (occName fld)) ]+           , text "Record selection and update using this field will be partial." ]+    TcRnHasFieldResolvedIncomplete name cons maxCons -> mkSimpleDecorated $+      hang (text "Selecting the record field" <+> quotes (ppr name)+              <+> text "may fail for the following constructors:")+           2+           (hsep $ punctuate comma $+            map ppr (take maxCons cons) ++ [ text "..." | lengthExceeds cons maxCons ])+    TcRnBadFieldAnnotation n con reason -> mkSimpleDecorated $+      hang (pprBadFieldAnnotationReason reason)+         2 (text "on the" <+> speakNth n+            <+> text "argument of" <+> quotes (ppr con))+    TcRnSuperclassCycle (MkSuperclassCycle cls definite details) ->+      let herald | definite  = text "Superclass cycle for"+                 | otherwise = text "Potential superclass cycle for"+      in mkSimpleDecorated $+       vcat [ herald <+> quotes (ppr cls), nest 2 (vcat (pprSuperclassCycleDetail <$> details))]+    TcRnDefaultSigMismatch sel_id dm_ty -> mkSimpleDecorated $+      hang (text "The default type signature for"+            <+> ppr sel_id <> colon)+         2 (ppr dm_ty)+      $$ (text "does not match its corresponding"+          <+> text "non-default type signature")+    TcRnTyFamsDisabled reason -> mkSimpleDecorated $+      text "Illegal family" <+> text sort <+> text "for" <+> quotes name+      where+        (sort, name) = case reason of+          TyFamsDisabledFamily n -> ("declaration", ppr n)+          TyFamsDisabledInstance n -> ("instance", ppr n)+    TcRnBadTyConTelescope tc -> mkSimpleDecorated $+      vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped")+                2 pp_tc_kind+           , extra+           , hang (text "Perhaps try this order instead:")+                2 (pprTyVars sorted_tvs) ]+      where+        pp_tc_kind = text "Inferred kind:" <+> ppr tc <+> dcolon <+> ppr_untidy (tyConKind tc)+        ppr_untidy ty = pprIfaceType (toIfaceType ty)+          -- We need ppr_untidy here because pprType will tidy the type, which+          -- will turn the bogus kind we are trying to report+          --     T :: forall (a::k) k (b::k) -> blah+          -- into a misleadingly sanitised version+          --     T :: forall (a::k) k1 (b::k1) -> blah++        tcbs = tyConBinders tc+        tvs  = binderVars tcbs+        sorted_tvs = scopedSort tvs++        inferred_tvs  = [ binderVar tcb+                        | tcb <- tcbs, Inferred == tyConBinderForAllTyFlag tcb ]+        specified_tvs = [ binderVar tcb+                        | tcb <- tcbs, Specified == tyConBinderForAllTyFlag tcb ]++        extra+          | null inferred_tvs && null specified_tvs+          = empty+          | null inferred_tvs+          = note $ "Specified variables" <+> pp_spec <+> "always come first"+          | null specified_tvs+          = note inf_always_first+          | otherwise+          = note $ inf_always_first $$+              "then specified variables" <+> pp_spec++        inf_always_first = "Inferred variables" <+> pp_inf $$ "always come first"++        pp_inf  = parens (text "namely:" <+> pprTyVars inferred_tvs)+        pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs)+    TcRnTyFamResultDisabled tc_name tvb -> mkSimpleDecorated $+      text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name)+    TcRnRoleValidationFailed role reason -> mkSimpleDecorated $+      vcat [text "Internal error in role inference:",+            pprRoleValidationFailedReason role reason,+            text "Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug"]+    TcRnCommonFieldResultTypeMismatch con1 con2 field_name -> mkSimpleDecorated $+      vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,+                 text "have a common field" <+> quotes (ppr field_name) <> comma],+            nest 2 $ text "but have different result types"]+    TcRnCommonFieldTypeMismatch con1 con2 field_name -> mkSimpleDecorated $+      sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,+           text "give different types for field", quotes (ppr field_name)]+    TcRnClassExtensionDisabled cls reason -> mkSimpleDecorated $+      pprDisabledClassExtension cls reason+    TcRnDataConParentTypeMismatch data_con res_ty_tmpl -> mkSimpleDecorated $+      hang (text "Data constructor" <+> quotes (ppr data_con) <+>+            text "returns type" <+> quotes (ppr actual_res_ty))+         2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl))+      where+        actual_res_ty = dataConOrigResTy data_con+    TcRnGADTsDisabled tc_name -> mkSimpleDecorated $+      text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name)+    TcRnExistentialQuantificationDisabled con -> mkSimpleDecorated $+      sdocOption sdocLinearTypes (\show_linear_types ->+        hang (text "Data constructor" <+> quotes (ppr con) <+>+              text "has existential type variables, a context, or a specialised result type")+           2 (ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)))+    TcRnGADTDataContext tc_name -> mkSimpleDecorated $+      text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name)+    TcRnMultipleConForNewtype tycon n -> mkSimpleDecorated $+      sep [text "A newtype must have exactly one constructor,",+           nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n]+    TcRnKindSignaturesDisabled thing -> mkSimpleDecorated $+      text "Illegal kind signature" <+> quotes (either ppr with_sig thing)+      where+        with_sig (tc_name, ksig) = ppr tc_name <+> dcolon <+> ppr ksig+    TcRnEmptyDataDeclsDisabled tycon -> mkSimpleDecorated $+      quotes (ppr tycon) <+> text "has no constructors"+    TcRnRoleMismatch var annot inferred -> mkSimpleDecorated $+      hang (text "Role mismatch on variable" <+> ppr var <> colon)+         2 (sep [ text "Annotation says", ppr annot+                , text "but role", ppr inferred+                , text "is required" ])+    TcRnRoleCountMismatch tyvars d@(L _ (RoleAnnotDecl _ _ annots)) -> mkSimpleDecorated $+      hang (text "Wrong number of roles listed in role annotation;" $$+            text "Expected" <+> (ppr tyvars) <> comma <+>+            text "got" <+> (ppr $ length annots) <> colon)+         2 (ppr d)+    TcRnIllegalRoleAnnotation (RoleAnnotDecl _ tycon _) -> mkSimpleDecorated $+      (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$+       text "they are allowed only for datatypes and classes.")+    TcRnRoleAnnotationsDisabled  tc -> mkSimpleDecorated $+      text "Illegal role annotation for" <+> ppr tc+    TcRnIncoherentRoles _ -> mkSimpleDecorated $+      (text "Roles other than" <+> quotes (text "nominal") <+>+      text "for class parameters can lead to incoherence.")+    TcRnUnexpectedKindVar tv_name+      -> mkSimpleDecorated $ text "Unexpected kind variable" <+> quotes (ppr tv_name)++    TcRnNegativeNumTypeLiteral tyLit+      -> mkSimpleDecorated $ text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit++    TcRnIllegalKind ty_thing _+      -> mkSimpleDecorated $ text "Illegal kind:" <+> (ppr ty_thing)++    TcRnPrecedenceParsingError op1 op2+      -> mkSimpleDecorated $+           hang (text "Precedence parsing error")+           4 (hsep [text "cannot mix", ppr_opfix op1, text "and",+           ppr_opfix op2,+           text "in the same infix expression"])++    TcRnSectionPrecedenceError op arg_op section+      -> mkSimpleDecorated $+           vcat [text "The operator" <+> ppr_opfix op <+> text "of a section",+             nest 4 (sep [text "must have lower precedence than that of the operand,",+                          nest 2 (text "namely" <+> ppr_opfix arg_op)]),+             nest 4 (text "in the section:" <+> quotes (ppr section))]++    TcRnUnexpectedPatSigType ty+      -> mkSimpleDecorated $+           hang (text "Illegal type signature:" <+> quotes (ppr ty))+              2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")++    TcRnIllegalKindSignature ty+      -> mkSimpleDecorated $ text "Illegal kind signature:" <+> quotes (ppr ty)++    TcRnUnusedQuantifiedTypeVar doc tyVar+      -> mkSimpleDecorated $+           vcat [ text "Unused quantified type variable" <+> quotes (ppr tyVar)+                , inHsDocContext doc ]++    TcRnDataKindsError typeOrKind thing+      -> case thing of+           Left renamer_thing ->+             mkSimpleDecorated $ msg renamer_thing+           Right typechecker_thing ->+             mkSimpleDecorated $ msg typechecker_thing+      where+        msg :: Outputable a => a -> SDoc+        msg thing = text "Illegal" <+> text (levelString typeOrKind) <>+                    colon <+> quotes (ppr thing)++    TcRnTypeSynonymCycle decl_or_tcs+      -> mkSimpleDecorated $+           sep [ text "Cycle in type synonym declarations:"+               , nest 2 (vcat (map ppr_decl decl_or_tcs)) ]+      where+        ppr_decl = \case+          Right (L loc decl) -> ppr (locA loc) <> colon <+> ppr decl+          Left tc ->+            let n = tyConName tc+            in ppr (getSrcSpan n) <> colon <+> ppr (tyConName tc)+                   <+> text "from external module"+    TcRnZonkerMessage err+      -> mkSimpleDecorated $ pprZonkerMessage err+    TcRnInterfaceError reason+      -> diagnosticMessage (tcOptsIfaceOpts opts) reason+    TcRnSelfImport imp_mod_name+      -> mkSimpleDecorated $+         text "A module cannot import itself:" <+> ppr imp_mod_name+    TcRnNoExplicitImportList mod+      -> mkSimpleDecorated $+         text "The module" <+> quotes (ppr mod) <+> text "does not have an explicit import list"+    TcRnSafeImportsDisabled _+      -> mkSimpleDecorated $+         text "safe import can't be used as Safe Haskell isn't on!"+    TcRnDeprecatedModule mod txt+      -> mkSimpleDecorated $+         sep [ text "Module" <+> quotes (ppr mod) <> text extra <> colon,+               nest 2 (vcat (map (ppr . hsDocString . unLoc) msg)) ]+         where+          (extra, msg) = case txt of+            WarningTxt _ _ msg -> ("", msg)+            DeprecatedTxt _ msg -> (" is deprecated", msg)+    TcRnRedundantSourceImport mod_name+      -> mkSimpleDecorated $+         text "Unnecessary {-# SOURCE #-} in the import of module" <+> quotes (ppr mod_name)+    TcRnImportLookup reason+      -> mkSimpleDecorated $+         pprImportLookup reason+    TcRnUnusedImport decl reason+      -> mkSimpleDecorated $+         pprUnusedImport decl reason+    TcRnDuplicateDecls name sorted_names+      -> mkSimpleDecorated $+         vcat [text "Multiple declarations of" <+>+               quotes (ppr name),+                -- NB. print the OccName, not the Name, because the+                -- latter might not be in scope in the RdrEnv and so will+                -- be printed qualified.+               text "Declared at:" <+>+               vcat (NE.toList $ ppr . nameSrcLoc <$> sorted_names)]+    TcRnPackageImportsDisabled+      -> mkSimpleDecorated $+         text "Package-qualified imports are not enabled"+    TcRnIllegalDataCon name+      -> mkSimpleDecorated $+         hsep [text "Illegal data constructor name", quotes (ppr name)]+    TcRnNestedForallsContexts entity+      -> mkSimpleDecorated $+         what <+> text "cannot contain nested"+         <+> quotes forAllLit <> text "s or contexts"+         where+           what = case entity of+             NFC_Specialize -> text "SPECIALISE instance type"+             NFC_ViaType -> quotes (text "via") <+> text "type"+             NFC_GadtConSig -> text "GADT constructor type signature"+             NFC_InstanceHead -> text "Instance head"+             NFC_StandaloneDerivedInstanceHead -> text "Standalone-derived instance head"+             NFC_DerivedClassType -> text "Derived class type"+    TcRnRedundantRecordWildcard+      -> mkSimpleDecorated $+         text "Record wildcard does not bind any new variables"+    TcRnUnusedRecordWildcard _+      -> mkSimpleDecorated $+         text "No variables bound in the record wildcard match are used"+    TcRnUnusedName name reason+      -> mkSimpleDecorated $+         pprUnusedName name reason+    TcRnQualifiedBinder rdr_name+      -> mkSimpleDecorated $+         text "Qualified name in binding position:" <+> ppr rdr_name+    TcRnTypeApplicationsDisabled ty ty_or_ki+      -> mkSimpleDecorated $+         text "Illegal visible" <+> what <+> text "application" <> colon+           <+> ppr arg+         where+           arg = char '@' <> ppr ty+           what = case ty_or_ki of+             TypeLevel -> text "type"+             KindLevel -> text "kind"+    TcRnInvalidRecordField con field+      -> mkSimpleDecorated $+         hsep [text "Constructor" <+> quotes (ppr con),+               text "does not have field", quotes (ppr field)]+    TcRnTupleTooLarge tup_size+      -> mkSimpleDecorated $+         sep [text "A" <+> int tup_size <> text "-tuple is too large for GHC",+              nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),+              nest 2 (text "Workaround: use nested tuples or define a data type")]+    TcRnCTupleTooLarge tup_size+      -> mkSimpleDecorated $+         hang (text "Constraint tuple arity too large:" <+> int tup_size+               <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))+            2 (text "Instead, use a nested tuple")+    TcRnIllegalInferredTyVars _+      -> mkSimpleDecorated $+         text "Inferred type variables are not allowed"+    TcRnAmbiguousName gre_env name gres+      -> mkSimpleDecorated $+         vcat [ text "Ambiguous occurrence" <+> quotes (ppr name) <> dot+              , text "It could refer to"+              , nest 3 (vcat msgs) ]+         where+           np1 NE.:| nps = gres+           msgs = punctuateFinal comma dot $+                    text "either" <+> ppr_gre np1+                 : [text "    or" <+> ppr_gre np | np <- nps]++           ppr_gre gre = pprAmbiguousGreName gre_env gre++    TcRnBindingNameConflict name locs+      -> mkSimpleDecorated $+         vcat [text "Conflicting definitions for" <+> quotes (ppr name),+               locations]+         where+           locations =+             text "Bound at:"+             <+> vcat (map ppr (sortBy leftmost_smallest (NE.toList locs)))+    TcRnNonCanonicalDefinition reason inst_ty+      -> mkSimpleDecorated $+         pprNonCanonicalDefinition inst_ty reason+    TcRnDefaultedExceptionContext ct_loc ->+      mkSimpleDecorated $ vcat [ header, warning, proposal ]+      where+        header, warning, proposal :: SDoc+        header+          = vcat [ text "Solving for an implicit ExceptionContext constraint"+                 , nest 2 $ pprCtOrigin (ctLocOrigin ct_loc) <> text "." ]+        warning+          = vcat [ text "Future versions of GHC will turn this warning into an error." ]+        proposal+          = vcat [ text "See GHC Proposal #330." ]+    TcRnImplicitImportOfPrelude+      -> mkSimpleDecorated $+         text "Module" <+> quotes (text "Prelude") <+> text "implicitly imported."+    TcRnMissingMain explicit_export_list main_mod main_occ+      -> mkSimpleDecorated $+         text "The" <+> ppMainFn main_occ+        <+> text "is not" <+> defOrExp <+> text "module"+        <+> quotes (ppr main_mod)+      where+        defOrExp :: SDoc+        defOrExp | explicit_export_list = text "exported by"+                 | otherwise            = text "defined in"+    TcRnGhciUnliftedBind id+      -> mkSimpleDecorated $+         sep [ text "GHCi can't bind a variable of unlifted type:"+             , nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id)) ]+    TcRnGhciMonadLookupFail ty lookups+      -> mkSimpleDecorated $+         hang (text "Can't find type" <+> pp_ty <> dot $$ ambig_msg)+           2 (text "When checking that" <+> pp_ty <>+              text "is a monad that can execute GHCi statements.")+      where+        pp_ty = quotes (text ty)+        ambig_msg = case lookups of+          Just (_:_:_) -> text "The type is ambiguous."+          _            -> empty+    TcRnIllegalQuasiQuotes -> mkSimpleDecorated $+      text "Quasi-quotes are not permitted without QuasiQuotes"+    TcRnTHError err -> pprTHError err+    TcRnPatersonCondFailure reason ctxt lhs rhs ->+      mkSimpleDecorated $ pprPatersonCondFailure reason ctxt lhs rhs+    TcRnIllegalInvisTyVarBndr bndr ->+      mkSimpleDecorated $+        hang (text "Illegal invisible type variable binder:")+           2 (ppr bndr)+    TcRnIllegalWildcardTyVarBndr bndr ->+      mkSimpleDecorated $+        hang (text "Illegal wildcard binder:")+           2 (ppr bndr)++    TcRnInvalidInvisTyVarBndr name hs_bndr ->+      mkSimpleDecorated $+        vcat [ hang (text "Invalid invisible type variable binder:")+                  2 (ppr hs_bndr)+             , text "There is no matching forall-bound variable"+             , text "in the standalone kind signature for" <+> quotes (ppr name) <> dot+             , note $ vcat [+                "Only" <+> quotes "forall a." <+> "-quantification matches invisible binders,",+                "whereas" <+> quotes "forall {a}." <+> "and" <+> quotes "forall a ->" <+> "do not"+             ]]++    TcRnInvisBndrWithoutSig _ hs_bndr ->+      mkSimpleDecorated $+        vcat [ hang (text "Invalid invisible type variable binder:")+                  2 (ppr hs_bndr)+             , text "Either a standalone kind signature (SAKS)"+             , text "or a complete user-supplied kind (CUSK, legacy feature)"+             , text "is required to use invisible binders." ]++    TcRnImplicitRhsQuantification kv -> mkSimpleDecorated $+      vcat [ text "The variable" <+> quotes (ppr kv) <+> text "occurs free on the RHS of the type declaration"+           , text "The next version of GHC will reject this program, no longer implicitly quantify over" <+> quotes (ppr kv)+           ]++    TcRnInvalidDefaultedTyVar wanteds proposal bad_tvs ->+      mkSimpleDecorated $+      pprWithInvisibleBitsWhen True $+      vcat [ text "Invalid defaulting proposal."+           , hang (text "The following type variable" <> plural (NE.toList bad_tvs) <+> text "cannot be defaulted, as" <+> why <> colon)+                2 (pprQuotedList (NE.toList bad_tvs))+           , hang (text "Defaulting proposal:")+                2 (ppr proposal)+           , hang (text "Wanted constraints:")+                2 (pprQuotedList (map ctPred wanteds))+           ]+        where+          why+            | _ :| [] <- bad_tvs+            = text "it is not an unfilled metavariable"+            | otherwise+            = text "they are not unfilled metavariables"++    TcRnNamespacedWarningPragmaWithoutFlag warning@(Warning (kw, _) _ txt) -> mkSimpleDecorated $+      vcat [ text "Illegal use of the" <+> quotes (ppr kw) <+> text "keyword:"+           , nest 2 (ppr warning)+           , text "in a" <+> pragma_type <+> text "pragma"+           ]+      where+        pragma_type = case txt of+          WarningTxt{} -> text "WARNING"+          DeprecatedTxt{} -> text "DEPRECATED"++    TcRnIllegalInvisibleTypePattern tp reason -> mkSimpleDecorated $+      vcat [ hang (text "Illegal invisible type pattern:")+                  2 (char '@' <> ppr tp)+           , case reason of+               InvisPatWithoutFlag -> empty+               InvisPatNoForall  -> text "An invisible type pattern must be checked against a forall."+               InvisPatMisplaced -> text "An invisible type pattern must occur in an argument position."+           ]++    TcRnNamespacedFixitySigWithoutFlag sig@(FixitySig kw _ _) -> mkSimpleDecorated $+      vcat [ text "Illegal use of the" <+> quotes (ppr kw) <+> text "keyword:"+           , nest 2 (ppr sig)+           , text "in a fixity signature"+           ]++    TcRnOutOfArityTyVar ts_name tv_name -> mkDecorated+      [ vcat [ text "The arity of" <+> quotes (ppr ts_name) <+> text "is insufficiently high to accommodate"+             , text "an implicit binding for the" <+> quotes (ppr tv_name) <+> text "type variable." ]+      , suggestion ]+      where+        suggestion =+          text "Use" <+> quotes at_bndr     <+> text "on the LHS" <+>+          text "or"  <+> quotes forall_bndr <+> text "on the RHS" <+>+          text "to bring it into scope."+        at_bndr     = char '@' <> ppr tv_name+        forall_bndr = text "forall" <+> ppr tv_name <> text "."++    TcRnUnexpectedTypeSyntaxInTerms syntax -> mkSimpleDecorated $+      text "Unexpected" <+> pprTypeSyntaxName syntax++  diagnosticReason :: TcRnMessage -> DiagnosticReason+  diagnosticReason = \case+    TcRnUnknownMessage m+      -> diagnosticReason m+    TcRnMessageWithInfo _ msg_with_info+      -> case msg_with_info of+           TcRnMessageDetailed _ m -> diagnosticReason m+    TcRnWithHsDocContext _ msg+      -> diagnosticReason msg+    TcRnSolverReport _report reason+      -> reason -- Error, or a Warning if we are deferring type errors+    TcRnSolverDepthError {}+      -> ErrorWithoutFlag+    TcRnRedundantConstraints {}+      -> WarningWithFlag Opt_WarnRedundantConstraints+    TcRnInaccessibleCode {}+      -> WarningWithFlag Opt_WarnInaccessibleCode+    TcRnInaccessibleCoAxBranch {}+      -> WarningWithFlag Opt_WarnInaccessibleCode+    TcRnTypeDoesNotHaveFixedRuntimeRep{}+      -> ErrorWithoutFlag+    TcRnImplicitLift{}+      -> WarningWithFlag Opt_WarnImplicitLift+    TcRnUnusedPatternBinds{}+      -> WarningWithFlag Opt_WarnUnusedPatternBinds+    TcRnDodgyImports{}+      -> WarningWithFlag Opt_WarnDodgyImports+    TcRnDodgyExports{}+      -> WarningWithFlag Opt_WarnDodgyExports+    TcRnMissingImportList{}+      -> WarningWithFlag Opt_WarnMissingImportList+    TcRnUnsafeDueToPlugin{}+      -> WarningWithoutFlag+    TcRnModMissingRealSrcSpan{}+      -> ErrorWithoutFlag+    TcRnIdNotExportedFromModuleSig{}+      -> ErrorWithoutFlag+    TcRnIdNotExportedFromLocalSig{}+      -> ErrorWithoutFlag+    TcRnShadowedName{}+      -> WarningWithFlag Opt_WarnNameShadowing+    TcRnInvalidWarningCategory{}+      -> ErrorWithoutFlag+    TcRnDuplicateWarningDecls{}+      -> ErrorWithoutFlag+    TcRnSimplifierTooManyIterations{}+      -> ErrorWithoutFlag+    TcRnIllegalPatSynDecl{}+      -> ErrorWithoutFlag+    TcRnLinearPatSyn{}+      -> ErrorWithoutFlag+    TcRnEmptyRecordUpdate+      -> ErrorWithoutFlag+    TcRnIllegalFieldPunning{}+      -> ErrorWithoutFlag+    TcRnIllegalWildcardsInRecord{}+      -> ErrorWithoutFlag+    TcRnIllegalWildcardInType{}+      -> ErrorWithoutFlag+    TcRnIllegalNamedWildcardInTypeArgument{}+      -> ErrorWithoutFlag+    TcRnIllegalImplicitTyVarInTypeArgument{}+      -> ErrorWithoutFlag+    TcRnIllegalPunnedVarOccInTypeArgument{}+      -> ErrorWithoutFlag+    TcRnDuplicateFieldName{}+      -> ErrorWithoutFlag+    TcRnIllegalViewPattern{}+      -> ErrorWithoutFlag+    TcRnCharLiteralOutOfRange{}+      -> ErrorWithoutFlag+    TcRnIllegalWildcardsInConstructor{}+      -> ErrorWithoutFlag+    TcRnIgnoringAnnotations{}+      -> WarningWithoutFlag+    TcRnAnnotationInSafeHaskell+      -> ErrorWithoutFlag+    TcRnInvalidTypeApplication{}+      -> ErrorWithoutFlag+    TcRnTagToEnumMissingValArg+      -> ErrorWithoutFlag+    TcRnTagToEnumUnspecifiedResTy{}+      -> ErrorWithoutFlag+    TcRnTagToEnumResTyNotAnEnum{}+      -> ErrorWithoutFlag+    TcRnTagToEnumResTyTypeData{}+      -> ErrorWithoutFlag+    TcRnArrowIfThenElsePredDependsOnResultTy+      -> ErrorWithoutFlag+    TcRnIllegalHsBootOrSigDecl {}+      -> ErrorWithoutFlag+    TcRnBootMismatch {}+      -> ErrorWithoutFlag+    TcRnRecursivePatternSynonym{}+      -> ErrorWithoutFlag+    TcRnPartialTypeSigTyVarMismatch{}+      -> ErrorWithoutFlag+    TcRnPartialTypeSigBadQuantifier{}+      -> ErrorWithoutFlag+    TcRnMissingSignature what exported+      -> WarningWithFlags $ missingSignatureWarningFlags what exported+    TcRnPolymorphicBinderMissingSig{}+      -> WarningWithFlag Opt_WarnMissingLocalSignatures+    TcRnOverloadedSig{}+      -> ErrorWithoutFlag+    TcRnTupleConstraintInst{}+      -> ErrorWithoutFlag+    TcRnUserTypeError{}+      -> ErrorWithoutFlag+    TcRnConstraintInKind{}+      -> ErrorWithoutFlag+    TcRnUnboxedTupleOrSumTypeFuncArg{}+      -> ErrorWithoutFlag+    TcRnLinearFuncInKind{}+      -> ErrorWithoutFlag+    TcRnForAllEscapeError{}+      -> ErrorWithoutFlag+    TcRnSimplifiableConstraint{}+      -> WarningWithFlag Opt_WarnSimplifiableClassConstraints+    TcRnArityMismatch{}+      -> ErrorWithoutFlag+    TcRnIllegalInstance rea+      -> illegalInstanceReason rea+    TcRnVDQInTermType{}+      -> ErrorWithoutFlag+    TcRnBadQuantPredHead{}+      -> ErrorWithoutFlag+    TcRnIllegalTupleConstraint{}+      -> ErrorWithoutFlag+    TcRnNonTypeVarArgInConstraint{}+      -> ErrorWithoutFlag+    TcRnIllegalImplicitParam{}+      -> ErrorWithoutFlag+    TcRnIllegalConstraintSynonymOfKind{}+      -> ErrorWithoutFlag+    TcRnOversaturatedVisibleKindArg{}+      -> ErrorWithoutFlag+    TcRnForAllRankErr{}+      -> ErrorWithoutFlag+    TcRnMonomorphicBindings{}+      -> WarningWithFlag Opt_WarnMonomorphism+    TcRnOrphanInstance{}+      -> WarningWithFlag Opt_WarnOrphans+    TcRnFunDepConflict{}+      -> ErrorWithoutFlag+    TcRnDupInstanceDecls{}+      -> ErrorWithoutFlag+    TcRnConflictingFamInstDecls{}+      -> ErrorWithoutFlag+    TcRnFamInstNotInjective{}+      -> ErrorWithoutFlag+    TcRnBangOnUnliftedType{}+      -> WarningWithFlag Opt_WarnRedundantStrictnessFlags+    TcRnLazyBangOnUnliftedType{}+      -> WarningWithFlag Opt_WarnRedundantStrictnessFlags+    TcRnMultipleDefaultDeclarations{}+      -> ErrorWithoutFlag+    TcRnBadDefaultType{}+      -> ErrorWithoutFlag+    TcRnPatSynBundledWithNonDataCon{}+      -> ErrorWithoutFlag+    TcRnPatSynBundledWithWrongType{}+      -> ErrorWithoutFlag+    TcRnDupeModuleExport{}+      -> WarningWithFlag Opt_WarnDuplicateExports+    TcRnExportedModNotImported{}+      -> ErrorWithoutFlag+    TcRnNullExportedModule{}+      -> WarningWithFlag Opt_WarnDodgyExports+    TcRnMissingExportList{}+      -> WarningWithFlag Opt_WarnMissingExportList+    TcRnExportHiddenComponents{}+      -> ErrorWithoutFlag+    TcRnExportHiddenDefault{}+      -> ErrorWithoutFlag+    TcRnDuplicateExport{}+      -> WarningWithFlag Opt_WarnDuplicateExports+    TcRnDuplicateNamedDefaultExport{}+      -> WarningWithFlag Opt_WarnDuplicateExports+    TcRnExportedParentChildMismatch{}+      -> ErrorWithoutFlag+    TcRnConflictingExports{}+      -> ErrorWithoutFlag+    TcRnDuplicateFieldExport {}+      -> ErrorWithoutFlag+    TcRnAmbiguousFieldInUpdate {}+      -> ErrorWithoutFlag+    TcRnAmbiguousRecordUpdate{}+      -> WarningWithFlag Opt_WarnAmbiguousFields+    TcRnMissingFields{}+      -> WarningWithFlag Opt_WarnMissingFields+    TcRnFieldUpdateInvalidType{}+      -> ErrorWithoutFlag+    TcRnMissingStrictFields{}+      -> ErrorWithoutFlag+    TcRnBadRecordUpdate{}+      -> ErrorWithoutFlag+    TcRnIllegalStaticExpression {}+      -> ErrorWithoutFlag+    TcRnStaticFormNotClosed{}+      -> ErrorWithoutFlag+    TcRnUselessTypeable+      -> WarningWithFlag Opt_WarnDerivingTypeable+    TcRnDerivingDefaults{}+      -> WarningWithFlag Opt_WarnDerivingDefaults+    TcRnNonUnaryTypeclassConstraint{}+      -> ErrorWithoutFlag+    TcRnPartialTypeSignatures{}+      -> WarningWithFlag Opt_WarnPartialTypeSignatures+    TcRnCannotDeriveInstance _ _ _ _ rea+      -> case rea of+           DerivErrNotWellKinded{}                 -> ErrorWithoutFlag+           DerivErrSafeHaskellGenericInst          -> ErrorWithoutFlag+           DerivErrDerivingViaWrongKind{}          -> ErrorWithoutFlag+           DerivErrNoEtaReduce{}                   -> ErrorWithoutFlag+           DerivErrBootFileFound                   -> ErrorWithoutFlag+           DerivErrDataConsNotAllInScope{}         -> ErrorWithoutFlag+           DerivErrGNDUsedOnData                   -> ErrorWithoutFlag+           DerivErrNullaryClasses                  -> ErrorWithoutFlag+           DerivErrLastArgMustBeApp                -> ErrorWithoutFlag+           DerivErrNoFamilyInstance{}              -> ErrorWithoutFlag+           DerivErrNotStockDeriveable{}            -> ErrorWithoutFlag+           DerivErrHasAssociatedDatatypes{}        -> ErrorWithoutFlag+           DerivErrNewtypeNonDeriveableClass       -> ErrorWithoutFlag+           DerivErrCannotEtaReduceEnough{}         -> ErrorWithoutFlag+           DerivErrOnlyAnyClassDeriveable{}        -> ErrorWithoutFlag+           DerivErrNotDeriveable{}                 -> ErrorWithoutFlag+           DerivErrNotAClass{}                     -> ErrorWithoutFlag+           DerivErrNoConstructors{}                -> ErrorWithoutFlag+           DerivErrLangExtRequired{}               -> ErrorWithoutFlag+           DerivErrDunnoHowToDeriveForType{}       -> ErrorWithoutFlag+           DerivErrMustBeEnumType{}                -> ErrorWithoutFlag+           DerivErrMustHaveExactlyOneConstructor{} -> ErrorWithoutFlag+           DerivErrMustHaveSomeParameters{}        -> ErrorWithoutFlag+           DerivErrMustNotHaveClassContext{}       -> ErrorWithoutFlag+           DerivErrBadConstructor{}                -> ErrorWithoutFlag+           DerivErrGenerics{}                      -> ErrorWithoutFlag+           DerivErrEnumOrProduct{}                 -> ErrorWithoutFlag+    TcRnLookupInstance _ _ _+      -> ErrorWithoutFlag+    TcRnLazyGADTPattern+      -> ErrorWithoutFlag+    TcRnArrowProcGADTPattern+      -> ErrorWithoutFlag+    TcRnTypeEqualityOutOfScope+      -> WarningWithFlag Opt_WarnTypeEqualityOutOfScope+    TcRnTypeEqualityRequiresOperators+      -> WarningWithFlag Opt_WarnTypeEqualityRequiresOperators+    TcRnIllegalTypeOperator {}+      -> ErrorWithoutFlag+    TcRnIllegalTypeOperatorDecl {}+      -> ErrorWithoutFlag+    TcRnGADTMonoLocalBinds {}+      -> WarningWithFlag Opt_WarnGADTMonoLocalBinds+    TcRnIncorrectNameSpace {}+      -> ErrorWithoutFlag+    TcRnNotInScope {}+      -> ErrorWithoutFlag+    TcRnTermNameInType {}+      -> ErrorWithoutFlag+    TcRnUntickedPromotedThing {}+      -> WarningWithFlag Opt_WarnUntickedPromotedConstructors+    TcRnIllegalBuiltinSyntax {}+      -> ErrorWithoutFlag+    TcRnWarnDefaulting {}+      -> WarningWithFlag Opt_WarnTypeDefaults+    TcRnWarnClashingDefaultImports {}+      -> WarningWithFlag Opt_WarnTypeDefaults+    TcRnForeignImportPrimExtNotSet{}+      -> ErrorWithoutFlag+    TcRnForeignImportPrimSafeAnn{}+      -> ErrorWithoutFlag+    TcRnForeignFunctionImportAsValue{}+      -> ErrorWithoutFlag+    TcRnFunPtrImportWithoutAmpersand{}+      -> WarningWithFlag Opt_WarnDodgyForeignImports+    TcRnIllegalForeignDeclBackend{}+      -> ErrorWithoutFlag+    TcRnUnsupportedCallConv _ unsupportedCC+      -> case unsupportedCC of+           StdCallConvUnsupported -> WarningWithFlag Opt_WarnUnsupportedCallingConventions+           _ -> ErrorWithoutFlag+    TcRnIllegalForeignType{}+      -> ErrorWithoutFlag+    TcRnInvalidCIdentifier{}+      -> ErrorWithoutFlag+    TcRnExpectedValueId{}+      -> ErrorWithoutFlag+    TcRnRecSelectorEscapedTyVar{}+      -> ErrorWithoutFlag+    TcRnPatSynNotBidirectional{}+      -> ErrorWithoutFlag+    TcRnIllegalDerivingItem{}+      -> ErrorWithoutFlag+    TcRnIllegalDefaultClass{}+      -> ErrorWithoutFlag+    TcRnIllegalNamedDefault{}+      -> ErrorWithoutFlag+    TcRnUnexpectedAnnotation{}+      -> ErrorWithoutFlag+    TcRnIllegalRecordSyntax{}+      -> ErrorWithoutFlag+    TcRnInvalidVisibleKindArgument{}+      -> ErrorWithoutFlag+    TcRnTooManyBinders{}+      -> ErrorWithoutFlag+    TcRnDifferentNamesForTyVar{}+      -> ErrorWithoutFlag+    TcRnDisconnectedTyVar{}+      -> ErrorWithoutFlag+    TcRnInvalidReturnKind{}+      -> ErrorWithoutFlag+    TcRnClassKindNotConstraint{}+      -> ErrorWithoutFlag+    TcRnUnpromotableThing{}+      -> ErrorWithoutFlag+    TcRnIllegalTermLevelUse{}+      -> ErrorWithoutFlag+    TcRnMatchesHaveDiffNumArgs{}+      -> ErrorWithoutFlag+    TcRnCannotBindScopedTyVarInPatSig{}+      -> ErrorWithoutFlag+    TcRnCannotBindTyVarsInPatBind{}+      -> ErrorWithoutFlag+    TcRnMultipleInlinePragmas{}+      -> WarningWithoutFlag+    TcRnUnexpectedPragmas{}+      -> WarningWithoutFlag+    TcRnNonOverloadedSpecialisePragma{}+      -> WarningWithoutFlag+    TcRnSpecialiseNotVisible{}+      -> WarningWithoutFlag+    TcRnPragmaWarning{pragma_warning_msg}+      -> WarningWithCategory (warningTxtCategory pragma_warning_msg)+    TcRnDifferentExportWarnings _ _+      -> ErrorWithoutFlag+    TcRnIncompleteExportWarnings _ _+      -> WarningWithFlag Opt_WarnIncompleteExportWarnings+    TcRnIllegalHsigDefaultMethods{}+      -> ErrorWithoutFlag+    TcRnHsigFixityMismatch{}+      -> ErrorWithoutFlag+    TcRnHsigShapeMismatch{}+      -> ErrorWithoutFlag+    TcRnHsigMissingModuleExport{}+      -> ErrorWithoutFlag+    TcRnBadGenericMethod{}+      -> ErrorWithoutFlag+    TcRnWarningMinimalDefIncomplete{}+      -> WarningWithoutFlag+    TcRnDefaultMethodForPragmaLacksBinding{}+      -> ErrorWithoutFlag+    TcRnIgnoreSpecialisePragmaOnDefMethod{}+      -> WarningWithoutFlag+    TcRnBadMethodErr{}+      -> ErrorWithoutFlag+    TcRnIllegalTypeData+      -> ErrorWithoutFlag+    TcRnIllegalQuasiQuotes{}+      -> ErrorWithoutFlag+    TcRnTHError err+      -> thErrorReason err+    TcRnTypeDataForbids{}+      -> ErrorWithoutFlag+    TcRnIllegalNewtype{}+      -> ErrorWithoutFlag+    TcRnOrPatBindsVariables{}+      -> ErrorWithoutFlag+    TcRnUnsatisfiedMinimalDef{}+      -> WarningWithFlag (Opt_WarnMissingMethods)+    TcRnMisplacedInstSig{}+      -> ErrorWithoutFlag+    TcRnNoRebindableSyntaxRecordDot{}+      -> ErrorWithoutFlag+    TcRnNoFieldPunsRecordDot{}+      -> ErrorWithoutFlag+    TcRnListComprehensionDuplicateBinding{}+      -> ErrorWithoutFlag+    TcRnEmptyStmtsGroup{}+      -> ErrorWithoutFlag+    TcRnLastStmtNotExpr{}+      -> ErrorWithoutFlag+    TcRnUnexpectedStatementInContext{}+      -> ErrorWithoutFlag+    TcRnSectionWithoutParentheses{}+      -> ErrorWithoutFlag+    TcRnIllegalImplicitParameterBindings{}+      -> ErrorWithoutFlag+    TcRnIllegalTupleSection{}+      -> ErrorWithoutFlag+    TcRnCapturedTermName{}+      -> WarningWithFlag Opt_WarnTermVariableCapture+    TcRnBindingOfExistingName{}+      -> ErrorWithoutFlag+    TcRnMultipleFixityDecls{}+      -> ErrorWithoutFlag+    TcRnIllegalPatternSynonymDecl{}+      -> ErrorWithoutFlag+    TcRnIllegalClassBinding{}+      -> ErrorWithoutFlag+    TcRnOrphanCompletePragma{}+      -> ErrorWithoutFlag+    TcRnSpecSigShape{}+      -> ErrorWithoutFlag+    TcRnEmptyCase{}+      -> ErrorWithoutFlag+    TcRnNonStdGuards{}+      -> WarningWithoutFlag+    TcRnDuplicateSigDecl{}+      -> ErrorWithoutFlag+    TcRnMisplacedSigDecl{}+      -> ErrorWithoutFlag+    TcRnUnexpectedDefaultSig{}+      -> ErrorWithoutFlag+    TcRnDuplicateMinimalSig{}+      -> ErrorWithoutFlag+    TcRnUnexpectedStandaloneDerivingDecl{}+      -> ErrorWithoutFlag+    TcRnUnusedVariableInRuleDecl{}+      -> ErrorWithoutFlag+    TcRnUnexpectedStandaloneKindSig{}+      -> ErrorWithoutFlag+    TcRnIllegalRuleLhs{}+      -> ErrorWithoutFlag+    TcRnRuleLhsEqualities{}+      -> WarningWithFlag Opt_WarnRuleLhsEqualities+    TcRnDuplicateRoleAnnot{}+      -> ErrorWithoutFlag+    TcRnDuplicateKindSig{}+      -> ErrorWithoutFlag+    TcRnIllegalDerivStrategy{}+      -> ErrorWithoutFlag+    TcRnIllegalMultipleDerivClauses{}+      -> ErrorWithoutFlag+    TcRnNoDerivStratSpecified{}+      -> WarningWithFlag Opt_WarnMissingDerivingStrategies+    TcRnStupidThetaInGadt{}+      -> ErrorWithoutFlag+    TcRnShadowedTyVarNameInFamResult{}+      -> ErrorWithoutFlag+    TcRnIncorrectTyVarOnLhsOfInjCond{}+      -> ErrorWithoutFlag+    TcRnUnknownTyVarsOnRhsOfInjCond{}+      -> ErrorWithoutFlag+    TcRnBadlyLevelled _ _ _ _ reason+      -> reason+    TcRnBadlyLevelledType{}+      -> WarningWithFlag Opt_WarnBadlyLevelledTypes+    TcRnTyThingUsedWrong{}+      -> ErrorWithoutFlag+    TcRnCannotDefaultKindVar{}+      -> ErrorWithoutFlag+    TcRnUninferrableTyVar{}+      -> ErrorWithoutFlag+    TcRnSkolemEscape{}+      -> ErrorWithoutFlag+    TcRnPatSynEscapedCoercion{}+      -> ErrorWithoutFlag+    TcRnPatSynExistentialInResult{}+      -> ErrorWithoutFlag+    TcRnPatSynArityMismatch{}+      -> ErrorWithoutFlag+    TcRnPatSynInvalidRhs{}+      -> ErrorWithoutFlag+    TcRnTyFamDepsDisabled{}+      -> ErrorWithoutFlag+    TcRnAbstractClosedTyFamDecl{}+      -> ErrorWithoutFlag+    TcRnPartialFieldSelector{}+      -> WarningWithFlag Opt_WarnPartialFields+    TcRnHasFieldResolvedIncomplete{}+      -> WarningWithFlag Opt_WarnIncompleteRecordSelectors+    TcRnBadFieldAnnotation _ _ LazyFieldsDisabled+      -> ErrorWithoutFlag+    TcRnBadFieldAnnotation _ _ UnusableUnpackPragma+      -> WarningWithFlag Opt_WarnUnusableUnpackPragmas+    TcRnBadFieldAnnotation{}+      -> WarningWithoutFlag+    TcRnSuperclassCycle{}+      -> ErrorWithoutFlag+    TcRnDefaultSigMismatch{}+      -> ErrorWithoutFlag+    TcRnTyFamsDisabled{}+      -> ErrorWithoutFlag+    TcRnBadTyConTelescope {}+      -> ErrorWithoutFlag+    TcRnTyFamResultDisabled{}+      -> ErrorWithoutFlag+    TcRnRoleValidationFailed{}+      -> ErrorWithoutFlag+    TcRnCommonFieldResultTypeMismatch{}+      -> ErrorWithoutFlag+    TcRnCommonFieldTypeMismatch{}+      -> ErrorWithoutFlag+    TcRnClassExtensionDisabled{}+      -> ErrorWithoutFlag+    TcRnDataConParentTypeMismatch{}+      -> ErrorWithoutFlag+    TcRnGADTsDisabled{}+      -> ErrorWithoutFlag+    TcRnExistentialQuantificationDisabled{}+      -> ErrorWithoutFlag+    TcRnGADTDataContext{}+      -> ErrorWithoutFlag+    TcRnMultipleConForNewtype{}+      -> ErrorWithoutFlag+    TcRnKindSignaturesDisabled{}+      -> ErrorWithoutFlag+    TcRnEmptyDataDeclsDisabled{}+      -> ErrorWithoutFlag+    TcRnRoleMismatch{}+      -> ErrorWithoutFlag+    TcRnRoleCountMismatch{}+      -> ErrorWithoutFlag+    TcRnIllegalRoleAnnotation{}+      -> ErrorWithoutFlag+    TcRnRoleAnnotationsDisabled{}+      -> ErrorWithoutFlag+    TcRnIncoherentRoles{}+      -> ErrorWithoutFlag+    TcRnUnexpectedKindVar{}+      -> ErrorWithoutFlag+    TcRnNegativeNumTypeLiteral{}+      -> ErrorWithoutFlag+    TcRnIllegalKind{}+      -> ErrorWithoutFlag+    TcRnPrecedenceParsingError{}+      -> ErrorWithoutFlag+    TcRnSectionPrecedenceError{}+      -> ErrorWithoutFlag+    TcRnUnexpectedPatSigType{}+      -> ErrorWithoutFlag+    TcRnIllegalKindSignature{}+      -> ErrorWithoutFlag+    TcRnUnusedQuantifiedTypeVar{}+      -> WarningWithFlag Opt_WarnUnusedForalls+    TcRnDataKindsError{}+      -> ErrorWithoutFlag+    TcRnTypeSynonymCycle{}+      -> ErrorWithoutFlag+    TcRnZonkerMessage msg+      -> zonkerMessageReason msg+    TcRnInterfaceError err+      -> interfaceErrorReason err+    TcRnSelfImport{}+      -> ErrorWithoutFlag+    TcRnNoExplicitImportList{}+      -> WarningWithFlag Opt_WarnMissingImportList+    TcRnSafeImportsDisabled{}+      -> ErrorWithoutFlag+    TcRnDeprecatedModule _ txt+      -> WarningWithCategory (warningTxtCategory txt)+    TcRnRedundantSourceImport{}+      -> WarningWithoutFlag+    TcRnImportLookup{}+      -> ErrorWithoutFlag+    TcRnUnusedImport{}+      -> WarningWithFlag Opt_WarnUnusedImports+    TcRnDuplicateDecls{}+      -> ErrorWithoutFlag+    TcRnPackageImportsDisabled+      -> ErrorWithoutFlag+    TcRnIllegalDataCon{}+      -> ErrorWithoutFlag+    TcRnNestedForallsContexts{}+      -> ErrorWithoutFlag+    TcRnRedundantRecordWildcard+      -> WarningWithFlag Opt_WarnRedundantRecordWildcards+    TcRnUnusedRecordWildcard{}+      -> WarningWithFlag Opt_WarnUnusedRecordWildcards+    TcRnUnusedName _ prov+      -> WarningWithFlag $ case prov of+        UnusedNameTopDecl -> Opt_WarnUnusedTopBinds+        UnusedNameImported _ -> Opt_WarnUnusedTopBinds+        UnusedNameTypePattern -> Opt_WarnUnusedTypePatterns+        UnusedNameMatch -> Opt_WarnUnusedMatches+        UnusedNameLocalBind -> Opt_WarnUnusedLocalBinds+    TcRnQualifiedBinder{}+      -> ErrorWithoutFlag+    TcRnTypeApplicationsDisabled{}+      -> ErrorWithoutFlag+    TcRnInvalidRecordField{}+      -> ErrorWithoutFlag+    TcRnTupleTooLarge{}+      -> ErrorWithoutFlag+    TcRnCTupleTooLarge{}+      -> ErrorWithoutFlag+    TcRnIllegalInferredTyVars{}+      -> ErrorWithoutFlag+    TcRnAmbiguousName{}+      -> ErrorWithoutFlag+    TcRnBindingNameConflict{}+      -> ErrorWithoutFlag+    TcRnNonCanonicalDefinition (NonCanonicalMonoid _) _+      -> WarningWithFlag Opt_WarnNonCanonicalMonoidInstances+    TcRnNonCanonicalDefinition (NonCanonicalMonad _) _+      -> WarningWithFlag Opt_WarnNonCanonicalMonadInstances+    TcRnDefaultedExceptionContext{}+      -> WarningWithFlag Opt_WarnDefaultedExceptionContext+    TcRnImplicitImportOfPrelude {}+      -> WarningWithFlag Opt_WarnImplicitPrelude+    TcRnMissingMain {}+      -> ErrorWithoutFlag+    TcRnGhciUnliftedBind {}+      -> ErrorWithoutFlag+    TcRnGhciMonadLookupFail {}+      -> ErrorWithoutFlag+    TcRnMissingRoleAnnotation{}+      -> WarningWithFlag Opt_WarnMissingRoleAnnotations+    TcRnIllegalInvisTyVarBndr{}+      -> ErrorWithoutFlag+    TcRnIllegalWildcardTyVarBndr{}+      -> ErrorWithoutFlag+    TcRnInvalidInvisTyVarBndr{}+      -> ErrorWithoutFlag+    TcRnInvisBndrWithoutSig{}+      -> ErrorWithoutFlag+    TcRnImplicitRhsQuantification{}+      -> WarningWithFlag Opt_WarnImplicitRhsQuantification+    TcRnPatersonCondFailure{}+      -> ErrorWithoutFlag+    TcRnIllformedTypePattern{}+      -> ErrorWithoutFlag+    TcRnIllegalTypePattern{}+      -> ErrorWithoutFlag+    TcRnIllformedTypeArgument{}+      -> ErrorWithoutFlag+    TcRnIllegalTypeExpr{}+      -> ErrorWithoutFlag+    TcRnInvalidDefaultedTyVar{}+      -> ErrorWithoutFlag+    TcRnNamespacedWarningPragmaWithoutFlag{}+      -> ErrorWithoutFlag+    TcRnIllegalInvisibleTypePattern{}+      -> ErrorWithoutFlag+    TcRnNamespacedFixitySigWithoutFlag{}+      -> ErrorWithoutFlag+    TcRnOutOfArityTyVar{}+      -> ErrorWithoutFlag+    TcRnUnexpectedTypeSyntaxInTerms{}+      -> ErrorWithoutFlag++  diagnosticHints = \case+    TcRnUnknownMessage m+      -> diagnosticHints m+    TcRnMessageWithInfo _ msg_with_info+      -> case msg_with_info of+           TcRnMessageDetailed info m ->+             errInfoHints info ++ diagnosticHints m+    TcRnWithHsDocContext _ msg+      -> diagnosticHints msg+    TcRnSolverReport (SolverReportWithCtxt ctxt msg) _+      -> tcSolverReportMsgHints ctxt msg+    TcRnSolverDepthError {}+      -> [SuggestIncreaseReductionDepth]+    TcRnRedundantConstraints{}+      -> noHints+    TcRnInaccessibleCode{}+      -> noHints+    TcRnInaccessibleCoAxBranch{}+      -> noHints+    TcRnTypeDoesNotHaveFixedRuntimeRep{}+      -> noHints+    TcRnImplicitLift{}+      -> noHints+    TcRnUnusedPatternBinds{}+      -> noHints+    TcRnDodgyImports{}+      -> noHints+    TcRnDodgyExports{}+      -> noHints+    TcRnMissingImportList{}+      -> noHints+    TcRnUnsafeDueToPlugin{}+      -> noHints+    TcRnModMissingRealSrcSpan{}+      -> noHints+    TcRnIdNotExportedFromModuleSig name mod+      -> [SuggestAddToHSigExportList name $ Just mod]+    TcRnIdNotExportedFromLocalSig name+      -> [SuggestAddToHSigExportList name Nothing]+    TcRnShadowedName{}+      -> noHints+    TcRnInvalidWarningCategory{}+      -> noHints+    TcRnDuplicateWarningDecls{}+      -> noHints+    TcRnSimplifierTooManyIterations{}+      -> [SuggestIncreaseSimplifierIterations]+    TcRnIllegalPatSynDecl{}+      -> noHints+    TcRnLinearPatSyn{}+      -> noHints+    TcRnEmptyRecordUpdate{}+      -> noHints+    TcRnIllegalFieldPunning{}+      -> [suggestExtension LangExt.NamedFieldPuns]+    TcRnIllegalWildcardsInRecord{}+      -> [suggestExtension LangExt.RecordWildCards]+    TcRnIllegalWildcardInType{}+      -> noHints+    TcRnIllegalNamedWildcardInTypeArgument{}+      -> [SuggestAnonymousWildcard]+    TcRnIllegalImplicitTyVarInTypeArgument tv+      -> [SuggestExplicitQuantification tv]+    TcRnIllegalPunnedVarOccInTypeArgument{}+      -> []+    TcRnDuplicateFieldName{}+      -> noHints+    TcRnIllegalViewPattern{}+      -> [suggestExtension LangExt.ViewPatterns]+    TcRnCharLiteralOutOfRange{}+      -> noHints+    TcRnIllegalWildcardsInConstructor{}+      -> noHints+    TcRnIgnoringAnnotations{}+      -> noHints+    TcRnAnnotationInSafeHaskell+      -> noHints+    TcRnInvalidTypeApplication{}+      -> noHints+    TcRnTagToEnumMissingValArg+      -> noHints+    TcRnTagToEnumUnspecifiedResTy{}+      -> noHints+    TcRnTagToEnumResTyNotAnEnum{}+      -> noHints+    TcRnTagToEnumResTyTypeData{}+      -> noHints+    TcRnArrowIfThenElsePredDependsOnResultTy+      -> noHints+    TcRnIllegalHsBootOrSigDecl {}+      -> noHints+    TcRnBootMismatch boot_or_sig err+      | Hsig <- boot_or_sig+      , BootMismatch _ _ (BootMismatchedTyCons _boot_tc real_tc tc_errs) <- err+      , any is_synAbsData_etaReduce (NE.toList tc_errs)+      -> [SuggestEtaReduceAbsDataTySyn real_tc]+      | otherwise+      -> noHints+      where+        is_synAbsData_etaReduce (SynAbstractData SynAbsDataTySynNotNullary) = True+        is_synAbsData_etaReduce _ = False+    TcRnRecursivePatternSynonym{}+      -> noHints+    TcRnPartialTypeSigTyVarMismatch{}+      -> noHints+    TcRnPartialTypeSigBadQuantifier{}+      -> noHints+    TcRnMissingSignature {}+      -> noHints+    TcRnPolymorphicBinderMissingSig{}+      -> noHints+    TcRnOverloadedSig{}+      -> noHints+    TcRnTupleConstraintInst{}+      -> noHints+    TcRnUserTypeError{}+      -> noHints+    TcRnConstraintInKind{}+      -> noHints+    TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum _+      -> [suggestExtension $ unboxedTupleOrSumExtension tuple_or_sum]+    TcRnLinearFuncInKind{}+      -> noHints+    TcRnForAllEscapeError{}+      -> noHints+    TcRnVDQInTermType mb_ty+      | isJust mb_ty -> [suggestExtension LangExt.RequiredTypeArguments]+      | otherwise    -> []+    TcRnBadQuantPredHead{}+      -> noHints+    TcRnIllegalTupleConstraint{}+      -> [suggestExtension LangExt.ConstraintKinds]+    TcRnNonTypeVarArgInConstraint{}+      -> [suggestExtension LangExt.FlexibleContexts]+    TcRnIllegalImplicitParam{}+      -> noHints+    TcRnIllegalConstraintSynonymOfKind{}+      -> [suggestExtension LangExt.ConstraintKinds]+    TcRnOversaturatedVisibleKindArg{}+      -> noHints+    TcRnForAllRankErr rank _+      -> case rank of+           LimitedRank{}      -> [suggestExtension LangExt.RankNTypes]+           MonoTypeRankZero   -> [suggestExtension LangExt.RankNTypes]+           MonoTypeTyConArg   -> [suggestExtension LangExt.ImpredicativeTypes]+           MonoTypeSynArg     -> [suggestExtension LangExt.LiberalTypeSynonyms]+           MonoTypeConstraint -> [suggestExtension LangExt.QuantifiedConstraints]+           _                  -> noHints+    TcRnSimplifiableConstraint{}+      -> noHints+    TcRnArityMismatch{}+      -> noHints+    TcRnIllegalInstance rea+      -> illegalInstanceHints rea+    TcRnMonomorphicBindings bindings+      -> case bindings of+          []     -> noHints+          (x:xs) -> [SuggestAddTypeSignatures $ NamedBindings (x NE.:| xs)]+    TcRnOrphanInstance clsOrFamInst+      -> [SuggestFixOrphanInst { isFamilyInstance = isFam }]+        where+          isFam = case clsOrFamInst :: Either ClsInst FamInst of+            Left  _clsInst -> Nothing+            Right famInst  -> Just $ fi_flavor famInst+    TcRnFunDepConflict{}+      -> noHints+    TcRnDupInstanceDecls{}+      -> noHints+    TcRnConflictingFamInstDecls{}+      -> noHints+    TcRnFamInstNotInjective rea _ _+      -> case rea of+           InjErrRhsBareTyVar{}      -> noHints+           InjErrRhsCannotBeATypeFam -> noHints+           InjErrRhsOverlap          -> noHints+           InjErrCannotInferFromRhs _ _ suggestUndInst+             | YesSuggestUndecidableInstaces <- suggestUndInst+             -> [suggestExtension LangExt.UndecidableInstances]+             | otherwise+             -> noHints+    TcRnBangOnUnliftedType{}+      -> noHints+    TcRnLazyBangOnUnliftedType{}+      -> noHints+    TcRnMultipleDefaultDeclarations{}+      -> noHints+    TcRnBadDefaultType{}+      -> noHints+    TcRnPatSynBundledWithNonDataCon{}+      -> noHints+    TcRnPatSynBundledWithWrongType{}+      -> noHints+    TcRnDupeModuleExport{}+      -> noHints+    TcRnExportedModNotImported{}+      -> noHints+    TcRnNullExportedModule{}+      -> noHints+    TcRnMissingExportList{}+      -> noHints+    TcRnExportHiddenComponents{}+      -> noHints+    TcRnExportHiddenDefault{}+      -> noHints+    TcRnDuplicateExport{}+      -> noHints+    TcRnDuplicateNamedDefaultExport{}+      -> noHints+    TcRnExportedParentChildMismatch{}+      -> noHints+    TcRnConflictingExports{}+      -> noHints+    TcRnDuplicateFieldExport {}+      -> [suggestExtension LangExt.DuplicateRecordFields]+    TcRnAmbiguousFieldInUpdate {}+      -> [suggestExtension LangExt.DisambiguateRecordFields]+    TcRnAmbiguousRecordUpdate{}+      -> noHints+    TcRnMissingFields{}+      -> noHints+    TcRnFieldUpdateInvalidType{}+      -> noHints+    TcRnMissingStrictFields{}+      -> noHints+    TcRnBadRecordUpdate{}+      -> noHints+    TcRnIllegalStaticExpression {}+      -> [suggestExtension LangExt.StaticPointers]+    TcRnStaticFormNotClosed{}+      -> noHints+    TcRnUselessTypeable+      -> noHints+    TcRnDerivingDefaults{}+      -> [useDerivingStrategies]+    TcRnNonUnaryTypeclassConstraint{}+      -> noHints+    TcRnPartialTypeSignatures suggestParSig _+      -> case suggestParSig of+           YesSuggestPartialTypeSignatures+             -> let info = text "to use the inferred type"+                in [suggestExtensionWithInfo info LangExt.PartialTypeSignatures]+           NoSuggestPartialTypeSignatures+             -> noHints+    TcRnCannotDeriveInstance cls _ _ newtype_deriving rea+      -> deriveInstanceErrReasonHints cls newtype_deriving rea+    TcRnLookupInstance _ _ _+      -> noHints+    TcRnLazyGADTPattern+      -> noHints+    TcRnArrowProcGADTPattern+      -> noHints+    TcRnTypeEqualityOutOfScope+      -> noHints+    TcRnTypeEqualityRequiresOperators+      -> [suggestExtension LangExt.TypeOperators]+    TcRnIllegalTypeOperator {}+      -> [suggestExtension LangExt.TypeOperators]+    TcRnIllegalTypeOperatorDecl {}+      -> [suggestExtension LangExt.TypeOperators]+    TcRnGADTMonoLocalBinds {}+      -> [suggestAnyExtension [LangExt.GADTs, LangExt.TypeFamilies]]+    TcRnIncorrectNameSpace nm is_th_use+      | is_th_use+      -> [SuggestAppropriateTHTick (nameNameSpace nm)]+      | otherwise+      -> noHints+    TcRnNotInScope err _nm+      -> scopeErrorHints err+    TcRnTermNameInType {}+      -> noHints+    TcRnUntickedPromotedThing thing+      -> [SuggestAddTick thing]+    TcRnIllegalBuiltinSyntax {}+      -> noHints+    TcRnWarnDefaulting {}+      -> noHints+    TcRnWarnClashingDefaultImports cls local imports+      -> suggestDefaultDeclaration cls (fold local) (cd_types <$> NE.toList imports)+    TcRnForeignImportPrimExtNotSet{}+      -> [suggestExtension LangExt.GHCForeignImportPrim]+    TcRnForeignImportPrimSafeAnn{}+      -> noHints+    TcRnForeignFunctionImportAsValue{}+      -> noHints+    TcRnFunPtrImportWithoutAmpersand{}+      -> noHints+    TcRnIllegalForeignDeclBackend{}+      -> noHints+    TcRnUnsupportedCallConv{}+      -> noHints+    TcRnIllegalForeignType _ reason+      -> case reason of+           TypeCannotBeMarshaled _ why+             | NewtypeDataConNotInScope tc _ <- why+             -> let tc_nm = tyConName tc+                    dc = dataConName $ head $ tyConDataCons tc+                in [ ImportSuggestion (occName dc)+                   $ ImportDataCon Nothing False False (nameOccName tc_nm) ]+             | UnliftedFFITypesNeeded <- why+             -> [suggestExtension LangExt.UnliftedFFITypes]+           _ -> noHints+    TcRnInvalidCIdentifier{}+      -> noHints+    TcRnExpectedValueId{}+      -> noHints+    TcRnRecSelectorEscapedTyVar{}+      -> [SuggestPatternMatchingSyntax]+    TcRnPatSynNotBidirectional{}+      -> noHints+    TcRnIllegalDerivingItem{}+      -> noHints+    TcRnIllegalDefaultClass{}+      -> noHints+    TcRnIllegalNamedDefault{}+      -> [suggestExtension LangExt.NamedDefaults]+    TcRnUnexpectedAnnotation{}+      -> noHints+    TcRnIllegalRecordSyntax{}+      -> noHints+    TcRnInvalidVisibleKindArgument{}+      -> noHints+    TcRnTooManyBinders{}+      -> noHints+    TcRnDifferentNamesForTyVar{}+      -> noHints+    TcRnDisconnectedTyVar n+      -> [SuggestBindTyVarExplicitly n]+    TcRnInvalidReturnKind _ _ _ mb_suggest_unlifted_ext+      -> case mb_suggest_unlifted_ext of+           Nothing -> noHints+           Just SuggestUnliftedNewtypes -> [suggestExtension LangExt.UnliftedNewtypes]+           Just SuggestUnliftedDatatypes -> [suggestExtension LangExt.UnliftedDatatypes]+    TcRnClassKindNotConstraint{}+      -> noHints+    TcRnUnpromotableThing{}+      -> noHints+    TcRnIllegalTermLevelUse {}+      -> noHints+    TcRnMatchesHaveDiffNumArgs{}+      -> noHints+    TcRnCannotBindScopedTyVarInPatSig{}+      -> noHints+    TcRnCannotBindTyVarsInPatBind{}+      -> noHints+    TcRnMultipleInlinePragmas{}+      -> noHints+    TcRnUnexpectedPragmas{}+      -> noHints+    TcRnNonOverloadedSpecialisePragma{}+      -> noHints+    TcRnSpecialiseNotVisible name+      -> [SuggestSpecialiseVisibilityHints name]+    TcRnPragmaWarning{}+      -> noHints+    TcRnDifferentExportWarnings _ _+      -> noHints+    TcRnIncompleteExportWarnings _ _+      -> noHints+    TcRnIllegalHsigDefaultMethods{}+      -> noHints+    TcRnIllegalQuasiQuotes{}+      -> [suggestExtension LangExt.QuasiQuotes]+    TcRnTHError err+      -> thErrorHints err+    TcRnHsigFixityMismatch{}+      -> noHints+    TcRnHsigShapeMismatch{}+      -> noHints+    TcRnHsigMissingModuleExport{}+      -> noHints+    TcRnBadGenericMethod{}+      -> noHints+    TcRnWarningMinimalDefIncomplete{}+      -> noHints+    TcRnDefaultMethodForPragmaLacksBinding{}+      -> noHints+    TcRnIgnoreSpecialisePragmaOnDefMethod{}+      -> noHints+    TcRnBadMethodErr{}+      -> noHints+    TcRnIllegalTypeData+      -> [suggestExtension LangExt.TypeData]+    TcRnTypeDataForbids{}+      -> noHints+    TcRnIllegalNewtype{}+      -> noHints+    TcRnOrPatBindsVariables{}+      -> noHints+    TcRnUnsatisfiedMinimalDef{}+      -> noHints+    TcRnMisplacedInstSig{}+      -> [suggestExtension LangExt.InstanceSigs]+    TcRnNoRebindableSyntaxRecordDot{}+      -> noHints+    TcRnNoFieldPunsRecordDot{}+      -> noHints+    TcRnListComprehensionDuplicateBinding{}+      -> noHints+    TcRnEmptyStmtsGroup EmptyStmtsGroupInDoNotation{}+      -> [suggestExtension LangExt.NondecreasingIndentation]+    TcRnEmptyStmtsGroup{}+      -> noHints+    TcRnLastStmtNotExpr{}+      -> noHints+    TcRnUnexpectedStatementInContext _ _ mExt+      | Nothing <- mExt -> noHints+      | Just ext <- mExt -> [suggestExtension ext]+    TcRnSectionWithoutParentheses{}+      -> noHints+    TcRnIllegalImplicitParameterBindings{}+      -> noHints+    TcRnIllegalTupleSection{}+      -> [suggestExtension LangExt.TupleSections]+    TcRnCapturedTermName{}+      -> [SuggestRenameTypeVariable]+    TcRnBindingOfExistingName{}+      -> noHints+    TcRnMultipleFixityDecls{}+      -> noHints+    TcRnIllegalPatternSynonymDecl{}+      -> [suggestExtension LangExt.PatternSynonyms]+    TcRnIllegalClassBinding{}+      -> noHints+    TcRnOrphanCompletePragma{}+      -> noHints+    TcRnEmptyCase _ reason ->+      case reason of+        EmptyCaseWithoutFlag{}    -> [suggestExtension LangExt.EmptyCase]+        EmptyCaseDisallowedCtxt{} -> noHints+        EmptyCaseForall{}         -> noHints+    TcRnSpecSigShape{}+      -> noHints+    TcRnNonStdGuards{}+      -> [suggestExtension LangExt.PatternGuards]+    TcRnDuplicateSigDecl{}+      -> noHints+    TcRnMisplacedSigDecl{}+      -> noHints+    TcRnUnexpectedDefaultSig{}+      -> [suggestExtension LangExt.DefaultSignatures]+    TcRnDuplicateMinimalSig{}+      -> noHints+    TcRnUnexpectedStandaloneDerivingDecl{}+      -> [suggestExtension LangExt.StandaloneDeriving]+    TcRnUnusedVariableInRuleDecl{}+      -> noHints+    TcRnUnexpectedStandaloneKindSig{}+      -> [suggestExtension LangExt.StandaloneKindSignatures]+    TcRnIllegalRuleLhs{}+      -> noHints+    TcRnRuleLhsEqualities{}+      -> noHints+    TcRnDuplicateRoleAnnot{}+      -> noHints+    TcRnDuplicateKindSig{}+      -> noHints+    TcRnIllegalDerivStrategy ds -> case ds of+      ViaStrategy{} -> [suggestExtension LangExt.DerivingVia]+      _ -> [suggestExtension LangExt.DerivingStrategies]+    TcRnIllegalMultipleDerivClauses{}+      -> [suggestExtension LangExt.DerivingStrategies]+    TcRnNoDerivStratSpecified is_ds_enabled info -> do+      let explicit_strategy_hint = case info of+            TcRnNoDerivingClauseStrategySpecified assumed_derivings ->+              SuggestExplicitDerivingClauseStrategies assumed_derivings+            TcRnNoStandaloneDerivingStrategySpecified assumed_strategy deriv_sig ->+              SuggestExplicitStandaloneDerivingStrategy assumed_strategy deriv_sig+      explicit_strategy_hint : [suggestExtension LangExt.DerivingStrategies | not is_ds_enabled]+    TcRnStupidThetaInGadt{}+      -> noHints+    TcRnShadowedTyVarNameInFamResult{}+      -> noHints+    TcRnIncorrectTyVarOnLhsOfInjCond{}+      -> noHints+    TcRnUnknownTyVarsOnRhsOfInjCond{}+      -> noHints+    TcRnBadlyLevelled{}+      -> noHints+    TcRnBadlyLevelledType{}+      -> noHints+    TcRnTyThingUsedWrong{}+      -> noHints+    TcRnCannotDefaultKindVar{}+      -> noHints+    TcRnUninferrableTyVar{}+      -> noHints+    TcRnSkolemEscape{}+      -> noHints+    TcRnPatSynEscapedCoercion{}+      -> noHints+    TcRnPatSynExistentialInResult{}+      -> noHints+    TcRnPatSynArityMismatch{}+      -> noHints+    TcRnPatSynInvalidRhs name pat args (PatSynNotInvertible _)+      -> [SuggestExplicitBidiPatSyn name pat args]+    TcRnPatSynInvalidRhs{}+      -> noHints+    TcRnTyFamDepsDisabled{}+      -> [suggestExtension LangExt.TypeFamilyDependencies]+    TcRnAbstractClosedTyFamDecl{}+      -> noHints+    TcRnPartialFieldSelector{}+      -> noHints+    TcRnHasFieldResolvedIncomplete{}+      -> noHints+    TcRnBadFieldAnnotation _ _ LazyFieldsDisabled+      -> [suggestExtension LangExt.StrictData]+    TcRnBadFieldAnnotation{}+      -> noHints+    TcRnSuperclassCycle{}+      -> [suggestExtension LangExt.UndecidableSuperClasses]+    TcRnDefaultSigMismatch{}+      -> noHints+    TcRnTyFamsDisabled{}+      -> [suggestExtension LangExt.TypeFamilies]+    TcRnBadTyConTelescope{}+      -> noHints+    TcRnTyFamResultDisabled{}+      -> [suggestExtension LangExt.TypeFamilyDependencies]+    TcRnRoleValidationFailed{}+      -> noHints+    TcRnCommonFieldResultTypeMismatch{}+      -> noHints+    TcRnCommonFieldTypeMismatch{}+      -> noHints+    TcRnClassExtensionDisabled _ MultiParamDisabled{}+      -> [suggestExtension LangExt.MultiParamTypeClasses]+    TcRnClassExtensionDisabled _ FunDepsDisabled{}+      -> [suggestExtension LangExt.FunctionalDependencies]+    TcRnClassExtensionDisabled _ ConstrainedClassMethodsDisabled{}+      -> [suggestExtension LangExt.ConstrainedClassMethods]+    TcRnDataConParentTypeMismatch{}+      -> noHints+    TcRnGADTsDisabled{}+      -> [suggestExtension LangExt.GADTs]+    TcRnExistentialQuantificationDisabled{}+      -> [suggestAnyExtension [LangExt.ExistentialQuantification, LangExt.GADTs]]+    TcRnGADTDataContext{}+      -> noHints+    TcRnMultipleConForNewtype{}+      -> noHints+    TcRnKindSignaturesDisabled{}+      -> [suggestExtension LangExt.KindSignatures]+    TcRnEmptyDataDeclsDisabled{}+      -> [suggestExtension LangExt.EmptyDataDecls]+    TcRnRoleMismatch{}+      -> noHints+    TcRnRoleCountMismatch{}+      -> noHints+    TcRnIllegalRoleAnnotation{}+      -> noHints+    TcRnRoleAnnotationsDisabled{}+      -> [suggestExtension LangExt.RoleAnnotations]+    TcRnIncoherentRoles{}+      -> [suggestExtension LangExt.IncoherentInstances]+    TcRnUnexpectedKindVar{}+      -> [suggestExtension LangExt.PolyKinds]+    TcRnNegativeNumTypeLiteral{}+      -> noHints+    TcRnIllegalKind _ suggest_polyKinds+      -> if suggest_polyKinds+         then [suggestExtension LangExt.PolyKinds]+         else noHints+    TcRnPrecedenceParsingError{}+      -> noHints+    TcRnSectionPrecedenceError{}+      -> noHints+    TcRnUnexpectedPatSigType{}+      -> [suggestExtension LangExt.ScopedTypeVariables]+    TcRnIllegalKindSignature{}+      -> [suggestExtension LangExt.KindSignatures]+    TcRnUnusedQuantifiedTypeVar{}+      -> noHints+    TcRnDataKindsError{}+      -> [suggestExtension LangExt.DataKinds]+    TcRnTypeSynonymCycle{}+      -> noHints+    TcRnZonkerMessage msg+      -> zonkerMessageHints msg+    TcRnInterfaceError reason+      -> interfaceErrorHints reason+    TcRnSelfImport{}+      -> noHints+    TcRnNoExplicitImportList{}+      -> noHints+    TcRnSafeImportsDisabled{}+      -> [SuggestSafeHaskell]+    TcRnDeprecatedModule{}+      -> noHints+    TcRnRedundantSourceImport{}+      -> noHints+    TcRnImportLookup (ImportLookupBad k _ is ie exts) ->+      let mod_name = moduleName $ is_mod is+          occ = rdrNameOcc $ ieName ie+          could_change_item item_suggestion =+            [useExtensionInOrderTo empty LangExt.ExplicitNamespaces | suggest_ext] +++            [ ImportSuggestion occ $+              CouldChangeImportItem mod_name item_suggestion ]+            where+              suggest_ext+                | ile_explicit_namespaces exts = False  -- extension already on+                | otherwise =+                    case item_suggestion of+                      -- ImportItemRemove* -> False+                      ImportItemRemoveType{}            -> False+                      ImportItemRemoveData{}            -> False+                      ImportItemRemovePattern{}         -> False+                      ImportItemRemoveSubordinateType{} -> False+                      ImportItemRemoveSubordinateData{} -> False+                      -- ImportItemAdd* -> True+                      ImportItemAddType{} -> True+      in case k of+        BadImportAvailVar -> could_change_item ImportItemRemoveType+        BadImportNotExported suggs -> suggs+        BadImportAvailTyCon+          -- The three cases (TyOp, DataKw, PatternKw) are laid out+          -- in Note [Reasons for BadImportAvailTyCon] in GHC.Tc.Errors.Types+          | isSymOcc occ    -> could_change_item ImportItemAddType        -- Case (TyOp)+          | otherwise       ->  -- Non-operator cases+              case unLoc (ieLIEWrappedName ie) of+                IEData{}    -> could_change_item ImportItemRemoveData     -- Case (DataKw)+                IEPattern{} -> could_change_item ImportItemRemovePattern  -- Case (PatternKw)+                _           -> panic "diagnosticHints: unexpected BadImportAvailTyCon"++        BadImportAvailDataCon par  ->+          [ ImportSuggestion occ $+            ImportDataCon { ies_suggest_import_from = Just mod_name+                          , ies_suggest_pattern_keyword = ile_pattern_synonyms exts+                              && not (ile_explicit_namespaces exts) -- do not suggest 'pattern' when we can suggest 'data'+                          , ies_suggest_data_keyword    = ile_explicit_namespaces exts+                          , ies_parent = par } ]+        BadImportNotExportedSubordinates{} -> noHints+        BadImportNonTypeSubordinates _ nontype1 ->+          could_change_item (ImportItemRemoveSubordinateType (nameOccName . greName <$> nontype1))+        BadImportNonDataSubordinates _ nondata1 ->+          could_change_item (ImportItemRemoveSubordinateData (nameOccName . greName <$> nondata1))+    TcRnImportLookup{}+      -> noHints+    TcRnUnusedImport{}+      -> noHints+    TcRnDuplicateDecls _ fs+      -> [suggestExtension LangExt.DuplicateRecordFields | all isFieldName fs]+    TcRnPackageImportsDisabled+      -> [suggestExtension LangExt.PackageImports]+    TcRnIllegalDataCon{}+      -> noHints+    TcRnNestedForallsContexts{}+      -> noHints+    TcRnRedundantRecordWildcard+      -> [SuggestRemoveRecordWildcard]+    TcRnUnusedRecordWildcard{}+      -> [SuggestRemoveRecordWildcard]+    TcRnUnusedName{}+      -> noHints+    TcRnQualifiedBinder{}+      -> noHints+    TcRnTypeApplicationsDisabled{}+      -> [suggestExtension LangExt.TypeApplications]+    TcRnInvalidRecordField{}+      -> noHints+    TcRnTupleTooLarge{}+      -> noHints+    TcRnCTupleTooLarge{}+      -> noHints+    TcRnIllegalInferredTyVars{}+      -> noHints+    TcRnAmbiguousName{}+      -> noHints+    TcRnBindingNameConflict{}+      -> noHints+    TcRnNonCanonicalDefinition reason _+      -> suggestNonCanonicalDefinition reason+    TcRnDefaultedExceptionContext _+      -> noHints+    TcRnImplicitImportOfPrelude {}+      -> noHints+    TcRnMissingMain {}+      -> noHints+    TcRnGhciUnliftedBind {}+      -> noHints+    TcRnGhciMonadLookupFail {}+      -> noHints+    TcRnMissingRoleAnnotation{}+      -> noHints+    TcRnIllegalInvisTyVarBndr{}+      -> [suggestExtension LangExt.TypeAbstractions]+    TcRnIllegalWildcardTyVarBndr{}+      -> [suggestExtension LangExt.TypeAbstractions]+    TcRnInvalidInvisTyVarBndr{}+      -> noHints+    TcRnInvisBndrWithoutSig name _+      -> [SuggestAddStandaloneKindSignature name]+    TcRnImplicitRhsQuantification kv+      -> [SuggestBindTyVarOnLhs (unLoc kv)]+    TcRnPatersonCondFailure{}+      -> [suggestExtension LangExt.UndecidableInstances]+    TcRnIllformedTypePattern{}+      -> noHints+    TcRnIllegalTypePattern{}+      -> noHints+    TcRnIllformedTypeArgument{}+      -> noHints+    TcRnIllegalTypeExpr{}+      -> noHints+    TcRnInvalidDefaultedTyVar{}+      -> noHints+    TcRnNamespacedWarningPragmaWithoutFlag{}+      -> [suggestExtension LangExt.ExplicitNamespaces]+    TcRnIllegalInvisibleTypePattern _ reason+      -> case reason of+          InvisPatWithoutFlag -> [suggestExtension LangExt.TypeAbstractions]+          InvisPatNoForall    -> noHints+          InvisPatMisplaced   -> noHints+    TcRnNamespacedFixitySigWithoutFlag{}+      -> [suggestExtension LangExt.ExplicitNamespaces]+    TcRnOutOfArityTyVar{}+      -> noHints+    TcRnUnexpectedTypeSyntaxInTerms syntax+      -> [suggestExtension (typeSyntaxExtension syntax)]++  diagnosticCode = constructorCode @GHC++pprTcRnBadlyLevelled :: LevelCheckReason -> Set.Set ThLevelIndex -> ThLevelIndex -> Maybe ErrorItem -> DecoratedSDoc+pprTcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt = mkDecorated $+         [ fsep [ text "Level error:", pprLevelCheckReason reason+                , text "is bound at" <+> pprThBindLevel bind_lvls+                , text "but used at level" <+> ppr use_lvl]+         ] +++         [hang (text "Could not be resolved by implicit lifting due to the following error:") 2+          (text "No instance for:" <+> quotes (ppr (errorItemPred item)))+         | Just item <- [lift_attempt]+         ] +++         [ vcat (text "Available from the imports:" : ppr_imports (gre_imp gre))+         | LevelCheckSplice _ (Just gre) <- [reason]+         , not (isEmptyBag (gre_imp gre)) ]+  where+    ppr_imports :: Bag ImportSpec -> [SDoc]+    ppr_imports = map ((bullet <+>) . ppr ) . bagToList++note :: SDoc -> SDoc+note note = "Note" <> colon <+> note <> dot++-- | 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]+commafyWith _ [] = []+commafyWith _ [x] = [x]+commafyWith conjunction [x, y] = [x <+> conjunction <+> y]+commafyWith conjunction xs = addConjunction $ punctuate comma xs+    where addConjunction [x, y] = [x, conjunction, y]+          addConjunction (x : xs) = x : addConjunction xs+          addConjunction _ = panic "commafyWith expected 2 or more elements"++deriveInstanceErrReasonHints :: Class+                             -> UsingGeneralizedNewtypeDeriving+                             -> DeriveInstanceErrReason+                             -> [GhcHint]+deriveInstanceErrReasonHints cls newtype_deriving = \case+  DerivErrNotWellKinded _ _ n_args_to_keep+    | cls `hasKey` gen1ClassKey && n_args_to_keep >= 0+    -> [suggestExtension LangExt.PolyKinds]+    | otherwise+    -> noHints+  DerivErrSafeHaskellGenericInst  -> noHints+  DerivErrDerivingViaWrongKind{}  -> noHints+  DerivErrNoEtaReduce{}           -> noHints+  DerivErrBootFileFound           -> noHints+  DerivErrDataConsNotAllInScope{} -> noHints+  DerivErrGNDUsedOnData           -> noHints+  DerivErrNullaryClasses          -> noHints+  DerivErrLastArgMustBeApp        -> noHints+  DerivErrNoFamilyInstance{}      -> noHints+  DerivErrNotStockDeriveable deriveAnyClassEnabled+    | deriveAnyClassEnabled == NoDeriveAnyClassEnabled+    -> [suggestExtension LangExt.DeriveAnyClass]+    | otherwise+    -> noHints+  DerivErrHasAssociatedDatatypes{}+    -> noHints+  DerivErrNewtypeNonDeriveableClass+    | newtype_deriving == NoGeneralizedNewtypeDeriving+    -> [useGND]+    | otherwise+    -> noHints+  DerivErrCannotEtaReduceEnough{}+    | newtype_deriving == NoGeneralizedNewtypeDeriving+    -> [useGND]+    | otherwise+    -> noHints+  DerivErrOnlyAnyClassDeriveable _ deriveAnyClassEnabled+    | deriveAnyClassEnabled == NoDeriveAnyClassEnabled+    -> [suggestExtension LangExt.DeriveAnyClass]+    | otherwise+    -> noHints+  DerivErrNotDeriveable deriveAnyClassEnabled+    | deriveAnyClassEnabled == NoDeriveAnyClassEnabled+    -> [suggestExtension LangExt.DeriveAnyClass]+    | otherwise+    -> noHints+  DerivErrNotAClass{}+    -> noHints+  DerivErrNoConstructors{}+    -> let info = text "to enable deriving for empty data types"+       in [useExtensionInOrderTo info LangExt.EmptyDataDeriving]+  DerivErrLangExtRequired{}+    -- This is a slightly weird corner case of GHC: we are failing+    -- to derive a typeclass instance because a particular 'Extension'+    -- is not enabled (and so we report in the main error), but here+    -- we don't want to /repeat/ to enable the extension in the hint.+    -> noHints+  DerivErrDunnoHowToDeriveForType{}+    -> noHints+  DerivErrMustBeEnumType rep_tc+    -- We want to suggest GND only if this /is/ a newtype.+    | newtype_deriving == NoGeneralizedNewtypeDeriving && isNewTyCon rep_tc+    -> [useGND]+    | otherwise+    -> noHints+  DerivErrMustHaveExactlyOneConstructor{}+    -> noHints+  DerivErrMustHaveSomeParameters{}+    -> noHints+  DerivErrMustNotHaveClassContext{}+    -> noHints+  DerivErrBadConstructor wcard _+    -> case wcard of+         Nothing        -> noHints+         Just YesHasWildcard -> [SuggestFillInWildcardConstraint]+         Just NoHasWildcard  -> [SuggestAddStandaloneDerivation]+  DerivErrGenerics{}+    -> noHints+  DerivErrEnumOrProduct{}+    -> noHints++--------------------------------------------------------------------------------++-- | Pretty-print supplementary information, to add to an error report.+pprSolverReportSupplementary :: HoleFitDispConfig -> SupplementaryInfo -> SDoc+-- This function should be in "GHC.Tc.Errors.Ppr",+-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'.+pprSolverReportSupplementary hfdc = \case+  SupplementaryBindings     binds -> pprRelevantBindings binds+  SupplementaryHoleFits     fits  -> pprValidHoleFits hfdc fits+  SupplementaryCts          cts   -> pprConstraintsInclude cts+  SupplementaryImportErrors errs  -> vcat (map ppr $ NE.toList errs)++-- | Display a collection of valid hole fits.+pprValidHoleFits :: HoleFitDispConfig -> ValidHoleFits -> SDoc+-- This function should be in "GHC.Tc.Errors.Ppr",+-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'.+pprValidHoleFits hfdc (ValidHoleFits (Fits fits discarded_fits) (Fits refs discarded_refs))+  = fits_msg $$ refs_msg++  where+    fits_msg, refs_msg, fits_discard_msg, refs_discard_msg :: SDoc+    fits_msg = ppUnless (null fits) $+                    hang (text "Valid hole fits include") 2 $+                    vcat (map (pprHoleFit hfdc) fits)+                      $$ ppWhen  discarded_fits fits_discard_msg+    refs_msg = ppUnless (null refs) $+                  hang (text "Valid refinement hole fits include") 2 $+                  vcat (map (pprHoleFit hfdc) refs)+                    $$ ppWhen discarded_refs refs_discard_msg+    fits_discard_msg =+      text "(Some hole fits suppressed;" <+>+      text "use -fmax-valid-hole-fits=N" <+>+      text "or -fno-max-valid-hole-fits)"+    refs_discard_msg =+      text "(Some refinement hole fits suppressed;" <+>+      text "use -fmax-refinement-hole-fits=N" <+>+      text "or -fno-max-refinement-hole-fits)"++-- For pretty printing hole fits, we display the name and type of the fit,+-- with added '_' to represent any extra arguments in case of a non-zero+-- refinement level.+pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc+pprHoleFit _ (RawHoleFit sd) = sd+pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (TcHoleFit (HoleFit {..})) =+ hang display 2 provenance+ where tyApp = sep $ zipWithEqual pprArg vars hfWrap+         where pprArg b arg = case binderFlag b of+                                Specified -> text "@" <> pprParendType arg+                                  -- Do not print type application for inferred+                                  -- variables (#16456)+                                Inferred  -> empty+                                Required  -> pprPanic "pprHoleFit: bad Required"+                                                         (ppr b <+> ppr arg)+       tyAppVars = sep $ punctuate comma $+           zipWithEqual (\v t -> ppr (binderVar v) <+> text "~" <+> pprParendType t)+           vars hfWrap++       vars = unwrapTypeVars hfType+         where+           -- Attempts to get all the quantified type variables in a type,+           -- e.g.+           -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a)+           -- into [m, a]+           unwrapTypeVars :: Type -> [ForAllTyBinder]+           unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of+                               Just (_, _, _, unfunned) -> unwrapTypeVars unfunned+                               _ -> []+             where (vars, unforalled) = splitForAllForAllTyBinders t+       holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches+       holeDisp = if sMs then holeVs+                  else sep $ replicate (length hfMatches) $ text "_"+       occDisp = case hfCand of+                   GreHFCand gre   -> pprPrefixOcc (greName gre)+                   NameHFCand name -> pprPrefixOcc name+                   IdHFCand id_    -> pprPrefixOcc id_+       tyDisp = ppWhen sTy $ dcolon <+> ppr hfType+       has = not . null+       wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars))+                   $ text "with" <+> if sWrp || not sTy+                                     then occDisp <+> tyApp+                                     else tyAppVars+       docs = case hfDoc of+                Just d -> pprHsDocStrings d+                _ -> empty+       funcInfo = ppWhen (has hfMatches && sTy) $+                    text "where" <+> occDisp <+> tyDisp+       subDisp = occDisp <+> if has hfMatches then holeDisp else tyDisp+       display =  subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp)+       provenance = ppWhen sProv $ parens $+             case hfCand of+                 GreHFCand gre -> pprNameProvenance gre+                 NameHFCand name -> text "bound at" <+> ppr (getSrcLoc name)+                 IdHFCand id_ -> text "bound at" <+> ppr (getSrcLoc id_)++-- | Add a "Constraints include..." message.+--+-- See Note [Constraints include ...]+pprConstraintsInclude :: NE.NonEmpty (PredType, RealSrcSpan) -> SDoc+-- This function should be in "GHC.Tc.Errors.Ppr",+-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'.+pprConstraintsInclude cts+  = hang (text "Constraints include")+        2 (vcat $ map pprConstraint $ NE.toList cts)+  where+    pprConstraint (constraint, loc) =+      ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc))++messageWithInfoDiagnosticMessage :: UnitState+                                 -> ErrInfo+                                 -> Bool+                                 -> DecoratedSDoc+                                 -> DecoratedSDoc+messageWithInfoDiagnosticMessage unit_state (ErrInfo {..}) show_ctxt important =+  let ctxt = pprWithUnitState unit_state+           $ vcat $ map pprErrCtxtMsg  [ ctx | ctx <- errInfoContext, show_ctxt ]++      supp = case errInfoSupplementary of+        Nothing -> empty+        Just (hfdc, supp_msgs) ->+          pprWithUnitState unit_state $+          vcat $ map (pprSolverReportSupplementary hfdc) supp_msgs+  in mapDecoratedSDoc (pprWithUnitState unit_state) important+       `unionDecoratedSDoc`+     mkDecorated [ctxt, supp]++messageWithHsDocContext :: TcRnMessageOpts -> HsDocContext -> DecoratedSDoc -> DecoratedSDoc+messageWithHsDocContext opts ctxt main_msg = do+      if tcOptsShowContext opts+         then main_msg `unionDecoratedSDoc` ctxt_msg+         else main_msg+      where+        ctxt_msg = mkSimpleDecorated (inHsDocContext ctxt)++--------------------------------------------------------------------------------++dodgy_msg :: Outputable ie => SDoc -> GlobalRdrElt -> ie -> SDoc+dodgy_msg kind tc ie+  = vcat [ text "The" <+> kind <+> text "item" <+> quotes (ppr ie) <+> text "suggests that"+         , quotes (ppr $ greName tc) <+> text "has" <+> sep rest ]+  where+    rest :: [SDoc]+    rest =+      case greInfo tc of+        IAmTyCon ClassFlavour+          -> [ text "(in-scope) class methods or associated types" <> comma+             , text "but it has none" ]+        IAmTyCon _+          -> [ text "(in-scope) constructors or record fields" <> comma+             , text "but it has none" ]+        _ -> [ text "children" <> comma+             , text "but it is not a type constructor or a class" ]++dodgy_msg_insert :: GlobalRdrElt -> IE GhcRn+dodgy_msg_insert tc_gre = IEThingAll (Nothing, noAnn) ii Nothing+  where+    ii = noLocA (IEName noExtField $ noLocA $ greName tc_gre)++pprTypeDoesNotHaveFixedRuntimeRep :: Type -> FixedRuntimeRepProvenance -> SDoc+pprTypeDoesNotHaveFixedRuntimeRep ty prov =+  let what = pprFixedRuntimeRepProvenance prov+  in text "The" <+> what <+> text "does not have a fixed runtime representation:"+  $$ format_frr_err ty++format_frr_err :: Type  -- ^ the type which doesn't have a fixed runtime representation+                -> SDoc+format_frr_err ty+  = (bullet <+> ppr tidy_ty <+> dcolon <+> ppr tidy_ki)+  where+    (tidy_env, tidy_ty) = tidyOpenTypeX emptyTidyEnv ty+    tidy_ki             = tidyType tidy_env (typeKind ty)++pprField :: (FieldLabelString, TcType) -> SDoc+pprField (f,ty) = ppr f <+> dcolon <+> ppr ty++pprRecordFieldPart :: RecordFieldPart -> SDoc+pprRecordFieldPart = \case+  RecordFieldDecl {}       -> text "declaration"+  RecordFieldConstructor{} -> text "construction"+  RecordFieldPattern{}     -> text "pattern"+  RecordFieldUpdate        -> text "update"++ppr_opfix :: (OpName, Fixity) -> SDoc+ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)+   where+     pp_op | NegateOp <- op = text "prefix `-'"+           | otherwise      = quotes (ppr op)++pprBindings :: [Name] -> SDoc+pprBindings = pprWithCommas (quotes . ppr)+++injectivityErrorHerald :: SDoc+injectivityErrorHerald =+  text "Type family equation violates the family's injectivity annotation."++formatExportItemError :: SDoc -> String -> SDoc+formatExportItemError exportedThing reason =+  hsep [ text "The export item"+       , quotes exportedThing+       , text reason ]++-- | What warning flags are associated with the given missing signature?+missingSignatureWarningFlags :: MissingSignature -> Exported -> NonEmpty WarningFlag+missingSignatureWarningFlags (MissingTopLevelBindingSig {}) exported+  -- We prefer "bigger" warnings first: #14794+  --+  -- See Note [Warnings controlled by multiple flags]+  = Opt_WarnMissingSignatures :|+    [ Opt_WarnMissingExportedSignatures | IsExported == exported ]+missingSignatureWarningFlags (MissingPatSynSig {}) exported+  = Opt_WarnMissingPatternSynonymSignatures :|+    [ Opt_WarnMissingExportedPatternSynonymSignatures | IsExported  == exported ]+missingSignatureWarningFlags (MissingTyConKindSig ty_con _) _+  = Opt_WarnMissingKindSignatures :| [Opt_WarnMissingPolyKindSignatures | isForAllTy_invis_ty (tyConKind ty_con) ]++useDerivingStrategies :: GhcHint+useDerivingStrategies =+  useExtensionInOrderTo (text "to pick a different strategy") LangExt.DerivingStrategies++useGND :: GhcHint+useGND = let info = text "for GHC's" <+> text "newtype-deriving extension"+         in suggestExtensionWithInfo info LangExt.GeneralizedNewtypeDeriving++cannotMakeDerivedInstanceHerald :: Class+                                -> [Type]+                                -> Maybe (DerivStrategy GhcTc)+                                -> UsingGeneralizedNewtypeDeriving+                                -> Bool -- ^ If False, only prints the why.+                                -> SDoc+                                -> SDoc+cannotMakeDerivedInstanceHerald cls cls_args mb_strat newtype_deriving pprHerald why =+  if pprHerald+     then sep [(hang (text "Can't make a derived instance of")+                   2 (quotes (ppr pred) <+> via_mechanism)+                $$ nest 2 extra) <> colon,+               nest 2 why]+      else why+  where+    strat_used = isJust mb_strat+    extra | not strat_used, (newtype_deriving == YesGeneralizedNewtypeDeriving)+          = text "(even with cunning GeneralizedNewtypeDeriving)"+          | otherwise = empty+    pred = mkClassPred cls cls_args+    via_mechanism | strat_used+                  , Just strat <- mb_strat+                  = text "with the" <+> (derivStrategyName strat) <+> text "strategy"+                  | otherwise+                  = empty++badCon :: DataCon -> SDoc -> SDoc+badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg++derivErrDiagnosticMessage :: Class+                          -> [Type]+                          -> Maybe (DerivStrategy GhcTc)+                          -> UsingGeneralizedNewtypeDeriving+                          -> Bool -- If True, includes the herald \"can't make a derived..\"+                          -> DeriveInstanceErrReason+                          -> SDoc+derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald = \case+  DerivErrNotWellKinded tc cls_kind _+    -> sep [ hang (text "Cannot derive well-kinded instance of form"+                         <+> quotes (pprClassPred cls cls_tys+                                       <+> parens (ppr tc <+> text "...")))+                  2 empty+           , nest 2 (text "Class" <+> quotes (ppr cls)+                         <+> text "expects an argument of kind"+                         <+> quotes (pprKind cls_kind))+           ]+  DerivErrSafeHaskellGenericInst+    ->     text "Generic instances can only be derived in"+       <+> text "Safe Haskell using the stock strategy."+  DerivErrDerivingViaWrongKind cls_kind via_ty via_kind+    -> hang (text "Cannot derive instance via" <+> quotes (pprType via_ty))+          2 (text "Class" <+> quotes (ppr cls)+                  <+> text "expects an argument of kind"+                  <+> quotes (pprKind cls_kind) <> char ','+         $+$ text "but" <+> quotes (pprType via_ty)+                  <+> text "has kind" <+> quotes (pprKind via_kind))+  DerivErrNoEtaReduce inst_ty+    -> sep [text "Cannot eta-reduce to an instance of form",+            nest 2 (text "instance (...) =>"+                   <+> pprClassPred cls (cls_tys ++ [inst_ty]))]+  DerivErrBootFileFound+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "Cannot derive instances in hs-boot files"+          $+$ text "Write an instance declaration instead")+  DerivErrDataConsNotAllInScope tc+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (hang (text "The data constructors of" <+> quotes (ppr tc) <+> text "are not all in scope")+            2 (text "so you cannot derive an instance for it"))+  DerivErrGNDUsedOnData+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "GeneralizedNewtypeDeriving cannot be used on non-newtypes")+  DerivErrNullaryClasses+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "Cannot derive instances for nullary classes")+  DerivErrLastArgMustBeApp+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         ( text "The last argument of the instance must be a"+         <+> text "data or newtype application")+  DerivErrNoFamilyInstance tc tc_args+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "No family instance for" <+> quotes (pprTypeApp tc tc_args))+  DerivErrNotStockDeriveable _+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (quotes (ppr cls) <+> text "is not a stock derivable class (Eq, Show, etc.)")+  DerivErrHasAssociatedDatatypes hasAdfs at_last_cls_tv_in_kinds at_without_last_cls_tv+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         $ vcat [ ppWhen (hasAdfs == YesHasAdfs) adfs_msg+               , case at_without_last_cls_tv of+                    YesAssociatedTyNotParamOverLastTyVar tc -> at_without_last_cls_tv_msg tc+                    NoAssociatedTyNotParamOverLastTyVar     -> empty+               , case at_last_cls_tv_in_kinds of+                   YesAssocTyLastVarInKind tc -> at_last_cls_tv_in_kinds_msg tc+                   NoAssocTyLastVarInKind     -> empty+               ]+       where++         adfs_msg  = text "the class has associated data types"++         at_without_last_cls_tv_msg at_tc = hang+           (text "the associated type" <+> quotes (ppr at_tc)+            <+> text "is not parameterized over the last type variable")+           2 (text "of the class" <+> quotes (ppr cls))++         at_last_cls_tv_in_kinds_msg at_tc = hang+           (text "the associated type" <+> quotes (ppr at_tc)+            <+> text "contains the last type variable")+          2 (text "of the class" <+> quotes (ppr cls)+            <+> text "in a kind, which is not (yet) allowed")+  DerivErrNewtypeNonDeriveableClass+    -> derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald (DerivErrNotStockDeriveable NoDeriveAnyClassEnabled)+  DerivErrCannotEtaReduceEnough eta_ok+    -> let cant_derive_err = ppUnless eta_ok eta_msg+           eta_msg = text "cannot eta-reduce the representation type enough"+       in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+          cant_derive_err+  DerivErrOnlyAnyClassDeriveable tc _+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (quotes (ppr tc) <+> text "is a type class,"+                          <+> text "and can only have a derived instance"+                          $+$ text "if DeriveAnyClass is enabled")+  DerivErrNotDeriveable _+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald empty+  DerivErrNotAClass predType+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (quotes (ppr predType) <+> text "is not a class")+  DerivErrNoConstructors rep_tc+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (quotes (pprSourceTyCon rep_tc) <+> text "must have at least one data constructor")+  DerivErrLangExtRequired ext+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "You need " <> ppr ext+            <+> text "to derive an instance for this class")+  DerivErrDunnoHowToDeriveForType ty+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+        (hang (text "Don't know how to derive" <+> quotes (ppr cls))+              2 (text "for type" <+> quotes (ppr ty)))+  DerivErrMustBeEnumType rep_tc+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (sep [ quotes (pprSourceTyCon rep_tc) <+>+                text "must be an enumeration type"+              , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ])++  DerivErrMustHaveExactlyOneConstructor rep_tc+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (quotes (pprSourceTyCon rep_tc) <+> text "must have precisely one constructor")+  DerivErrMustHaveSomeParameters rep_tc+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "Data type" <+> quotes (ppr rep_tc) <+> text "must have some type parameters")+  DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "Data type" <+> quotes (ppr rep_tc)+           <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta)+  DerivErrBadConstructor _ reasons+    -> let why = vcat $ map renderReason reasons+       in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why+         where+           renderReason = \case+                 DerivErrBadConExistential con+                   -> badCon con $ text "must be truly polymorphic in the last argument of the data type"+                 DerivErrBadConCovariant con+                   -> badCon con $ text "must not use the type variable in a function argument"+                 DerivErrBadConFunTypes con+                   -> badCon con $ text "must not contain function types"+                 DerivErrBadConWrongArg con+                   -> badCon con $ text "must use the type variable only as the last argument of a data type"+                 DerivErrBadConIsGADT con+                   -> badCon con $ text "is a GADT"+                 DerivErrBadConHasExistentials con+                   -> badCon con $ text "has existential type variables in its type"+                 DerivErrBadConHasConstraints con+                   -> badCon con $ text "has constraints in its type"+                 DerivErrBadConHasHigherRankType con+                   -> badCon con $ text "has a higher-rank type"+  DerivErrGenerics reasons+    -> let why = vcat $ map renderReason reasons+       in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why+         where+           renderReason = \case+             DerivErrGenericsMustNotHaveDatatypeContext tc_name+                -> ppr tc_name <+> text "must not have a datatype context"+             DerivErrGenericsMustNotHaveExoticArgs dc+                -> ppr dc <+> text "must not have exotic unlifted or polymorphic arguments"+             DerivErrGenericsMustBeVanillaDataCon dc+                -> ppr dc <+> text "must be a vanilla data constructor"+             DerivErrGenericsMustHaveSomeTypeParams rep_tc+                ->     text "Data type" <+> quotes (ppr rep_tc)+                   <+> text "must have some type parameters"+             DerivErrGenericsMustNotHaveExistentials con+               -> badCon con $ text "must not have existential arguments"+             DerivErrGenericsWrongArgKind con+               -> badCon con $+                    text "applies a type to an argument involving the last parameter"+                 $$ text "but the applied type is not of kind * -> *"+  DerivErrEnumOrProduct this that+    -> let ppr1 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False this+           ppr2 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False that+       in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+          (ppr1 $$ text "  or" $$ ppr2)++lookupInstanceErrDiagnosticMessage :: Class+                                   -> [Type]+                                   -> LookupInstanceErrReason+                                   -> SDoc+lookupInstanceErrDiagnosticMessage cls tys = \case+  LookupInstErrNotExact+    -> text "Not an exact match (i.e., some variables get instantiated)"+  LookupInstErrFlexiVar+    -> text "flexible type variable:" <+> (ppr $ mkTyConApp (classTyCon cls) tys)+  LookupInstErrNotFound+    -> text "instance not found" <+> (ppr $ mkTyConApp (classTyCon cls) tys)++{- *********************************************************************+*                                                                      *+              Outputable SolverReportErrCtxt (for debugging)+*                                                                      *+**********************************************************************-}++instance Outputable SolverReportErrCtxt where+  ppr (CEC { cec_binds              = bvar+           , cec_defer_type_errors  = dte+           , cec_expr_holes         = eh+           , cec_type_holes         = th+           , cec_out_of_scope_holes = osh+           , cec_warn_redundant     = wr+           , cec_expand_syns        = es+           , cec_suppress           = sup })+    = text "CEC" <+> braces (vcat+         [ text "cec_binds"              <+> equals <+> ppr bvar+         , text "cec_defer_type_errors"  <+> equals <+> ppr dte+         , text "cec_expr_holes"         <+> equals <+> ppr eh+         , text "cec_type_holes"         <+> equals <+> ppr th+         , text "cec_out_of_scope_holes" <+> equals <+> ppr osh+         , text "cec_warn_redundant"     <+> equals <+> ppr wr+         , text "cec_expand_syns"        <+> equals <+> ppr es+         , text "cec_suppress"           <+> equals <+> ppr sup ])++{- *********************************************************************+*                                                                      *+                    Outputting TcSolverReportMsg errors+*                                                                      *+**********************************************************************-}++-- | Pretty-print a 'SolverReportWithCtxt', containing a 'TcSolverReportMsg'+-- with its enclosing 'SolverReportErrCtxt'.+pprSolverReportWithCtxt :: SolverReportWithCtxt -> SDoc+pprSolverReportWithCtxt (SolverReportWithCtxt { reportContext = ctxt, reportContent = msg })+   = pprTcSolverReportMsg ctxt msg++-- | Pretty-print a 'TcSolverReportMsg', with its enclosing 'SolverReportErrCtxt'.+pprTcSolverReportMsg :: SolverReportErrCtxt -> TcSolverReportMsg -> SDoc+pprTcSolverReportMsg _ (BadTelescope telescope skols) =+  hang (text "These kind and type variables:" <+> ppr telescope $$+       text "are out of dependency order. Perhaps try this ordering:")+    2 (pprTyVars sorted_tvs)+  where+    sorted_tvs = scopedSort skols+pprTcSolverReportMsg _ (UserTypeError ty) =+  pprUserTypeErrorTy ty+pprTcSolverReportMsg _ (UnsatisfiableError ty) =+  pprUserTypeErrorTy ty+pprTcSolverReportMsg ctxt (ReportHoleError hole err) =+  pprHoleError ctxt hole err+pprTcSolverReportMsg ctxt+  (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 })+  = vcat ([ pprMismatchMsg ctxt mismatch_msg+          , 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+    -- Assemble the error message: pair up each origin with the corresponding type, e.g.+    --   • FixedRuntimeRep origin msg 1 ...+    --       a :: TYPE r1+    --   • FixedRuntimeRep origin msg 2 ...+    --       b :: TYPE r2+    make_msg :: FixedRuntimeRepErrorInfo -> SDoc+    make_msg (FRR_Info { frr_info_origin =+                           FixedRuntimeRepOrigin+                             { frr_type    = ty+                             , frr_context = frr_ctxt }+                       , frr_info_not_concrete = mb_not_conc+                       , frr_info_other_origin = mb_other_orig }) =+      -- Add bullet points if there is more than one error.+      (if length frr_origs > 1 then (bullet <+>) else id) $+        vcat [ sep [ pprFixedRuntimeRepContext frr_ctxt+                   , text "does not have a fixed runtime representation." ]+             , type_printout ty+             , case mb_other_orig of+                 Nothing -> empty+                 Just o -> other_context o+             , case mb_not_conc of+                Just (conc_tv, not_conc)+                  | conc_tv `elemVarSet` tyCoVarsOfType ty+                  -- Only show this message if 'conc_tv' appears somewhere+                  -- in the type, otherwise it's not helpful.+                  -> unsolved_concrete_eq_explanation conc_tv not_conc+                _ -> empty+            ]++    -- Don't print out the type (only the kind), if the type includes+    -- a confusing cast, unless the user passed -fprint-explicit-coercions.+    --+    -- Example:+    --+    --   In T20363, we have a representation-polymorphism error with a type+    --   of the form+    --+    --     ( (# #) |> co ) :: TYPE NilRep+    --+    --   where NilRep is a nullary type family application which reduces to TupleRep '[].+    --   We prefer avoiding showing the cast to the user, but we also don't want to+    --   print the confusing:+    --+    --     (# #) :: TYPE NilRep+    --+    --  So in this case we simply don't print the type, only the kind.+    confusing_cast :: Type -> Bool+    confusing_cast ty =+      case ty of+        CastTy inner_ty _+          -- A confusing cast is one that is responsible+          -- for a representation-polymorphism error.+          -> isConcreteType (typeKind inner_ty)+        _ -> False++    type_printout :: Type -> SDoc+    type_printout ty =+      sdocOption sdocPrintExplicitCoercions $ \ show_coercions ->+        if  confusing_cast ty && not show_coercions+        then vcat [ text "Its kind is:"+                  , nest 2 $ pprWithTYPE (typeKind ty)+                  , text "(Use -fprint-explicit-coercions to see the full type.)" ]+        else vcat [ text "Its type is:"+                  , nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE (typeKind ty) ]++    other_context :: CtOrigin -> SDoc+    other_context = \case+      TypeEqOrigin { uo_actual = actual_ty, uo_expected = exp_ty } ->+        -- TODO: use uo_thing in the error message as well?+        hang (text "When unifying:") 2 $+          vcat [ bullet <+> ppr actual_ty+               , bullet <+> ppr exp_ty+               ]+      KindEqOrigin _ _ orig' _+        -> other_context orig'+      _ -> empty -- Don't think this ever happens++    unsolved_concrete_eq_explanation :: TcTyVar -> Type -> SDoc+    unsolved_concrete_eq_explanation tv not_conc =+          text "Cannot unify" <+> quotes (ppr not_conc)+      <+> text "with the type variable" <+> quotes (ppr tv)+      $$  text "because the former is not a concrete" <+> what <> dot+      where+        ki = tyVarKind tv+        what :: SDoc+        what+          | isRuntimeRepTy ki+          = quotes (text "RuntimeRep")+          | isLevityTy ki+          = quotes (text "Levity")+          | otherwise+          = text "type"+pprTcSolverReportMsg _ (ExpectingMoreArguments n thing) =+  text "Expecting" <+> speakN (abs n) <+>+    more <+> quotes (ppr thing)+  where+    more+     | n == 1    = text "more argument to"+     | otherwise = text "more arguments to" -- n > 1+pprTcSolverReportMsg ctxt (UnboundImplicitParams (item :| items)) =+  let givens = getUserGivens ctxt+  in if null givens+     then addArising (errorItemCtLoc item) $+            sep [ text "Unbound implicit parameter" <> plural preds+                , nest 2 (pprParendTheta preds) ]+     else pprMismatchMsg ctxt (CouldNotDeduce givens (item :| items) Nothing)+  where+    preds = map errorItemPred (item : items)+pprTcSolverReportMsg _ (AmbiguityPreventsSolvingCt item ambigs) =+  pprAmbiguityInfo (Ambiguity True ambigs) <+>+  pprArising (errorItemCtLoc item) $$+  text "prevents the constraint" <+> quotes (pprParendType $ errorItemPred item)+  <+> text "from being solved."+pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics})+  (CannotResolveInstance item unifiers candidates rel_binds)+  =+    vcat+      [ no_inst_msg+      , extra_note+      , mb_patsyn_prov `orElse` empty+      , ppWhen (has_ambigs && not (null unifiers && null useful_givens))+        (vcat [ ppUnless lead_with_ambig $+                  pprAmbiguityInfo (Ambiguity False (ambig_kvs, ambig_tvs))+              , pprRelevantBindings rel_binds+                -- "Relevant bindings" can help explain to the user where an+                -- ambiguous type variable comes from.+              , potential_msg ])+      , ppWhen (isNothing mb_patsyn_prov) $+            -- Don't suggest fixes for the provided context of a pattern+            -- synonym; the right fix is to bind more in the pattern+        show_fixes (ctxt_fixes ++ drv_fixes ++ naked_sc_fixes)+      , ppWhen (not (null candidates))+        (hang (text "There are instances for similar types:")+            2 (vcat (map ppr candidates)))+            -- See Note [Report candidate instances]+      ]+  where+    orig          = errorItemOrigin item+    pred          = errorItemPred item+    (clas, tys)   = getClassPredTys pred+    -- See Note [Highlighting ambiguous type variables] in GHC.Tc.Errors+    (ambig_kvs, ambig_tvs) = ambigTkvsOfTy pred+    ambigs = ambig_kvs ++ ambig_tvs+    has_ambigs = not (null ambigs)+    useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics)+         -- useful_givens are the enclosing implications with non-empty givens,+         -- modulo the horrid discardProvCtxtGivens+    lead_with_ambig = not (null ambigs)+                   && not (any isRuntimeUnkSkol ambigs)+                   && not (null unifiers)+                   && null useful_givens++    no_inst_msg :: SDoc+    no_inst_msg+      | lead_with_ambig+      = pprTcSolverReportMsg ctxt $ AmbiguityPreventsSolvingCt item (ambig_kvs, ambig_tvs)+      | otherwise+      = 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+    want_potential (TypeEqOrigin {}) = False+    want_potential _                 = True++    potential_msg+      = ppWhen (not (null unifiers) && want_potential orig) $+          potential_hdr $$+          potentialInstancesErrMsg (PotentialInstances { matches = [], unifiers })++    potential_hdr+      = ppWhen lead_with_ambig $+        text "Probable fix: use a type annotation to specify what"+        <+> pprQuotedList ambig_tvs <+> text "should be."++    mb_patsyn_prov :: Maybe SDoc+    mb_patsyn_prov+      | not lead_with_ambig+      , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig+      = Just (vcat [ text "In other words, a successful match on the pattern"+                   , nest 2 $ ppr pat+                   , text "does not provide the constraint" <+> pprParendType pred ])+      | otherwise = Nothing++    extra_note+      -- Flag up partially applied uses of (->)+      | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys)+      = text "(maybe you haven't applied a function to enough arguments?)"++      -- Clarify the mysterious "No instance for (Typeable T)+      | className clas == typeableClassName+      , [_,ty] <- tys     -- Look for (Typeable (k->*) (T k))+      , Just (tc,_) <- tcSplitTyConApp_maybe ty+      , not (isTypeFamilyTyCon tc)+      = hang (text "GHC can't yet do polykinded")+           2 (text "Typeable" <+>+              parens (ppr ty <+> dcolon <+> ppr (typeKind ty)))++      | otherwise+      = empty++    ----------- Possible fixes ----------------+    ctxt_fixes = ctxtFixes has_ambigs pred implics++    drv_fixes = case orig of+                   DerivOrigin standalone             -> [drv_fix standalone]+                   DerivOriginDC _ _       standalone -> [drv_fix standalone]+                   DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone]+                   _                                  -> []++    drv_fix standalone_wildcard+      | standalone_wildcard+      = text "fill in the wildcard constraint yourself"+      | otherwise+      = hang (text "use a standalone 'deriving instance' declaration,")+           2 (text "so you can specify the instance context yourself")++    -- naked_sc_fix: try to produce a helpful error message for+    -- superclass constraints caught by the subtleties described by+    -- Note [Recursive superclasses] in GHC.TyCl.Instance+    naked_sc_fixes+      | ScOrigin IsClsInst NakedSc <- orig  -- A superclass wanted with no instance decls used yet+      , any non_tyvar_preds useful_givens   -- Some non-tyvar givens+      = [vcat [ text "if the constraint looks soluble from a superclass of the instance context,"+              , text "read 'Undecidable instances and loopy superclasses' in the user manual" ]]+      | otherwise = []++    non_tyvar_preds :: UserGiven -> Bool+    non_tyvar_preds = any non_tyvar_pred . ic_given++    non_tyvar_pred :: EvVar -> Bool+    -- Tells if the Given is of form (C ty1 .. tyn), where the tys are not all tyvars+    non_tyvar_pred given = case getClassPredTys_maybe (idType given) of+                             Just (_, tys) -> not (all isTyVarTy tys)+                             Nothing       -> False++pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item matches unifiers) =+  vcat+    [ addArising ct_loc $+        (text "Overlapping instances for"+        <+> pprType (mkClassPred clas tys))+    , ppUnless (null matching_givens) $+                  sep [text "Matching givens (or their superclasses):"+                      , nest 2 (vcat matching_givens)]+    ,  potentialInstancesErrMsg+        (PotentialInstances { matches = NE.toList matches, unifiers })+    ,  ppWhen (null matching_givens && null (NE.tail matches) && null unifiers) $+       -- Intuitively, some given matched the wanted in their+       -- flattened or rewritten (from given equalities) form+       -- but the matcher can't figure that out because the+       -- constraints are non-flat and non-rewritten so we+       -- simply report back the whole given+       -- context. Accelerate Smart.hs showed this problem.+         sep [ text "There exists a (perhaps superclass) match:"+             , nest 2 (vcat (pp_from_givens useful_givens))]++    ,  ppWhen (null $ NE.tail matches) $+       parens (vcat [ ppUnless (null tyCoVars) $+                        text "The choice depends on the instantiation of" <+>+                          quotes (pprWithCommas ppr tyCoVars)+                    , ppUnless (null famTyCons) $+                        if (null tyCoVars)+                          then+                            text "The choice depends on the result of evaluating" <+>+                              quotes (pprWithCommas ppr famTyCons)+                          else+                            text "and the result of evaluating" <+>+                              quotes (pprWithCommas ppr famTyCons)+                    , ppWhen (null (matching_givens)) $+                      vcat [ text "To pick the first instance above, use IncoherentInstances"+                           , text "when compiling the other instance declarations"]+               ])]+  where+    ct_loc          = errorItemCtLoc item+    orig            = ctLocOrigin ct_loc+    pred            = errorItemPred item+    (clas, tys)     = getClassPredTys pred+    tyCoVars        = tyCoVarsOfTypesList tys+    famTyCons       = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys+    useful_givens   = discardProvCtxtGivens orig (getUserGivensFromImplics implics)+    matching_givens = mapMaybe matchable useful_givens+    matchable implic@(Implic { ic_given = evvars, ic_info = skol_info })+      = case ev_vars_matching of+             [] -> Nothing+             _  -> Just $ hang (pprTheta ev_vars_matching)+                            2 (sep [ text "bound by" <+> ppr skol_info+                                   , text "at" <+>+                                     ppr (getCtLocEnvLoc (ic_env implic)) ])+        where ev_vars_matching = [ pred+                                 | ev_var <- evvars+                                 , let pred = evVarPred ev_var+                                 , any can_match (pred : transSuperClasses pred) ]+              can_match pred+                 = case getClassPredTys_maybe pred of+                     Just (clas', tys') -> clas' == clas+                                          && isJust (tcMatchTys tys tys')+                     Nothing -> False+pprTcSolverReportMsg _ (UnsafeOverlap item match unsafe_overlapped) =+  vcat [ addArising ct_loc (text "Unsafe overlapping instances for"+                  <+> pprType (mkClassPred clas tys))+       , sep [text "The matching instance is:",+              nest 2 (pprInstance match)]+       , vcat [ text "It is compiled in a Safe module and as such can only"+              , text "overlap instances from the same module, however it"+              , text "overlaps the following instances from different" <+>+                text "modules:"+              , nest 2 (vcat [pprInstances $ NE.toList unsafe_overlapped])+              ]+       ]+  where+    ct_loc      = errorItemCtLoc item+    pred        = errorItemPred item+    (clas, tys) = getClassPredTys pred++pprTcSolverReportMsg _ MultiplicityCoercionsNotSupported = text "GHC bug #19517: GHC currently does not support programs using GADTs or type families to witness equality of multiplicities"++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 (getCtLocEnvLoc (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++pprUntouchableVariable :: TcTyVar -> Implication -> SDoc+pprUntouchableVariable tv (Implic { ic_given = given, ic_info = skol_info, ic_env = env })+  = sep [ quotes (ppr tv) <+> text "is untouchable"+        , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given+        , nest 2 $ text "bound by" <+> ppr skol_info+        , nest 2 $ text "at" <+> ppr (getCtLocEnvLoc env) ]++pprMismatchMsg :: SolverReportErrCtxt -> MismatchMsg -> SDoc+pprMismatchMsg ctxt+  (BasicMismatch { mismatch_ea   = ea+                 , mismatch_item = item+                 , mismatch_ty1  = ty1  -- Expected+                 , mismatch_ty2  = ty2  -- Actual+                 , mismatch_whenMatching = mb_match_txt+                 , mismatch_mb_same_occ  = same_occ_info })+  =  vcat [ addArising (errorItemCtLoc item) msg+          , pprQCOriginExtra item+          , ea_extra+          , 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 ]++    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++    (want_ea, ea_extra)+      = case ea of+         NoEA        -> (False, empty)+         EA mb_extra -> (True , maybe empty (pprExpectedActualInfo ctxt) mb_extra)+    is_repr = case errorItemEqRel item of { ReprEq -> True; NomEq -> False }++    what = levelString (ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel)++    conc :: [String] -> String+    conc = unwords . filter (not . null)++pprMismatchMsg ctxt+  (TypeEqMismatch { teq_mismatch_item     = item+                  , teq_mismatch_ty1      = ty1   -- These types are the actual types+                  , teq_mismatch_ty2      = ty2   --   that don't match; may be swapped+                  , teq_mismatch_expected = exp   -- These are the context of+                  , teq_mismatch_actual   = act   --   the mis-match+                  , teq_mismatch_what     = mb_thing+                  , teq_mb_same_occ       = mb_same_occ })+  = vcat [ addArising ct_loc $+           pprWithInvisibleBitsWhen ppr_invis_bits msg+           $$ maybe empty pprSameOccInfo mb_same_occ+         , pprQCOriginExtra item ]+  where++    msg | Just (torc, rep) <- sORTKind_maybe exp+        = msg_for_exp_sort torc rep++        | Just nargs_msg <- num_args_msg+        , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig+        = nargs_msg $$ ea_msg++        | ea_looks_same ty1 ty2 exp act+        , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig+        = ea_msg++        | otherwise+        = bale_out_msg++      -- bale_out_msg: the mismatched types are /inside/ exp and act+    bale_out_msg = vcat errs+      where+        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+                                  , ea_err ]+        mismatch_err = mkBasicMismatchMsg NoEA item ty1 ty2++      -- 'expected' is (TYPE rep) or (CONSTRAINT rep)+    msg_for_exp_sort exp_torc exp_rep+      | Just (act_torc, act_rep) <- sORTKind_maybe act+      = -- (TYPE exp_rep) ~ (CONSTRAINT act_rep) etc+        msg_torc_torc act_torc act_rep+      | otherwise+      = -- (TYPE _) ~ Bool, etc+        maybe_num_args_msg $$+        sep [ text "Expected a" <+> ppr_torc exp_torc <> comma+            , text "but" <+> case mb_thing of+                Nothing    -> text "found something with kind"+                Just thing -> quotes (ppr thing) <+> text "has kind"+            , quotes (pprWithTYPE act) ]++      where+        msg_torc_torc act_torc act_rep+          | exp_torc == act_torc+          = msg_same_torc act_torc act_rep+          | otherwise+          = sep [ text "Expected a" <+> ppr_torc exp_torc <> comma+                , text "but" <+> case mb_thing of+                     Nothing    -> text "found a"+                     Just thing -> quotes (ppr thing) <+> text "is a"+                  <+> ppr_torc act_torc ]++        msg_same_torc act_torc act_rep+          | Just exp_doc <- describe_rep exp_rep+          , Just act_doc <- describe_rep act_rep+          = sep [ text "Expected" <+> exp_doc <+> ppr_torc exp_torc <> comma+                , text "but" <+> case mb_thing of+                     Just thing -> quotes (ppr thing) <+> text "is"+                     Nothing    -> text "got"+                  <+> act_doc <+> ppr_torc act_torc ]+        msg_same_torc _ _ = bale_out_msg++    ct_loc = errorItemCtLoc item+    orig   = errorItemOrigin item+    level  = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel+    ppr_invis_bits = shouldPprWithInvisibleBits ty1 ty2 orig++    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 isVisiblePiTyBinder $ fst $ splitPiTys ty++    ppr_torc TypeLike       = text "type";+    ppr_torc ConstraintLike = text "constraint"++    describe_rep :: RuntimeRepType -> Maybe SDoc+    -- describe_rep IntRep            = Just "an IntRep"+    -- describe_rep (BoxedRep Lifted) = Just "a lifted"+    --   etc+    describe_rep rep+      | Just (rr_tc, rr_args) <- splitRuntimeRep_maybe rep+      = case rr_args of+          [lev_ty] | rr_tc `hasKey` boxedRepDataConKey+                   , Just lev <- levityType_maybe lev_ty+                -> case lev of+                      Lifted   -> Just (text "a lifted")+                      Unlifted -> Just (text "a boxed unlifted")+          [] | rr_tc `hasKey` tupleRepDataConTyConKey -> Just (text "a zero-bit")+             | starts_with_vowel rr_occ -> Just (text "an" <+> text rr_occ)+             | otherwise                -> Just (text "a"  <+> text rr_occ)+             where+               rr_occ = occNameString (getOccName rr_tc)++          _ -> Nothing -- Must be TupleRep [r1..rn]+      | otherwise = Nothing++    starts_with_vowel (c:_) = c `elem` ("AEIOU" :: String)+    starts_with_vowel []    = False++pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra)+  = vcat [ main_msg+         , pprQCOriginExtra item+         , ea_supplementary ]+  where+    main_msg+      | null useful_givens = addArising ct_loc no_instance_msg+      | otherwise          = vcat ( addArising ct_loc no_deduce_msg+                                  : pp_from_givens useful_givens)++    ea_supplementary = case mb_extra of+      Nothing                        -> empty+      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] | -- Guard: don't say "no instance" for a constraint+                   -- such as "c" for a type variable c.+                   Just (tc, _) <- splitTyConApp_maybe wanted+                 , isClassTyCon tc+                 -> text "No instance for" <+> quotes (ppr wanted)+        _        -> text "Could not solve:" <+> pprTheta wanteds++    no_deduce_msg =+      case wanteds of+        [wanted] -> text "Could not deduce" <+> quotes (ppr wanted)+        _        -> text "Could not deduce:" <+> pprTheta wanteds++pprQCOriginExtra :: ErrorItem -> SDoc+-- When we were originally trying to solve a quantified constraint like+--    (forall a. Eq a => Eq (c a))+-- add a note to say so, so the overall error looks like+--    Cannot deduce Eq (c a)+--       from (Eq a)+--    when trying to solve (forall a. Eq a => Eq (c a))+-- Without this, the error is very inscrutable+-- See (WFA3) in Note [Solving a Wanted forall-constraint],+--            in GHC.Tc.Solver.Solve+pprQCOriginExtra item+  | ScOrigin (IsQC pred orig) _ <- orig+  = hang (text "When trying to solve the quantified constraint")+       2 (vcat [ ppr pred+               , text "arising from" <+> pprCtOriginBriefly orig ])+  | otherwise+  = empty+  where+    orig = ctLocOrigin (errorItemCtLoc item)++pprKindMismatchMsg :: TypedThing -> Type -> Type -> SDoc+pprKindMismatchMsg thing exp act+  = hang (text "Expected" <+> kind_desc <> comma)+      2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+>+        quotes (ppr act))+  where+    kind_desc | isConstraintLikeKind 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)++-- | Whether to print explicit kinds (with @-fprint-explicit-kinds@)+-- in an 'SDoc' when a type mismatch occurs to due invisible parts of the types.+-- See Note [Showing invisible bits of types in error messages]+--+-- This function first checks to see if the 'CtOrigin' argument is a+-- 'TypeEqOrigin'. If so, it first checks whether the equality is a visible+-- equality; if it's not, definitely print the kinds. Even if the equality is+-- a visible equality, check the expected/actual types to see if the types+-- have equal visible components. If the 'CtOrigin' is+-- not a 'TypeEqOrigin', fall back on the actual mismatched types themselves.+shouldPprWithInvisibleBits :: Type -> Type -> CtOrigin -> Bool+shouldPprWithInvisibleBits _ty1 _ty2 (TypeEqOrigin { uo_actual = act+                                                   , uo_expected = exp+                                                   , uo_visible = vis })+  | not vis   = True                  -- See tests T15870, T16204c+  | otherwise = mayLookIdentical act exp   -- See tests T9171, T9144.+shouldPprWithInvisibleBits ty1 ty2 _ct+  = mayLookIdentical ty1 ty2++{- Note [Showing invisible bits of types in error messages]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It can be terribly confusing to get an error message like (#9171)++    Couldn't match expected type ‘GetParam Base (GetParam Base Int)’+                with actual type ‘GetParam Base (GetParam Base Int)’++The reason may be that the kinds don't match up.  Typically you'll get+more useful information, but not when it's as a result of ambiguity.++To mitigate this, when we find a type or kind mis-match:++* See if normally-visible parts of the type would make the two types+  look different.  This check is made by+  `GHC.Core.TyCo.Compare.mayLookIdentical`++* If not, display the types with their normally-visible parts made visible,+  by setting flags in the `SDocContext":+  Specifically:+    - Display kind arguments: sdocPrintExplicitKinds+    - Don't default away runtime-reps: sdocPrintExplicitRuntimeReps,+           which controls `GHC.Iface.Type.hideNonStandardTypes`+  (NB: foralls are always printed by pprType, it turns out.)++As a result the above error message would instead be displayed as:++    Couldn't match expected type+                  ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’+                with actual type+                  ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’++Which makes it clearer that the culprit is the mismatch between `k2` and `k20`.++Another example of what goes wrong without this: #24553.+-}++{- *********************************************************************+*                                                                      *+                 Displaying potential instances+*                                                                      *+**********************************************************************-}++-- | Directly display the given matching and unifying instances,+-- with a header for each: `Matching instances`/`Potentially matching instances`.+pprPotentialInstances :: (ClsInst -> SDoc) -> PotentialInstances -> SDoc+pprPotentialInstances ppr_inst (PotentialInstances { matches, unifiers }) =+  vcat+    [ ppWhen (not $ null matches) $+       text "Matching instance" <> plural matches <> colon $$+         nest 2 (vcat (map ppr_inst matches))+    , ppWhen (not $ null unifiers) $+        (text "Potentially matching instance" <> plural unifiers <> colon) $$+         nest 2 (vcat (map ppr_inst unifiers))+    ]++-- | Display a summary of available instances, omitting those involving+-- out-of-scope types, in order to explain why we couldn't solve a particular+-- constraint, e.g. due to instance overlap or out-of-scope types.+--+-- To directly display a collection of matching/unifying instances,+-- use 'pprPotentialInstances'.+potentialInstancesErrMsg :: PotentialInstances -> SDoc+-- See Note [Displaying potential instances]+potentialInstancesErrMsg potentials =+  sdocOption sdocPrintPotentialInstances $ \print_insts ->+  getPprStyle $ \sty ->+    potentials_msg_with_options potentials print_insts sty++-- | Display a summary of available instances, omitting out-of-scope ones.+--+-- Use 'potentialInstancesErrMsg' to automatically set the pretty-printing+-- options.+potentials_msg_with_options :: PotentialInstances+                            -> Bool -- ^ Whether to print /all/ potential instances+                            -> PprStyle+                            -> SDoc+potentials_msg_with_options+  (PotentialInstances { matches, unifiers })+  show_all_potentials sty+  | null matches && null unifiers+  = empty++  | null show_these_matches && null show_these_unifiers+  = vcat [ not_in_scope_msg empty+         , flag_hint ]++  | otherwise+  = vcat [ pprPotentialInstances+            pprInstance -- print instance + location info+            (PotentialInstances+              { matches  = show_these_matches+              , unifiers = show_these_unifiers })+         , overlapping_but_not_more_specific_msg sorted_matches+         , nest 2 $ vcat+           [ ppWhen (n_in_scope_hidden > 0) $+             text "...plus"+               <+> speakNOf n_in_scope_hidden (text "other")+           , ppWhen (not_in_scopes > 0) $+              not_in_scope_msg (text "...plus")+           , flag_hint ] ]+  where+    n_show_matches, n_show_unifiers :: Int+    n_show_matches  = 3+    n_show_unifiers = 2++    (in_scope_matches, not_in_scope_matches) = partition inst_in_scope matches+    (in_scope_unifiers, not_in_scope_unifiers) = partition inst_in_scope unifiers+    sorted_matches = sortBy fuzzyClsInstCmp in_scope_matches+    sorted_unifiers = sortBy fuzzyClsInstCmp in_scope_unifiers+    (show_these_matches, show_these_unifiers)+       | show_all_potentials = (sorted_matches, sorted_unifiers)+       | otherwise           = (take n_show_matches  sorted_matches+                               ,take n_show_unifiers sorted_unifiers)+    n_in_scope_hidden+      = length sorted_matches + length sorted_unifiers+      - length show_these_matches - length show_these_unifiers++       -- "in scope" means that all the type constructors+       -- are lexically in scope; these instances are likely+       -- to be more useful+    inst_in_scope :: ClsInst -> Bool+    inst_in_scope cls_inst = nameSetAll name_in_scope $+                             orphNamesOfTypes (is_tys cls_inst)++    name_in_scope name+      | pretendNameIsInScope name+      = True -- E.g. (->); see Note [pretendNameIsInScope] in GHC.Builtin.Names+      | Just mod <- nameModule_maybe name+      = qual_in_scope (qualName sty mod Nothing (nameOccName name))+      | otherwise+      = True++    qual_in_scope :: QualifyName -> Bool+    qual_in_scope NameUnqual    = True+    qual_in_scope (NameQual {}) = True+    qual_in_scope _             = False++    not_in_scopes :: Int+    not_in_scopes = length not_in_scope_matches + length not_in_scope_unifiers++    not_in_scope_msg herald =+      hang (herald <+> speakNOf not_in_scopes (text "instance")+                     <+> text "involving out-of-scope types")+           2 (ppWhen show_all_potentials $+               pprPotentialInstances+               pprInstanceHdr -- only print the header, not the instance location info+                 (PotentialInstances+                   { matches = not_in_scope_matches+                   , unifiers = not_in_scope_unifiers+                   }))++    flag_hint = ppUnless (show_all_potentials+                         || (equalLength show_these_matches matches+                             && equalLength show_these_unifiers unifiers)) $+                text "(use -fprint-potential-instances to see them all)"++-- | Compute a message informing the user of any instances that are overlapped+-- but were not discarded because the instance overlapping them wasn't+-- strictly more specific.+overlapping_but_not_more_specific_msg :: [ClsInst] -> SDoc+overlapping_but_not_more_specific_msg insts+  -- Only print one example of "overlapping but not strictly more specific",+  -- to avoid information overload.+  | overlap : _ <- overlapping_but_not_more_specific+  = overlap_header $$ ppr_overlapping overlap+  | otherwise+  = empty+    where+      overlap_header :: SDoc+      overlap_header+        | [_] <- overlapping_but_not_more_specific+        = text "An overlapping instance can only be chosen when it is strictly more specific."+        | otherwise+        = text "Overlapping instances can only be chosen when they are strictly more specific."+      overlapping_but_not_more_specific :: [(ClsInst, ClsInst)]+      overlapping_but_not_more_specific+        = nubOrdBy (comparing (is_dfun . fst))+          [ (overlapper, overlappee)+          | these <- groupBy ((==) `on` is_cls_nm) insts+          -- Take all pairs of distinct instances...+          , one:others <- tails these -- if `these = [inst_1, inst_2, ...]`+          , other <- others           -- then we get pairs `(one, other) = (inst_i, inst_j)` with `i < j`+          -- ... such that one instance in the pair overlaps the other...+          , let mb_overlapping+                  | hasOverlappingFlag (overlapMode $ is_flag one)+                  || hasOverlappableFlag (overlapMode $ is_flag other)+                  = [(one, other)]+                  | hasOverlappingFlag (overlapMode $ is_flag other)+                  || hasOverlappableFlag (overlapMode $ is_flag one)+                  = [(other, one)]+                  | otherwise+                  = []+          , (overlapper, overlappee) <- mb_overlapping+          -- ... but the overlapper is not more specific than the overlappee.+          , not (overlapper `more_specific_than` overlappee)+          ]+      more_specific_than :: ClsInst -> ClsInst -> Bool+      is1 `more_specific_than` is2+        = isJust (tcMatchTys (is_tys is1) (is_tys is2))+      ppr_overlapping :: (ClsInst, ClsInst) -> SDoc+      ppr_overlapping (overlapper, overlappee)+        = text "The first instance that follows overlaps the second, but is not more specific than it:"+        $$ nest 2 (vcat $ map pprInstanceHdr [overlapper, overlappee])++{- Note [Displaying potential instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When showing a list of instances for+  - overlapping instances (show ones that match)+  - no such instance (show ones that could match)+we want to give it a bit of structure.  Here's the plan++* Say that an instance is "in scope" if all of the+  type constructors it mentions are lexically in scope.+  These are the ones most likely to be useful to the programmer.++* Show at most n_show in-scope instances,+  and summarise the rest ("plus N others")++* Summarise the not-in-scope instances ("plus 4 not in scope")++* Add the flag -fshow-potential-instances which replaces the+  summary with the full list+-}++{- *********************************************************************+*                                                                      *+             Outputting additional solver report information+*                                                                      *+**********************************************************************-}++-- | Pretty-print an informational message, to accompany a 'TcSolverReportMsg'.+pprExpectedActualInfo :: SolverReportErrCtxt -> ExpectedActualInfo -> SDoc+pprExpectedActualInfo _ (ExpectedActual { ea_expected = exp, ea_actual = act }) =+  vcat+    [ text "Expected:" <+> ppr exp+    , text "  Actual:" <+> ppr act ]+pprExpectedActualInfo _+  (ExpectedActualAfterTySynExpansion+    { ea_expanded_expected = exp+    , ea_expanded_actual   = act } )+  = vcat+      [ text "Type synonyms expanded:"+      , text "Expected type:" <+> ppr exp+      , text "  Actual type:" <+> ppr act ]++pprCoercibleMsg :: CoercibleMsg -> SDoc+pprCoercibleMsg (UnknownRoles ty) =+  note $ "We cannot know what roles the parameters to" <+> quotes (ppr ty) <+> "have;" $$+           "we must assume that the role is nominal"+pprCoercibleMsg (TyConIsAbstract tc) =+  note $ "The type constructor" <+> quotes (pprSourceTyCon tc) <+> "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)+      then vcat [ hang (text "When matching" <+> sub_whats)+                      2 (vcat [ ppr cty1 <+> dcolon <+>+                               ppr (typeKind cty1)+                             , ppr cty2 <+> dcolon <+>+                               ppr (typeKind cty2) ])+                , supplementary ]+      else text "When matching the kind of" <+> quotes (ppr cty1)+  where+    sub_t_or_k = mb_sub_t_or_k `orElse` TypeLevel+    sub_whats  = text (levelString sub_t_or_k) <> char 's'+    supplementary = mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o++pprTyVarInfo :: SolverReportErrCtxt -> TyVarInfo -> SDoc+pprTyVarInfo ctxt (TyVarInfo { thisTyVar = tv1, otherTy = mb_tv2, thisTyVarIsUntouchable = mb_implic })+  = vcat [ mk_msg tv1+         , maybe empty (pprUntouchableVariable tv1) mb_implic+         , 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) =+  note $ quotes (ppr tc) <+> text "is a non-injective type family"++pprSameOccInfo :: SameOccInfo -> SDoc+pprSameOccInfo (SameOcc same_pkg n1 n2) =+  note (ppr_from same_pkg n1 $$ ppr_from same_pkg n2)+  where+    ppr_from same_pkg nm+      | isGoodSrcSpan loc+      = hang (quotes (ppr nm) <+> text "is defined at")+           2 (ppr loc)+      | otherwise  -- Imported things have an UnhelpfulSrcSpan+      = hang (quotes (ppr nm))+           2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod))+                  , ppUnless (same_pkg || pkg == mainUnit) $+                    nest 4 $ text "in package" <+> quotes (ppr pkg) ])+      where+        pkg = moduleUnit mod+        mod = nameModule nm+        loc = nameSrcSpan nm++{- *********************************************************************+*                                                                      *+                  Outputting HoleError messages+*                                                                      *+**********************************************************************-}++pprHoleError :: SolverReportErrCtxt -> Hole -> HoleError -> SDoc+pprHoleError _ (Hole { hole_ty, hole_occ = rdr }) OutOfScopeHole+  = out_of_scope_msg+  where+    herald | isDataOcc (rdrNameOcc rdr) = text "Data constructor not in scope:"+           | otherwise     = text "Variable not in scope:"+    out_of_scope_msg -- Print v :: ty only if the type has structure+      | boring_type = hang herald 2 (ppr rdr)+      | otherwise   = hang herald 2 (pp_rdr_with_type rdr hole_ty)+    boring_type = isTyVarTy hole_ty+pprHoleError ctxt (Hole { hole_ty, hole_occ}) (HoleError sort other_tvs hole_skol_info) =+  vcat [ hole_msg+       , tyvars_msg+       , case sort of { ExprHole {} -> expr_hole_hint; _ -> type_hole_hint } ]++  where++    hole_msg = case sort of+      ExprHole {} ->+        hang (text "Found hole:")+          2 (pp_rdr_with_type hole_occ hole_ty)+      TypeHole ->+        hang (text "Found type wildcard" <+> quotes (ppr hole_occ))+          2 (text "standing for" <+> quotes pp_hole_type_with_kind)+      ConstraintHole ->+        hang (text "Found extra-constraints wildcard standing for")+          2 (quotes $ pprType hole_ty)  -- always kind Constraint++    hole_kind = typeKind hole_ty++    pp_hole_type_with_kind+      | isLiftedTypeKind hole_kind+        || isEqPred hole_ty  -- Don't print the kind of unlifted+                             -- equalities (#15039)+      = pprType hole_ty+      | otherwise+      = pprType hole_ty <+> dcolon <+> pprKind hole_kind++    tyvars = tyCoVarsOfTypeList hole_ty+    tyvars_msg = ppUnless (null tyvars) $+                 text "Where:" <+> (vcat (map loc_msg other_tvs)+                                    $$ pprSkols ctxt hole_skol_info)+                      -- Coercion variables can be free in the+                      -- hole, via kind casts+    expr_hole_hint                       -- Give hint for, say,   f x = _x+         | lengthFS (occNameFS (rdrNameOcc hole_occ)) > 1  -- Don't give this hint for plain "_"+         = text "Or perhaps" <+> quotes (ppr hole_occ)+           <+> text "is mis-spelled, or not in scope"+         | otherwise+         = empty++    type_hole_hint+         | ErrorWithoutFlag <- cec_type_holes ctxt+         = text "To use the inferred type, enable PartialTypeSignatures"+         | otherwise+         = empty++    loc_msg tv+       | isTyVar tv+       = case tcTyVarDetails tv of+           MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable"+           _         -> empty  -- Skolems dealt with already+       | otherwise  -- A coercion variable can be free in the hole type+       = ppWhenOption sdocPrintExplicitCoercions $+           quotes (ppr tv) <+> text "is a coercion variable"++pp_rdr_with_type :: RdrName -> Type -> SDoc+pp_rdr_with_type occ hole_ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty)++{- *********************************************************************+*                                                                      *+                  Outputting ScopeError messages+*                                                                      *+**********************************************************************-}++pprScopeError :: RdrName -> NotInScopeError -> SDoc+pprScopeError rdr_name scope_err =+  case scope_err of+    NotInScope ->+      hang (text "Not in scope:")+        2 (what <+> quotes (ppr rdr_name))+    NotARecordField ->+      hang (text "Not in scope:")+        2 (text "record field" <+> quotes (ppr rdr_name))+    NoExactName name ->+      text "The Name" <+> quotes (ppr name) <+> text "is not in scope."+    SameName gres ->+      assertPpr (length gres >= 2) (text "pprScopeError SameName: fewer than 2 elements" $$ nest 2 (ppr gres))+      $ hang (text "Same Name in multiple name-spaces:")+           2 (vcat (map pp_one sorted_names))+      where+        sorted_names = sortBy (leftmost_smallest `on` nameSrcSpan)+                     $ map greName gres+        pp_one name+          = hang (pprNameSpace (occNameSpace (getOccName name))+                  <+> quotes (ppr name) <> comma)+               2 (text "declared at:" <+> ppr (nameSrcLoc name))+    MissingBinding sig _ ->+      sep [ text "The" <+> pprSigLike sig+               <+> text "for" <+> quotes (ppr rdr_name)+          , nest 2 $ text "lacks an accompanying binding" ]+    NoTopLevelBinding ->+      hang (text "No top-level binding for")+        2 (what <+> quotes (ppr rdr_name) <+> text "in this module")+    UnknownSubordinate parent_nm sub ->+      quotes (ppr rdr_name) <+> text "is not a (visible)" <+> pprSubordinate parent_nm sub+    NotInScopeTc env ->+      vcat[text "GHC internal error:" <+> quotes (ppr rdr_name) <+>+      text "is not in scope during type checking, but it passed the renamer",+      text "tcl_env of environment:" <+> ppr env]+  where+    what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))++scopeErrorHints :: NotInScopeError -> [GhcHint]+scopeErrorHints scope_err =+  case scope_err of+    NotInScope             -> noHints+    NotARecordField        -> noHints+    NoExactName {}         -> [SuggestDumpSlices]+    SameName {}            -> [SuggestDumpSlices]+    MissingBinding _ hints -> hints+    NoTopLevelBinding      -> noHints+    UnknownSubordinate {}  -> noHints+    NotInScopeTc _         -> noHints++tcSolverReportMsgHints :: SolverReportErrCtxt -> TcSolverReportMsg -> [GhcHint]+tcSolverReportMsgHints ctxt = \case+  BadTelescope {}+    -> noHints+  UserTypeError {}+    -> noHints+  UnsatisfiableError {}+    -> noHints+  ReportHoleError {}+    -> noHints+  CannotUnifyVariable mismatch_msg rea+    -> mismatchMsgHints ctxt mismatch_msg ++ cannotUnifyVariableHints rea+  Mismatch { mismatchMsg = mismatch_msg }+    -> mismatchMsgHints ctxt mismatch_msg+  FixedRuntimeRepError {}+    -> noHints+  ExpectingMoreArguments {}+    -> noHints+  UnboundImplicitParams {}+    -> noHints+  AmbiguityPreventsSolvingCt {}+    -> noHints+  CannotResolveInstance {}+    -> noHints+  OverlappingInstances {}+    -> noHints+  UnsafeOverlap {}+   -> noHints+  MultiplicityCoercionsNotSupported {}+   -> noHints++mismatchMsgHints :: SolverReportErrCtxt -> MismatchMsg -> [GhcHint]+mismatchMsgHints ctxt msg =+  maybeToList [ hint | (exp,act) <- mismatchMsg_ExpectedActuals msg+                     , hint <- suggestAddSig ctxt exp act ]++mismatchMsg_ExpectedActuals :: MismatchMsg -> Maybe (Type, Type)+mismatchMsg_ExpectedActuals = \case+  BasicMismatch { mismatch_ty1 = exp, mismatch_ty2 = act } ->+    Just (exp, act)+  TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } ->+    Just (exp,act)+  CouldNotDeduce { cnd_extra = cnd_extra }+    | Just (CND_Extra _ exp act) <- cnd_extra+    -> Just (exp, act)+    | otherwise+    -> Nothing++cannotUnifyVariableHints :: CannotUnifyVariableReason -> [GhcHint]+cannotUnifyVariableHints = \case+  CannotUnifyWithPolytype {}+    -> noHints+  OccursCheck {}+    -> noHints+  SkolemEscape {}+    -> noHints+  DifferentTyVars {}+    -> noHints+  RepresentationalEq {}+    -> noHints++suggestAddSig :: SolverReportErrCtxt -> TcType -> TcType -> Maybe GhcHint+-- See Note [Suggest adding a type signature]+suggestAddSig ctxt ty1 _ty2+  | bndr : bndrs <- inferred_bndrs+  = Just $ SuggestAddTypeSignatures $ NamedBindings (bndr :| bndrs)+  | otherwise+  = Nothing+  where+    inferred_bndrs =+      case getTyVar_maybe ty1 of+        Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv+        _                          -> []++    -- 'find' returns the binders of an InferSkol for 'tv',+    -- provided there is an intervening implication with+    -- ic_given_eqs /= NoGivenEqs (i.e. a GADT match)+    find [] _ _ = []+    find (implic:implics) seen_eqs tv+       | tv `elem` ic_skols implic+       , InferSkol prs <- ic_info implic+       , seen_eqs+       = map fst prs+       | otherwise+       = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv++{- Note [Suggest adding a type signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The OutsideIn algorithm rejects GADT programs that don't have a principal+type, and indeed some that do.  Example:+   data T a where+     MkT :: Int -> T Int++   f (MkT n) = n++Does this have type f :: T a -> a, or f :: T a -> Int?+The error that shows up tends to be an attempt to unify an+untouchable type variable.  So suggestAddSig sees if the offending+type variable is bound by an *inferred* signature, and suggests+adding a declared signature instead.++More specifically, we suggest adding a type sig if we have p ~ ty, and+p is a skolem bound by an InferSkol.  Those skolems were created from+unification variables in simplifyInfer.  Why didn't we unify?  It must+have been because of an intervening GADT or existential, making it+untouchable. Either way, a type signature would help.  For GADTs, it+might make it typeable; for existentials the attempt to write a+signature will fail -- or at least will produce a better error message+next time++This initially came up in #8968, concerning pattern synonyms.+-}++{- *********************************************************************+*                                                                      *+                  Outputting ImportError messages+*                                                                      *+**********************************************************************-}++instance Outputable ImportError where+  ppr err = note $ case err of+      MissingModule mod_name -> "No module named" <+> quoted mod_name <+> "is imported"+      ModulesDoNotExport mods what_look occ_name+        | mod NE.:| [] <- mods -> "The module" <+> quoted mod <+> "does not export" <+> what <+> quoted occ_name+        | otherwise -> "Neither" <+> quotedListWithNor (map ppr $ NE.toList mods) <+> "export" <+> what <+> quoted occ_name+        where+          what :: SDoc+          what = case what_look of+            WL_ConLike -> text "data constructor"+            WL_RecField -> text "record field"+            _ -> empty+    where+      quoted :: Outputable a => a -> SDoc+      quoted = quotes . ppr++{- *********************************************************************+*                                                                      *+             Suggested fixes for implication constraints+*                                                                      *+**********************************************************************-}++-- TODO: these functions should use GhcHint instead.++show_fixes :: [SDoc] -> SDoc+show_fixes []     = empty+show_fixes (f:fs) = sep [ text "Possible fix:"+                        , nest 2 (vcat (f : map (text "or" <+>) fs))]++ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc]+ctxtFixes has_ambig_tvs pred implics+  | not has_ambig_tvs+  , isTyVarClassPred pred   -- Don't suggest adding (Eq T) to the context, say+  , (skol:skols) <- usefulContext implics pred+  , let what | null skols+             , SigSkol (PatSynCtxt {}) _ _ <- skol+             = text "\"required\""+             | otherwise+             = empty+  = [sep [ text "add" <+> pprParendType pred+           <+> text "to the" <+> what <+> text "context of"+         , nest 2 $ ppr_skol skol $$+                    vcat [ text "or" <+> ppr_skol skol+                         | skol <- skols ] ] ]+  | otherwise = []+  where+    ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc)+    ppr_skol (PatSkol (PatSynCon ps)   _) = text "the pattern synonym"  <+> quotes (ppr ps)+    ppr_skol skol_info = ppr skol_info++usefulContext :: [Implication] -> PredType -> [SkolemInfoAnon]+-- usefulContext picks out the implications whose context+-- the programmer might plausibly augment to solve 'pred'+usefulContext implics pred+  = go implics+  where+    pred_tvs = tyCoVarsOfType pred+    go [] = []+    go (ic : ics)+       | implausible ic = rest+       | otherwise      = ic_info ic : rest+       where+          -- Stop when the context binds a variable free in the predicate+          rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = []+               | otherwise                                 = go ics++    implausible ic+      | null (ic_skols ic)            = True+      | implausible_info (ic_info ic) = True+      | otherwise                     = False++    implausible_info (SigSkol (InfSigCtxt {}) _ _) = True+    implausible_info _                             = False+    -- Do not suggest adding constraints to an *inferred* type signature++pp_from_givens :: [Implication] -> [SDoc]+pp_from_givens givens+   = case givens of+         []     -> []+         (g:gs) ->      ppr_given (text "from the context:") g+                 : map (ppr_given (text "or from:")) gs+    where+       ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info })+           = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs))+             -- See Note [Suppress redundant givens during error reporting]+             -- for why we use mkMinimalBySCs above.+                2 (sep [ text "bound by" <+> ppr skol_info+                       , text "at" <+> ppr (getCtLocEnvLoc (ic_env implic)) ])++{- *********************************************************************+*                                                                      *+                       CtOrigin information+*                                                                      *+**********************************************************************-}++levelString :: TypeOrKind -> String+levelString TypeLevel = "type"+levelString KindLevel = "kind"++pprArising :: CtLoc -> SDoc+-- Used for the main, top-level error message+-- We've done special processing for TypeEq, KindEq, givens+pprArising ct_loc+  | in_generated_code = empty  -- See Note ["Arising from" messages in generated code]+  | suppress_origin   = empty+  | otherwise         = pprCtOrigin orig+  where+    orig = ctLocOrigin ct_loc+    in_generated_code = ctLocEnvInGeneratedCode (ctLocEnv ct_loc)+    suppress_origin+      | isGivenOrigin orig = True+      | otherwise          = case orig of+          TypeEqOrigin {}         -> True -- We've done special processing+          KindEqOrigin {}         -> True -- for TypeEq, KindEq, givens+          AmbiguityCheckOrigin {} -> True -- The "In the ambiguity check" context+                                          -- is sufficient; more would be repetitive+          _ -> False++-- Add the "arising from..." part to a message+addArising :: CtLoc -> SDoc -> SDoc+addArising ct_loc msg = hang msg 2 (pprArising ct_loc)++pprWithArising :: [Ct] -> SDoc+-- Print something like+--    (Eq a) arising from a use of x at y+--    (Show a) arising from a use of p at q+-- Also return a location for the error message+-- Works for Wanted/Derived only+pprWithArising []+  = panic "pprWithArising"+pprWithArising (ct:cts)+  | null cts+  = addArising loc (pprTheta [ctPred ct])+  | otherwise+  = vcat (map ppr_one (ct:cts))+  where+    loc = ctLoc ct+    ppr_one ct' = hang (parens (pprType (ctPred ct')))+                     2 (pprCtLoc (ctLoc ct'))++{- Note ["Arising from" messages in generated code]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider code generated when we desugar code before typechecking;+see Note [Rebindable syntax and XXExprGhcRn].++In this code, constraints may be generated, but we don't want to+say "arising from a call of foo" if 'foo' doesn't appear in the+users code.  We leave the actual CtOrigin untouched (partly because+it is generated in many, many places), but suppress the "Arising from"+message for constraints that originate in generated code.+-}+++{- *********************************************************************+*                                                                      *+                           SkolemInfo+*                                                                      *+**********************************************************************-}+++tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo+tidySkolemInfo env (SkolemInfo u sk_anon) = SkolemInfo u (tidySkolemInfoAnon env sk_anon)++----------------+tidySkolemInfoAnon :: TidyEnv -> SkolemInfoAnon -> SkolemInfoAnon+tidySkolemInfoAnon env (DerivSkol ty)         = DerivSkol (tidyType env ty)+tidySkolemInfoAnon env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs+tidySkolemInfoAnon env (InferSkol ids)        = InferSkol (mapSnd (tidyType env) ids)+tidySkolemInfoAnon env (UnifyForAllSkol ty)   = UnifyForAllSkol (tidyType env ty)+tidySkolemInfoAnon _   info                   = info++tidySigSkol :: TidyEnv -> UserTypeCtxt+            -> TcType -> [(Name,TcTyVar)] -> SkolemInfoAnon+-- We need to take special care when tidying SigSkol+-- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin"+tidySigSkol env cx ty tv_prs+  = SigSkol cx (tidy_ty env ty) tv_prs'+  where+    tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs+    inst_env = mkNameEnv tv_prs'++    tidy_ty env (ForAllTy (Bndr tv vis) ty)+      = ForAllTy (Bndr tv' vis) (tidy_ty env' ty)+      where+        (env', tv') = tidy_tv_bndr env tv++    tidy_ty env ty@(FunTy { ft_mult = w, ft_arg = arg, ft_res = res })+      = -- Look under  c => t and t1 -> t2+        ty { ft_mult = tidy_ty env w+           , ft_arg  = tidyType env arg+           , ft_res  = tidy_ty env res }++    tidy_ty env ty = tidyType env ty++    tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)+    tidy_tv_bndr env@(occ_env, subst) tv+      | Just tv' <- lookupNameEnv inst_env (tyVarName tv)+      = ((occ_env, extendVarEnv subst tv tv'), tv')++      | otherwise+      = tidyVarBndr env tv++pprSkols :: SolverReportErrCtxt -> [(SkolemInfoAnon, [TcTyVar])] -> SDoc+pprSkols ctxt zonked_ty_vars+  =+      let tidy_ty_vars = map (bimap (tidySkolemInfoAnon (cec_tidy ctxt)) id) zonked_ty_vars+      in vcat (map pp_one tidy_ty_vars)+  where++    no_msg = text "No skolem info - we could not find the origin of the following variables" <+> ppr zonked_ty_vars+       $$ text "This should not happen, please report it as a bug following the instructions at:"+       $$ text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug"+++    pp_one (UnkSkol cs, tvs)+      = vcat [ hang (pprQuotedList tvs)+                 2 (is_or_are tvs "a" "(rigid, skolem)")+             , nest 2 (text "of unknown origin")+             , nest 2 (text "bound at" <+> ppr (skolsSpan tvs))+             , no_msg+             , prettyCallStackDoc cs+             ]+    pp_one (RuntimeUnkSkol, tvs)+      = hang (pprQuotedList tvs)+           2 (is_or_are tvs "an" "unknown runtime")+    pp_one (skol_info, tvs)+      = vcat [ hang (pprQuotedList tvs)+                  2 (is_or_are tvs "a"  "rigid" <+> text "bound by")+             , nest 2 (pprSkolInfo skol_info)+             , nest 2 (text "at" <+> ppr (skolsSpan tvs)) ]++    is_or_are [_] article adjective = text "is" <+> text article <+> text adjective+                                      <+> text "type variable"+    is_or_are _   _       adjective = text "are" <+> text adjective+                                      <+> text "type variables"++skolsSpan :: [TcTyVar] -> SrcSpan+skolsSpan skol_tvs = foldr1WithDefault noSrcSpan combineSrcSpans (map getSrcSpan skol_tvs)++{- *********************************************************************+*                                                                      *+                Utilities for expected/actual messages+*                                                                      *+**********************************************************************-}++mk_supplementary_ea_msg :: SolverReportErrCtxt -> TypeOrKind+                        -> Type -> Type -> CtOrigin -> SDoc+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)+  = case mk_ea_msg ctxt Nothing level orig of+      Left infos -> vcat $ map (pprExpectedActualInfo ctxt) infos+      Right msg  -> msg+  | otherwise+  = empty++ea_looks_same :: Type -> Type -> Type -> Type -> Bool+-- True if the faulting types (ty1, ty2) look the same as+-- the expected/actual types (exp, act).+-- If so, we don't want to redundantly report the latter+ea_looks_same ty1 ty2 exp act+  = (act `looks_same` ty1 && exp `looks_same` ty2) ||+    (exp `looks_same` ty1 && act `looks_same` ty2)+  where+    looks_same t1 t2 = t1 `pickyEqType` t2+                    || t1 `eqType` liftedTypeKind && t2 `eqType` liftedTypeKind+      -- pickyEqType is sensitive to synonyms, so only replies True+      -- when the types really look the same.  However,+      -- (TYPE 'LiftedRep) and Type both print the same way.++mk_ea_msg :: SolverReportErrCtxt -> Maybe ErrorItem -> TypeOrKind+          -> CtOrigin -> Either [ExpectedActualInfo] SDoc+-- Constructs a "Couldn't match" message+-- The (Maybe ErrorItem) says whether this is the main top-level message (Just)+--     or a supplementary message (Nothing)+mk_ea_msg ctxt at_top level+  (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing })+  | Just thing <- mb_thing+  , KindLevel <- level+  = Right $ pprKindMismatchMsg thing exp act+  | Just item <- at_top+  , let  ea = EA $ if expanded_syns then Just ea_expanded else Nothing+         mismatch = mkBasicMismatchMsg ea item exp act+  = Right (pprMismatchMsg ctxt mismatch)+  | otherwise+  = Left $+    if expanded_syns+    then [ea,ea_expanded]+    else [ea]++  where+    ea = ExpectedActual { ea_expected = exp, ea_actual = act }+    ea_expanded =+      ExpectedActualAfterTySynExpansion+        { ea_expanded_expected = expTy1+        , ea_expanded_actual   = expTy2 }++    expanded_syns = cec_expand_syns ctxt+                 && not (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act)+    (expTy1, expTy2) = expandSynonymsToMatch exp act+mk_ea_msg _ _ _ _ = Left []++{- Note [Expanding type synonyms to make types similar]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In type error messages, if -fprint-expanded-types is used, we want to expand+type synonyms to make expected and found types as similar as possible, but we+shouldn't expand types too much to make type messages even more verbose and+harder to understand. The whole point here is to make the difference in expected+and found types clearer.++`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms+only as much as necessary. Given two types t1 and t2:++  * If they're already same, it just returns the types.++  * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are+    type constructors), it expands C1 and C2 if they're different type synonyms.+    Then it recursively does the same thing on expanded types. If C1 and C2 are+    same, then it applies the same procedure to arguments of C1 and arguments of+    C2 to make them as similar as possible.++    Most important thing here is to keep number of synonym expansions at+    minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3,+    Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and+    `T (T3, T3, Bool)`.++  * Otherwise types don't have same shapes and so the difference is clearly+    visible. It doesn't do any expansions and show these types.++Note that we only expand top-layer type synonyms. Only when top-layer+constructors are the same we start expanding inner type synonyms.++Suppose top-layer type synonyms of t1 and t2 can expand N and M times,+respectively. If their type-synonym-expanded forms will meet at some point (i.e.+will have same shapes according to `sameShapes` function), it's possible to find+where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M))+comparisons. We first collect all the top-layer expansions of t1 and t2 in two+lists, then drop the prefix of the longer list so that they have same lengths.+Then we search through both lists in parallel, and return the first pair of+types that have same shapes. Inner types of these two types with same shapes+are then expanded using the same algorithm.++In case they don't meet, we return the last pair of types in the lists, which+has top-layer type synonyms completely expanded. (in this case the inner types+are not expanded at all, as the current form already shows the type error)+-}++-- | Expand type synonyms in given types only enough to make them as similar as+-- possible. Returned types are the same in terms of used type synonyms.+--+-- To expand all synonyms, see 'Type.expandTypeSynonyms'.+--+-- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for+-- some examples of how this should work.+expandSynonymsToMatch :: Type -> Type -> (Type, Type)+expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret)+  where+    (ty1_ret, ty2_ret) = go ty1 ty2++    -- Returns (type synonym expanded version of first type,+    --          type synonym expanded version of second type)+    go :: Type -> Type -> (Type, Type)+    go t1 t2+      | t1 `pickyEqType` t2 =+        -- Types are same, nothing to do+        (t1, t2)++    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      | tc1 == tc2+      , tys1 `equalLength` tys2 =+        -- Type constructors are same. They may be synonyms, but we don't+        -- expand further. The lengths of tys1 and tys2 must be equal;+        -- for example, with type S a = a, we don't want+        -- to zip (S Monad Int) and (S Bool).+        let (tys1', tys2') = unzip (zipWithEqual go tys1 tys2)+         in (TyConApp tc1 tys1', TyConApp tc2 tys2')++    go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) =+      let (t1_1', t2_1') = go t1_1 t2_1+          (t1_2', t2_2') = go t1_2 t2_2+       in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2')++    go ty1@(FunTy _ w1 t1_1 t1_2) ty2@(FunTy _ w2 t2_1 t2_2) | w1 `eqType` w2 =+      let (t1_1', t2_1') = go t1_1 t2_1+          (t1_2', t2_2') = go t1_2 t2_2+       in ( ty1 { ft_arg = t1_1', ft_res = t1_2' }+          , ty2 { ft_arg = t2_1', ft_res = t2_2' })++    go (ForAllTy b1 t1) (ForAllTy b2 t2) =+      -- NOTE: We may have a bug here, but we just can't reproduce it easily.+      -- See D1016 comments for details and our attempts at producing a test+      -- case. Short version: We probably need RnEnv2 to really get this right.+      let (t1', t2') = go t1 t2+       in (ForAllTy b1 t1', ForAllTy b2 t2')++    go (CastTy ty1 _) ty2 = go ty1 ty2+    go ty1 (CastTy ty2 _) = go ty1 ty2++    go t1 t2 =+      -- See Note [Expanding type synonyms to make types similar] for how this+      -- works+      let+        t1_exp_tys = t1 : tyExpansions t1+        t2_exp_tys = t2 : tyExpansions t2+        t1_exps    = length t1_exp_tys+        t2_exps    = length t2_exp_tys+        dif        = abs (t1_exps - t2_exps)+      in+        followExpansions $+          zipEqual+            (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys)+            (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys)++    -- Expand the top layer type synonyms repeatedly, collect expansions in a+    -- list. The list does not include the original type.+    --+    -- Example, if you have:+    --+    --   type T10 = T9+    --   type T9  = T8+    --   ...+    --   type T0  = Int+    --+    -- `tyExpansions T10` returns [T9, T8, T7, ..., Int]+    --+    -- This only expands the top layer, so if you have:+    --+    --   type M a = Maybe a+    --+    -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded)+    tyExpansions :: Type -> [Type]+    tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` coreView t)++    -- Drop the type pairs until types in a pair look alike (i.e. the outer+    -- constructors are the same).+    followExpansions :: [(Type, Type)] -> (Type, Type)+    followExpansions [] = pprPanic "followExpansions" empty+    followExpansions [(t1, t2)]+      | sameShapes t1 t2 = go t1 t2 -- expand subtrees+      | otherwise        = (t1, t2) -- the difference is already visible+    followExpansions ((t1, t2) : tss)+      -- Traverse subtrees when the outer shapes are the same+      | sameShapes t1 t2 = go t1 t2+      -- Otherwise follow the expansions until they look alike+      | otherwise = followExpansions tss++    sameShapes :: Type -> Type -> Bool+    sameShapes AppTy{}          AppTy{}          = True+    sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2+    sameShapes (FunTy {})       (FunTy {})       = True+    sameShapes (ForAllTy {})    (ForAllTy {})    = True+    sameShapes (CastTy ty1 _)   ty2              = sameShapes ty1 ty2+    sameShapes ty1              (CastTy ty2 _)   = sameShapes ty1 ty2+    sameShapes _                _                = False++{-+************************************************************************+*                                                                      *+\subsection{Contexts for renaming errors}+*                                                                      *+************************************************************************+-}++inHsDocContext :: HsDocContext -> SDoc+inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt++pprHsDocContext :: HsDocContext -> SDoc+pprHsDocContext (GenericCtx doc)      = doc+pprHsDocContext (TypeSigCtx vs)       = text "the type signature for" <+> ppr_sig_bndrs vs+pprHsDocContext (StandaloneKindSigCtx v)= text "the standalone kind signature for" <+> quotes (ppr v)+pprHsDocContext PatCtx                = text "a pattern type-signature"+pprHsDocContext SpecInstSigCtx        = text "a SPECIALISE instance pragma"+pprHsDocContext DefaultDeclCtx        = text "a `default' declaration"+pprHsDocContext DerivDeclCtx          = text "a deriving declaration"+pprHsDocContext (RuleCtx name)        = text "the rewrite rule" <+> doubleQuotes (ftext name)+pprHsDocContext (SpecECtx name)       = text "the SPECIALISE pragma for" <+> quotes (ppr name)+pprHsDocContext (TyDataCtx tycon)     = text "the data type declaration for" <+> quotes (ppr tycon)+pprHsDocContext (FamPatCtx tycon)     = text "a type pattern of family instance for" <+> quotes (ppr tycon)+pprHsDocContext (TySynCtx name)       = text "the declaration for type synonym" <+> quotes (ppr name)+pprHsDocContext (TyFamilyCtx name)    = text "the declaration for type family" <+> quotes (ppr name)+pprHsDocContext (ClassDeclCtx name)   = text "the declaration for class" <+> quotes (ppr name)+pprHsDocContext ExprWithTySigCtx      = text "an expression type signature"+pprHsDocContext TypBrCtx              = text "a Template-Haskell quoted type"+pprHsDocContext HsTypeCtx             = text "a type argument"+pprHsDocContext HsTypePatCtx          = text "a type argument in a pattern"+pprHsDocContext GHCiCtx               = text "GHCi input"+pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty)+pprHsDocContext ReifyInstancesCtx      = text "GHC.Tc.Gen.Splice.reifyInstances"+pprHsDocContext (ClassInstanceCtx inst_ty) =+  text "the instance declaration for" <+> quotes (ppr inst_ty)+pprHsDocContext (ClassMethodSigCtx name) = text "a class method signature for" <+> quotes (ppr name)+pprHsDocContext (SpecialiseSigCtx name) = text "a SPECIALISE signature for" <+> quotes (ppr name)+pprHsDocContext (PatSynSigCtx vs) =+  text "a pattern synonym signature for" <+> ppr_sig_bndrs vs++pprHsDocContext (ForeignDeclCtx name)+   = text "the foreign declaration for" <+> quotes (ppr name)+pprHsDocContext (ConDeclCtx [name])+   = text "the definition of data constructor" <+> quotes (ppr name)+pprHsDocContext (ConDeclCtx names)+   = text "the definition of data constructors" <+> interpp'SP names++ppr_sig_bndrs :: [LocatedN RdrName] -> SDoc+ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)++pprConversionFailReason :: ConversionFailReason -> SDoc+pprConversionFailReason = \case+  IllegalOccName ctxt_ns occ ->+    text "Illegal" <+> pprNameSpace ctxt_ns+    <+> text "name:" <+> quotes (text occ)+  SumAltArityExceeded alt arity ->+    text "Sum alternative" <+> int alt+    <+> text "exceeds its arity," <+> int arity+  IllegalSumAlt alt ->+    vcat [ text "Illegal sum alternative:" <+> int alt+         , nest 2 $ text "Sum alternatives must start from 1" ]+  IllegalSumArity arity ->+    vcat [ text "Illegal sum arity:" <+> int arity+         , nest 2 $ text "Sums must have an arity of at least 2" ]+  MalformedType typeOrKind ty ->+    text "Malformed " <> text ty_str <+> text (show ty)+    where ty_str = case typeOrKind of+                     TypeLevel -> "type"+                     KindLevel -> "kind"+  IllegalLastStatement do_or_lc stmt ->+    vcat [ text "Illegal last statement of" <+> pprAHsDoFlavour do_or_lc <> colon+         , nest 2 $ ppr stmt+         , text "(It should be an expression.)" ]+  KindSigsOnlyAllowedOnGADTs ->+    text "Kind signatures are only allowed on GADTs"+  IllegalDeclaration declDescr bad_decls ->+    sep [ text "Illegal" <+> what <+> text "in" <+> descrDoc <> colon+        , nest 2 bads ]+    where+      (what, bads) = case bad_decls of+        IllegalDecls (NE.toList -> decls) ->+            (text "declaration" <> plural decls, vcat $ map ppr decls)+        IllegalFamDecls (NE.toList -> decls) ->+            ( text "family declaration" <> plural decls, vcat $ map ppr decls)+      descrDoc = text $ case declDescr of+                   InstanceDecl -> "an instance declaration"+                   WhereClause -> "a where clause"+                   LetBinding -> "a let expression"+                   LetExpression -> "a let expression"+                   ClssDecl -> "a class declaration"+  CannotMixGADTConsWith98Cons ->+    text "Cannot mix GADT constructors with Haskell 98"+    <+> text "constructors"+  EmptyStmtListInDoBlock ->+    text "Empty stmt list in do-block"+  NonVarInInfixExpr ->+    text "Non-variable expression is not allowed in an infix expression"+  MultiWayIfWithoutAlts ->+    text "Multi-way if-expression with no alternatives"+  CasesExprWithoutAlts ->+    text "\\cases expression with no alternatives"+  ImplicitParamsWithOtherBinds ->+    text "Implicit parameters mixed with other bindings"+  InvalidCCallImpent from ->+    text (show from) <+> text "is not a valid ccall impent"+  RecGadtNoCons ->+    quotes (text "RecGadtC") <+> text "must have at least one constructor name"+  GadtNoCons ->+    quotes (text "GadtC") <+> text "must have at least one constructor name"+  InvalidTypeInstanceHeader tys ->+    text "Invalid type instance header:"+    <+> text (show tys)+  InvalidTyFamInstLHS lhs ->+    text "Invalid type family instance LHS:"+    <+> text (show lhs)+  InvalidImplicitParamBinding ->+    text "Implicit parameter binding only allowed in let or where"+  DefaultDataInstDecl adts ->+    (text "Default data instance declarations"+    <+> text "are not allowed:")+      $$ ppr adts+  FunBindLacksEquations nm ->+    text "Function binding for"+    <+> quotes (text (TH.pprint nm))+    <+> text "has no equations"+  EmptyGuard ->+    text "Empty guard"+  EmptyParStmt ->+    text "Empty par stmt"++pprTyThingUsedWrong :: WrongThingSort -> TcTyThing -> Name -> SDoc+pprTyThingUsedWrong sort thing name =+  pprTcTyThingCategory thing <+> quotes (ppr name) <+>+  text "used as a" <+> pprWrongThingSort sort++pprWrongThingSort :: WrongThingSort -> SDoc+pprWrongThingSort =+  text . \case+    WrongThingType -> "type"+    WrongThingDataCon -> "data constructor"+    WrongThingPatSyn -> "pattern synonym"+    WrongThingConLike -> "constructor-like thing"+    WrongThingClass -> "class"+    WrongThingTyCon -> "type constructor"+    WrongThingAxiom -> "axiom"++pprLevelCheckReason :: LevelCheckReason -> SDoc+pprLevelCheckReason = \case+  LevelCheckInstance _ t ->+    text "instance for" <+> quotes (ppr t)+  LevelCheckSplice t _ ->+    quotes (ppr t)++pprUninferrableTyVarCtx :: UninferrableTyVarCtx -> SDoc+pprUninferrableTyVarCtx = \case+  UninfTyCtx_ClassContext theta ->+    sep [ text "the class context:", pprTheta theta ]+  UninfTyCtx_DataContext theta ->+    sep [ text "the datatype context:", pprTheta theta ]+  UninfTyCtx_ProvidedContext theta ->+    sep [ text "the provided context:" , pprTheta theta ]+  UninfTyCtx_TyFamRhs rhs_ty ->+    sep [ text "the type family equation right-hand side:" , ppr rhs_ty ]+  UninfTyCtx_TySynRhs rhs_ty ->+    sep [ text "the type synonym right-hand side:" , ppr rhs_ty ]+  UninfTyCtx_Sig exp_kind full_hs_ty ->+    hang (text "the kind" <+> ppr exp_kind) 2+         (text "of the type signature:" <+> ppr full_hs_ty)++pprPatSynInvalidRhsReason :: PatSynInvalidRhsReason -> SDoc+pprPatSynInvalidRhsReason = \case+  PatSynNotInvertible p ->+    text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"+  PatSynUnboundVar var ->+    quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym"++pprBadFieldAnnotationReason :: BadFieldAnnotationReason -> SDoc+pprBadFieldAnnotationReason = \case+  LazyFieldsDisabled ->+    text "Lazy field annotations (~) are disabled"+  UnpackWithoutStrictness ->+    text "UNPACK pragma lacks '!'"+  UnusableUnpackPragma ->+    text "Ignoring unusable UNPACK pragma"++pprSuperclassCycleDetail :: SuperclassCycleDetail -> SDoc+pprSuperclassCycleDetail = \case+  SCD_HeadTyVar pred ->+    hang (text "one of whose superclass constraints is headed by a type variable:")+       2 (quotes (ppr pred))+  SCD_HeadTyFam pred ->+    hang (text "one of whose superclass constraints is headed by a type family:")+       2 (quotes (ppr pred))+  SCD_Superclass cls ->+    text "one of whose superclasses is" <+> quotes (ppr cls)++pprRoleValidationFailedReason :: Role -> RoleValidationFailedReason -> SDoc+pprRoleValidationFailedReason role = \case+  TyVarRoleMismatch tv role' ->+    text "type variable" <+> quotes (ppr tv) <+>+    text "cannot have role" <+> ppr role <+>+    text "because it was assigned role" <+> ppr role'+  TyVarMissingInEnv tv ->+    text "type variable" <+> quotes (ppr tv) <+> text "missing in environment"+  BadCoercionRole co ->+    text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role++pprDisabledClassExtension :: Class -> DisabledClassExtension -> SDoc+pprDisabledClassExtension cls = \case+  MultiParamDisabled n ->+    text howMany <+> text "parameters for class" <+> quotes (ppr cls)+    where+      howMany | n == 0 = "No"+              | otherwise = "Too many"+  FunDepsDisabled ->+    text "Fundeps in class" <+> quotes (ppr cls)+  ConstrainedClassMethodsDisabled sel_id pred ->+    vcat [ hang (text "Constraint" <+> quotes (ppr pred)+                 <+> text "in the type of" <+> quotes (ppr sel_id))+              2 (text "constrains only the class type variables")]++pprImportLookup :: ImportLookupReason -> SDoc+pprImportLookup = \case+  ImportLookupBad k iface decl_spec ie _exts ->+    let+      pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc+      pprImpDeclSpec iface decl_spec =+        quotes (ppr (moduleName $ is_mod decl_spec)) <+> case mi_boot iface of+            IsBoot  -> text "(hi-boot interface)"+            NotBoot -> empty+      withContext msgs =+        hang (text "In the import of" <+> pprImpDeclSpec iface decl_spec <> colon)+          2 (vcat msgs)+    in case k of+      BadImportNotExported _ ->+        vcat+          [ text "Module" <+> pprImpDeclSpec iface decl_spec <+>+            text "does not export" <+> quotes (ppr ie) <> dot+          ]+      BadImportAvailVar ->+        withContext+          [ text "an item called"+              <+> quotes val <+> text "is exported, but it is not a type."+          ]+        where+          val_occ = rdrNameOcc $ ieName ie+          val = parenSymOcc val_occ (ppr val_occ)+      BadImportAvailTyCon {} ->+        withContext+          [ text "an item called"+            <+> quotes tycon <+> text "is exported, but it is a type."+          ]+        where+          tycon_occ = rdrNameOcc $ ieName ie+          tycon = parenSymOcc tycon_occ (ppr tycon_occ)+      BadImportNotExportedSubordinates gre unavailable1 ->+        withContext+          [ what <+> text "called" <+> parent_name <+> text "is exported, but it does not export"+          , text "any" <+> what_children <+> text "called" <+> unavailable_names <> dot+          ]+          where+            unavailable = NE.toList unavailable1+            parent_name = (quotes . pprPrefixOcc . nameOccName . gre_name) gre+            unavailable_names = pprWithCommas (quotes . ppr) unavailable+            any_names p = any (p . unpackFS) unavailable+            what = case greInfo gre of+              IAmTyCon ClassFlavour -> text "a class"+              IAmTyCon _            -> text "a data type"+              _                     -> text "an item"+            what_children = unquotedListWith "or" $ case greInfo gre of+              IAmTyCon ClassFlavour ->+                [text "class methods"    | any_names okVarOcc ] +++                [text "associated types" | any_names okTcOcc ]+              IAmTyCon _ ->+                [text "constructors"  | any_names okConOcc ] +++                [text "record fields" | any_names okVarOcc ]+              _ -> [text "children"]+      BadImportNonTypeSubordinates gre nontype1 ->+        withContext+          [ what <+> text "called" <+> parent_name <+> text "is exported,"+          , sep [ text "but its subordinate item" <> plural nontype <+> nontype_names+                , isOrAre nontype <+> "not in the type namespace." ] ]+          where+            nontype = NE.toList nontype1+            parent_name = (quotes . pprPrefixOcc . nameOccName . gre_name) gre+            nontype_names = pprWithCommas (quotes . pprPrefixOcc . nameOccName . gre_name) nontype+            what = case greInfo gre of+              IAmTyCon ClassFlavour -> text "a class"+              IAmTyCon _            -> text "a data type"+              _                     -> text "an item"+      BadImportNonDataSubordinates gre nondata1 ->+        withContext+          [ what <+> text "called" <+> parent_name <+> text "is exported,"+          , sep [ text "but its subordinate item" <> plural nondata <+> nondata_names+                , isOrAre nondata <+> "not in the data namespace." ] ]+          where+            nondata = NE.toList nondata1+            parent_name = (quotes . pprPrefixOcc . nameOccName . gre_name) gre+            nondata_names = pprWithCommas (quotes . pprPrefixOcc . nameOccName . gre_name) nondata+            what = case greInfo gre of+              IAmTyCon ClassFlavour -> text "a class"+              IAmTyCon _            -> text "a data type"+              _                     -> text "an item"+      BadImportAvailDataCon dataType_occ ->+        withContext+          [ text "an item called" <+> quotes datacon+          , text "is exported, but it is a data constructor of"+          , quotes dataType <> dot+          ]+          where+            datacon_occ = rdrNameOcc $ ieName ie+            datacon = parenSymOcc datacon_occ (ppr datacon_occ)+            dataType = parenSymOcc dataType_occ (ppr dataType_occ)+  ImportLookupQualified rdr ->+    hang (text "Illegal qualified name in import item:")+       2 (ppr rdr)+  ImportLookupIllegal ->+    text "Illegal import item"+  ImportLookupAmbiguous rdr gres ->+    hang (text "Ambiguous name" <+> quotes (ppr rdr) <+> text "in import item. It could refer to:")+       2 (vcat (map (ppr . greOccName) gres))++pprUnusedImport :: ImportDecl GhcRn -> UnusedImportReason -> SDoc+pprUnusedImport decl = \case+  UnusedImportNone ->+    vcat [ pp_herald <+> quotes pp_mod <+> text "is redundant"+         , nest 2 (text "except perhaps to import instances from"+                   <+> quotes pp_mod)+         , text "To import instances alone, use:"+           <+> text "import" <+> pp_mod <> parens empty ]+  UnusedImportSome sort_unused ->+    sep [ pp_herald <+> quotes (pprWithCommas pp_unused sort_unused)+        , text "from module" <+> quotes pp_mod <+> text "is redundant"]+  where+    pp_mod = ppr (unLoc (ideclName decl))+    pp_herald = text "The" <+> pp_qual <+> text "import of"+    pp_qual+      | isImportDeclQualified (ideclQualified decl) = text "qualified"+      | otherwise                                   = empty+    pp_unused = \case+      UnusedImportNameRegular n ->+        pprNameUnqualified n+      UnusedImportNameRecField par fld_occ ->+        case par of+          ParentIs p -> pprNameUnqualified p <> parens (ppr fld_occ)+          NoParent   -> ppr fld_occ++pprUnusedName :: OccName -> UnusedNameProv -> SDoc+pprUnusedName name reason =+  sep [ msg <> colon+      , nest 2 $ pprNonVarNameSpace (occNameSpace name)+                 <+> quotes (ppr name)]+  where+    msg = case reason of+      UnusedNameTopDecl ->+        defined+      UnusedNameImported mod ->+        text "Imported from" <+> quotes (ppr mod) <+> text "but not used"+      UnusedNameTypePattern ->+        defined <+> text "on the right hand side"+      UnusedNameMatch ->+        defined+      UnusedNameLocalBind ->+        defined+    defined = text "Defined but not used"++-- When printing the name, take care to qualify it in the same+-- way as the provenance reported by pprNameProvenance, namely+-- the head of 'gre_imp'.  Otherwise we get confusing reports like+--   Ambiguous occurrence ‘null’+--   It could refer to either ‘T15487a.null’,+--                            imported from ‘Prelude’ at T15487.hs:1:8-13+--                     or ...+-- See #15487+pprAmbiguousGreName :: GlobalRdrEnv -> GlobalRdrElt -> SDoc+pprAmbiguousGreName gre_env gre+  | IAmRecField fld_info <- greInfo gre+  = sep [ text "the field" <+> quotes (ppr occ) <+> parent_info fld_info <> comma+        , pprNameProvenance gre ]+  | otherwise+  = sep [ quotes (pp_qual <> dot <> ppr occ) <> comma+        , pprNameProvenance gre ]++  where+    occ = greOccName gre+    parent_info fld_info =+      case first_con of+        PatSynName  ps -> text "of pattern synonym" <+> quotes (ppr ps)+        DataConName {} ->+          case greParent gre of+            ParentIs par+              -- For a data family, only reporting the family TyCon can be+              -- unhelpful (see T23301). So we give a bit of additional+              -- info in that case.+              | Just par_gre <- lookupGRE_Name gre_env par+              , IAmTyCon tc_flav <- greInfo par_gre+              , OpenFamilyFlavour (IAmData {}) _ <- tc_flav+              -> vcat [ ppr_cons+                      , text "in a data family instance of" <+> quotes (ppr par) ]+              | otherwise+              -> text "of record" <+> quotes (ppr par)+            NoParent -> ppr_cons+      where+        cons :: [ConLikeName]+        cons = nonDetEltsUniqSet $ recFieldCons fld_info+        first_con :: ConLikeName+        first_con = head cons+        ppr_cons :: SDoc+        ppr_cons = hsep [ text "belonging to data constructor"+                        , quotes (ppr $ nameOccName $ conLikeName_Name first_con)+                        , if length cons > 1 then parens (text "among others") else empty+                        ]+    pp_qual+        | gre_lcl gre+        = ppr (nameModule $ greName gre)+        | Just imp  <- headMaybe $ gre_imp gre+            -- This 'imp' is the one that+            -- pprNameProvenance chooses+        , ImpDeclSpec { is_as = mod } <- is_decl imp+        = ppr mod+        | otherwise+        = pprPanic "addNameClassErrRn" (ppr gre)+          -- Invariant: either 'lcl' is True or 'iss' is non-empty++pprNonCanonicalDefinition :: LHsSigType GhcRn+                          -> NonCanonicalDefinition+                          -> SDoc+pprNonCanonicalDefinition inst_ty = \case+  NonCanonicalMonoid sub -> case sub of+    NonCanonical_Sappend ->+      msg1 "(<>)" "mappend"+    NonCanonical_Mappend ->+      msg2 "mappend" "(<>)"+  NonCanonicalMonad sub -> case sub of+    NonCanonical_Pure ->+      msg1 "pure" "return"+    NonCanonical_ThenA ->+      msg1 "(*>)" "(>>)"+    NonCanonical_Return ->+      msg2 "return" "pure"+    NonCanonical_ThenM ->+      msg2 "(>>)" "(*>)"+  where+    msg1 :: String -> String -> SDoc+    msg1 lhs rhs =+      vcat [ text "Noncanonical" <+>+            quotes (text (lhs ++ " = " ++ rhs)) <+>+            text "definition detected"+          , inst+          ]++    msg2 :: String -> String -> SDoc+    msg2 lhs rhs =+      vcat [ text "Noncanonical" <+>+            quotes (text lhs) <+>+            text "definition detected"+          , inst+          , quotes (text lhs) <+>+            text "will eventually be removed in favour of" <+>+            quotes (text rhs)+          ]++    inst = instDeclCtxt1 inst_ty++    -- stolen from GHC.Tc.TyCl.Instance+    instDeclCtxt1 :: LHsSigType GhcRn -> SDoc+    instDeclCtxt1 hs_inst_ty+      = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))++    inst_decl_ctxt :: SDoc -> SDoc+    inst_decl_ctxt doc = hang (text "in the instance declaration for")+                         2 (quotes doc <> text ".")++suggestNonCanonicalDefinition :: NonCanonicalDefinition -> [GhcHint]+suggestNonCanonicalDefinition reason =+  [action doc]+  where+    action = case reason of+      NonCanonicalMonoid sub -> case sub of+        NonCanonical_Sappend -> move sappendName mappendName+        NonCanonical_Mappend -> remove mappendName sappendName+      NonCanonicalMonad sub -> case sub of+        NonCanonical_Pure -> move pureAName returnMName+        NonCanonical_ThenA -> move thenAName thenMName+        NonCanonical_Return -> remove returnMName pureAName+        NonCanonical_ThenM -> remove thenMName thenAName++    move = SuggestMoveNonCanonicalDefinition+    remove = SuggestRemoveNonCanonicalDefinition++    doc = case reason of+      NonCanonicalMonoid _ -> doc_monoid+      NonCanonicalMonad _ -> doc_monad++    doc_monoid =+      "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid"+    doc_monad =+      "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return"++suggestDefaultDeclaration :: Class-> [Type] -> [[Type]] -> [GhcHint]+suggestDefaultDeclaration cls prefix seqs =+  [SuggestDefaultDeclaration cls $ supersequence (prefix : seqs)]+  where+    -- Not exactly the shortest possible supersequence, but it preserves+    -- the head sequence as the prefix of the result which is a requirement.+    supersequence :: [[Type]] -> [Type]+    supersequence [] = []+    supersequence ([] : seqs) = supersequence seqs+    supersequence ((x : xs) : seqs) =+      x : supersequence (xs : (dropHead x <$> seqs))+    dropHead x ys@(y : ys')+      | tcEqType x y = ys'+      | otherwise = ys+    dropHead _ [] = []++--------------------------------------------------------------------------------+-- hs-boot mismatch errors++pprBootMismatch :: HsBootOrSig -> BootMismatch -> SDoc+pprBootMismatch boot_or_sig = \case+  MissingBootThing nm err ->+    let def_or_exp = case err of+          MissingBootDefinition -> text "defined in"+          MissingBootExport     -> text "exported by"+    in quotes (ppr nm) <+> text "is exported by the"+       <+> ppr_boot_or_sig <> comma+       <+> text "but not"+       <+> def_or_exp <+> text "the implementing module."+  MissingBootInstance boot_dfun ->+    hang (text "instance" <+> ppr (idType boot_dfun))+       2 (text "is defined in the" <+> ppr ppr_boot_or_sig <> comma <+>+          text "but not in the implementing module.")+  BadReexportedBootThing name name' ->+    withUserStyle alwaysQualify AllTheWay $ vcat+        [ text "The" <+> ppr_boot_or_sig+           <+> text "(re)exports" <+> quotes (ppr name)+        , text "but the implementing module exports a different identifier" <+> quotes (ppr name')+        ]+  BootMismatch boot_thing real_thing err ->+    vcat+      [ ppr real_thing <+>+        text "has conflicting definitions in the module"+      , text "and its" <+> ppr_boot_or_sig <> dot,+                    text "Main module:" <+> real_doc+      , (case boot_or_sig of+          HsBoot -> text "  Boot file:"+          Hsig   -> text "  Hsig file:") <+> boot_doc+      , pprBootMismatchWhat boot_or_sig err+      ]+      where+        to_doc+          = pprTyThingInContext $+            showToHeader+              { ss_forall =+                  case boot_or_sig of+                    HsBoot -> ShowForAllMust+                    Hsig   -> ShowForAllWhen }++        real_doc = to_doc real_thing+        boot_doc = to_doc boot_thing++  where+    ppr_boot_or_sig = case boot_or_sig of+      HsBoot -> text "hs-boot file"+      Hsig   -> text "hsig file"+++pprBootMismatchWhat :: HsBootOrSig -> BootMismatchWhat -> SDoc+pprBootMismatchWhat boot_or_sig = \case+  BootMismatchedIdTypes {} ->+    text "The two types are different."+  BootMismatchedTyCons tc1 tc2 errs ->+    vcat $ map (pprBootTyConMismatch boot_or_sig tc1 tc2) (NE.toList errs)++pprBootTyConMismatch :: HsBootOrSig -> TyCon -> TyCon+                     -> BootTyConMismatch -> SDoc+pprBootTyConMismatch boot_or_sig tc1 tc2 = \case+  TyConKindMismatch ->+    text "The types have different kinds."+  TyConRoleMismatch sub_type ->+    if sub_type+    then+      text "The roles are not compatible:" $$+      text "Main module:" <+> ppr (tyConRoles tc1) $$+      text "  Hsig file:" <+> ppr (tyConRoles tc2)+    else+      text "The roles do not match." $$+      if boot_or_sig == HsBoot+      then note $ "Roles on abstract types default to" <+> quotes "representational" <+> "in hs-boot files"+      else empty+  TyConSynonymMismatch {} -> empty -- nothing interesting to say+  TyConFlavourMismatch fam_flav1 fam_flav2 ->+    whenPprDebug $+      text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+>+      text "do not match"+  TyConAxiomMismatch ax_errs ->+    pprBootListMismatches (text "Type family equations do not match:")+      pprTyConAxiomMismatch ax_errs+  TyConInjectivityMismatch {} ->+    text "Injectivity annotations do not match"+  TyConMismatchedClasses _ _ err ->+    pprBootClassMismatch boot_or_sig err+  TyConMismatchedData _rhs1 _rhs2 err ->+    pprBootDataMismatch err+  SynAbstractData err ->+    pprSynAbstractDataError err+  TyConsVeryDifferent ->+    empty -- should be obvious to the user what the problem is++pprSynAbstractDataError :: SynAbstractDataError -> SDoc+pprSynAbstractDataError = \case+  SynAbsDataTySynNotNullary ->+    text "Illegal parameterized type synonym in implementation of abstract data."+  SynAbstractDataInvalidRHS bad_sub_tys ->+    let msgs = mapMaybe pprInvalidAbstractSubTy (NE.toList bad_sub_tys)+    in  case msgs of+      []     -> herald <> dot+      msg:[] -> hang (herald <> colon)+                   2 msg+      _      -> hang (herald <> colon)+                   2 (vcat $ map (<+> bullet) msgs)++  where+    herald = text "Illegal implementation of abstract data"+    pprInvalidAbstractSubTy = \case+      TyConApp tc _+        -> assertPpr (isTypeFamilyTyCon tc) (ppr tc) $+           Just $ text "Invalid type family" <+> quotes (ppr tc) <> dot+      ty@(ForAllTy {})+        -> Just $ text "Invalid polymorphic type" <> colon <+> ppr ty <> dot+      ty@(FunTy af _ _ _)+        | not (af == FTF_T_T)+        -> Just $ text "Invalid qualified type" <> colon <+> ppr ty <> dot+      _ -> Nothing++pprTyConAxiomMismatch :: BootListMismatch CoAxBranch BootAxiomBranchMismatch -> SDoc+pprTyConAxiomMismatch = \case+  MismatchedLength ->+    text "The number of equations differs."+  MismatchedThing i br1 br2 err ->+    hang (text "The" <+> speakNth (i+1) <+> text "equations do not match.")+       2 (pprCoAxBranchMismatch br1 br2 err)++pprCoAxBranchMismatch :: CoAxBranch -> CoAxBranch -> BootAxiomBranchMismatch -> SDoc+pprCoAxBranchMismatch _br1 _br2 err =+  text "The" <+> what <+> text "don't match."+  where+    what = case err of+      MismatchedAxiomBinders -> text "variables bound in the equation"+      MismatchedAxiomLHS     -> text "equation left-hand sides"+      MismatchedAxiomRHS     -> text "equation right-hand sides"++pprBootListMismatches :: SDoc -- ^ herald+                      -> (BootListMismatch item err -> SDoc)+                      -> BootListMismatches item err -> SDoc+pprBootListMismatches herald ppr_one errs =+  hang herald 2 msgs+  where+    msgs = case errs of+      err :| [] -> ppr_one err+      _         -> vcat $ map ((bullet <+>) . ppr_one) $ NE.toList errs++pprBootClassMismatch :: HsBootOrSig -> BootClassMismatch -> SDoc+pprBootClassMismatch boot_or_sig = \case+  MismatchedMethods errs ->+    pprBootListMismatches (text "The class methods do not match:")+      pprBootClassMethodListMismatch errs+  MismatchedATs at_errs ->+    pprBootListMismatches (text "The associated types do not match:")+      (pprATMismatch boot_or_sig) at_errs+  MismatchedFunDeps ->+    text "The functional dependencies do not match."+  MismatchedSuperclasses ->+    text "The superclass constraints do not match."+  MismatchedMinimalPragmas ->+    text "The MINIMAL pragmas are not compatible."++pprATMismatch :: HsBootOrSig -> BootListMismatch ClassATItem BootATMismatch -> SDoc+pprATMismatch boot_or_sig = \case+  MismatchedLength ->+    text "The number of associated type defaults differs."+  MismatchedThing i at1 at2 err ->+    pprATMismatchErr boot_or_sig i at1 at2 err++pprATMismatchErr :: HsBootOrSig -> Int -> ClassATItem -> ClassATItem -> BootATMismatch -> SDoc+pprATMismatchErr boot_or_sig i (ATI tc1 _) (ATI tc2 _) = \case+  MismatchedTyConAT err ->+    hang (text "The associated types differ:")+       2 $ pprBootTyConMismatch boot_or_sig tc1 tc2 err+  MismatchedATDefaultType ->+    text "The types of the" <+> speakNth (i+1) <+>+    text "associated type default differ."++pprBootClassMethodListMismatch :: BootListMismatch ClassOpItem BootMethodMismatch -> SDoc+pprBootClassMethodListMismatch = \case+  MismatchedLength ->+    text "The number of class methods differs."+  MismatchedThing _ op1 op2 err ->+    pprBootClassMethodMismatch op1 op2 err++pprBootClassMethodMismatch :: ClassOpItem -> ClassOpItem -> BootMethodMismatch -> SDoc+pprBootClassMethodMismatch (op1, _) (op2, _) = \case+  MismatchedMethodNames ->+    text "The method names" <+> quotes pname1 <+> text "and"+                            <+> quotes pname2 <+> text "differ."+  MismatchedMethodTypes {} ->+    text "The types of" <+> pname1 <+> text "are different."+  MismatchedDefaultMethods subtype_check ->+    if subtype_check+    then+      text "The default methods associated with" <+> pname1 <+>+      text "are not compatible."+    else+      text "The default methods associated with" <+> pname1 <+>+      text "are different."+  where+    nm1 = idName op1+    nm2 = idName op2+    pname1 = quotes (ppr nm1)+    pname2 = quotes (ppr nm2)++pprBootDataMismatch :: BootDataMismatch -> SDoc+pprBootDataMismatch = \case+  MismatchedNewtypeVsData ->+    text "Cannot match a" <+> quotes (text "data") <+>+    text "definition with a" <+> quotes (text "newtype") <+>+    text "definition."+  MismatchedConstructors dc_errs ->+    pprBootListMismatches (text "The constructors do not match:")+      pprBootDataConMismatch dc_errs+  MismatchedDatatypeContexts {} ->+    text "The datatype contexts do not match."++pprBootDataConMismatch :: BootListMismatch DataCon BootDataConMismatch+                       -> SDoc+pprBootDataConMismatch = \case+  MismatchedLength ->+    text "The number of constructors differs."+  MismatchedThing _ dc1 dc2 err ->+    pprBootDataConMismatchErr dc1 dc2 err++pprBootDataConMismatchErr :: DataCon -> DataCon -> BootDataConMismatch -> SDoc+pprBootDataConMismatchErr dc1 dc2 = \case+  MismatchedDataConNames ->+    text "The names" <+> pname1 <+> text "and" <+> pname2 <+> text "differ."+  MismatchedDataConFixities ->+    text "The fixities of" <+> pname1 <+> text "differ."+  MismatchedDataConBangs ->+    text "The strictness annotations for" <+> pname1 <+> text "differ."+  MismatchedDataConFieldLabels ->+    text "The record label lists for" <+> pname1 <+> text "differ."+  MismatchedDataConTypes ->+    text "The types for" <+> pname1 <+> text "differ."+  where+     name1 = dataConName dc1+     name2 = dataConName dc2+     pname1 = quotes (ppr name1)+     pname2 = quotes (ppr name2)++--------------------------------------------------------------------------------+-- Illegal instance errors++pprIllegalInstance :: IllegalInstanceReason -> SDoc+pprIllegalInstance = \case+  IllegalClassInstance head_ty reason ->+    pprIllegalClassInstanceReason head_ty reason+  IllegalFamilyInstance reason ->+    pprIllegalFamilyInstance reason+  IllegalFamilyApplicationInInstance inst_ty invis_arg tf_tc tf_args ->+    pprWithInvisibleBitsWhen invis_arg $+      hang (text "Illegal type synonym family application"+              <+> quotes (ppr tf_ty) <+> text "in instance" <> colon)+         2 (ppr inst_ty)+      where+        tf_ty = mkTyConApp tf_tc tf_args++pprIllegalClassInstanceReason :: TypedThing -> IllegalClassInstanceReason -> SDoc+pprIllegalClassInstanceReason head_ty = \case+  IllegalInstanceHead reason ->+    pprIllegalInstanceHeadReason head_ty reason+  IllegalHasFieldInstance has_field_err ->+    with_illegal_instance_header head_ty $+      pprIllegalHasFieldInstance has_field_err+  IllegalSpecialClassInstance cls because_safeHaskell ->+    text "Class" <+> quotes (ppr $ className cls)+    <+> text "does not support user-specified instances"+    <> safeHaskell_msg+      where+        safeHaskell_msg+          | because_safeHaskell+          = text " when Safe Haskell is enabled."+          | otherwise+          = dot+  IllegalInstanceFailsCoverageCondition cls coverage_failure ->+    with_illegal_instance_header head_ty $+      pprNotCovered cls coverage_failure++pprIllegalInstanceHeadReason :: TypedThing+                             -> IllegalInstanceHeadReason -> SDoc+pprIllegalInstanceHeadReason head_ty = \case+  InstHeadTySynArgs -> with_illegal_instance_header head_ty $+    text "All instance types must be of the form (T t1 ... tn)" $$+    text "where T is not a synonym."+  InstHeadNonTyVarArgs -> with_illegal_instance_header head_ty $ vcat [+    text "All instance types must be of the form (T a1 ... an)",+    text "where a1 ... an are *distinct type variables*,",+    text "and each type variable appears at most once in the instance head."]+  InstHeadMultiParam -> with_illegal_instance_header head_ty $ parens $+    text "Only one type can be given in an instance head."+  InstHeadAbstractClass cls ->+    text "Cannot define instance for abstract class" <+>+    quotes (ppr cls)+  InstHeadNonClassHead bad_head ->+    vcat [ text "Illegal" <+> what_illegal <> dot+         , text "Instance heads must be of the form"+         , nest 2 $ text "C ty_1 ... ty_n"+         , text "where" <+> quotes (char 'C') <+> text "is a class."+         ]+    where+      what_illegal = case bad_head of+        InstNonClassTyCon tc_nm flav ->+          text "instance for" <+> ppr flav <+> quotes (ppr tc_nm)+        InstNonTyCon ->+          text "head of an instance declaration:" <+> quotes (ppr head_ty)++with_illegal_instance_header :: TypedThing -> SDoc -> SDoc+with_illegal_instance_header head_ty msg =+  hang (hang (text "Illegal instance declaration for")+           2 (quotes (ppr head_ty)) <> colon)+      2 msg++pprIllegalHasFieldInstance :: IllegalHasFieldInstance -> SDoc+pprIllegalHasFieldInstance = \case+  IllegalHasFieldInstanceNotATyCon+    -> text "Record data type must be specified."+  IllegalHasFieldInstanceFamilyTyCon+    -> text "Record data type may not be a data family."+  IllegalHasFieldInstanceTyConHasField tc lbl+    -> quotes (ppr tc) <+> text "already has a field" <+> quotes (ppr lbl) <> dot+  IllegalHasFieldInstanceTyConHasFields tc lbl+    -> sep [ ppr_tc <+> text "has fields, and the type" <+> quotes (ppr lbl)+           , text "could unify with one of the field labels of" <+> ppr_tc <> dot ]+    where ppr_tc = quotes (ppr tc)++pprNotCovered :: Class -> CoverageProblem -> SDoc+pprNotCovered clas+  CoverageProblem+  { not_covered_fundep        = fd+  , not_covered_fundep_inst   = (ls, rs)+  , not_covered_invis_vis_tvs = undetermined_tvs+  , not_covered_liberal       = which_cc_failed+  } =+  pprWithInvisibleBitsWhen (isEmptyVarSet $ pSnd undetermined_tvs) $+    vcat [ sep [ text "The"+                  <+> ppWhen liberal (text "liberal")+                  <+> text "coverage condition fails in class"+                  <+> quotes (ppr clas)+                , nest 2 $ text "for functional dependency:"+                  <+> quotes (pprFunDep fd) ]+          , sep [ text "Reason: lhs type" <> plural ls <+> pprQuotedList ls+                , nest 2 $+                  (if isSingleton ls+                  then text "does not"+                  else text "do not jointly")+                  <+> text "determine rhs type" <> plural rs+                  <+> pprQuotedList rs ]+          , text "Un-determined variable" <> pluralVarSet undet_set <> colon+                  <+> pprVarSet undet_set (pprWithCommas ppr)+          ]+  where+    liberal = case which_cc_failed of+                   FailedLICC   -> True+                   FailedICC {} -> False+    undet_set = fold undetermined_tvs++illegalInstanceHints :: IllegalInstanceReason -> [GhcHint]+illegalInstanceHints = \case+  IllegalClassInstance _ reason ->+    illegalClassInstanceHints reason+  IllegalFamilyInstance reason ->+    illegalFamilyInstanceHints reason+  IllegalFamilyApplicationInInstance {} ->+    noHints++illegalInstanceReason :: IllegalInstanceReason -> DiagnosticReason+illegalInstanceReason = \case+  IllegalClassInstance _ reason ->+    illegalClassInstanceReason reason+  IllegalFamilyInstance reason ->+    illegalFamilyInstanceReason reason+  IllegalFamilyApplicationInInstance {} ->+    ErrorWithoutFlag++illegalClassInstanceHints :: IllegalClassInstanceReason -> [GhcHint]+illegalClassInstanceHints = \case+  IllegalInstanceHead reason ->+    illegalInstanceHeadHints reason+  IllegalHasFieldInstance has_field_err ->+    illegalHasFieldInstanceHints has_field_err+  IllegalSpecialClassInstance {} -> noHints+  IllegalInstanceFailsCoverageCondition _ coverage_failure ->+    failedCoverageConditionHints coverage_failure+++illegalClassInstanceReason :: IllegalClassInstanceReason -> DiagnosticReason+illegalClassInstanceReason = \case+  IllegalInstanceHead reason ->+    illegalInstanceHeadReason reason+  IllegalHasFieldInstance has_field_err ->+    illegalHasFieldInstanceReason has_field_err+  IllegalSpecialClassInstance {} -> ErrorWithoutFlag+  IllegalInstanceFailsCoverageCondition _ coverage_failure ->+    failedCoverageConditionReason coverage_failure++illegalInstanceHeadHints :: IllegalInstanceHeadReason -> [GhcHint]+illegalInstanceHeadHints = \case+  InstHeadTySynArgs ->+    [suggestExtension LangExt.TypeSynonymInstances]+  InstHeadNonTyVarArgs ->+    [suggestExtension LangExt.FlexibleInstances]+  InstHeadMultiParam ->+    [suggestExtension LangExt.MultiParamTypeClasses]+  InstHeadAbstractClass {} ->+    noHints+  InstHeadNonClassHead {} ->+    noHints++illegalInstanceHeadReason :: IllegalInstanceHeadReason -> DiagnosticReason+illegalInstanceHeadReason = \case+  -- These are serious+  InstHeadAbstractClass {} ->+    ErrorWithoutFlag+  InstHeadNonClassHead {} ->+    ErrorWithoutFlag++  -- These are less serious (enable an extension)+  InstHeadTySynArgs ->+    ErrorWithoutFlag+  InstHeadNonTyVarArgs ->+    ErrorWithoutFlag+  InstHeadMultiParam ->+    ErrorWithoutFlag++illegalHasFieldInstanceHints :: IllegalHasFieldInstance -> [GhcHint]+illegalHasFieldInstanceHints = \case+  IllegalHasFieldInstanceNotATyCon+    -> noHints+  IllegalHasFieldInstanceFamilyTyCon+    -> noHints+  IllegalHasFieldInstanceTyConHasField {}+    -> noHints+  IllegalHasFieldInstanceTyConHasFields {}+    -> noHints++illegalHasFieldInstanceReason :: IllegalHasFieldInstance -> DiagnosticReason+illegalHasFieldInstanceReason = \case+  IllegalHasFieldInstanceNotATyCon+    -> ErrorWithoutFlag+  IllegalHasFieldInstanceFamilyTyCon+    -> ErrorWithoutFlag+  IllegalHasFieldInstanceTyConHasField {}+    -> ErrorWithoutFlag+  IllegalHasFieldInstanceTyConHasFields {}+    -> ErrorWithoutFlag++failedCoverageConditionHints :: CoverageProblem -> [GhcHint]+failedCoverageConditionHints (CoverageProblem { not_covered_liberal = failed_cc })+  = case failed_cc of+      FailedLICC -> noHints+      FailedICC { alsoFailedLICC = failed_licc } ->+        -- Turning on UndecidableInstances makes the check liberal,+        -- so if the liberal check passes, suggest enabling UndecidableInstances.+        if failed_licc+        then noHints+        else [suggestExtension LangExt.UndecidableInstances]++failedCoverageConditionReason :: CoverageProblem -> DiagnosticReason+failedCoverageConditionReason _ = ErrorWithoutFlag++pprIllegalFamilyInstance :: IllegalFamilyInstanceReason -> SDoc+pprIllegalFamilyInstance = \case+  InvalidAssoc reason -> pprInvalidAssoc reason+  NotAFamilyTyCon ty_or_data tc ->+    vcat [ text "Illegal family instance for" <+> quotes (ppr tc)+         , nest 2 $ parens (quotes (ppr tc) <+> text "is not a" <+> what) ]+    where+      what = ppr ty_or_data <+> text "family"+  NotAnOpenFamilyTyCon tc ->+    text "Illegal instance for closed family" <+> quotes (ppr tc)+  FamilyCategoryMismatch tc ->+    text "Wrong category of family instance; declaration was for a" <+> what <> dot+    where+      what = case tyConFlavour tc of+        OpenFamilyFlavour (IAmData {}) _ -> text "data family"+        _                                -> text "type family"+  FamilyArityMismatch _ max_args ->+    text "Number of parameters must match family declaration; expected"+    <+> ppr max_args <> dot+  TyFamNameMismatch fam_tc_name eqn_tc_name ->+    hang (text "Mismatched type name in type family instance.")+       2 (vcat [ text "Expected:" <+> ppr fam_tc_name+               , text "  Actual:" <+> ppr eqn_tc_name ])+  FamInstRHSOutOfScopeTyVars mb_dodgy (NE.toList -> tvs) ->+    hang (text "Out of scope type variable" <> plural tvs+         <+> pprWithCommas (quotes . ppr) tvs+         <+> text "in the RHS of a family instance.")+       2 (text "All such variables must be bound on the LHS.")+    $$ mk_extra+    where+    -- mk_extra: #7536: give a decent error message for+    --         type T a = Int+    --         type instance F (T a) = a+    mk_extra = case mb_dodgy of+      Nothing -> empty+      Just (fam_tc, pats, dodgy_tvs) ->+        ppWhen (any (`elemVarSetByKey` dodgy_tvs) (fmap nameUnique tvs)) $+          hang (text "The real LHS (expanding synonyms) is:")+             2 (pprTypeApp fam_tc (map expandTypeSynonyms pats))+  FamInstLHSUnusedBoundTyVars (NE.toList -> bad_qtvs) ->+    vcat [ not_bound_msg, not_used_msg, dodgy_msg ]+    where++      -- Filter to only keep user-written variables,+      -- unless none were user-written in which case we report all of them+      -- (as we need to report an error).+      filter_user tvs+        = map ifiqtv+        $ case filter ifiqtv_user_written tvs of { [] -> tvs ; qvs -> qvs }++      (not_bound, not_used, dodgy)+        = case foldr acc_tv ([], [], []) bad_qtvs of+            (nb, nu, d) -> (filter_user nb, filter_user nu, filter_user d)++      acc_tv tv (nb, nu, d) = case ifiqtv_reason tv of+        InvalidFamInstQTvNotUsedInRHS   -> (nb, tv : nu, d)+        InvalidFamInstQTvNotBoundInPats -> (tv : nb, nu, d)+        InvalidFamInstQTvDodgy          -> (nb, nu, tv : d)++      -- Error message for type variables not bound in LHS patterns.+      not_bound_msg+        | null not_bound+        = empty+        | otherwise+        = vcat [ text "The type variable" <> plural not_bound <+> pprQuotedList not_bound+            <+> isOrAre not_bound <+> text "bound by a forall,"+              , text "but" <+> doOrDoes not_bound <+> text "not appear in any of the LHS patterns of the family instance." ]++      -- Error message for type variables bound by a forall but not used+      -- in the RHS.+      not_used_msg =+        if null not_used+        then empty+        else text "The type variable" <> plural not_used <+> pprQuotedList not_used+             <+> isOrAre not_used <+> text "bound by a forall," $$+             text "but" <+> itOrThey not_used <+>+             isOrAre not_used <> text "n't used in the family instance."++      -- Error message for dodgy type variables.+      -- See Note [Dodgy binding sites in type family instances] in GHC.Tc.Validity.+      dodgy_msg+        | null dodgy+        = empty+        | otherwise+        = hang (text "Dodgy type variable" <> plural dodgy <+> pprQuotedList dodgy+               <+> text "in the LHS of a family instance:")+             2 (text "the type variable" <> plural dodgy <+> pprQuotedList dodgy+                <+> text "syntactically appear" <> singular dodgy <+> text "in LHS patterns,"+               $$ text "but" <+> itOrThey dodgy <+> doOrDoes dodgy <> text "n't appear in an injective position.")+++illegalFamilyInstanceHints :: IllegalFamilyInstanceReason -> [GhcHint]+illegalFamilyInstanceHints = \case+  InvalidAssoc rea -> invalidAssocHints rea+  NotAFamilyTyCon {} -> noHints+  NotAnOpenFamilyTyCon {} -> noHints+  FamilyCategoryMismatch {} -> noHints+  FamilyArityMismatch {} -> noHints+  TyFamNameMismatch {} -> noHints+  FamInstRHSOutOfScopeTyVars {} -> noHints+  FamInstLHSUnusedBoundTyVars {} -> noHints++illegalFamilyInstanceReason :: IllegalFamilyInstanceReason -> DiagnosticReason+illegalFamilyInstanceReason = \case+  InvalidAssoc rea -> invalidAssocReason rea+  NotAFamilyTyCon {} -> ErrorWithoutFlag+  NotAnOpenFamilyTyCon {} -> ErrorWithoutFlag+  FamilyCategoryMismatch {} -> ErrorWithoutFlag+  FamilyArityMismatch {} -> ErrorWithoutFlag+  TyFamNameMismatch {} -> ErrorWithoutFlag+  FamInstRHSOutOfScopeTyVars {} -> ErrorWithoutFlag+  FamInstLHSUnusedBoundTyVars {} -> ErrorWithoutFlag++pprInvalidAssoc :: InvalidAssoc -> SDoc+pprInvalidAssoc = \case+  InvalidAssocInstance rea -> pprInvalidAssocInstance rea+  InvalidAssocDefault  rea -> pprInvalidAssocDefault  rea++pprInvalidAssocInstance :: InvalidAssocInstance -> SDoc+pprInvalidAssocInstance = \case+  AssocInstanceMissing name ->+    text "No explicit" <+> text "associated type"+    <+> text "or default declaration for"+    <+> quotes (ppr name)+  AssocInstanceNotInAClass fam_tc ->+    text "Associated type" <+> quotes (ppr fam_tc) <+>+    text "must be inside a class instance"+  AssocNotInThisClass cls fam_tc ->+    hsep [ text "Class", quotes (ppr cls)+         , text "does not have an associated type", quotes (ppr fam_tc) ]+  AssocNoClassTyVar cls fam_tc ->+    sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc)))+        , text "mentions none of the type or kind variables of the class" <+>+                quotes (ppr cls <+> hsep (map ppr (classTyVars cls)))]+  AssocTyVarsDontMatch vis fam_tc exp_tys act_tys ->+    pprWithInvisibleBitsWhen (isInvisibleForAllTyFlag vis) $+    vcat [ text "Type indexes must match class instance head"+         , text "Expected:" <+> pp exp_tys+         , text "  Actual:" <+> pp act_tys ]+    where+      pp tys = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $+               toIfaceTcArgs fam_tc tys++pprInvalidAssocDefault :: InvalidAssocDefault -> SDoc+pprInvalidAssocDefault = \case+  AssocDefaultNotAssoc cls tc ->+    hsep [ text "Class", quotes (ppr cls)+         , text "does not have an associated type", quotes (ppr tc) ]+  AssocMultipleDefaults name ->+      text "More than one default declaration for" <+> quotes (ppr name)+  AssocDefaultBadArgs fam_tc pat_tys bad_arg ->+    let (pat_vis, main_msg) = case bad_arg of+          AssocDefaultNonTyVarArg (pat_ty, pat_vis) ->+            (pat_vis,+             text "Illegal argument" <+> quotes (ppr pat_ty) <+> text "in:")+          AssocDefaultDuplicateTyVars dups ->+            let (pat_tv, pat_vis) = NE.head dups+            in (pat_vis,+                text "Illegal duplicate variable" <+> quotes (ppr pat_tv) <+> text "in:")+    in pprWithInvisibleBitsWhen (isInvisibleForAllTyFlag pat_vis) $+         hang main_msg+            2 (vcat [ppr_eqn, suggestion])+    where+      ppr_eqn :: SDoc+      ppr_eqn =+        quotes (text "type" <+> ppr (mkTyConApp fam_tc pat_tys)+                <+> equals <+> text "...")++      suggestion :: SDoc+      suggestion = text "The arguments to" <+> quotes (ppr fam_tc)+               <+> text "must all be distinct type variables."++invalidAssocHints :: InvalidAssoc -> [GhcHint]+invalidAssocHints = \case+  InvalidAssocInstance rea -> invalidAssocInstanceHints rea+  InvalidAssocDefault  rea -> invalidAssocDefaultHints  rea++invalidAssocInstanceHints :: InvalidAssocInstance -> [GhcHint]+invalidAssocInstanceHints = \case+  AssocInstanceMissing {} -> noHints+  AssocInstanceNotInAClass {} -> noHints+  AssocNotInThisClass {} -> noHints+  AssocNoClassTyVar {} -> noHints+  AssocTyVarsDontMatch {} -> noHints++invalidAssocDefaultHints :: InvalidAssocDefault -> [GhcHint]+invalidAssocDefaultHints = \case+  AssocDefaultNotAssoc {} -> noHints+  AssocMultipleDefaults {} -> noHints+  AssocDefaultBadArgs _ _ bad ->+    assocDefaultBadArgHints bad++assocDefaultBadArgHints :: AssocDefaultBadArgs -> [GhcHint]+assocDefaultBadArgHints = \case+  AssocDefaultNonTyVarArg {} -> noHints+  AssocDefaultDuplicateTyVars {} -> noHints++invalidAssocReason :: InvalidAssoc -> DiagnosticReason+invalidAssocReason = \case+  InvalidAssocInstance rea -> invalidAssocInstanceReason rea+  InvalidAssocDefault  rea -> invalidAssocDefaultReason  rea++invalidAssocInstanceReason :: InvalidAssocInstance -> DiagnosticReason+invalidAssocInstanceReason = \case+  AssocInstanceMissing {} -> WarningWithFlag (Opt_WarnMissingMethods)+  AssocInstanceNotInAClass {} -> ErrorWithoutFlag+  AssocNotInThisClass {} -> ErrorWithoutFlag+  AssocNoClassTyVar {} -> ErrorWithoutFlag+  AssocTyVarsDontMatch {} -> ErrorWithoutFlag++invalidAssocDefaultReason :: InvalidAssocDefault -> DiagnosticReason+invalidAssocDefaultReason = \case+  AssocDefaultNotAssoc {} -> ErrorWithoutFlag+  AssocMultipleDefaults {} -> ErrorWithoutFlag+  AssocDefaultBadArgs _ _ rea ->+    assocDefaultBadArgReason rea++assocDefaultBadArgReason :: AssocDefaultBadArgs -> DiagnosticReason+assocDefaultBadArgReason = \case+  AssocDefaultNonTyVarArg {} -> ErrorWithoutFlag+  AssocDefaultDuplicateTyVars {} -> ErrorWithoutFlag++--------------------------------------------------------------------------------+-- Template Haskell quotes and splices++pprTHError :: THError -> DecoratedSDoc+pprTHError = \case+  THSyntaxError err -> pprTHSyntaxError err+  THNameError   err -> pprTHNameError   err+  THReifyError  err -> pprTHReifyError  err+  TypedTHError  err -> pprTypedTHError  err+  THSpliceFailed rea -> pprSpliceFailReason rea+  AddTopDeclsError err -> pprAddTopDeclsError err++  IllegalStaticFormInSplice e ->+    mkSimpleDecorated $+      sep [ text "static forms cannot be used in splices:"+          , nest 2 $ ppr e+          ]++  FailedToLookupThInstName th_type reason ->+    mkSimpleDecorated $+    case reason of+      NoMatchesFound ->+        text "Couldn't find any instances of"+          <+> text (TH.pprint th_type)+          <+> text "to add documentation to"+      CouldNotDetermineInstance ->+        text "Couldn't work out what instance"+          <+> text (TH.pprint th_type)+          <+> text "is supposed to be"++  AddInvalidCorePlugin plugin ->+    mkSimpleDecorated $+      hang (text "addCorePlugin: invalid plugin module" <+> quotes (text plugin) )+         2 (text "Plugins in the current package can't be specified.")++  AddDocToNonLocalDefn doc_loc ->+    mkSimpleDecorated $+      text "Can't add documentation to" <+> ppr_loc doc_loc <> comma <+>+      text "as it isn't inside the current module."+      where+        ppr_loc (TH.DeclDoc n) = text $ TH.pprint n+        ppr_loc (TH.ArgDoc n _) = text $ TH.pprint n+        ppr_loc (TH.InstDoc t) = text $ TH.pprint t+        ppr_loc TH.ModuleDoc = text "the module header"++  ReportCustomQuasiError _ msg -> mkSimpleDecorated $ text msg++pprTHSyntaxError :: THSyntaxError -> DecoratedSDoc+pprTHSyntaxError = mkSimpleDecorated . \case+  IllegalTHQuotes expr ->+    text "Syntax error on" <+> ppr expr+      -- The error message context will say+      -- "In the Template Haskell quotation", so no need to repeat that here.+  BadImplicitSplice ->+    sep [ text "Parse error: module header, import declaration"+        , text "or top-level declaration expected." ]+    -- The compiler should not mention TemplateHaskell, as the common case+    -- is that this is a simple beginner error, for example:+    --+    -- module M where+    --   f :: Int -> Int; f x = x+    --   xyzzy+    --   g y = f y + 1+    --+    -- It's unlikely that 'xyzzy' above was intended to be a Template Haskell+    -- splice; instead it's probably something mistakenly left in the code.+    -- See #12146 for discussion.++  IllegalTHSplice ->+    text "Unexpected top-level splice."+  MismatchedSpliceType splice_type inner_splice_or_bracket ->+    inner <+> text "may not appear in" <+> outer <> dot+      where+        (inner, outer) = case inner_splice_or_bracket of+          IsSplice -> case splice_type of+            Typed   -> (text "Typed splices"  , text "untyped brackets")+            Untyped -> (text "Untyped splices", text "typed brackets")+          IsBracket ->+            case splice_type of+            Typed   -> (text "Untyped brackets", text "typed splices")+            Untyped -> (text "Typed brackets"  , text "untyped splices")+  NestedTHBrackets ->+    text "Template Haskell brackets cannot be nested" <+>+    text "(without intervening splices)"++pprTHNameError :: THNameError -> DecoratedSDoc+pprTHNameError = \case+  NonExactName name ->+    mkSimpleDecorated $+      hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.")+         2 (text "Probable cause: you used mkName instead of newName to generate a binding.")++pprTHReifyError :: THReifyError -> DecoratedSDoc+pprTHReifyError = \case+  CannotReifyInstance ty+    -> mkSimpleDecorated $+       hang (text "reifyInstances:" <+> quotes (ppr ty))+          2 (text "is not a class constraint or type family application")+  CannotReifyOutOfScopeThing th_name+    -> mkSimpleDecorated $+       quotes (text (TH.pprint th_name)) <+>+               text "is not in scope at a reify"+             -- Ugh! Rather an indirect way to display the name+  CannotReifyThingNotInTypeEnv name+    -> mkSimpleDecorated $+       quotes (ppr name) <+> text "is not in the type environment at a reify"+  NoRolesAssociatedWithThing thing+    -> mkSimpleDecorated $+       text "No roles associated with" <+> (ppr thing)+  CannotRepresentType sort ty+    -> mkSimpleDecorated $+       hang (text "Can't represent" <+> sort_doc <+> text "in Template Haskell:")+          2 (ppr ty)+     where+       sort_doc = text $+         case sort of+           LinearInvisibleArgument -> "linear invisible argument"+           CoercionsInTypes -> "coercions in types"+           DataConVisibleForall -> "visible forall in the type of a data constructor"++pprTypedTHError :: TypedTHError -> DecoratedSDoc+pprTypedTHError = \case+  SplicePolymorphicLocalVar ident+    -> mkSimpleDecorated $+         text "Can't splice the polymorphic local variable" <+> quotes (ppr ident)+  TypedTHWithPolyType ty+    -> mkSimpleDecorated $+      vcat [ text "Illegal polytype:" <+> ppr ty+           , text "The type of a Typed Template Haskell expression must" <+>+             text "not have any quantification." ]++pprSpliceFailReason :: SpliceFailReason -> DecoratedSDoc+pprSpliceFailReason = \case+  SpliceThrewException phase _exn exn_msg expr show_code ->+    mkSimpleDecorated $+      vcat [ text "Exception when trying to" <+> text phaseStr <+> text "compile-time code:"+           , nest 2 (text exn_msg)+           , if show_code then text "Code:" <+> ppr expr else empty]+    where phaseStr =+            case phase of+              SplicePhase_Run -> "run"+              SplicePhase_CompileAndLink -> "compile and link"+  RunSpliceFailure err -> pprRunSpliceFailure Nothing err++pprAddTopDeclsError :: AddTopDeclsError -> DecoratedSDoc+pprAddTopDeclsError = \case+  InvalidTopDecl _decl ->+    mkSimpleDecorated $+      sep [ text "Only function, value, annotation, and foreign import declarations"+          , text "may be added with" <+> quotes (text "addTopDecls") <> dot ]+  AddTopDeclsUnexpectedDeclarationSplice {} ->+    mkSimpleDecorated $+      text "Declaration splices are not permitted" <+>+      text "inside top-level declarations added with" <+>+      quotes (text "addTopDecls") <> dot+  AddTopDeclsRunSpliceFailure err ->+    pprRunSpliceFailure (Just "addTopDecls") err++pprRunSpliceFailure :: Maybe String -> RunSpliceFailReason -> DecoratedSDoc+pprRunSpliceFailure mb_calling_fn (ConversionFail what reason) =+  mkSimpleDecorated . add_calling_fn . addSpliceInfo $+    pprConversionFailReason reason+  where+    add_calling_fn rest =+      case mb_calling_fn of+        Just calling_fn ->+          hang (text "Error in a declaration passed to" <+> quotes (text calling_fn) <> colon)+             2 rest+        Nothing -> rest+    addSpliceInfo = case what of+      ConvDec  d -> addSliceInfo' "declaration" d+      ConvExp  e -> addSliceInfo' "expression" e+      ConvPat  p -> addSliceInfo' "pattern" p+      ConvType t -> addSliceInfo' "type" t+    addSliceInfo' what item reasonErr = reasonErr $$ descr+      where+            -- Show the item in pretty syntax normally,+            -- but with all its constructors if you say -dppr-debug+        descr = hang (text "When splicing a TH" <+> text what <> colon)+                   2 (getPprDebug $ \case+                       True  -> text (show item)+                       False -> text (TH.pprint item))++thErrorReason :: THError -> DiagnosticReason+thErrorReason = \case+  THSyntaxError err -> thSyntaxErrorReason err+  THNameError   err -> thNameErrorReason   err+  THReifyError  err -> thReifyErrorReason  err+  TypedTHError  err -> typedTHErrorReason  err+  THSpliceFailed rea -> spliceFailedReason rea+  AddTopDeclsError err -> addTopDeclsErrorReason err++  IllegalStaticFormInSplice {} -> ErrorWithoutFlag+  FailedToLookupThInstName {}  -> ErrorWithoutFlag+  AddInvalidCorePlugin {}      -> ErrorWithoutFlag+  AddDocToNonLocalDefn {}      -> ErrorWithoutFlag+  ReportCustomQuasiError is_error _ ->+    if is_error+    then ErrorWithoutFlag+    else WarningWithoutFlag++thSyntaxErrorReason :: THSyntaxError -> DiagnosticReason+thSyntaxErrorReason = \case+  IllegalTHQuotes{}      -> ErrorWithoutFlag+  BadImplicitSplice      -> ErrorWithoutFlag+  IllegalTHSplice{}      -> ErrorWithoutFlag+  NestedTHBrackets{}     -> ErrorWithoutFlag+  MismatchedSpliceType{} -> ErrorWithoutFlag++thNameErrorReason :: THNameError -> DiagnosticReason+thNameErrorReason = \case+  NonExactName {}         -> ErrorWithoutFlag++thReifyErrorReason :: THReifyError -> DiagnosticReason+thReifyErrorReason = \case+  CannotReifyInstance {}          -> ErrorWithoutFlag+  CannotReifyOutOfScopeThing {}   -> ErrorWithoutFlag+  CannotReifyThingNotInTypeEnv {} -> ErrorWithoutFlag+  NoRolesAssociatedWithThing {}   -> ErrorWithoutFlag+  CannotRepresentType {}          -> ErrorWithoutFlag++typedTHErrorReason :: TypedTHError -> DiagnosticReason+typedTHErrorReason = \case+  SplicePolymorphicLocalVar {} -> ErrorWithoutFlag+  TypedTHWithPolyType {}       -> ErrorWithoutFlag++spliceFailedReason :: SpliceFailReason -> DiagnosticReason+spliceFailedReason = \case+  SpliceThrewException {} -> ErrorWithoutFlag+  RunSpliceFailure {}     -> ErrorWithoutFlag++addTopDeclsErrorReason :: AddTopDeclsError -> DiagnosticReason+addTopDeclsErrorReason = \case+  InvalidTopDecl {}+    -> ErrorWithoutFlag+  AddTopDeclsUnexpectedDeclarationSplice {}+    -> ErrorWithoutFlag+  AddTopDeclsRunSpliceFailure {}+    -> ErrorWithoutFlag++thErrorHints :: THError -> [GhcHint]+thErrorHints = \case+  THSyntaxError err -> thSyntaxErrorHints err+  THNameError   err -> thNameErrorHints   err+  THReifyError  err -> thReifyErrorHints  err+  TypedTHError  err -> typedTHErrorHints  err+  THSpliceFailed rea -> spliceFailedHints rea+  AddTopDeclsError err -> addTopDeclsErrorHints err++  IllegalStaticFormInSplice {} -> noHints+  FailedToLookupThInstName {}  -> noHints+  AddInvalidCorePlugin {}      -> noHints+  AddDocToNonLocalDefn {}      -> noHints+  ReportCustomQuasiError {}    -> noHints++thSyntaxErrorHints :: THSyntaxError -> [GhcHint]+thSyntaxErrorHints = \case+  IllegalTHQuotes{}+    -> [suggestExtension LangExt.TemplateHaskellQuotes]+  BadImplicitSplice {}+    -> noHints -- NB: don't suggest TemplateHaskell+               -- see comments on BadImplicitSplice in pprTHSyntaxError+  IllegalTHSplice{}+    -> [suggestExtension LangExt.TemplateHaskell]+  NestedTHBrackets{}+    -> noHints+  MismatchedSpliceType{}+    -> noHints++thNameErrorHints :: THNameError -> [GhcHint]+thNameErrorHints = \case+  NonExactName {}         -> noHints++thReifyErrorHints :: THReifyError -> [GhcHint]+thReifyErrorHints = \case+  CannotReifyInstance {}          -> noHints+  CannotReifyOutOfScopeThing {}   -> noHints+  CannotReifyThingNotInTypeEnv {} -> noHints+  NoRolesAssociatedWithThing {}   -> noHints+  CannotRepresentType {}          -> noHints++typedTHErrorHints :: TypedTHError -> [GhcHint]+typedTHErrorHints = \case+  SplicePolymorphicLocalVar {} -> noHints+  TypedTHWithPolyType {}       -> noHints++spliceFailedHints :: SpliceFailReason -> [GhcHint]+spliceFailedHints = \case+  SpliceThrewException {} -> noHints+  RunSpliceFailure {}     -> noHints++addTopDeclsErrorHints :: AddTopDeclsError -> [GhcHint]+addTopDeclsErrorHints = \case+  InvalidTopDecl {}+    -> noHints+  AddTopDeclsUnexpectedDeclarationSplice {}+    -> noHints+  AddTopDeclsRunSpliceFailure {}+    -> noHints++--------------------------------------------------------------------------------++pprPatersonCondFailure ::+  PatersonCondFailure -> PatersonCondFailureContext -> Type -> Type -> SDoc+pprPatersonCondFailure (PCF_TyVar tvs) InInstanceDecl lhs rhs =+  hang (occMsg tvs)+    2 (sep [ text "in the constraint" <+> quotes (ppr lhs)+         , text "than in the instance head" <+> quotes (ppr rhs) ])+  where+    occMsg tvs = text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs)+                 <+> pp_occurs <+> text "more often"+    pp_occurs | isSingleton tvs = text "occurs"+              | otherwise       = text "occur"+pprPatersonCondFailure (PCF_TyVar tvs) InTyFamEquation lhs rhs =+  hang (occMsg tvs)+    2 (sep [ text "in the type-family application" <+> quotes (ppr rhs)+         , text "than in the LHS of the family instance" <+> quotes (ppr lhs) ])+  where+    occMsg tvs = text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs)+                 <+> pp_occurs <+> text "more often"+    pp_occurs | isSingleton tvs = text "occurs"+              | otherwise       = text "occur"+pprPatersonCondFailure PCF_Size InInstanceDecl lhs rhs =+  hang (text "The constraint" <+> quotes (ppr lhs))+    2 (sep [ text "is no smaller than", pp_rhs ])+  where pp_rhs = text "the instance head" <+> quotes (ppr rhs)+pprPatersonCondFailure PCF_Size InTyFamEquation lhs rhs =+  hang (text "The type-family application" <+> quotes (ppr rhs))+    2 (sep [ text "is no smaller than", pp_lhs ])+  where pp_lhs = text "the LHS of the family instance" <+> quotes (ppr lhs)+pprPatersonCondFailure  (PCF_TyFam tc) InInstanceDecl lhs _rhs =+  hang (text "Illegal use of type family" <+> quotes (ppr tc))+    2 (text "in the constraint" <+> quotes (ppr lhs))+pprPatersonCondFailure  (PCF_TyFam tc) InTyFamEquation _lhs rhs =+  hang (text "Illegal nested use of type family" <+> quotes (ppr tc))+    2 (text "in the arguments of the type-family application" <+> quotes (ppr rhs))++--------------------------------------------------------------------------------++defaultTypesAndImport :: ClassDefaults -> SDoc+defaultTypesAndImport ClassDefaults{cd_types, cd_provenance = DP_Imported cdm} =+  hang (parens $ pprWithCommas ppr cd_types)+     2 (text "imported from" <+> ppr cdm)+defaultTypesAndImport ClassDefaults{cd_types} = parens (pprWithCommas ppr cd_types)++--------------------------------------------------------------------------------++pprZonkerMessage :: ZonkerMessage -> SDoc+pprZonkerMessage = \case+  ZonkerCannotDefaultConcrete frr ->+    ppr (frr_context frr) $$+    text "cannot be assigned a fixed runtime representation," <+>+    text "not even by defaulting."++zonkerMessageHints :: ZonkerMessage -> [GhcHint]+zonkerMessageHints = \case+  ZonkerCannotDefaultConcrete {} -> [SuggestAddTypeSignatures UnnamedBinding]++zonkerMessageReason :: ZonkerMessage -> DiagnosticReason+zonkerMessageReason = \case+  ZonkerCannotDefaultConcrete {} -> ErrorWithoutFlag++--------------------------------------------------------------------------------++pprTypeSyntaxName :: TypeSyntax -> SDoc+pprTypeSyntaxName TypeKeywordSyntax     = "keyword" <+> quotes "type"+pprTypeSyntaxName ForallTelescopeSyntax = "forall telescope"+pprTypeSyntaxName ContextArrowSyntax    = "context arrow (=>)"+pprTypeSyntaxName FunctionArrowSyntax   = "function type arrow (->)"++--------------------------------------------------------------------------------+-- ErrCtxt++pprTyConInstFlavour :: TyConInstFlavour -> SDoc+pprTyConInstFlavour+  ( TyConInstFlavour+      { tyConInstFlavour   = flav+      , tyConInstIsDefault = is_dflt+      }+  ) = (if is_dflt then text "default" else empty) <+> ppr flav <+> text "instance"++pprErrCtxtMsg :: ErrCtxtMsg -> SDoc+pprErrCtxtMsg = \case+  ExprCtxt expr ->+    hang (text "In the expression:")+       2 (ppr (stripParensHsExpr expr))+  ThetaCtxt ctxt theta ->+    vcat [ text "In the context:" <+> pprTheta theta+         , text "While checking" <+> pprUserTypeCtxt ctxt ]+  QuantifiedCtCtxt pty ->+    text "In the quantified constraint" <+> quotes (ppr pty)+  InferredTypeCtxt poly_name poly_ty ->+    vcat [ text "When checking the inferred type"+         , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]+  SigCtxt sig ->+    text "In" <+> ppr sig+  UserSigCtxt ctxt hs_ty+    | Just n <- isSigMaybe ctxt+    -> hang (text "In the type signature:")+          2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty)+    | otherwise+    -> hang (text "In" <+> pprUserTypeCtxt ctxt <> colon)+          2 (ppr hs_ty)+  RecordUpdCtxt ne_relevant_cons@(relevant_con :| _) upd_fld_names ex_tvs ->+    make_lines_msg $+    (text "In a record update at field" <> plural upd_fld_names <+> pprQuotedList upd_fld_names :)+    $ case relevant_con of+         RealDataCon con ->+            [ text "with type constructor" <+> quotes (ppr (dataConTyCon con))+            , text "data constructor" <+> plural relevant_cons <+> cons ]+         PatSynCon {} ->+            [ text "with pattern synonym" <+> plural relevant_cons <+> cons ]+    ++ if null ex_tvs+       then []+       else [ text "existential variable" <> plural ex_tvs <+> pprQuotedList ex_tvs ]++    where+     cons = pprQuotedList relevant_cons+     relevant_cons = NE.toList ne_relevant_cons+     -- Pretty-print a collection of lines, adding commas at the end of each line,+     -- and adding "and" to the start of the last line.+     make_lines_msg :: [SDoc] -> SDoc+     make_lines_msg []      = empty+     make_lines_msg [last]  = ppr last <> dot+     make_lines_msg [l1,l2] = l1 $$ text "and" <+> l2 <> dot+     make_lines_msg (l:ls)  = l <> comma $$ make_lines_msg ls+  PatSigErrCtxt sig_ty res_ty ->+    vcat [ hang (text "When checking that the pattern signature:")+              4 (ppr sig_ty)+         , nest 2 (hang (text "fits the type of its context:")+                      2 (ppr res_ty)) ]+  PatCtxt pat ->+    hang (text "In the pattern:") 2 (ppr pat)+  PatSynDeclCtxt name ->+    text "In the declaration for pattern synonym" <+> quotes (ppr name)+  ClassOpCtxt meth meth_ty ->+    sep [ text "When checking the class method:"+        , nest 2 (pprPrefixOcc meth <+> dcolon <+> ppr meth_ty)]+  MethSigCtxt sel_name sig_ty meth_ty ->+    hang (text "When checking that instance signature for" <+> quotes (ppr sel_name))+       2 (vcat [ text "is more general than its signature in the class"+               , text "Instance sig:" <+> ppr sig_ty+               , text "   Class sig:" <+> ppr meth_ty ])+  PatMonoBindsCtxt pat grhss ->+    hang (text "In a pattern binding:")+       2 (pprPatBind pat grhss)+  ForeignDeclCtxt fo ->+    hang (text "When checking declaration:")+       2 (ppr fo)+  RuleCtxt rule_name ->+    text "When checking the rewrite rule" <+> doubleQuotes (ftext rule_name)+  FieldCtxt field_name ->+    text "In the" <+> quotes (ppr field_name) <+> text "field of a record"+  TypeCtxt ty ->+    text "In the type" <+> quotes (ppr ty)+  KindCtxt ki ->+    text "In the kind" <+> quotes (ppr ki)+  SubTypeCtxt ty_expected ty_actual ->+    vcat [ hang (text "When checking that:")+              4 (ppr ty_actual)+         , nest 2 (hang (text "is more polymorphic than:")+                      2 (ppr ty_expected)) ]+  AmbiguityCheckCtxt ctxt allow_ambiguous ->+     vcat [ text "In the ambiguity check for" <+> what+          , ppUnless allow_ambiguous ambig_msg ]+    where+      ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes"+      what | Just n <- isSigMaybe ctxt = quotes (ppr n)+           | otherwise                 = pprUserTypeCtxt ctxt++  FunAppCtxt fun_arg arg_no ->+    hang (hsep [ text "In the", speakNth arg_no, text "argument of"+               , quotes fun <> text ", namely"])+       2 (quotes arg)+      where+        fun, arg :: SDoc+        (fun, arg) = case fun_arg of+          FunAppCtxtExpr fn a -> (ppr fn, ppr a)+          FunAppCtxtTy   fn a -> (ppr fn, ppr a)+  FunTysCtxt herald fun_ty n_vis_args_in_call n_fun_args+    | n_vis_args_in_call <= n_fun_args  -- Enough args, in the end+    -> text "In the result of a function call"+    | otherwise+    -> hang (full_herald <> comma)+         2 (sep [ text "but its type" <+> quotes (pprSigmaType fun_ty)+                , if n_fun_args == 0 then text "has none"+                  else text "has only" <+> speakN n_fun_args])+    where+      full_herald = pprExpectedFunTyHerald herald+                <+> speakNOf n_vis_args_in_call (text "visible argument")+                 -- What are "visible" arguments? See Note [Visibility and arity] in GHC.Types.Basic+  FunResCtxt fun n_val_args res_fun res_env n_fun n_env+    | -- Check for too few args+      --  fun_tau = a -> b, res_tau = Int+      n_fun > n_env+    , not_fun res_env+    -> text "Probable cause:" <+> quotes (ppr fun)+      <+> text "is applied to too few arguments"++    | -- Check for too many args+      -- fun_tau = a -> Int,   res_tau = a -> b -> c -> d+      -- The final guard suppresses the message when there+      -- aren't enough args to drop; eg. the call is (f e1)+      n_fun < n_env+    , not_fun res_fun+    , n_fun + n_val_args >= n_env+       -- Never suggest that a naked variable is+                        -- applied to too many args!+    -> text "Possible cause:" <+> quotes (ppr fun)+      <+> text "is applied to too many arguments"++    | otherwise+    -> empty+    where+      not_fun ty   -- ty is definitely not an arrow type,+                   -- and cannot conceivably become one+        = case tcSplitTyConApp_maybe ty of+            Just (tc, _) -> isAlgTyCon tc+            Nothing      -> False++  TyConDeclCtxt name flav ->+    hsep [ text "In the", ppr flav+         , text "declaration for", quotes (ppr name) ]+  TyConInstCtxt name flav ->+    hsep [ text "In the" <+> pprTyConInstFlavour flav <+> text "declaration for"+         , quotes (ppr name) ]+  DataConDefCtxt cons ->+    text "In the definition of data constructor" <> plural (NE.toList cons)+      <+> ppr_cons (NE.toList cons)+    where+      ppr_cons :: [LocatedN Name] -> SDoc+      ppr_cons [con] = quotes (ppr con)+      ppr_cons cons  = interpp'SP cons+  DataConResTyCtxt cons ->+    text "In the result type of data constructor" <> plural (NE.toList cons)+     <+> ppr_cons (NE.toList cons)+    where+      ppr_cons :: [LocatedN Name] -> SDoc+      ppr_cons [con] = quotes (ppr con)+      ppr_cons cons  = interpp'SP cons+  ClosedFamEqnCtxt tc ->+    text "In the equations for closed type family" <+>+           quotes (ppr tc)+  TySynErrCtxt tc ->+    text "In the expansion of type synonym" <+> quotes (ppr tc)+  RoleAnnotErrCtxt name ->+    nest 2 $ text "while checking a role annotation for" <+> quotes (ppr name)+  CmdCtxt cmd ->+    text "In the command:" <+> ppr cmd+  InstDeclErrCtxt either_ty_ty ->+    hang (text "In the instance declaration for")+       2 (quotes $ ppr_ty)+   where+    ppr_ty = case either_ty_ty of+      Left  ty -> ppr ty+      Right ty -> ppr ty+  StaticFormCtxt expr ->+    hang (text "In the body of a static form:")+       2 (ppr expr)+  DefaultDeclErrCtxt { ddec_in_type_list = in_type_list } ->+    if in_type_list+    then+      text "When checking the types in a default declaration"+    else+      text "When checking the class at the head of a named default declaration"+  MainCtxt main_name ->+    text "When checking the type of the"+       <+> ppMainFn (nameOccName main_name)++  VDQWarningCtxt tycon ->+    vcat+      [ text "NB: Type" <+> quotes (ppr tycon) <+>+        text "was inferred to use visible dependent quantification."+      , text "Most types with visible dependent quantification are"+      , text "polymorphically recursive and need a standalone kind"+      , text "signature. Perhaps supply one, with StandaloneKindSignatures."+      ]+  TermLevelUseCtxt name ctxt ->+    pprTermLevelUseCtxt name ctxt++  StmtErrCtxt ctxt stmt+    -- For [ e | .. ], do not mutter about "stmts"+    | LastStmt _ e _ _ <- stmt+    , isComprehensionContext ctxt+    -> hang (text "In the expression:") 2 (ppr e)+    | otherwise+    -> hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon)+       2 (ppr_stmt stmt)+    where+      -- For Group and Transform Stmts, don't print the nested stmts!+      ppr_stmt (TransStmt { trS_by = by, trS_using = using+                          , trS_form = form }) = pprTransStmt by using form+      ppr_stmt stmt = pprStmt stmt++  DerivInstCtxt pred ->+    text "When deriving the instance for" <+> parens (ppr pred)+  StandaloneDerivCtxt ty ->+    hang (text "In the stand-alone deriving instance for")+       2 (quotes (ppr ty))+  DerivBindCtxt sel_id clas tys ->+    vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id)+         , nest 2 (text "in a derived instance for"+                   <+> quotes (pprClassPred clas tys) <> colon)+         , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ]+++  ExportCtxt ie ->+    text "In the export:" <+> ppr ie+  PatSynExportCtxt ps ->+    text "In the pattern synonym:" <+> ppr ps+  PatSynRecSelExportCtxt _ps sel ->+    text "In the pattern synonym record selector:" <+> ppr sel++  SyntaxNameCtxt name orig ty loc ->+    vcat [ text "when checking that" <+> quotes (ppr name)+                    <+> text "(needed by a syntactic construct)"+         , nest 2 (text "has the required type:"+                   <+> ppr ty)+         , nest 2 (sep [ppr orig, text "at" <+> ppr loc])]++  AnnCtxt ann ->+    hang (text "In the annotation:") 2 (ppr ann)+  SpecPragmaCtxt prag ->+    hang (text "In the pragma:") 2 (ppr prag)+  MatchCtxt ctxt ->+    text "In" <+> pprMatchContext ctxt+  MatchInCtxt match ->+    hang (text "In" <+> pprMatchContext (m_ctxt match) <> colon)+       4 (pprMatch match)+  UntypedTHBracketCtxt br ->+    hang (text "In the Template Haskell quotation" <> colon)+       2 (ppr br)+  TypedTHBracketCtxt br_body ->+    hang (text "In the Template Haskell typed quotation" <> colon)+       2 (thTyBrackets . ppr $ br_body)+  UntypedSpliceCtxt splice ->+    hang (text "In the" <+> what) 2 (pprUntypedSplice True Nothing splice)+      where+        what = case splice of+                 HsUntypedSpliceExpr {} -> text "untyped splice:"+                 HsQuasiQuote        {} -> text "quasi-quotation:"+  TypedSpliceCtxt mb_nm expr ->+    hang (text "In the typed Template Haskell splice:")+       2 (pprTypedSplice mb_nm expr)+  TypedSpliceResultCtxt expr ->+    sep [ text "In the result of the splice:"+        , nest 2 (pprTypedSplice Nothing (HsTypedSpliceExpr noExtField expr))+        , text "To see what the splice expanded to, use -ddump-splices"]++  ReifyInstancesCtxt th_nm th_tys ->+    text "In the argument of" <+> quotes (text "reifyInstances") <> colon+      <+> ppr_th th_nm <+> sep (map ppr_th th_tys)+    where+      ppr_th :: TH.Ppr a => a -> SDoc+      ppr_th x = text (TH.pprint x)++  MergeSignaturesCtxt unit_state mod_name reqs ->+    pprWithUnitState unit_state $+    if null reqs+    then  text "While checking the local signature" <+> ppr mod_name <+>+          text "for consistency"+    else   hang (text "While merging the signatures from" <> colon)+              2 (vcat [ bullet <+> ppr req | req <- reqs ] $$+                 bullet <+> text "...and the local signature for" <+> ppr mod_name)+  CheckImplementsCtxt unit_state impl_mod (Module req_uid req_mod_name) ->+    pprWithUnitState unit_state $+      text "While checking that" <+> quotes (ppr impl_mod) <+>+      text "implements signature" <+> quotes (ppr req_mod_name) <+>+      text "in" <+> quotes (ppr req_uid) <> dot++--------------------------------------------------------------------------------++pprThBindLevel :: Set.Set ThLevelIndex -> SDoc+pprThBindLevel levels_set = text "level" <> pluralSet levels_set <+> pprUnquotedSet levels_set
compiler/GHC/Tc/Errors/Types.hs view
@@ -6,18 +6,20 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE LambdaCase #-}  module GHC.Tc.Errors.Types (   -- * Main types     TcRnMessage(..)   , TcRnMessageOpts(..)   , mkTcRnUnknownMessage-  , TcRnMessageDetailed(..)+  , TcRnMessageDetailed(..), ErrInfo(..)   , TypeDataForbids(..)-  , ErrInfo(..)   , FixedRuntimeRepProvenance(..)   , pprFixedRuntimeRepProvenance   , ShadowedNameProvenance(..)+  , ResolvedNameInfo(..)+  , pprResolvedNameProvenance   , RecordFieldPart(..)   , IllegalNewtypeReason(..)   , BadRecordUpdateReason(..)@@ -57,7 +59,7 @@    , ErrorItem(..), errorItemOrigin, errorItemEqRel, errorItemPred, errorItemCtLoc -  , SolverReport(..), SolverReportSupplementary(..)+  , SolverReport(..), SupplementaryInfo(..)   , SolverReportWithCtxt(..)   , SolverReportErrCtxt(..)   , getUserGivens, discardProvCtxtGivens@@ -77,8 +79,11 @@   , RelevantBindings(..), pprRelevantBindings   , PromotionErr(..), pprPECategory, peCategory   , TermLevelUseErr(..), teCategory-  , NotInScopeError(..), mkTcRnNotInScope+  , NotInScopeError(..)+  , Subordinate(..), pprSubordinate   , ImportError(..)+  , WhatLooking(..)+  , lookingForSubordinate   , HoleError(..)   , CoercibleMsg(..)   , PotentialInstances(..)@@ -94,7 +99,7 @@   , RuleLhsErrReason(..)   , HsigShapeMismatchReason(..)   , WrongThingSort(..)-  , StageCheckReason(..)+  , LevelCheckReason(..)   , UninferrableTyVarCtx(..)   , PatSynInvalidRhsReason(..)   , BadFieldAnnotationReason(..)@@ -103,13 +108,14 @@   , RoleValidationFailedReason(..)   , DisabledClassExtension(..)   , TyFamsDisabledReason(..)-  , TypeApplication(..)+  , BadInvisPatReason(..)   , BadEmptyCaseReason(..)   , HsTypeOrSigType(..)   , HsTyVarBndrExistentialFlag(..)   , TySynCycleTyCons   , BadImportKind(..)   , DodgyImportsReason (..)+  , ImportLookupExtensions (..)   , ImportLookupReason (..)   , UnusedImportReason (..)   , UnusedImportName (..)@@ -146,6 +152,7 @@   , InvalidFamInstQTv(..), InvalidFamInstQTvReason(..)   , InvalidAssoc(..), InvalidAssocInstance(..)   , InvalidAssocDefault(..), AssocDefaultBadArgs(..)+  , InstHeadNonClassHead(..)      -- * Template Haskell errors   , THError(..), THSyntaxError(..), THNameError(..)@@ -163,9 +170,12 @@   -- * Zonker errors   , ZonkerMessage(..) -  -- FFI Errors+  -- * FFI Errors   , IllegalForeignTypeReason(..)   , TypeCannotBeMarshaledReason(..)++  -- * Error contexts+  , ErrCtxtMsg(..)   ) where  import GHC.Prelude@@ -174,28 +184,29 @@  import GHC.Tc.Errors.Types.PromotionErr import GHC.Tc.Errors.Hole.FitTypes (HoleFit)+import GHC.Tc.Types.BasicTypes import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence (EvBindsVar)+import GHC.Tc.Types.ErrCtxt import GHC.Tc.Types.Origin ( CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol)                            , UserTypeCtxt (PatSynCtxt), TyVarBndrs, TypedThing                            , FixedRuntimeRepOrigin(..), InstanceWhat ) import GHC.Tc.Types.CtLoc( CtLoc, ctLocOrigin, SubGoalDepth ) import GHC.Tc.Types.Rank (Rank) import GHC.Tc.Types.TH-import GHC.Tc.Types.BasicTypes import GHC.Tc.Utils.TcType (TcType, TcSigmaType, TcPredType,                             PatersonCondFailure, PatersonCondFailureContext)  import GHC.Types.Basic import GHC.Types.Error import GHC.Types.Avail-import GHC.Types.Hint (UntickedPromotedThing(..), AssumedDerivingStrategy(..))+import GHC.Types.Hint (UntickedPromotedThing(..), AssumedDerivingStrategy(..), SigLike) import GHC.Types.ForeignCall (CLabelString) import GHC.Types.Id.Info ( RecSelParent(..) ) import GHC.Types.Name (NamedThing(..), Name, OccName, getSrcLoc, getSrcSpan)+import GHC.Types.Name.Env (NameEnv) import qualified GHC.Types.Name.Occurrence as OccName import GHC.Types.Name.Reader-import GHC.Types.Name.Env (NameEnv) import GHC.Types.SourceFile (HsBootOrSig(..)) import GHC.Types.SrcLoc import GHC.Types.TyThing (TyThing)@@ -209,6 +220,8 @@ import GHC.Unit.Module.Warnings (WarningCategory, WarningTxt) import GHC.Unit.Module.ModIface (ModIface) +import GHC.Utils.Outputable+ import GHC.Core.Class (Class, ClassMinimalDef, ClassOpItem, ClassATItem) import GHC.Core.Coercion (Coercion) import GHC.Core.Coercion.Axiom (CoAxBranch)@@ -223,7 +236,8 @@  import GHC.Driver.Backend (Backend) -import GHC.Utils.Outputable+import GHC.Iface.Errors.Types+ import GHC.Utils.Misc (filterOut)  import qualified GHC.LanguageExtensions as LangExt@@ -233,15 +247,15 @@  import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import           Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import           Data.Typeable (Typeable) import qualified GHC.Boot.TH.Syntax as TH import Data.Map.Strict (Map)  import GHC.Generics ( Generic )-import GHC.Iface.Errors.Types -+import qualified Data.Set as Set  data TcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext :: !Bool -- ^ Whether we show the error context or not                                        , tcOptsIfaceOpts   :: !IfaceMessageOpts@@ -279,25 +293,31 @@ existence of these two types, which for now remain a "necessary evil". -} --- The majority of TcRn messages come with extra context about the error,++-- | The majority of TcRn messages come with extra context about the error, -- and this newtype captures it. See Note [Migrating TcM Messages]. data ErrInfo = ErrInfo {-    errInfoContext :: !SDoc+    errInfoContext :: ![ErrCtxtMsg]     -- ^ Extra context associated to the error.-  , errInfoSupplementary :: !SDoc+  , errInfoSupplementary :: !(Maybe (HoleFitDispConfig, [SupplementaryInfo]))     -- ^ Extra supplementary info associated to the error.+  , errInfoHints :: ![GhcHint]+    -- ^ Extra hints associated to the error.   } + -- | 'TcRnMessageDetailed' is an \"internal\" type (used only inside -- 'GHC.Tc.Utils.Monad' that wraps a 'TcRnMessage' while also providing -- any extra info needed to correctly pretty-print this diagnostic later on. data TcRnMessageDetailed-  = TcRnMessageDetailed !ErrInfo-                        -- ^ Extra info associated with the message-                        !TcRnMessage+  = TcRnMessageDetailed+      !ErrInfo+        -- ^ extra info associated with the message+      !TcRnMessage+        -- ^ main error payload   deriving Generic -mkTcRnUnknownMessage :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts)+mkTcRnUnknownMessage :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts, DiagnosticHint a ~ DiagnosticHint TcRnMessage)                      => a -> TcRnMessage mkTcRnUnknownMessage diag = TcRnUnknownMessage (mkSimpleUnknownDiagnostic diag)   -- Please don't use this function inside the GHC codebase;@@ -311,7 +331,7 @@   {-| Simply wraps an unknown 'Diagnostic' message @a@. It can be used by plugins       to provide custom diagnostic messages originated during typechecking/renaming.   -}-  TcRnUnknownMessage :: (UnknownDiagnostic (DiagnosticOpts TcRnMessage)) -> TcRnMessage+  TcRnUnknownMessage :: UnknownDiagnosticFor TcRnMessage -> TcRnMessage    {-| Wrap an 'IfaceMessage' to a 'TcRnMessage' for when we attempt to load interface       files during typechecking but encounter an error. -}@@ -433,7 +453,7 @@   -}   TcRnTypeDoesNotHaveFixedRuntimeRep :: !Type                                      -> !FixedRuntimeRepProvenance-                                     -> !ErrInfo -- Extra info accumulated in the TcM monad+                                     -> ![ErrCtxtMsg] -- Extra info accumulated in the TcM monad                                      -> TcRnMessage    {-| TcRnImplicitLift is a warning (controlled with -Wimplicit-lift) that occurs when@@ -445,7 +465,7 @@       Test cases: th/T17804   -}-  TcRnImplicitLift :: Name -> !ErrInfo -> TcRnMessage+  TcRnImplicitLift :: Name -> ![ErrCtxtMsg] -> 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@@ -758,6 +778,20 @@     :: RdrName     -> TcRnMessage +  {- TcRnIllegalPunnedVarOccInTypeArgument is an error raised+     when a punned variable occurs in a required type argument.++     Example:+       vfun :: forall (a :: k) -> ()+       f (Just @a a) = vfun a+       --                  ^^^+       --  which `a` is referenced?+  -}+  TcRnIllegalPunnedVarOccInTypeArgument+    :: { illegalPunTermName :: !ResolvedNameInfo     -- ^ How the variable was actually resolved (term namespace)+       , illegalPunTypeName :: !ResolvedNameInfo     -- ^ How the variable could have been resolved (type namespace)+       } -> TcRnMessage+   {-| TcRnDuplicateFieldName is an error that occurs whenever       there are duplicate field names in a single record. @@ -1472,7 +1506,7 @@       Text cases: module/mod58   -}-  TcRnMultipleDefaultDeclarations :: Class -> [LDefaultDecl GhcRn] -> TcRnMessage+  TcRnMultipleDefaultDeclarations :: Class -> ClassDefaults -> TcRnMessage    {-| TcRnWarnClashingDefaultImports is a warning that occurs when a module imports       more than one default declaration for the same class, and they are not all@@ -1496,7 +1530,7 @@       Test cases: typecheck/should_fail/T11974b   -}-  TcRnBadDefaultType :: Type -> NE.NonEmpty Class -> TcRnMessage+  TcRnBadDefaultType :: LHsType GhcRn -> NonEmpty Class -> TcRnMessage    {-| TcRnPatSynBundledWithNonDataCon is an error that occurs when a module's       export list bundles a pattern synonym with a type that is not a proper@@ -1603,6 +1637,13 @@   -}   TcRnDuplicateExport :: GlobalRdrElt -> IE GhcPs -> IE GhcPs -> TcRnMessage +  {-| TcRnDuplicateNamedDefaultExport is a warning (controlled by -Wduplicate-exports)+      that occurs when a named default declaration appears in an export list+      more than once.++  -}+  TcRnDuplicateNamedDefaultExport :: TyCon -> IE GhcPs -> IE GhcPs -> TcRnMessage+   {-| TcRnExportedParentChildMismatch is an error that occurs when an export is       bundled with a parent that it does not belong to @@ -1834,7 +1875,7 @@                  deriving/should_fail/drvfail009                  deriving/should_fail/drvfail006   -}-  TcRnNonUnaryTypeclassConstraint :: !UserTypeCtxt -> !(LHsSigType GhcRn) -> TcRnMessage+  TcRnNonUnaryTypeclassConstraint :: !UserTypeCtxt -> !TypedThing -> TcRnMessage    {-| TcRnPartialTypeSignatures is a warning (controlled by -Wpartial-type-signatures)       that occurs when a wildcard '_' is found in place of a type in a signature or a@@ -2007,8 +2048,6 @@       See 'NotInScopeError' for more details. -}   TcRnNotInScope :: NotInScopeError  -- ^ what the problem is                  -> RdrName          -- ^ the name that is not in scope-                 -> [ImportError]    -- ^ import errors that are relevant-                 -> [GhcHint]        -- ^ hints, e.g. enable DataKinds to refer to a promoted data constructor                  -> TcRnMessage    {-| TcRnTermNameInType is an error that occurs when a term-level identifier@@ -2023,7 +2062,7 @@        Test cases: T21605{c,d}   -}-  TcRnTermNameInType :: RdrName -> [GhcHint] -> TcRnMessage+  TcRnTermNameInType :: !RdrName -> TcRnMessage    {-| TcRnUntickedPromotedThing is a warning (controlled with -Wunticked-promoted-constructors)       that is triggered by an unticked occurrence of a promoted data constructor.@@ -2051,10 +2090,9 @@        Test cases: rnfail042, T14907b, T15124, T15233.   -}-  TcRnIllegalBuiltinSyntax :: SDoc -- ^ what kind of thing this is (a binding, fixity declaration, ...)+  TcRnIllegalBuiltinSyntax :: SigLike -- ^ what kind of thing this is (a binding, fixity declaration, ...)                            -> RdrName                            -> TcRnMessage-    -- TODO: remove the SDoc argument.    {-| TcRnWarnDefaulting is a warning (controlled by -Wtype-defaults)       that is triggered whenever a Wanted typeclass constraint@@ -2240,7 +2278,7 @@      Test cases: default/fail01   -}-  TcRnIllegalDefaultClass :: !(LHsSigType GhcRn) -> TcRnMessage+  TcRnIllegalDefaultClass :: !Name -> TcRnMessage    {-| TcRnIllegalNamedDefault is an error for specifying an explicit default class name      without @-XNamedDefaults@.@@ -2263,7 +2301,7 @@                 typecheck/should_fail/T7210                 rename/should_fail/T22478b   -}-  TcRnUnexpectedAnnotation :: !(HsType GhcRn) -> !HsBang -> TcRnMessage+  TcRnUnexpectedAnnotation :: !(HsType GhcPs) -> !HsSrcBang -> TcRnMessage    {-| TcRnIllegalRecordSyntax is an error indicating an illegal use of record syntax. @@ -2274,7 +2312,7 @@                 rename/should_fail/T9077                 rename/should_fail/T22478b   -}-  TcRnIllegalRecordSyntax :: Either (HsType GhcPs) (HsType GhcRn) -> TcRnMessage+  TcRnIllegalRecordSyntax :: HsType GhcPs -> TcRnMessage    {-| TcRnInvalidVisibleKindArgument is an error for a kind application on a      target type that cannot accept it.@@ -2448,7 +2486,13 @@        Test cases: T18740a, T18740b, T23739_fail_ret, T23739_fail_case   -}-  TcRnIllegalTermLevelUse :: !Name -> !TermLevelUseErr -> TcRnMessage+  TcRnIllegalTermLevelUse+    :: !Bool -- ^ should we give a simple "out of scope" message,+             -- instead of a full-blown "Illegal term level use" message?+    -> !RdrName -- ^ the user-written identifier+    -> !Name    -- ^ the type-level 'Name' we resolved it to+    -> !TermLevelUseErr+    -> TcRnMessage    {-| TcRnMatchesHaveDiffNumArgs is an error occurring when something has matches      that have different numbers of arguments@@ -2509,11 +2553,11 @@                   rename/should_fail/T22478e                   th/TH_Promoted1Tuple                   typecheck/should_compile/tcfail094-                  typecheck/should_compile/T22141a-                  typecheck/should_compile/T22141b-                  typecheck/should_compile/T22141c-                  typecheck/should_compile/T22141d-                  typecheck/should_compile/T22141e+                  typecheck/should_fail/T22141a+                  typecheck/should_fail/T22141b+                  typecheck/should_fail/T22141c+                  typecheck/should_fail/T22141d+                  typecheck/should_fail/T22141e                   typecheck/should_compile/T22141f                   typecheck/should_compile/T22141g                   typecheck/should_fail/T20873c@@ -2542,21 +2586,6 @@   -}   TcRnCannotBindTyVarsInPatBind :: !(NE.NonEmpty (Name, TcTyVar)) -> TcRnMessage -  {-| TcRnTooManyTyArgsInConPattern is an error occurring when a constructor pattern-     has more than the expected number of type arguments--     Example(s):-     f (Just @Int @Bool x) = x--    Test cases: typecheck/should_fail/TyAppPat_TooMany-                typecheck/should_fail/T20443b-  -}-  TcRnTooManyTyArgsInConPattern-    :: !ConLike-    -> !Int -- ^ Expected number of args-    -> !Int -- ^ Actual number of args-    -> TcRnMessage-   {-| TcRnMultipleInlinePragmas is a warning signifying that multiple inline pragmas      reference the same definition. @@ -2595,6 +2624,7 @@                 typecheck/should_compile/T10504   -}   TcRnNonOverloadedSpecialisePragma :: !(LIdP GhcRn) -> TcRnMessage+    -- NB: this constructor is deprecated and will be removed in GHC 9.18 (#25540)    {-| TcRnSpecialiseNotVisible is a warning that occurs when the subject of a      SPECIALISE pragma has a definition that is not visible from the current module.@@ -3176,6 +3206,14 @@   -}   TcRnDuplicateMinimalSig :: LSig GhcPs -> LSig GhcPs -> [LSig GhcPs] -> TcRnMessage +  {-| TcRnSpecSigShape is an error that occurs when the user writes a SPECIALISE+      pragma that isn't just a function application.++      Example:+        {-# SPECIALISE let x=True in x #-}+  -}+  TcRnSpecSigShape :: LHsExpr GhcPs -> TcRnMessage+   {-| 'TcRnIllegalInvisTyVarBndr' is an error that occurs       when invisible type variable binders in type declarations       are used without enabling the @TypeAbstractions@ extension.@@ -3235,15 +3273,6 @@     -> !(LHsTyVarBndr (HsBndrVis GhcRn) GhcRn)     -> TcRnMessage -  {-| TcRnDeprecatedInvisTyArgInConPat is a warning that triggers on type applications-      in constructor patterns when the user has not enabled '-XTypeAbstractions'-      but instead has enabled both '-XScopedTypeVariables' and '-XTypeApplications'.--      This warning is a deprecation mechanism that is scheduled until GHC 9.12.-  -}-  TcRnDeprecatedInvisTyArgInConPat-    :: TcRnMessage-   {-| TcRnUnexpectedStandaloneDerivingDecl is an error thrown when a user uses       standalone deriving without enabling the StandaloneDeriving extension. @@ -3291,11 +3320,23 @@   -}   TcRnIllegalRuleLhs     :: RuleLhsErrReason-    -> FastString -- Rule name-    -> LHsExpr GhcRn -- Full expression-    -> HsExpr GhcRn -- Bad expression+    -> FastString -- ^ Rule name+    -> LHsExpr GhcRn -- ^ Full expression+    -> HsExpr GhcRn -- ^ Bad expression     -> TcRnMessage +  {-| TcRnRuleLhsEqualities is a warning, controlled by '-Wrule-lhs-equalities',+      that is triggered by a RULE whose LHS contains equality constraints+      (of a certain form, such as @F a ~ b@ for a type family @F@).++      Test case: typecheck/should_compile/RuleEqs+  -}+  TcRnRuleLhsEqualities+    :: FastString -- ^ rule name+    -> LHsExpr GhcRn -- ^ LHS expression+    -> NE.NonEmpty Ct -- ^ LHS equality constraints+    -> TcRnMessage+   {-| TcRnDuplicateRoleAnnot is an error triggered by two or more role       annotations for one type @@ -3432,41 +3473,33 @@     -> !LookupInstanceErrReason     -> TcRnMessage -  {-| TcRnBadlyStaged is an error that occurs when a TH binding is used in an-    invalid stage.--    Test cases:-      T17820d-  -}-  TcRnBadlyStaged-    :: !StageCheckReason -- ^ The binding being spliced.-    -> !Int -- ^ The binding stage.-    -> !Int -- ^ The stage at which the binding is used.-    -> TcRnMessage--  {-| TcRnStageRestriction is an error that occurs when a top level splice refers to-    a local name.+  {-| TcRnBadlyLevelled is an error that occurs when a TH binding is used at an+      invalid level.      Test cases:-      T17820, T21547, T5795, qq00[1-4], annfail0{3,4,6,9}+      T17820d, T17820, T21547, T5795, qq00[1-4], annfail0{3,4,6,9}   -}-  TcRnStageRestriction-    :: !StageCheckReason -- ^ The binding being spliced.+  TcRnBadlyLevelled+    :: !LevelCheckReason -- ^ The binding+    -> !(Set.Set ThLevelIndex) -- ^ The binding levels+    -> !ThLevelIndex -- ^ The level at which the binding is used.+    -> !(Maybe ErrorItem) -- ^ The attempt we made to implicitly lift the binding.+    -> DiagnosticReason   -- ^ Whether to defer this error or fail     -> TcRnMessage -  {-| TcRnBadlyStagedWarn is a warning that occurs when a TH type binding is+  {-| TcRnBadlyLevelledWarn is a warning that occurs when a TH type binding is     used in an invalid stage.      Controlled by flags:-       - Wbadly-staged-type+       - Wbadly-levelled-type      Test cases:       T23829_timely T23829_tardy T23829_hasty   -}-  TcRnBadlyStagedType+  TcRnBadlyLevelledType     :: !Name  -- ^ The type binding being spliced.-    -> !Int -- ^ The binding stage.-    -> !Int -- ^ The stage at which the binding is used.+    -> !(Set.Set ThLevelIndex) -- ^ The binding stage.+    -> !ThLevelIndex -- ^ The stage at which the binding is used.     -> TcRnMessage    {-| TcRnTyThingUsedWrong is an error that occurs when a thing is used where another@@ -3611,7 +3644,10 @@      Test cases:        TcIncompleteRecSel   -}-  TcRnHasFieldResolvedIncomplete :: !Name -> TcRnMessage+  TcRnHasFieldResolvedIncomplete :: !Name         -- ^ The selector+                                 -> ![ConLike]    -- ^ The partial constructors+                                 -> !Int          -- ^ The max number of constructors reported+                                 -> TcRnMessage    {-| TcRnBadFieldAnnotation is an error/warning group indicating that a     strictness/unpack related data type field annotation is invalid.@@ -4023,7 +4059,8 @@     Test cases:       T12411, T12446, T15527, T16133, T18251c   -}-  TcRnTypeApplicationsDisabled :: !TypeApplication -- ^ what kind of type application is it?+  TcRnTypeApplicationsDisabled :: !(HsType GhcPs)+                               -> !TypeOrKind                                -> TcRnMessage    {-| TcRnInvalidRecordField is an error indicating that a record field was@@ -4313,33 +4350,44 @@   -}   TcRnNamespacedWarningPragmaWithoutFlag :: WarnDecl GhcPs -> TcRnMessage -  {-| TcRnInvisPatWithNoForAll is an error raised when invisible type pattern-      is used without associated `forall` in types+  {-| TcRnIllegalInvisibleTypePattern is an error raised when an invisible+      type pattern, i.e. a pattern of the form `@p`, is rejected. -      Examples:+      Example for InvisPatWithoutFlag: +        {-# LANGUAGE NoTypeAbstractions #-}+        id :: a -> a+        id @t x = x++      Examples for InvisPatNoForall:+         f :: Int         f @t = 5          g :: [a -> a]         g = [\ @t x -> x :: t] -      Test cases: T17694c T17594d-  -}-  TcRnInvisPatWithNoForAll :: HsTyPat GhcRn -> TcRnMessage--  {-| TcRnIllegalInvisibleTypePattern is an error raised when invisible type pattern-      is used without the TypeAbstractions extension enabled+      Examples for InvisPatMisplaced: -      Example:+        f (smth, $(invisP (varT (newName "blah")))) = ... -        {-# LANGUAGE NoTypeAbstractions #-}-        id :: a -> a-        id @t x = x+        g = do+          $(invisP (varT (newName "blah"))) <- aciton1+          ... -      Test cases: T17694b+      Test cases:+        T17694b          -- InvisPatWithoutFlag+        T17694c          -- InvisPatNoForall+        T17594d          -- InvisPatNoForall+        T24557a          -- InvisPatMisplaced+        T24557b          -- InvisPatMisplaced+        T24557c          -- InvisPatMisplaced+        T24557d          -- InvisPatMisplaced   -}-  TcRnIllegalInvisibleTypePattern :: HsTyPat GhcPs -> TcRnMessage+  TcRnIllegalInvisibleTypePattern+    :: !(HsTyPat GhcRn)     -- the rejected type pattern+    -> !BadInvisPatReason   -- the reason for rejection+    -> TcRnMessage    {-| TcRnNamespacedFixitySigWithoutFlag is an error that occurs when       a namespace specifier is used in fixity signatures@@ -4382,24 +4430,6 @@     -> Name -- ^ Type variable's name     -> TcRnMessage -  {- TcRnMisplacedInvisPat is an error raised when invisible @-pattern-     appears in invalid context (e.g. pattern in case of or in do-notation)-     or nested inside the pattern. Template Haskell seems to be the only-     source for this diagnostic.--     Examples:--        f (smth, $(invisP (varT (newName "blah")))) = ...--        g = do-          $(invisP (varT (newName "blah"))) <- aciton1-          ...--     Test cases: T24557a T24557b T24557c T24557d--  -}-  TcRnMisplacedInvisPat :: HsTyPat GhcPs -> TcRnMessage-   {- TcRnUnexpectedTypeSyntaxInTerms is an error that occurs      when type syntax is used in terms without -XRequiredTypeArguments      extension enabled@@ -4492,6 +4522,18 @@   | ShadowedNameProvenanceGlobal [GlobalRdrElt]     -- ^ The shadowed name is global, typically imported from elsewhere. +-- | Information about a resolved name+data ResolvedNameInfo+  = ResolvedNameInfo ![GlobalRdrElt] !RdrName !Name++instance Outputable ResolvedNameInfo where+  ppr (ResolvedNameInfo _ rdr name) = ppr (WithUserRdr rdr name)++pprResolvedNameProvenance :: ResolvedNameInfo -> SDoc+pprResolvedNameProvenance (ResolvedNameInfo gres _ name)+  | gre:_ <- gres = pprNameProvenance gre+  | otherwise     = text "bound at" <+> ppr (getSrcLoc name)+ -- | In what context did we require a type to have a fixed runtime representation? -- -- Used by 'GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep' for throwing@@ -4788,7 +4830,7 @@   --      f :: a   --   -- Test cases: typecheck/should_fail/T13068-  = InstHeadAbstractClass !Class+  = InstHeadAbstractClass !(WithUserRdr Name) -- ^ name of the abstract 'Class'   -- | An instance whose head is not a class.   --   -- Examples(s):@@ -4808,10 +4850,7 @@   --             rename/should_fail/T18240a   --             polykinds/T13267   --             deriving/should_fail/T23522-  | InstHeadNonClass-    !(Maybe TyCon) -- ^ the 'TyCon' at the head of the instance head,-                   -- or 'Nothing' if the instance head is not even headed-                   -- by a 'TyCon'+  | InstHeadNonClassHead InstHeadNonClassHead    -- | Instance head was headed by a type synonym.   --@@ -4842,6 +4881,13 @@   deriving Generic  +-- | What was at the head of an instance head, when we expected a class?+data InstHeadNonClassHead+  -- | A 'TyCon' that isn't a class was at the head+  = InstNonClassTyCon (WithUserRdr Name) (TyConFlavour Name)+  -- | Something else than a 'TyCon' was at the head+  | InstNonTyCon+ -- | Why is a (type or data) family instance invalid? data IllegalFamilyInstanceReason   {-| A top-level family instance for a 'TyCon' that isn't a family 'TyCon'.@@ -5021,7 +5067,7 @@     --     -- Test cases: none.   | AssocMultipleDefaults !Name-    -- | Invalid arguments in an associated family instance.+    -- | Invalid arguments in an associated family instance default declaration.     --     -- See t'AssocDefaultBadArgs'.   | AssocDefaultBadArgs !TyCon ![Type] AssocDefaultBadArgs@@ -5307,17 +5353,19 @@ data SolverReport   = SolverReport   { sr_important_msg :: SolverReportWithCtxt-  , sr_supplementary :: [SolverReportSupplementary]+  , sr_supplementary :: [SupplementaryInfo]+  , sr_hints         :: [GhcHint]   } --- | Additional information to print in a 'SolverReport', after the+-- | Additional information to print in an error message, after the -- important messages and after the error context. -- -- See Note [Error report].-data SolverReportSupplementary-  = SupplementaryBindings RelevantBindings-  | SupplementaryHoleFits ValidHoleFits-  | SupplementaryCts      [(PredType, RealSrcSpan)]+data SupplementaryInfo+  = SupplementaryBindings     RelevantBindings+  | SupplementaryHoleFits     ValidHoleFits+  | SupplementaryCts          (NE.NonEmpty (PredType, RealSrcSpan))+  | SupplementaryImportErrors (NE.NonEmpty ImportError)  -- | A 'TcSolverReportMsg', together with context (e.g. enclosing implication constraints) -- that are needed in order to report it.@@ -5523,17 +5571,6 @@    -- See 'FixedRuntimeRepErrorInfo' and 'FixedRuntimeRepContext' for more information.   | FixedRuntimeRepError [FixedRuntimeRepErrorInfo] -  -- | An equality between two types is blocked on a kind equality-  -- between their kinds.-  ---  -- Test cases: none.-  | BlockedEquality ErrorItem-    -- These are for the "blocked" equalities, as described in-    -- Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality,-    -- wrinkle (EIK2). There should always be another unsolved wanted around,-    -- which will ordinarily suppress this message. But this can still be printed out-    -- with -fdefer-type-errors (sigh), so we must produce a message.-   -- | Something was not applied to sufficiently many arguments.   --   --  Example:@@ -5578,11 +5615,8 @@     { cannotResolve_item         :: ErrorItem     , cannotResolve_unifiers     :: [ClsInst]     , cannotResolve_candidates   :: [ClsInst]-    , cannotResolve_importErrors :: [ImportError]-    , cannotResolve_suggestions  :: [GhcHint]-    , cannotResolve_relevant_bindings :: RelevantBindings }-      -- TODO: remove the fields of type [GhcHint] and RelevantBindings,-      -- in order to handle them uniformly with other diagnostic messages.+    , cannotResolve_relBinds     :: RelevantBindings+    }    -- | Could not solve a constraint using available instances   -- because the instances overlap.@@ -5603,6 +5637,8 @@     , unsafeOverlap_match   :: ClsInst     , unsafeOverlapped      :: NE.NonEmpty ClsInst } +  | MultiplicityCoercionsNotSupported+   deriving Generic  data MismatchMsg@@ -5622,19 +5658,9 @@       , 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.+  -- Test cases: T1470, tcfail212, T2994, T7609.   | TypeEqMismatch       { teq_mismatch_item     :: ErrorItem       , teq_mismatch_ty1      :: Type@@ -5783,16 +5809,58 @@   -- | Missing @type@ keyword when importing a type.   -- e.g.  `import TypeLits( (+) )`, where TypeLits exports a /type/ (+), not a /term/ (+)   -- Then we want to suggest using `import TypeLits( type (+) )`-  | BadImportAvailTyCon Bool -- ^ is ExplicitNamespaces enabled?+  | BadImportAvailTyCon   -- | Trying to import a data constructor directly, e.g.   -- @import Data.Maybe (Just)@ instead of @import Data.Maybe (Maybe(Just))@   | BadImportAvailDataCon OccName   -- | The parent does not export the given children.-  | BadImportNotExportedSubordinates [OccName]+  | BadImportNotExportedSubordinates !GlobalRdrElt (NonEmpty FastString)+  -- | Incorrect @type@ keyword when importing subordinates that aren't types.+  | BadImportNonTypeSubordinates !GlobalRdrElt (NonEmpty GlobalRdrElt)+  -- | Incorrect @data@ keyword when importing something which isn't a term.+  | BadImportNonDataSubordinates !GlobalRdrElt (NonEmpty GlobalRdrElt)   -- | Incorrect @type@ keyword when importing something which isn't a type.   | BadImportAvailVar   deriving Generic +{- Note [Reasons for BadImportAvailTyCon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+BadImportAvailTyCon means a name is available in the TcCls namespace+but name resolution could not use it. Possible reasons for that:++- Case (TyOp) `import M ((#))` or `import M (data (#))`+    The user tried to import a type operator without using the `type` keyword,+    or using a different keyword. Suggested fix: add 'type'.++- Case (DataKw) `import M (data T)`+    The user tried to import a non-operator type constructor, but mistakenly+    used the `data` keyword, which restricted the lookup to the value namespace.+    Suggested fix: remove 'data'; no need to add 'type' for non-operators.++- Case (PatternKw) `import M (pattern T)`+    Same as the (DataKw) case, mutatis mutandis.++Any other case would not have resulted in BadImportAvailTyCon.+-}++-- | Describes what category of subordinate we are dealing with, e.g.+-- a method of a class, a field of a record, etc.+data Subordinate+  = MethodOfClass          -- ^ A method of a class+  | AssociatedTypeOfClass  -- ^ An associated type of a class+  | FieldOfConstructor     -- ^ A field of a constructor++  deriving Generic++pprSubordinate :: Name -> Subordinate -> SDoc+pprSubordinate parent_nm = \case+  MethodOfClass ->+    text "method of class" <+> quotes (ppr parent_nm)+  AssociatedTypeOfClass  ->+    text "associated type of class" <+> quotes (ppr parent_nm)+  FieldOfConstructor ->+    text "field of constructor" <+> quotes (ppr parent_nm)+ -- | Some form of @"not in scope"@ error. See also the 'OutOfScopeHole' -- constructor of 'HoleError'. data NotInScopeError@@ -5820,8 +5888,7 @@    -- A type signature, fixity declaration, pragma, standalone kind signature...   -- is missing an associated binding.-  | MissingBinding SDoc [GhcHint]-    -- TODO: remove the SDoc argument.+  | MissingBinding SigLike [GhcHint]    -- | Couldn't find a top-level binding.   --@@ -5834,7 +5901,9 @@   -- | 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+  | UnknownSubordinate+      Name -- ^ name of the parent+      Subordinate -- ^ the kind of subordinate    -- | A name is not in scope during type checking but passed the renamer.   --@@ -5843,10 +5912,6 @@   | NotInScopeTc (NameEnv TcTyThing)   deriving Generic --- | Create a @"not in scope"@ error message for the given 'RdrName'.-mkTcRnNotInScope :: RdrName -> NotInScopeError -> TcRnMessage-mkTcRnNotInScope rdr err = TcRnNotInScope err rdr [] noHints- -- | Configuration for pretty-printing valid hole fits. data HoleFitDispConfig =   HFDC { showWrap, showWrapVars, showType, showProv, showMatches@@ -5864,7 +5929,7 @@   -- See 'NotInScopeError' for other not-in-scope errors.   --   -- Test cases: T9177a.-  = OutOfScopeHole [ImportError] [GhcHint]+  = OutOfScopeHole   -- | Report a typed hole, or wildcard, with additional information.   | HoleError HoleSort               [TcTyVar]                     -- Other type variables which get computed on the way.@@ -5908,8 +5973,59 @@   -- | Couldn't find a module with the requested name.   = MissingModule ModuleName   -- | The imported modules don't export what we're looking for.-  | ModulesDoNotExport (NE.NonEmpty Module) OccName+  | ModulesDoNotExport (NE.NonEmpty Module) WhatLooking OccName +-- What kind of suggestion are we looking for? #19843+data WhatLooking = WL_Anything+                     -- ^ Any sugestion+                 | WL_Constructor+                     -- ^ Suggest type constructors, data constructors+                     -- (including promoted data constructors), and pattern+                     -- synonyms.+                 | WL_TyCon+                     -- ^ Suggest type constructors/classes only; do not+                     -- include promoted data constructors.+                 | WL_TyCon_or_TermVar+                     -- ^ Suggest type constructors and term variables,+                     -- but not data constructors nor type variables+                 | WL_TyVar+                     -- ^ Suggest type variables only.+                 | WL_ConLike+                   -- ^ Suggest term-level data constructors and pattern+                   -- synonyms; no type constructors or promoted data+                   -- constructors+                 | WL_RecField+                     -- ^ Suggest record fields+                     --+                     -- E.g. in @K { f1 = True, f2 = False }@, if @f2@ is not in+                     -- scope, suggest only constructor fields+                 | WL_Term+                     -- ^ Suggest terms+                     --+                     -- If we are expecting a term value, then only suggest+                     -- terms (e.g. term variables, data constructors) and+                     -- not type constructors or type variables+                 | WL_TermVariable+                    -- ^ Suggest term variables (and record fields)+                 | WL_Type+                     -- ^ Suggest types: type constructors, type variables,+                     -- promoted data constructors.+                 | WL_None+                     -- ^ No suggestions+                     --+                     -- This is is used for rebindable syntax, where there+                     -- is no point in suggesting alternative spellings+                 deriving (Eq, Show)++-- | In what namespaces should we look for a subordinate+-- of the given 'GlobalRdrElt'.+lookingForSubordinate :: GlobalRdrElt -> WhatLooking+lookingForSubordinate parent_gre =+  case greInfo parent_gre of+    IAmTyCon ClassFlavour+      -> WL_TyCon_or_TermVar+    _ -> WL_Term+ -- | This datatype collates instances that match or unifier, -- in order to report an error message for an unsolved typeclass constraint. data PotentialInstances@@ -5973,6 +6089,10 @@   , frr_info_not_concrete :: Maybe (TcTyVar, TcType)       -- ^ Which non-concrete type did we try to       -- unify this concrete type variable with?+  , frr_info_other_origin :: Maybe CtOrigin+      -- ^ Did the representation polymorphism check arise+      -- from another constraint? If so, record that 'CtOrigin' here+      -- (it will never be a 'FRROrigin').   }  {-@@ -5983,17 +6103,20 @@ ************************************************************************ -} --- AZ:TODO: Change these all to be Name instead of RdrName.---          Merge TcType.UserTypeContext in to it.+-- | An error message context, for errors in the renamer.+--+-- TODO: this should probably get merged in some way with 'ErrCtxtMsg',+-- but that's a battle for another day. data HsDocContext-  = TypeSigCtx SDoc-  | StandaloneKindSigCtx SDoc+  = TypeSigCtx [LocatedN RdrName]+  | StandaloneKindSigCtx (LocatedN RdrName)   | PatCtx   | SpecInstSigCtx   | DefaultDeclCtx   | ForeignDeclCtx (LocatedN RdrName)   | DerivDeclCtx   | RuleCtx FastString+  | SpecECtx RdrName   | TyDataCtx (LocatedN RdrName)   | TySynCtx (LocatedN RdrName)   | TyFamilyCtx (LocatedN RdrName)@@ -6006,7 +6129,16 @@   | HsTypePatCtx   | GHCiCtx   | SpliceTypeCtx (LHsType GhcPs)-  | ClassInstanceCtx+  | ReifyInstancesCtx+  | ClassInstanceCtx (LHsType GhcRn)+  | ClassMethodSigCtx (LocatedN RdrName)  -- ^ Class method signature+  | SpecialiseSigCtx (LocatedN RdrName)   -- ^ SPECIALISE signature+  | PatSynSigCtx [LocatedN RdrName]       -- ^ Pattern synonym signature++  -- | Escape hatch, for GHC plugins and other GHC API users.+  --+  -- Not for use within GHC; add a new constructor to 'HsDocContext'+  -- if you need to add a new renamer error context.   | GenericCtx SDoc  -- | Context for a mismatch in the number of arguments@@ -6108,9 +6240,9 @@   | WrongThingTyCon   | WrongThingAxiom -data StageCheckReason-  = StageCheckInstance !InstanceWhat !PredType-  | StageCheckSplice !Name+data LevelCheckReason+  = LevelCheckInstance !InstanceWhat !PredType+  | LevelCheckSplice !Name !(Maybe GlobalRdrElt)  data UninferrableTyVarCtx   = UninfTyCtx_ClassContext [TcType]@@ -6139,13 +6271,28 @@     T14761a, T7562   -}   UnpackWithoutStrictness :: BadFieldAnnotationReason-  {-| An UNPACK pragma was applied to an abstract type in an indefinite package-    in Backpack.+  {-| An UNPACK pragma is unusable. +    A possible reason for this warning is that the UNPACK pragma was applied to+    one of the following:++      * a function type @a -> b@+      * a recursive use of the data type being defined+      * a sum type that cannot be unpacked, see @Note [UNPACK for sum types]@+      * a type/data family application with no matching instance in the environment++    However, it is deliberately /not/ emitted if:++      * the failure occurs in an indefinite package in Backpack+      * the pragma is usable, but unpacking is disabled by @-O0@+     Test cases:-    unpack_sums_5, T3966, T7050+      unpack_sums_5, T3966, T7050, T25672, T23307c++    Negative test cases (must not trigger this warning):+      T3990   -}-  BackpackUnpackAbstractType :: BadFieldAnnotationReason+  UnusableUnpackPragma :: BadFieldAnnotationReason   deriving (Generic)  data SuperclassCycle =@@ -6191,10 +6338,12 @@   | TyFamsDisabledInstance !TyCon   deriving (Generic) -data TypeApplication-  = TypeApplication !(HsType GhcPs) !TypeOrKind-  | TypeApplicationInPattern !(HsConPatTyArg GhcPs)-  deriving Generic+-- | Why was an invisible pattern `@p` rejected?+data BadInvisPatReason+  = InvisPatWithoutFlag+  | InvisPatNoForall+  | InvisPatMisplaced+  deriving (Generic)  -- | Why was the empty case rejected? data BadEmptyCaseReason@@ -6243,6 +6392,14 @@   DodgyImportsHiding !ImportLookupReason   deriving (Generic) +-- | What extensions were enabled at import site.+data ImportLookupExtensions =+  ImportLookupExtensions+    { ile_pattern_synonyms    :: !Bool+    , ile_explicit_namespaces :: !Bool+    }+  deriving (Generic)+ -- | Different types of errors for import lookup. data ImportLookupReason where   {-| An item in an import statement is not exported by the corresponding@@ -6256,7 +6413,7 @@                   -> ModIface                   -> ImpDeclSpec                   -> IE GhcPs-                  -> Bool -- ^ whether @-XPatternSynonyms@ was enabled+                  -> ImportLookupExtensions                   -> ImportLookupReason   {-| A name is specified with a qualifying module. @@ -6606,13 +6763,6 @@   -}   = NonExactName !RdrName -  {-| QuotedNameWrongStage is an error that can happen when a-      (non-top-level) Name is used at a different Template Haskell stage-      than the stage at which it is bound.--     Test cases: T16976z-  -}-  | QuotedNameWrongStage !(HsQuote GhcPs)   deriving Generic  data THReifyError@@ -6798,6 +6948,8 @@   | InvalidImplicitParamBinding   | DefaultDataInstDecl ![LDataFamInstDecl GhcPs]   | FunBindLacksEquations !TH.Name+  | EmptyGuard+  | EmptyParStmt   deriving Generic  data IllegalDecls@@ -6824,6 +6976,7 @@ data UnrepresentableTypeDescr   = LinearInvisibleArgument   | CoercionsInTypes+  | DataConVisibleForall  -- FFI error types data IllegalForeignTypeReason
compiler/GHC/Tc/Errors/Types/PromotionErr.hs view
@@ -1,8 +1,12 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+ module GHC.Tc.Errors.Types.PromotionErr ( PromotionErr(..)                                         , pprPECategory                                         , peCategory                                         , TermLevelUseErr(..)+                                        , TermLevelUseCtxt(..)+                                        , pprTermLevelUseCtxt                                         , teCategory                                         ) where @@ -11,6 +15,8 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Generics (Generic)+import GHC.Types.Name.Reader (GlobalRdrElt, pprNameProvenance)+import GHC.Types.Name (Name, nameSrcLoc)  data PromotionErr   = TyConPE          -- TyCon used in a kind before we are ready@@ -65,6 +71,17 @@ teCategory ClassTE = "class" teCategory TyConTE = "type constructor" teCategory TyVarTE = "type variable"++data TermLevelUseCtxt+  = TermLevelUseGRE !GlobalRdrElt+  | TermLevelUseTyVar+  deriving (Generic)++pprTermLevelUseCtxt :: Name -> TermLevelUseCtxt -> SDoc+pprTermLevelUseCtxt nm = \case+  TermLevelUseGRE gre -> pprNameProvenance gre+  TermLevelUseTyVar -> text "bound at" <+> ppr (nameSrcLoc nm)+  {- Note [Type variable scoping errors during typechecking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Tc/Solver/InertSet.hs view
@@ -1,38 +1,36 @@ {-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.Tc.Solver.InertSet (     -- * The work list     WorkList(..), isEmptyWorkList, emptyWorkList,     extendWorkListNonEq, extendWorkListCt,     extendWorkListCts, extendWorkListCtList,-    extendWorkListEq, extendWorkListEqs,-    appendWorkList, extendWorkListImplic,+    extendWorkListEq, extendWorkListChildEqs,+    extendWorkListRewrittenEqs,+    appendWorkList,     workListSize,-    selectWorkItem,      -- * The inert set     InertSet(..),     InertCans(..),-    emptyInert,+    emptyInertSet, emptyInertCans, -    noMatchableGivenDicts,     noGivenNewtypeReprEqs, updGivenEqs,-    mightEqualLater,     prohibitedSuperClassSolve,      -- * Inert equalities     InertEqs,     foldTyEqs, delEq, findEq,     partitionInertEqs, partitionFunEqs,+    filterInertEqs, filterFunEqs,     foldFunEqs, addEqToCans,      -- * Inert Dicts     updDicts, delDict, addDict, filterDicts, partitionDicts,-    addSolvedDict,+    addSolvedDict, lookupSolvedDict, lookupInertDict,      -- * Inert Irreds     InertIrreds, delIrred, addIrreds, addIrred, foldIrreds,@@ -63,28 +61,23 @@ import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set+import GHC.Types.Unique( hasKey ) import GHC.Types.Basic( SwapFlag(..) )  import GHC.Core.Reduction import GHC.Core.Predicate-import GHC.Core.TyCo.FVs import qualified GHC.Core.TyCo.Rep as Rep-import GHC.Core.Class( Class ) import GHC.Core.TyCon-import GHC.Core.Class( classTyCon )-import GHC.Core.Unify-+import GHC.Core.Class( Class, classTyCon )+import GHC.Builtin.Names( eqPrimTyConKey, heqTyConKey, eqTyConKey, coercibleTyConKey ) import GHC.Utils.Misc       ( partitionWith ) import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Data.Maybe import GHC.Data.Bag -import Data.List.NonEmpty ( NonEmpty(..), (<|) )-import qualified Data.List.NonEmpty as NE-import Data.Function ( on )- import Control.Monad      ( forM_ )+import Data.List.NonEmpty ( NonEmpty(..), (<|) )+import Data.Function      ( on )  {- ************************************************************************@@ -161,53 +154,47 @@   NB: since we do not currently apply the substitution to the   inert_solved_dicts, the knot-tying still seems a bit fragile.   But this makes it better.--Note [Residual implications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The wl_implics in the WorkList are the residual implication-constraints that are generated while solving or canonicalising the-current worklist.  Specifically, when canonicalising-   (forall a. t1 ~ forall a. t2)-from which we get the implication-   (forall a. t1 ~ t2)-See GHC.Tc.Solver.Monad.deferTcSForAllEq- -}  -- See Note [WorkList priorities] data WorkList   = WL { wl_eqs_N :: [Ct]  -- /Nominal/ equalities (s ~#N t), (s ~ t), (s ~~ t)-                           -- with empty rewriter set+                           -- with definitely-empty rewriter set+        , wl_eqs_X :: [Ct]  -- CEqCan, CDictCan, CIrredCan-                           -- with empty rewriter set+                           -- with definitely-empty rewriter set            -- All other equalities: contains both equality constraints and            -- their class-level variants (a~b) and (a~~b);            -- See Note [Prioritise equalities]            -- See Note [Prioritise class equalities] -       , wl_rw_eqs  :: [Ct]  -- Like wl_eqs, but ones that have a non-empty-                             -- rewriter set; or, more precisely, did when-                             -- added to the WorkList+       , wl_rw_eqs  :: [Ct]  -- Like wl_eqs, but ones that may have a non-empty+                             -- rewriter set          -- We prioritise wl_eqs over wl_rw_eqs;          -- see Note [Prioritise Wanteds with empty RewriterSet]          -- in GHC.Tc.Types.Constraint for more details.         , wl_rest :: [Ct]--       , wl_implics :: Bag Implication  -- See Note [Residual implications]     } +isNominalEqualityCt :: Ct -> Bool+-- A nominal equality, primitive or not,+--                     canonical or not+--     (s ~# t), (s ~ t), or (s ~~ t)+isNominalEqualityCt ct+  | Just tc <- tcTyConAppTyCon_maybe (ctPred ct)+  = tc `hasKey` eqPrimTyConKey || tc `hasKey` heqTyConKey || tc `hasKey` eqTyConKey+  | otherwise+  = False+ appendWorkList :: WorkList -> WorkList -> WorkList appendWorkList-    (WL { wl_eqs_N = eqs1_N, wl_eqs_X = eqs1_X, wl_rw_eqs = rw_eqs1-        , wl_rest = rest1, wl_implics = implics1 })-    (WL { wl_eqs_N = eqs2_N, wl_eqs_X = eqs2_X, wl_rw_eqs = rw_eqs2-        , wl_rest = rest2, wl_implics = implics2 })+    (WL { wl_eqs_N = eqs1_N, wl_eqs_X = eqs1_X, wl_rw_eqs = rw_eqs1, wl_rest = rest1 })+    (WL { wl_eqs_N = eqs2_N, wl_eqs_X = eqs2_X, wl_rw_eqs = rw_eqs2, wl_rest = rest2 })    = WL { wl_eqs_N   = eqs1_N   ++ eqs2_N         , wl_eqs_X   = eqs1_X   ++ eqs2_X         , wl_rw_eqs  = rw_eqs1  ++ rw_eqs2-        , wl_rest    = rest1    ++ rest2-        , wl_implics = implics1 `unionBags`   implics2 }+        , wl_rest    = rest1    ++ rest2 }  workListSize :: WorkList -> Int workListSize (WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X, wl_rw_eqs = rw_eqs, wl_rest = rest })@@ -219,26 +206,28 @@   | isEmptyRewriterSet rewriters      -- A wanted that has not been rewritten     -- isEmptyRewriterSet: see Note [Prioritise Wanteds with empty RewriterSet]     --                         in GHC.Tc.Types.Constraint-  = if isNomEqPred (ctPred ct)+  = if isNominalEqualityCt ct     then wl { wl_eqs_N = ct : eqs_N }     else wl { wl_eqs_X = ct : eqs_X }    | otherwise   = wl { wl_rw_eqs = ct : rw_eqs } -extendWorkListEqs :: RewriterSet -> Bag Ct -> WorkList -> WorkList+extendWorkListChildEqs :: CtEvidence -> Bag Ct -> WorkList -> WorkList -- Add [eq1,...,eqn] to the work-list--- They all have the same rewriter set -- The constraints will be solved in left-to-right order: --   see Note [Work-list ordering] in GHC.Tc.Solver.Equality --+-- Precondition: if the parent constraint has an empty+--               rewriter set, so will the new equalities -- Precondition: new_eqs is non-empty-extendWorkListEqs rewriters new_eqs+extendWorkListChildEqs parent_ev new_eqs     wl@(WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X, wl_rw_eqs = rw_eqs })-  | isEmptyRewriterSet rewriters+  | isEmptyRewriterSet (ctEvRewriters parent_ev)     -- isEmptyRewriterSet: see Note [Prioritise Wanteds with empty RewriterSet]     --                         in GHC.Tc.Types.Constraint-  = case partitionBag is_nominal new_eqs of+    -- If the rewriter set is empty, add to wl_eqs_X and wl_eqs_N+  = case partitionBag isNominalEqualityCt new_eqs of        (new_eqs_N, new_eqs_X)           | isEmptyBag new_eqs_N -> wl { wl_eqs_X = new_eqs_X `push_on_front` eqs_X }           | isEmptyBag new_eqs_X -> wl { wl_eqs_N = new_eqs_N `push_on_front` eqs_N }@@ -247,22 +236,22 @@           -- These isEmptyBag tests are just trying           -- to avoid creating unnecessary thunks -  | otherwise+  | otherwise  -- If the rewriter set is non-empty, add to wl_rw_eqs   = wl { wl_rw_eqs = new_eqs `push_on_front` rw_eqs }   where     push_on_front :: Bag Ct -> [Ct] -> [Ct]-    -- push_on_front puts the new equlities on the front of the queue+    -- push_on_front puts the new equalities on the front of the queue     push_on_front new_eqs eqs = foldr (:) eqs new_eqs -    is_nominal ct = isNomEqPred (ctPred ct)+extendWorkListRewrittenEqs :: [EqCt] -> WorkList -> WorkList+-- Don't bother checking the RewriterSet: just pop them into wl_rw_eqs+extendWorkListRewrittenEqs new_eqs wl@(WL { wl_rw_eqs = rw_eqs })+  = wl { wl_rw_eqs = foldr ((:) . CEqCan) rw_eqs new_eqs }  extendWorkListNonEq :: Ct -> WorkList -> WorkList -- Extension by non equality extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl } -extendWorkListImplic :: Implication -> WorkList -> WorkList-extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl }- extendWorkListCt :: Ct -> WorkList -> WorkList -- Agnostic about what kind of constraint extendWorkListCt ct wl@@ -287,27 +276,17 @@  isEmptyWorkList :: WorkList -> Bool isEmptyWorkList (WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X-                    , wl_rest = rest, wl_implics = implics })-  = null eqs_N && null eqs_X && null rest && isEmptyBag implics+                    , wl_rw_eqs = rw_eqs, wl_rest = rest })+  = null eqs_N && null eqs_X && null rw_eqs && null rest  emptyWorkList :: WorkList emptyWorkList = WL { wl_eqs_N = [], wl_eqs_X = []-                   , wl_rw_eqs = [], wl_rest = [], wl_implics = emptyBag }--selectWorkItem :: WorkList -> Maybe (Ct, WorkList)--- See Note [Prioritise equalities]-selectWorkItem wl@(WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X-                      , wl_rw_eqs = rw_eqs, wl_rest = rest })-  | ct:cts <- eqs_N  = Just (ct, wl { wl_eqs_N  = cts })-  | ct:cts <- eqs_X  = Just (ct, wl { wl_eqs_X  = cts })-  | ct:cts <- rw_eqs = Just (ct, wl { wl_rw_eqs = cts })-  | ct:cts <- rest   = Just (ct, wl { wl_rest   = cts })-  | otherwise        = Nothing+                   , wl_rw_eqs = [], wl_rest = [] }  -- Pretty printing instance Outputable WorkList where-  ppr (WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X, wl_rw_eqs = rw_eqs-          , wl_rest = rest, wl_implics = implics })+  ppr (WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X+          , wl_rw_eqs = rw_eqs, wl_rest = rest })    = text "WL" <+> (braces $      vcat [ ppUnless (null eqs_N) $             text "Eqs_N =" <+> vcat (map ppr eqs_N)@@ -317,9 +296,6 @@             text "RwEqs =" <+> vcat (map ppr rw_eqs)           , ppUnless (null rest) $             text "Non-eqs =" <+> vcat (map ppr rest)-          , ppUnless (isEmptyBag implics) $-            ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics)))-                       (text "(Implics omitted)")           ])  {- *********************************************************************@@ -344,6 +320,10 @@               -- Canonical Given, Wanted               -- Sometimes called "the inert set" +       , inert_givens :: InertCans+              -- A subset of inert_cans, containing only Givens+              -- Used to initialise inert_cans when recursing inside implications+        , inert_cycle_breakers :: CycleBreakerVarStack         , inert_famapp_cache :: FunEqMap Reduction@@ -361,35 +341,49 @@               -- Always a dictionary solved by an instance decl; never an implict parameter               -- See Note [Solved dictionaries]               -- and Note [Do not add superclasses of solved dictionaries]++       , inert_safehask :: DictMap DictCt+              -- Failed dictionary resolution due to Safe Haskell overlapping+              -- instances restriction. We keep this separate from inert_dicts+              -- as it doesn't cause compilation failure, just safe inference+              -- failure.+              --+              -- ^ See Note [Safe Haskell Overlapping Instances Implementation]+              -- in GHC.Tc.Solver        }  instance Outputable InertSet where   ppr (IS { inert_cans = ics+          , inert_safehask = safehask           , inert_solved_dicts = solved_dicts })       = vcat [ ppr ics              , ppUnless (null dicts) $-               text "Solved dicts =" <+> vcat (map ppr dicts) ]+               text "Solved dicts =" <+> vcat (map ppr dicts)+             , ppUnless (isEmptyTcAppMap safehask) $+               text "Safe Haskell unsafe overlap =" <+> pprBag (dictsToBag safehask) ]          where            dicts = bagToList (dictsToBag solved_dicts) -emptyInertCans :: InertCans-emptyInertCans+emptyInertCans :: TcLevel -> InertCans+emptyInertCans given_eq_lvl   = IC { inert_eqs          = emptyTyEqs        , inert_funeqs       = emptyFunEqs-       , inert_given_eq_lvl = topTcLevel+       , inert_given_eq_lvl = given_eq_lvl        , inert_given_eqs    = False        , inert_dicts        = emptyDictMap-       , inert_safehask     = emptyDictMap-       , inert_insts        = []+       , inert_qcis         = []        , inert_irreds       = emptyBag } -emptyInert :: InertSet-emptyInert-  = IS { inert_cans           = emptyInertCans+emptyInertSet :: TcLevel -> InertSet+emptyInertSet given_eq_lvl+  = IS { inert_cans           = empty_cans+       , inert_givens         = empty_cans        , inert_cycle_breakers = emptyBag :| []        , inert_famapp_cache   = emptyFunEqs-       , inert_solved_dicts   = emptyDictMap }-+       , inert_solved_dicts   = emptyDictMap+       , inert_safehask       = emptyDictMap }+  where+    empty_cans = emptyInertCans given_eq_lvl  {- Note [Solved dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -677,6 +671,23 @@    imply nominal ones. For example, if (G a ~R G b) and G's argument's    role is nominal, then we can deduce a ~N b. +(TGE6) A subtle point is this: when initialising the solver, giving it+   an empty InertSet, we must conservatively initialise `inert_given_lvl`+   to the /current/ TcLevel.  This matters when doing let-generalisation.+   Consider #26004:+      f w e = case e of+                  T1 -> let y = not w in False   -- T1 is a GADT+                  T2 -> True+   When let-generalising `y`, we will have (w :: alpha[1]) in the type+   envt; and we are under GADT pattern match.  So when we solve the+   constraints from y's RHS, in simplifyInfer, we must NOT unify+       alpha[1] := Bool+   Since we don't know what enclosing equalities there are, we just+   conservatively assume that there are some.++   This initialisation in done in `runTcSWithEvBinds`, which passes+   the current TcLevel to `emptyInertSet`.+ Historical note: prior to #24938 we also ignored Given equalities that did not mention an "outer" type variable.  But that is wrong, as #24938 showed. Another example is immortalised in test LocalGivenEqs2@@ -1237,16 +1248,8 @@               -- All fully rewritten (modulo flavour constraints)               --     wrt inert_eqs -       , inert_insts :: [QCInst]--       , inert_safehask :: DictMap DictCt-              -- Failed dictionary resolution due to Safe Haskell overlapping-              -- instances restriction. We keep this separate from inert_dicts-              -- as it doesn't cause compilation failure, just safe inference-              -- failure.-              ---              -- ^ See Note [Safe Haskell Overlapping Instances Implementation]-              -- in GHC.Tc.Solver+       , inert_qcis :: [QCInst] -- See Note [Quantified constraints]+                                -- in GHC.Tc.Solver.Solve         , inert_irreds :: InertIrreds               -- Irreducible predicates that cannot be made canonical,@@ -1275,11 +1278,10 @@   ppr (IC { inert_eqs = eqs           , inert_funeqs = funeqs           , inert_dicts = dicts-          , inert_safehask = safehask           , inert_irreds = irreds           , inert_given_eq_lvl = ge_lvl           , inert_given_eqs = given_eqs-          , inert_insts = insts })+          , inert_qcis = insts })      = braces $ vcat       [ ppUnless (isEmptyDVarEnv eqs) $@@ -1290,8 +1292,6 @@           <+> pprBag (foldFunEqs consBag funeqs emptyBag)       , ppUnless (isEmptyTcAppMap dicts) $         text "Dictionaries =" <+> pprBag (dictsToBag dicts)-      , ppUnless (isEmptyTcAppMap safehask) $-        text "Safe Haskell unsafe overlap =" <+> pprBag (dictsToBag safehask)       , ppUnless (isEmptyBag irreds) $         text "Irreds =" <+> pprBag irreds       , ppUnless (null insts) $@@ -1377,6 +1377,17 @@ addInertEqs eq_ct@(EqCt { eq_lhs = TyVarLHS tv }) eqs = addTyEq eqs tv eq_ct addInertEqs other _ = pprPanic "extendInertEqs" (ppr other) +-- | Filter InertEqs according to a predicate+filterInertEqs :: (EqCt -> Bool) -> InertEqs -> InertEqs+filterInertEqs f = mapMaybeDVarEnv g+  where+    g xs =+      let filtered = filter f xs+      in+        if null filtered+        then Nothing+        else Just filtered+ ------------------------  addCanFunEq :: InertFunEqs -> TyCon -> [TcType] -> EqCt -> InertFunEqs@@ -1400,7 +1411,16 @@   = addCanFunEq fun_eqs tc args eq_ct addFunEqs other _ = pprPanic "extendFunEqs" (ppr other) -+-- | Filter entries in InertFunEqs that satisfy the predicate+filterFunEqs :: (EqCt -> Bool) -> InertFunEqs -> InertFunEqs+filterFunEqs f = mapMaybeTcAppMap g+  where+    g xs =+      let filtered = filter f xs+      in+        if null filtered+        then Nothing+        else Just filtered  {- ********************************************************************* *                                                                      *@@ -1408,6 +1428,17 @@ *                                                                      * ********************************************************************* -} +-- | Look up a dictionary inert.+lookupInertDict :: InertCans -> Class -> [Type] -> Maybe DictCt+lookupInertDict (IC { inert_dicts = dicts }) cls tys+  = findDict dicts cls tys++-- | Look up a solved inert.+lookupSolvedDict :: InertSet -> Class -> [Type] -> Maybe CtEvidence+-- Returns just if exactly this predicate type exists in the solved.+lookupSolvedDict (IS { inert_solved_dicts = solved }) cls tys+  = fmap dictCtEvidence (findDict solved cls tys)+ updDicts :: (DictMap DictCt -> DictMap DictCt) -> InertCans -> InertCans updDicts upd ics = ics { inert_dicts = upd (inert_dicts ics) } @@ -1574,19 +1605,18 @@ kickOutRewritableLHS :: KickOutSpec -> CtFlavourRole -> InertCans -> (Cts, InertCans) -- See Note [kickOutRewritable] kickOutRewritableLHS ko_spec new_fr@(_, new_role)-                     ics@(IC { inert_eqs      = tv_eqs-                             , inert_dicts    = dictmap-                             , inert_funeqs   = funeqmap-                             , inert_irreds   = irreds-                             , inert_insts    = old_insts })+                     ics@(IC { inert_eqs     = tv_eqs+                             , inert_dicts   = dictmap+                             , inert_funeqs  = funeqmap+                             , inert_irreds  = irreds+                             , inert_qcis    = old_insts })   = (kicked_out, inert_cans_in)   where-    -- inert_safehask stays unchanged; is that right?-    inert_cans_in = ics { inert_eqs      = tv_eqs_in-                        , inert_dicts    = dicts_in-                        , inert_funeqs   = feqs_in-                        , inert_irreds   = irs_in-                        , inert_insts    = insts_in }+    inert_cans_in = ics { inert_eqs     = tv_eqs_in+                        , inert_dicts   = dicts_in+                        , inert_funeqs  = feqs_in+                        , inert_irreds  = irs_in+                        , inert_qcis    = insts_in }      kicked_out :: Cts     kicked_out = (fmap CDictCan dicts_out `andCts` fmap CIrredCan irs_out)@@ -1824,114 +1854,36 @@   | otherwise  = False  -- Coercion variables; doesn't much matter  noGivenNewtypeReprEqs :: TyCon -> InertSet -> Bool--- True <=> there is no Irred looking like (N tys1 ~ N tys2)--- See Note [Decomposing newtype equalities] (EX2) in GHC.Tc.Solver.Equality---     This is the only call site.-noGivenNewtypeReprEqs tc inerts-  = not (anyBag might_help (inert_irreds (inert_cans inerts)))-  where-    might_help irred-      = case classifyPredType (ctEvPred (irredCtEvidence irred)) of-          EqPred ReprEq t1 t2-             | Just (tc1,_) <- tcSplitTyConApp_maybe t1-             , tc == tc1-             , Just (tc2,_) <- tcSplitTyConApp_maybe t2-             , tc == tc2-             -> True-          _  -> False---- | Returns True iff there are no Given constraints that might,--- potentially, match the given class constraint. This is used when checking to see if a--- Given might overlap with an instance. See Note [Instance and Given overlap]--- in GHC.Tc.Solver.Dict-noMatchableGivenDicts :: InertSet -> CtLoc -> Class -> [TcType] -> Bool-noMatchableGivenDicts inerts@(IS { inert_cans = inert_cans }) loc_w clas tys-  = not $ anyBag matchable_given $-    findDictsByClass (inert_dicts inert_cans) clas+-- True <=> there is no Given looking like (N tys1 ~ N tys2)+-- See Note [Decomposing newtype equalities] (EX3) in GHC.Tc.Solver.Equality+noGivenNewtypeReprEqs tc (IS { inert_cans = inerts })+  | IC { inert_irreds = irreds, inert_qcis = quant_cts } <- inerts+  = not (anyBag might_help_irred irreds || any might_help_qc quant_cts)+    -- Look in both inert_irreds /and/ inert_qcis (#26020)   where-    pred_w = mkClassPred clas tys--    matchable_given :: DictCt -> Bool-    matchable_given (DictCt { di_ev = ev })-      | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ev-      = isJust $ mightEqualLater inerts pred_g loc_g pred_w loc_w-+    might_help_irred (IrredCt { ir_ev = ev })+      | EqPred ReprEq t1 t2 <- classifyPredType (ctEvPred ev)+      = headed_by_tc t1 t2       | otherwise       = False -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.Dict-mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc-  | prohibitedSuperClassSolve given_loc wanted_loc-  = Nothing--  | otherwise-  = case tcUnifyTysFG bind_fun [flattened_given] [flattened_wanted] of-      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]--    -- NB: flatten both at the same time, so that we can share mappings-    -- from type family applications to variables, and also to guarantee-    -- that the fresh variables are really fresh between the given and-    -- the wanted. Flattening both at the same time is needed to get-    -- Example 10 from the Note.-    ([flattened_given, flattened_wanted], var_mapping)-      = flattenTysX in_scope [given_pred, wanted_pred]--    bind_fun :: BindFun-    bind_fun tv rhs_ty-      | isMetaTyVar tv-      , can_unify tv (metaTyVarInfo tv) rhs_ty-         -- this checks for CycleBreakerTvs and TyVarTvs; forgetting-         -- the latter was #19106.-      = BindMe--         -- See Examples 4, 5, and 6 from the Note-      | Just (_fam_tc, fam_args) <- lookupVarEnv var_mapping tv-      , anyFreeVarsOfTypes mentions_meta_ty_var fam_args-      = BindMe-+    might_help_qc (QCI { qci_ev = ev, qci_body = pred })+      | isGiven ev+      , ClassPred cls [_, t1, t2] <- classifyPredType pred+      , cls `hasKey` coercibleTyConKey+      = headed_by_tc t1 t2       | otherwise-      = Apart+      = False -    -- True for TauTv and TyVarTv (and RuntimeUnkTv) meta-tyvars-    -- (as they can be unified)-    -- and also for CycleBreakerTvs that mentions meta-tyvars-    mentions_meta_ty_var :: TyVar -> Bool-    mentions_meta_ty_var tv-      | isMetaTyVar tv-      = case metaTyVarInfo tv of-          -- See Examples 8 and 9 in the Note-          CycleBreakerTv-            -> anyFreeVarsOfType mentions_meta_ty_var-                 (lookupCycleBreakerVar tv inert_set)-          _ -> True+    headed_by_tc t1 t2+      | Just (tc1,_) <- tcSplitTyConApp_maybe t1+      , tc == tc1+      , Just (tc2,_) <- tcSplitTyConApp_maybe t2+      , tc == tc2+      = True       | otherwise       = False -    -- Like checkTopShape, but allows cbv variables to unify-    can_unify :: TcTyVar -> MetaInfo -> Type -> Bool-    can_unify _lhs_tv TyVarTv rhs_ty  -- see Example 3 from the Note-      | Just rhs_tv <- getTyVar_maybe rhs_ty-      = case tcTyVarDetails rhs_tv of-          MetaTv { mtv_info = TyVarTv } -> True-          MetaTv {}                     -> False  -- Could unify with anything-          SkolemTv {}                   -> True-          RuntimeUnk                    -> True-      | otherwise  -- not a var on the RHS-      = False-    can_unify lhs_tv _other _rhs_ty = mentions_meta_ty_var lhs_tv- -- | Is it (potentially) loopy to use the first @ct1@ to solve @ct2@? -- -- Necessary (but not sufficient) conditions for this function to return @True@:@@ -1953,155 +1905,13 @@   | otherwise   = False -{- Note [What might equal later?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must determine whether a Given might later equal a Wanted. We-definitely need to account for the possibility that any metavariable-might be arbitrarily instantiated. Yet we do *not* want-to allow skolems in to be instantiated, as we've already rewritten-with respect to any Givens. (We're solving a Wanted here, and so-all Givens have already been processed.) -This is best understood by example.--1. C alpha  ~?  C Int--   That given certainly might match later.--2. C a  ~?  C Int--   No. No new givens are going to arise that will get the `a` to rewrite-   to Int.--3. C alpha[tv]   ~?  C Int--   That alpha[tv] is a TyVarTv, unifiable only with other type variables.-   It cannot equal later.--4. C (F alpha)   ~?   C Int--   Sure -- that can equal later, if we learn something useful about alpha.--5. C (F alpha[tv])  ~?  C Int--   This, too, might equal later. Perhaps we have [G] F b ~ Int elsewhere.-   Or maybe we have C (F alpha[tv] beta[tv]), these unify with each other,-   and F x x = Int. Remember: returning True doesn't commit ourselves to-   anything.--6. C (F a)  ~?  C a--   No, this won't match later. If we could rewrite (F a) or a, we would-   have by now. But see also Red Herring below.--7. C (Maybe alpha)  ~?  C alpha--   We say this cannot equal later, because it would require-   alpha := Maybe (Maybe (Maybe ...)). While such a type can be contrived,-   we choose not to worry about it. See Note [Infinitary substitution in lookup]-   in GHC.Core.InstEnv. Getting this wrong let to #19107, tested in-   typecheck/should_compile/T19107.--8. C cbv   ~?  C Int-   where cbv = F a--   The cbv is a cycle-breaker var which stands for F a. See-   Note [Type equality cycles] in GHC.Tc.Solver.Equality-   This is just like case 6, and we say "no". Saying "no" here is-   essential in getting the parser to type-check, with its use of DisambECP.--9. C cbv   ~?   C Int-   where cbv = F alpha--   Here, we might indeed equal later. Distinguishing between-   this case and Example 8 is why we need the InertSet in mightEqualLater.--10. C (F alpha, Int)  ~?  C (Bool, F alpha)--   This cannot equal later, because F a would have to equal both Bool and-   Int.--To deal with type family applications, we use the Core flattener. See-Note [Flattening type-family applications when matching instances] in GHC.Core.Unify.-The Core flattener replaces all type family applications with-fresh variables. The next question: should we allow these fresh-variables in the domain of a unifying substitution?--A type family application that mentions only skolems (example 6) is settled:-any skolems would have been rewritten w.r.t. Givens by now. These type family-applications match only themselves. A type family application that mentions-metavariables, on the other hand, can match anything. So, if the original type-family application contains a metavariable, we use BindMe to tell the unifier-to allow it in the substitution. On the other hand, a type family application-with only skolems is considered rigid.--This treatment fixes #18910 and is tested in-typecheck/should_compile/InstanceGivenOverlap{,2}--Red Herring-~~~~~~~~~~~-In #21208, we have this scenario:--instance forall b. C b-[G] C a[sk]-[W] C (F a[sk])--What should we do with that wanted? According to the logic above, the Given-cannot match later (this is example 6), and so we use the global instance.-But wait, you say: What if we learn later (say by a future type instance F a = a)-that F a unifies with a? That looks like the Given might really match later!--This mechanism described in this Note is *not* about this kind of situation, however.-It is all asking whether a Given might match the Wanted *in this run of the solver*.-It is *not* about whether a variable might be instantiated so that the Given matches,-or whether a type instance introduced in a downstream module might make the Given match.-The reason we care about what might match later is only about avoiding order-dependence.-That is, we don't want to commit to a course of action that depends on seeing constraints-in a certain order. But an instantiation of a variable and a later type instance-don't introduce order dependency in this way, and so mightMatchLater is right to ignore-these possibilities.--Here is an example, with no type families, that is perhaps clearer:--instance forall b. C (Maybe b)-[G] C (Maybe Int)-[W] C (Maybe a)--What to do? We *might* say that the Given could match later and should thus block-us from using the global instance. But we don't do this. Instead, we rely on class-coherence to say that choosing the global instance is just fine, even if later we-call a function with (a := Int). After all, in this run of the solver, [G] C (Maybe Int)-will definitely never match [W] C (Maybe a). (Recall that we process Givens before-Wanteds, so there is no [G] a ~ Int hanging about unseen.)--Interestingly, in the first case (from #21208), the behavior changed between-GHC 8.10.7 and GHC 9.2, with the latter behaving correctly and the former-reporting overlapping instances.--Test case: typecheck/should_compile/T21208.---}- {- ********************************************************************* *                                                                      *     Cycle breakers *                                                                      * ********************************************************************* -} --- | Return the type family application a CycleBreakerTv maps to.-lookupCycleBreakerVar :: TcTyVar    -- ^ cbv, must be a CycleBreakerTv-                      -> InertSet-                      -> TcType     -- ^ type family application the cbv maps to-lookupCycleBreakerVar cbv (IS { inert_cycle_breakers = cbvs_stack })--- This function looks at every environment in the stack. This is necessary--- to avoid #20231. This function (and its one usage site) is the only reason--- that we store a stack instead of just the top environment.-  | Just tyfam_app <- assert (isCycleBreakerTyVar cbv) $-                      firstJusts (NE.map (lookupBag cbv) cbvs_stack)-  = tyfam_app-  | otherwise-  = pprPanic "lookupCycleBreakerVar found an unbound cycle breaker" (ppr cbv $$ ppr cbvs_stack)- -- | Push a fresh environment onto the cycle-breaker var stack. Useful -- when entering a nested implication. pushCycleBreakerVarStack :: CycleBreakerVarStack -> CycleBreakerVarStack@@ -2151,45 +1961,55 @@ -- We can always solve one from the other: even if both are wanted, -- although we don't rewrite wanteds with wanteds, we can combine -- two wanteds into one by solving one from the other+--+-- Compare the corresponding function for equalities:+--      GHC.Tc.Solver.Equality.inertEqsCanDischarge  solveOneFromTheOther ct_i ct_w-  | CtWanted { ctev_loc = loc_w } <- ev_w+  | CtWanted {} <- ev_w   , prohibitedSuperClassSolve loc_i loc_w   -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance   = -- Inert must be Given     KeepWork -  | CtWanted {} <- ev_w+  | CtWanted (WantedCt { ctev_rewriters = rw_w }) <- ev_w   = -- Inert is Given or Wanted     case ev_i of       CtGiven {} -> KeepInert         -- work is Wanted; inert is Given: easy choice. -      CtWanted {} -- Both are Wanted+      CtWanted (WantedCt { ctev_rewriters = rw_i }) -- Both are Wanted         -- If only one has no pending superclasses, use it         -- Otherwise we can get infinite superclass expansion (#22516)         -- in silly cases like   class C T b => C a b where ...-        | not is_psc_i, is_psc_w     -> KeepInert-        | is_psc_i,     not is_psc_w -> KeepWork+        | Just res <- better (not is_psc_i) (not is_psc_w)+        -> res +        -- If only one has an empty rewriter set, use it+        -- c.f. GHC.Tc.Solver.Equality.inertsCanDischarge, and especially+        --      (CE4) in Note [Combining equalities]+        | Just res <- better (isEmptyRewriterSet rw_i) (isEmptyRewriterSet rw_w)+        -> res+         -- If only one is a WantedSuperclassOrigin (arising from expanding         -- a Wanted class constraint), keep the other: wanted superclasses         -- may be unexpected by users-        | not is_wsc_orig_i, is_wsc_orig_w     -> KeepInert-        | is_wsc_orig_i,     not is_wsc_orig_w -> KeepWork+        | Just res <- better (not is_wsc_orig_i) (not is_wsc_orig_w)+        -> res -        -- otherwise, just choose the lower span+        -- Otherwise, just choose the lower span         -- reason: if we have something like (abs 1) (where the         -- Num constraint cannot be satisfied), it's better to         -- get an error about abs than about 1.         -- This test might become more elaborate if we see an         -- opportunity to improve the error messages         | ((<) `on` ctLocSpan) loc_i loc_w -> KeepInert+         | otherwise                        -> KeepWork    -- From here on the work-item is Given -  | CtWanted { ctev_loc = loc_i } <- ev_i+  | CtWanted {} <- ev_i   , prohibitedSuperClassSolve loc_w loc_i   = KeepInert   -- Just discard the un-usable Given                 -- This never actually happens because@@ -2207,6 +2027,15 @@   | otherwise   -- Both are Given, levels differ   = different_level_strategy   where+     better :: Bool -> Bool -> Maybe InteractResult+     -- (better inert-is-good wanted-is-good) returns+     --   Just KeepWork  if wanted is strictly better than inert+     --   Just KeepInert if inert is strictly better than wanted+     --   Nothing if they are the same+     better True False = Just KeepInert+     better False True = Just KeepWork+     better _     _    = Nothing+      ev_i  = ctEvidence ct_i      ev_w  = ctEvidence ct_w @@ -2226,10 +2055,10 @@      is_wsc_orig_w = isWantedSuperclassOrigin orig_w       different_level_strategy  -- Both Given-       | isIPLikePred pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork  else KeepInert-       | otherwise         = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork+       | couldBeIPLike pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork  else KeepInert+       | otherwise          = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork        -- See Note [Replacement vs keeping] part (1)-       -- For the isIPLikePred case see Note [Shadowing of implicit parameters]+       -- For the couldBeIPLike case see Note [Shadowing of implicit parameters]        --                               in GHC.Tc.Solver.Dict       same_level_strategy -- Both Given@@ -2275,18 +2104,8 @@        (a) If both are GivenSCOrigin, choose the one that is unblocked if possible            according to Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance. -       (b) Prefer constraints that are not superclass selections. Example:--             f :: (Eq a, Ord a) => a -> Bool-             f x = x == x--           Eager superclass expansion gives us two [G] Eq a constraints. We-           want to keep the one from the user-written Eq a, not the superclass-           selection. This means we report the Ord a as redundant with-           -Wredundant-constraints, not the Eq a.--           Getting this wrong was #20602. See also-           Note [Tracking redundant constraints] in GHC.Tc.Solver.+       (b) Prefer constraints that are not superclass selections. See+           (TRC3) in Note [Tracking redundant constraints] in GHC.Tc.Solver.         (c) If both are GivenSCOrigin, chooose the one with the shallower            superclass-selection depth, in the hope of identifying more correct@@ -2320,3 +2139,4 @@ (Actually I think that the order in which the work-list is processed means that this chain of events won't happen, but that's very fragile.) -}+
compiler/GHC/Tc/Solver/Types.hs view
@@ -14,6 +14,7 @@      TcAppMap, emptyTcAppMap, isEmptyTcAppMap,     insertTcApp, alterTcApp, filterTcAppMap,+    mapMaybeTcAppMap,     tcAppMapToBag, foldTcAppMap, delTcApp,      EqualCtList, filterEqualCtList, addToEqualCtList@@ -23,8 +24,6 @@ import GHC.Prelude  import GHC.Tc.Types.Constraint-import GHC.Tc.Types.Origin-import GHC.Tc.Types.CtLoc( CtLoc, ctLocOrigin ) import GHC.Tc.Utils.TcType  import GHC.Types.Unique@@ -32,7 +31,6 @@  import GHC.Core.Class import GHC.Core.Map.Type-import GHC.Core.Predicate import GHC.Core.TyCon import GHC.Core.TyCon.Env @@ -114,6 +112,16 @@       where         filtered_tm = filterTM f tm +mapMaybeTcAppMap :: forall a b. (a -> Maybe b) -> TcAppMap a -> TcAppMap b+mapMaybeTcAppMap f m = mapMaybeDTyConEnv one_tycon m+  where+    one_tycon :: ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap b)+    one_tycon tm+      | isEmptyTM mapped_tm = Nothing+      | otherwise           = Just mapped_tm+      where+        mapped_tm = mapMaybeTM f tm+ tcAppMapToBag :: TcAppMap a -> Bag a tcAppMapToBag m = foldTcAppMap consBag m emptyBag @@ -131,13 +139,8 @@ emptyDictMap :: DictMap a emptyDictMap = emptyTcAppMap -findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a-findDict m loc cls tys-  | Just {} <- isCallStackPred cls tys-  , isPushCallStackOrigin (ctLocOrigin loc)-  = Nothing             -- See Note [Solving CallStack constraints]--  | otherwise+findDict :: DictMap a -> Class -> [Type] -> Maybe a+findDict m cls tys   = findTcApp m (classTyCon cls) tys  findDictsByClass :: DictMap a -> Class -> Bag a@@ -153,33 +156,6 @@  foldDicts :: (a -> b -> b) -> DictMap a -> b -> b foldDicts = foldTcAppMap--{- Note [Solving CallStack constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [Overview of implicit CallStacks] in GHc.Tc.Types.Evidence.--Suppose f :: HasCallStack => blah.  Then--* Each call to 'f' gives rise to-    [W] s1 :: IP "callStack" CallStack    -- CtOrigin = OccurrenceOf f-  with a CtOrigin that says "OccurrenceOf f".-  Remember that HasCallStack is just shorthand for-    IP "callStack" CallStack-  See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence--* We canonicalise such constraints, in GHC.Tc.Solver.Dict.canDictNC, by-  pushing the call-site info on the stack, and changing the CtOrigin-  to record that has been done.-   Bind:  s1 = pushCallStack <site-info> s2-   [W] s2 :: IP "callStack" CallStack   -- CtOrigin = IPOccOrigin--* Then, and only then, we can solve the constraint from an enclosing-  Given.--So we must be careful /not/ to solve 's1' from the Givens.  Again,-we ensure this by arranging that findDict always misses when looking-up such constraints.--}  {- ********************************************************************* *                                                                      *
compiler/GHC/Tc/Types.hs view
@@ -59,9 +59,15 @@         CompleteMatch, CompleteMatches,          -- Template Haskell-        ThStage(..), SpliceType(..), SpliceOrBracket(..), PendingStuff(..),-        topStage, topAnnStage, topSpliceStage,-        ThLevel, impLevel, outerLevel, thLevel,+        ThLevel(..), SpliceType(..), SpliceOrBracket(..), PendingStuff(..),+        topLevel, topAnnLevel, topSpliceLevel,+        ThLevelIndex,+        topLevelIndex,+        spliceLevelIndex,+        quoteLevelIndex,++        thLevelIndex,+         ForeignSrcLang(..), THDocs, DocLoc(..),         ThBindEnv, @@ -154,7 +160,6 @@ import GHC.Types.Unique.FM import GHC.Types.Basic import GHC.Types.CostCentre.State-import GHC.Types.HpcInfo  import GHC.Data.IOEnv import GHC.Data.Bag@@ -206,7 +211,11 @@  data ImpUserList   = ImpUserAll -- ^ no user import list-  | ImpUserExplicit !GlobalRdrEnv+  | ImpUserExplicit+      { iul_avails :: ![AvailInfo]+      , iul_non_explicit_parents :: !NameSet+        -- ^ The @T@s in import list items of the form @T(..)@+      }   | ImpUserEverythingBut !NameSet  -- | A 'NameShape' is a substitution on 'Name's that can be used@@ -498,6 +507,9 @@         tcg_fam_inst_env :: !FamInstEnv, -- ^ Ditto for family instances           -- NB. BangPattern is to fix a leak, see #15111         tcg_ann_env      :: AnnEnv,     -- ^ And for annotations+        tcg_complete_match_env :: CompleteMatches,+        -- ^ The complete matches for all /home-package/ modules;+        -- Includes the complete matches in tcg_complete_matches                  -- Now a bunch of things about this module that are simply                 -- accumulated, but never consulted until the end.@@ -556,11 +568,6 @@           -- is implicit rather than explicit, so we have to zap a           -- mutable variable. -        tcg_th_splice_used :: TcRef Bool,-          -- ^ @True@ \<=> A Template Haskell splice was used.-          ---          -- Splices disable recompilation avoidance (see #481)-         tcg_th_needed_deps :: TcRef ([Linkable], PkgsLoaded),           -- ^ The set of runtime dependencies required by this module           -- See Note [Object File Dependencies]@@ -646,10 +653,6 @@         tcg_hdr_info   :: (Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName)),         -- ^ Maybe Haddock header docs and Maybe located module name -        tcg_hpc       :: !AnyHpcUsage,       -- ^ @True@ if any part of the-                                             --  prog uses hpc instrumentation.-           -- NB. BangPattern is to fix a leak, see #15111-         tcg_self_boot :: SelfBootInfo,       -- ^ Whether this module has a                                              -- corresponding hi-boot file @@ -689,9 +692,10 @@           -- ^ Wanted constraints of static forms.         -- See Note [Constraints in static forms].         tcg_complete_matches :: !CompleteMatches,+        -- ^ Complete matches defined in this module. -        -- ^ Tracking indices for cost centre annotations         tcg_cc_st   :: TcRef CostCentreState,+        -- ^ Tracking indices for cost centre annotations          tcg_next_wrapper_num :: TcRef (ModuleEnv Int)         -- ^ See Note [Generating fresh names for FFI wrappers]@@ -908,6 +912,20 @@   where     add env (uid, elt) = extendInstalledModuleEnv env (mkModule uid (gwib_mod elt)) elt +plusDirectModDeps :: InstalledModuleEnv (S.Set ImportLevel, ModuleNameWithIsBoot)+            -> InstalledModuleEnv (S.Set ImportLevel, ModuleNameWithIsBoot)+            -> InstalledModuleEnv (S.Set ImportLevel, ModuleNameWithIsBoot)+plusDirectModDeps = plusInstalledModuleEnv plus_mod_dep+  where+    plus_mod_dep (st1, r1@(GWIB { gwib_mod = m1, gwib_isBoot = boot1 }))+                 (st2, r2@(GWIB {gwib_mod = m2, gwib_isBoot = boot2}))+      | assertPpr (m1 == m2) ((ppr m1 <+> ppr m2) $$ (ppr (boot1 == IsBoot) <+> ppr (boot2 == IsBoot)))+        boot1 == IsBoot = (st1 `S.union` st2, r2)+      | otherwise = (st1 `S.union` st2, r1)+      -- If either side can "see" a non-hi-boot interface, use that+      -- Reusing existing tuples saves 10% of allocations on test+      -- perf/compiler/MultiLayerModules+ plusModDeps :: InstalledModuleEnv ModuleNameWithIsBoot             -> InstalledModuleEnv ModuleNameWithIsBoot             -> InstalledModuleEnv ModuleNameWithIsBoot@@ -955,7 +973,7 @@                   imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2,                   imp_orphs = orphs2, imp_finsts = finsts2 })   = ImportAvails { imp_mods          = M.unionWith (++) mods1 mods2,-                   imp_direct_dep_mods = ddmods1 `plusModDeps` ddmods2,+                   imp_direct_dep_mods = ddmods1 `plusDirectModDeps` ddmods2,                    imp_dep_direct_pkgs      = ddpkgs1 `S.union` ddpkgs2,                    imp_trust_pkgs    = tpkgs1 `S.union` tpkgs2,                    imp_trust_own_pkg = tself1 || tself2,
compiler/GHC/Tc/Types/Constraint.hs view
@@ -1,5 +1,5 @@- {-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -17,7 +17,7 @@         isUnsatisfiableCt_maybe,         ctEvidence, updCtEvidence,         ctLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,-        ctRewriters,+        ctRewriters, ctHasNoRewriters, wantedCtHasNoRewriters,         ctEvId, wantedEvId_maybe, mkTcEqPredLikeEv,         mkNonCanonical, mkGivens,         tyCoVarsOfCt, tyCoVarsOfCts,@@ -38,7 +38,7 @@         CtIrredReason(..), isInsolubleReason,          CheckTyEqResult, CheckTyEqProblem, cteProblem, cterClearOccursCheck,-        cteOK, cteImpredicative, cteTypeFamily, cteCoercionHole,+        cteOK, cteImpredicative, cteTypeFamily,         cteInsolubleOccurs, cteSolubleOccurs, cterSetOccursCheckSoluble,         cteConcrete, cteSkolemEscape,         impredicativeProblem, insolubleOccursProblem, solubleOccursProblem,@@ -46,26 +46,28 @@         cterHasNoProblem, cterHasProblem, cterHasOnlyProblem, cterHasOnlyProblems,         cterRemoveProblem, cterHasOccursCheck, cterFromKind, -+        -- Equality left-hand sides, re-exported from GHC.Core.Predicate         CanEqLHS(..), canEqLHS_maybe, canTyFamEqLHS_maybe,         canEqLHSKind, canEqLHSType, eqCanEqLHS, +        -- Holes         Hole(..), HoleSort(..), isOutOfScopeHole,         DelayedError(..), NotConcreteError(..),-        NotConcreteReason(..),          WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,         isSolvedWC, andWC, unionsWC, mkSimpleWC, mkImplicWC,         addInsols, dropMisleading, addSimples, addImplics, addHoles,-        addNotConcreteError, addDelayedErrors,+        addNotConcreteError, addMultiplicityCoercionError, addDelayedErrors,         tyCoVarsOfWC, tyCoVarsOfWCList,         insolubleWantedCt, insolubleCt, insolubleIrredCt,         insolubleImplic, nonDefaultableTyVarsOfWC,+        approximateWCX, approximateWC,          Implication(..), implicationPrototype, checkTelescopeSkol,         ImplicStatus(..), isInsolubleStatus, isSolvedStatus,         UserGiven, getUserGivensFromImplics,         HasGivenEqs(..), checkImplicationInvariants,+        EvNeedSet(..), emptyEvNeedSet, unionEvNeedSet, extendEvNeedSet, delGivensFromEvNeedSet,          -- CtLocEnv         CtLocEnv(..), setCtLocEnvLoc, setCtLocEnvLvl, getCtLocEnvLoc, getCtLocEnvLvl, ctLocEnvInGeneratedCode,@@ -74,11 +76,16 @@         CtEvidence(..), TcEvDest(..),         isWanted, isGiven,         ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel,-        ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId,-        ctEvRewriters, ctEvUnique, tcEvDestUnique,+        ctEvExpr, ctEvTerm,+        ctEvCoercion, givenCtEvCoercion,+        ctEvEvId, wantedCtEvEvId,+        ctEvRewriters, setWantedCtEvRewriters, ctEvUnique, tcEvDestUnique,         ctEvRewriteRole, ctEvRewriteEqRel, setCtEvPredType, setCtEvLoc,         tyCoVarsOfCtEvList, tyCoVarsOfCtEv, tyCoVarsOfCtEvsList, +        -- CtEvidence constructors+        GivenCtEvidence(..), WantedCtEvidence(..),+         -- RewriterSet         RewriterSet(..), emptyRewriterSet, isEmptyRewriterSet,            -- exported concretely only for zonkRewriterSet@@ -99,11 +106,14 @@  import GHC.Prelude +import GHC.Core import GHC.Core.Predicate import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Class import GHC.Core.TyCon+import GHC.Core.TyCo.Ppr+ import GHC.Types.Name import GHC.Types.Var @@ -112,26 +122,24 @@ import GHC.Tc.Types.Origin import GHC.Tc.Types.CtLoc -import GHC.Core+import GHC.Builtin.Names -import GHC.Core.TyCo.Ppr-import GHC.Utils.FV import GHC.Types.Var.Set-import GHC.Builtin.Names import GHC.Types.Unique.Set+import GHC.Types.Name.Reader +import GHC.Utils.FV import GHC.Utils.Outputable-import GHC.Data.Bag import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Constants (debugIsOn)-import GHC.Types.Name.Reader +import GHC.Data.Bag+ import Data.Coerce import qualified Data.Semigroup as S import Control.Monad ( msum, when ) import Data.Maybe ( mapMaybe, isJust )-import Data.List.NonEmpty ( NonEmpty )  -- these are for CheckTyEqResult import Data.Word  ( Word8 )@@ -189,15 +197,24 @@ {-# INLINE assertFuelPreconditionStrict #-} assertFuelPreconditionStrict fuel = assertPpr (pendingFuel fuel) insufficientFuelError +-- | Constraint data Ct+  -- | A dictionary constraint (canonical)   = CDictCan      DictCt-  | CIrredCan     IrredCt      -- A "irreducible" constraint (non-canonical)-  | CEqCan        EqCt         -- A canonical equality constraint-  | CQuantCan     QCInst       -- A quantified constraint-  | CNonCanonical CtEvidence   -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad+  -- | An irreducible constraint (non-canonical)+  | CIrredCan     IrredCt+  -- | An equality constraint (canonical)+  | CEqCan        EqCt+  -- | A quantified constraint (canonical)+  | CQuantCan     QCInst+  -- | A non-canonical constraint+  --+  -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad+  | CNonCanonical CtEvidence  --------------- DictCt -------------- +-- | A canonical dictionary constraint data DictCt   -- e.g.  Num ty   = DictCt { di_ev  :: CtEvidence  -- See Note [Ct/evidence invariant] @@ -226,20 +243,26 @@ {- Note [Canonical equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ An EqCt is a canonical equality constraint, one that can live in the inert set,-and that can be used to rewrite other constrtaints. It satisfies these invariants:+and that can be used to rewrite other constraints. It satisfies these invariants:+   * (TyEq:OC) lhs does not occur in rhs (occurs check)               Note [EqCt occurs check]+   * (TyEq:F) rhs has no foralls       (this avoids substituting a forall for the tyvar in other types)+   * (TyEq:K) typeKind lhs `tcEqKind` typeKind rhs; Note [Ct kind invariant]+   * (TyEq:N) If the equality is representational, rhs is not headed by a saturated     application of a newtype TyCon. See GHC.Tc.Solver.Equality     Note [No top-level newtypes on RHS of representational equalities].     (Applies only when constructor of newtype is in scope.)+   * (TyEq:U) An EqCt is not immediately unifiable. If we can unify a:=ty, we     will not form an EqCt (a ~ ty).+   * (TyEq:CH) rhs does not mention any coercion holes that resulted from fixing up-    a hetero-kinded equality.  See Note [Equalities with incompatible kinds] in+    a hetero-kinded equality.  See Note [Equalities with heterogeneous kinds] in     GHC.Tc.Solver.Equality, wrinkle (EIK2)  These invariants ensure that the EqCts in inert_eqs constitute a terminating@@ -257,10 +280,10 @@  * For type variables, the occurs-check looks deeply including kinds of   type variables. This is because a CEqCan over a meta-variable is-  also used to inform unification, in-  GHC.Tc.Solver.Monad.checkTouchableTyVarEq. If the LHS appears-  anywhere in the RHS, at all, unification will create an infinite-  structure which is bad.+  also used to inform unification, via `checkTyEqRhs`, called in+  `canEqCanLHSFinish_try_unification`.+  If the LHS appears anywhere in the RHS, at all, unification will create+  an infinite structure, which is bad.  * For type family applications, the occurs-check is shallow; it looks   only in places where we might rewrite. (Specifically, it does not@@ -279,7 +302,10 @@ in GHC.Tc.Solver.InertSet. -} -data EqCt -- An equality constraint; see Note [Canonical equalities]+-- | A canonical equality constraint.+--+-- See Note [Canonical equalities] in GHC.Tc.Types.Constraint.+data EqCt   = EqCt {  -- CanEqLHS ~ rhs       eq_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]       eq_lhs    :: CanEqLHS,@@ -287,17 +313,6 @@       eq_eq_rel :: EqRel       -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev     } --- | A 'CanEqLHS' is a type that can appear on the left of a canonical--- equality: a type variable or /exactly-saturated/ type family application.-data CanEqLHS-  = TyVarLHS TcTyVar-  | TyFamLHS TyCon  -- ^ TyCon of the family-             [Xi]   -- ^ Arguments, /exactly saturating/ the family--instance Outputable CanEqLHS where-  ppr (TyVarLHS tv)              = ppr tv-  ppr (TyFamLHS fam_tc fam_args) = ppr (mkTyConApp fam_tc fam_args)- eqCtEvidence :: EqCt -> CtEvidence eqCtEvidence = eq_ev @@ -330,18 +345,24 @@  --------------- QCInst -------------- -data QCInst  -- A much simplified version of ClsInst-             -- See Note [Quantified constraints] in GHC.Tc.Solver.Solve-  = QCI { qci_ev   :: CtEvidence -- Always of type forall tvs. context => ty-                                 -- Always Given-        , qci_tvs  :: [TcTyVar]  -- The tvs-        , qci_pred :: TcPredType -- The ty+-- | A quantified constraint, also called a "local instance"+-- (a simplified version of 'ClsInst').+--+-- See Note [Quantified constraints] in GHC.Tc.Solver.Solve+data QCInst+  -- | A quantified constraint, of type @forall tvs. context => ty@+  = QCI { qci_ev    :: CtEvidence -- See Note [Ct/evidence invariant]+        , qci_tvs   :: [TcTyVar]  -- ^ @tvs@+        , qci_theta :: TcThetaType+        , qci_body  :: TcPredType -- ^ the body of the @forall@, i.e. @ty@         , qci_pend_sc :: ExpansionFuel-             -- Invariants: qci_pend_sc > 0 =>-             --       (a) qci_pred is a ClassPred-             --       (b) this class has superclass(es), and-             --       (c) the superclass(es) are not explored yet-             -- Same as di_pend_sc flag in DictCt+             -- ^ Invariants: qci_pend_sc > 0 =>+             --+             --    (a) 'qci_body' is a ClassPred+             --    (b) this class has superclass(es), and+             --    (c) the superclass(es) are not explored yet+             --+             -- Same as 'di_pend_sc' flag in 'DictCt'              -- See Note [Expanding Recursive Superclasses and ExpansionFuel] in GHC.Tc.Solver     } @@ -360,20 +381,26 @@   = DE_Hole Hole     -- ^ A hole (in a type or in a term).     ---    -- See Note [Holes].+    -- See Note [Holes in expressions].   | DE_NotConcrete NotConcreteError     -- ^ A type could not be ensured to be concrete.     --     -- See Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete.+  | DE_Multiplicity TcCoercion CtLoc+    -- ^ An error if the TcCoercion isn't a reflexivity constraint.+    --+    -- See Note [Coercion errors in tcSubMult] in GHC.Tc.Utils.Unify. + instance Outputable DelayedError where   ppr (DE_Hole hole) = ppr hole   ppr (DE_NotConcrete err) = ppr err+  ppr (DE_Multiplicity co _) = ppr co  -- | A hole stores the information needed to report diagnostics -- about holes in terms (unbound identifiers or underscores) or -- in types (also called wildcards, as used in partial type--- signatures). See Note [Holes].+-- signatures). See Note [Holes in expressions] for holes in terms. data Hole   = Hole { hole_sort :: HoleSort -- ^ What flavour of hole is this?          , hole_occ  :: RdrName  -- ^ The name of this hole@@ -428,30 +455,8 @@       -- ^ Where did this check take place?     , nce_frr_origin :: FixedRuntimeRepOrigin       -- ^ Which representation-polymorphism check did we perform?-    , nce_reasons    :: NonEmpty NotConcreteReason-      -- ^ Why did the check fail?     } --- | Why did we decide that a type was not concrete?-data NotConcreteReason-  -- | The type contains a 'TyConApp' of a non-concrete 'TyCon'.-  ---  -- See Note [Concrete types] in GHC.Tc.Utils.Concrete.-  = NonConcreteTyCon TyCon [TcType]--  -- | The type contains a type variable that could not be made-  -- concrete (e.g. a skolem type variable).-  | NonConcretisableTyVar TyVar--  -- | The type contains a cast.-  | ContainsCast TcType TcCoercionN--  -- | The type contains a forall.-  | ContainsForall ForAllTyBinder TcType--  -- | The type contains a 'CoercionTy'.-  | ContainsCoercionTy TcCoercion- instance Outputable NotConcreteError where   ppr (NCE_FRR { nce_frr_origin = frr_orig })     = text "NCE_FRR" <+> parens (ppr (frr_type frr_orig))@@ -527,7 +532,7 @@ newtype CheckTyEqProblem = CTEP Word8  cteImpredicative, cteTypeFamily, cteInsolubleOccurs,-  cteSolubleOccurs, cteCoercionHole, cteConcrete,+  cteSolubleOccurs, cteConcrete,   cteSkolemEscape :: CheckTyEqProblem cteImpredicative   = CTEP (bit 0)   -- Forall or (=>) encountered cteTypeFamily      = CTEP (bit 1)   -- Type family encountered@@ -539,9 +544,11 @@    -- cteSolubleOccurs must be one bit to the left of cteInsolubleOccurs    -- See also Note [Insoluble mis-match] in GHC.Tc.Errors -cteCoercionHole    = CTEP (bit 4)   -- Coercion hole encountered+-- NB:  CTEP (bit 4) currently unused+ cteConcrete        = CTEP (bit 5)   -- Type variable that can't be made concrete                                     --    e.g. alpha[conc] ~ Maybe beta[tv]+ cteSkolemEscape    = CTEP (bit 6)   -- Skolem escape e.g.  alpha[2] ~ b[sk,4]  cteProblem :: CheckTyEqProblem -> CheckTyEqResult@@ -628,8 +635,7 @@           , (cteInsolubleOccurs, "cteInsolubleOccurs")           , (cteSolubleOccurs,   "cteSolubleOccurs")           , (cteConcrete,        "cteConcrete")-          , (cteSkolemEscape,    "cteSkolemEscape")-          , (cteCoercionHole,    "cteCoercionHole") ]+          , (cteSkolemEscape,    "cteSkolemEscape") ]  {- Note [CIrredCan constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -662,44 +668,6 @@ of the rhs. This is necessary because these constraints are used for substitutions during solving. If the kinds differed, then the substitution would take a well-kinded type to an ill-kinded one.--Note [Holes]-~~~~~~~~~~~~-This Note explains how GHC tracks *holes*.--A hole represents one of two conditions:- - A missing bit of an expression. Example: foo x = x + _- - A missing bit of a type. Example: bar :: Int -> _--What these have in common is that both cause GHC to emit a diagnostic to the-user describing the bit that is left out.--When a hole is encountered, a new entry of type Hole is added to the ambient-WantedConstraints. The type (hole_ty) of the hole is then simplified during-solving (with respect to any Givens in surrounding implications). It is-reported with all the other errors in GHC.Tc.Errors.--For expression holes, the user has the option of deferring errors until runtime-with -fdefer-type-errors. In this case, the hole actually has evidence: this-evidence is an erroring expression that prints an error and crashes at runtime.-The ExprHole variant of holes stores an IORef EvTerm that will contain this evidence;-during constraint generation, this IORef was stored in the HsUnboundVar extension-field by the type checker. The desugarer simply dereferences to get the CoreExpr.--Prior to fixing #17812, we used to invent an Id to hold the erroring-expression, and then bind it during type-checking. But this does not support-representation-polymorphic out-of-scope identifiers. See-typecheck/should_compile/T17812. We thus use the mutable-CoreExpr approach-described above.--You might think that the type in the HoleExprRef is the same as the type of the-hole. However, because the hole type (hole_ty) is rewritten with respect to-givens, this might not be the case. That is, the hole_ty is always (~) to the-type of the HoleExprRef, but they might not be `eqType`. We need the type of the generated-evidence to match what is expected in the context of the hole, and so we must-store these types separately.--Type-level holes have no evidence at all. -}  mkNonCanonical :: CtEvidence -> Ct@@ -709,9 +677,9 @@ mkGivens loc ev_ids   = map mk ev_ids   where-    mk ev_id = mkNonCanonical (CtGiven { ctev_evar = ev_id-                                       , ctev_pred = evVarPred ev_id-                                       , ctev_loc = loc })+    mk ev_id = mkNonCanonical (CtGiven (GivenCt { ctev_evar = ev_id+                                               , ctev_pred = evVarPred ev_id+                                               , ctev_loc = loc }))  ctEvidence :: Ct -> CtEvidence ctEvidence (CQuantCan (QCI { qci_ev = ev }))    = ev@@ -764,8 +732,8 @@ mkTcEqPredLikeEv :: CtEvidence -> TcType -> TcType -> TcType mkTcEqPredLikeEv ev   = case predTypeEqRel pred of-      NomEq  -> mkPrimEqPred-      ReprEq -> mkReprPrimEqPred+      NomEq  -> mkNomEqPred+      ReprEq -> mkReprEqPred   where     pred = ctEvPred ev @@ -794,45 +762,6 @@ instance Outputable EqCt where   ppr (EqCt { eq_ev = ev }) = ppr ev --------------------------------------- | Is a type a canonical LHS? That is, is it a tyvar or an exactly-saturated--- type family application?--- Does not look through type synonyms.-canEqLHS_maybe :: Xi -> Maybe CanEqLHS-canEqLHS_maybe xi-  | Just tv <- getTyVar_maybe xi-  = Just $ TyVarLHS tv--  | otherwise-  = canTyFamEqLHS_maybe xi--canTyFamEqLHS_maybe :: Xi -> Maybe CanEqLHS-canTyFamEqLHS_maybe xi-  | Just (tc, args) <- tcSplitTyConApp_maybe xi-  , isTypeFamilyTyCon tc-  , args `lengthIs` tyConArity tc-  = Just $ TyFamLHS tc args--  | otherwise-  = Nothing---- | Convert a 'CanEqLHS' back into a 'Type'-canEqLHSType :: CanEqLHS -> TcType-canEqLHSType (TyVarLHS tv) = mkTyVarTy tv-canEqLHSType (TyFamLHS fam_tc fam_args) = mkTyConApp fam_tc fam_args---- | Retrieve the kind of a 'CanEqLHS'-canEqLHSKind :: CanEqLHS -> TcKind-canEqLHSKind (TyVarLHS tv) = tyVarKind tv-canEqLHSKind (TyFamLHS fam_tc fam_args) = piResultTys (tyConKind fam_tc) fam_args---- | Are two 'CanEqLHS's equal?-eqCanEqLHS :: CanEqLHS -> CanEqLHS -> Bool-eqCanEqLHS (TyVarLHS tv1) (TyVarLHS tv2) = tv1 == tv2-eqCanEqLHS (TyFamLHS fam_tc1 fam_args1) (TyFamLHS fam_tc2 fam_args2)-  = tcEqTyConApps fam_tc1 fam_args1 fam_tc2 fam_args2-eqCanEqLHS _ _ = False- {- ************************************************************************ *                                                                      *@@ -951,6 +880,7 @@ tyCoFVsOfDelayedError :: DelayedError -> FV tyCoFVsOfDelayedError (DE_Hole hole) = tyCoFVsOfHole hole tyCoFVsOfDelayedError (DE_NotConcrete {}) = emptyFV+tyCoFVsOfDelayedError (DE_Multiplicity co _) = tyCoFVsOfCo co  tyCoFVsOfHole :: Hole -> FV tyCoFVsOfHole (Hole { hole_ty = ty }) = tyCoFVsOfType ty@@ -973,75 +903,6 @@ isGivenCt :: Ct -> Bool isGivenCt = isGiven . ctEvidence -{- Note [Custom type errors in constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When GHC reports a type-error about an unsolved-constraint, we check-to see if the constraint contains any custom-type errors, and if so-we report them.  Here are some examples of constraints containing type-errors:--TypeError msg           -- The actual constraint is a type error--TypError msg ~ Int      -- Some type was supposed to be Int, but ended up-                        -- being a type error instead--Eq (TypeError msg)      -- A class constraint is stuck due to a type error--F (TypeError msg) ~ a   -- A type function failed to evaluate due to a type err--It is also possible to have constraints where the type error is nested deeper,-for example see #11990, and also:--Eq (F (TypeError msg))  -- Here the type error is nested under a type-function-                        -- call, which failed to evaluate because of it,-                        -- and so the `Eq` constraint was unsolved.-                        -- This may happen when one function calls another-                        -- and the called function produced a custom type error.--}---- | A constraint is considered to be a custom type error, if it contains--- custom type errors anywhere in it.--- See Note [Custom type errors in constraints]-getUserTypeErrorMsg :: PredType -> Maybe ErrorMsgType-getUserTypeErrorMsg pred = msum $ userTypeError_maybe pred-                                  : map getUserTypeErrorMsg (subTys pred)-  where-   -- Richard thinks this function is very broken. What is subTys-   -- supposed to be doing? Why are exactly-saturated tyconapps special?-   -- What stops this from accidentally ripping apart a call to TypeError?-    subTys t = case splitAppTys t of-                 (t,[]) ->-                   case splitTyConApp_maybe t of-                              Nothing     -> []-                              Just (_,ts) -> ts-                 (t,ts) -> t : ts---- | Is this an user error message type, i.e. either the form @TypeError err@ or--- @Unsatisfiable err@?-isTopLevelUserTypeError :: PredType -> Bool-isTopLevelUserTypeError pred =-  isJust (userTypeError_maybe pred) || isJust (isUnsatisfiableCt_maybe pred)---- | Does this constraint contain an user error message?------ That is, the type is either of the form @Unsatisfiable err@, or it contains--- a type of the form @TypeError msg@, either at the top level or nested inside--- the type.-containsUserTypeError :: PredType -> Bool-containsUserTypeError pred =-  isJust (getUserTypeErrorMsg pred) || isJust (isUnsatisfiableCt_maybe pred)---- | Is this type an unsatisfiable constraint?--- If so, return the error message.-isUnsatisfiableCt_maybe :: Type -> Maybe ErrorMsgType-isUnsatisfiableCt_maybe t-  | Just (tc, [msg]) <- splitTyConApp_maybe t-  , tc `hasKey` unsatisfiableClassNameKey-  = Just msg-  | otherwise-  = Nothing- isPendingScDict :: Ct -> Bool isPendingScDict (CDictCan dict_ct) = isPendingScDictCt dict_ct isPendingScDict _                  = False@@ -1061,8 +922,9 @@  pendingScInst_maybe :: QCInst -> Maybe QCInst -- Same as isPendingScDict, but for QCInsts-pendingScInst_maybe qci@(QCI { qci_pend_sc = f })-  | pendingFuel f = Just (qci { qci_pend_sc = doNotExpand })+pendingScInst_maybe qci@(QCI { qci_ev = ev, qci_pend_sc = f })+  | isGiven ev -- Do not expand Wanted QCIs+  , pendingFuel f = Just (qci { qci_pend_sc = doNotExpand })   | otherwise     = Nothing  superClassesMightHelp :: WantedConstraints -> Bool@@ -1227,6 +1089,11 @@ addNotConcreteError wc err   = wc { wc_errors = unitBag (DE_NotConcrete err) `unionBags` wc_errors wc } +-- See Note [Coercion errors in tcSubMult] in GHC.Tc.Utils.Unify.+addMultiplicityCoercionError :: WantedConstraints -> TcCoercion -> CtLoc -> WantedConstraints+addMultiplicityCoercionError wc mult_co loc+  = wc { wc_errors = unitBag (DE_Multiplicity mult_co loc) `unionBags` wc_errors wc }+ addDelayedErrors :: WantedConstraints -> Bag DelayedError -> WantedConstraints addDelayedErrors wc errs   = wc { wc_errors = errs `unionBags` wc_errors wc }@@ -1248,12 +1115,16 @@            , wc_impl   = mapBag drop_implic implics            , wc_errors  = filterBag keep_delayed_error errors } -    keep_ct ct = case classifyPredType (ctPred ct) of-                    ClassPred {} -> False-                    _ -> True+    keep_ct ct+      = case classifyPredType (ctPred ct) of+           ClassPred cls _ -> isEqualityClass cls+             -- isEqualityClass: see (CERR2) in Note [Constraints and errors]+             --                  in GHC.Tc.Utils.Monad+           _ -> True      keep_delayed_error (DE_Hole hole) = isOutOfScopeHole hole     keep_delayed_error (DE_NotConcrete {}) = True+    keep_delayed_error (DE_Multiplicity {}) = True  isSolvedStatus :: ImplicStatus -> Bool isSolvedStatus (IC_Solved {}) = True@@ -1313,6 +1184,7 @@         = case err of             NCE_FRR { nce_frr_origin = frr } -> tyCoVarsOfType (frr_type frr)       non_defaultable_tvs_of_err (DE_Hole {}) = emptyVarSet+      non_defaultable_tvs_of_err (DE_Multiplicity {}) = emptyVarSet  insolubleWC :: WantedConstraints -> Bool insolubleWC (WC { wc_impl = implics, wc_simple = simples, wc_errors = errors })@@ -1323,6 +1195,7 @@   where       is_insoluble (DE_Hole hole) = isOutOfScopeHole hole -- See Note [Insoluble holes]       is_insoluble (DE_NotConcrete {}) = True+      is_insoluble (DE_Multiplicity {}) = False  insolubleWantedCt :: Ct -> Bool -- Definitely insoluble, in particular /excluding/ type-hole constraints@@ -1336,7 +1209,7 @@   | CIrredCan ir_ct <- ct       -- CIrredCan: see (IW1) in Note [Insoluble Wanteds]   , IrredCt { ir_ev = ev } <- ir_ct-  , CtWanted { ctev_loc = loc, ctev_rewriters = rewriters }  <- ev+  , CtWanted (WantedCt { ctev_loc = loc, ctev_rewriters = rewriters })  <- ev       -- It's a Wanted   , insolubleIrredCt ir_ct       -- It's insoluble@@ -1471,6 +1344,93 @@ insoluble, so that it trumps other errors during error reporting. Yuk! +-}++{- *********************************************************************+*                                                                      *+          Custom type errors: Unsatisfiable and TypeError+*                                                                      *+********************************************************************* -}++{- Note [Custom type errors in constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When GHC reports a type-error about an unsolved-constraint, we check+to see if the constraint contains any custom-type errors, and if so+we report them.  Here are some examples of constraints containing type+errors:++  TypeError msg           -- The actual constraint is a type error++  TypError msg ~ Int      -- Some type was supposed to be Int, but ended up+                          -- being a type error instead++  Eq (TypeError msg)      -- A class constraint is stuck due to a type error++  F (TypeError msg) ~ a   -- A type function failed to evaluate due to a type err++It is also possible to have constraints where the type error is nested deeper,+for example see #11990, and also:++  Eq (F (TypeError msg))  -- Here the type error is nested under a type-function+                          -- call, which failed to evaluate because of it,+                          -- and so the `Eq` constraint was unsolved.+                          -- This may happen when one function calls another+                          -- and the called function produced a custom type error.++A good use-case is described in "Detecting the undetectable"+   https://blog.csongor.co.uk/report-stuck-families/+which features+   type family Assert (err :: Constraint) (break :: Type -> Type) (a :: k) :: k where+     Assert _ Dummy _ = Any+     Assert _ _ k = k+and an unsolved constraint like+   Assert (TypeError ...) (F ty1) ty1 ~ ty2+that reports that (F ty1) remains stuck.+-}++-- | A constraint is considered to be a custom type error, if it contains+-- custom type errors anywhere in it.+-- See Note [Custom type errors in constraints]+getUserTypeErrorMsg :: PredType -> Maybe ErrorMsgType+getUserTypeErrorMsg pred = msum $ userTypeError_maybe pred+                                  : map getUserTypeErrorMsg (subTys pred)+  where+   -- Richard thinks this function is very broken. What is subTys+   -- supposed to be doing? Why are exactly-saturated tyconapps special?+   -- What stops this from accidentally ripping apart a call to TypeError?+    subTys t = case splitAppTys t of+                 (t,[]) ->+                   case splitTyConApp_maybe t of+                              Nothing     -> []+                              Just (_,ts) -> ts+                 (t,ts) -> t : ts++-- | Is this an user error message type, i.e. either the form @TypeError err@ or+-- @Unsatisfiable err@?+isTopLevelUserTypeError :: PredType -> Bool+isTopLevelUserTypeError pred =+  isJust (userTypeError_maybe pred) || isJust (isUnsatisfiableCt_maybe pred)++-- | Does this constraint contain an user error message?+--+-- That is, the type is either of the form @Unsatisfiable err@, or it contains+-- a type of the form @TypeError msg@, either at the top level or nested inside+-- the type.+containsUserTypeError :: PredType -> Bool+containsUserTypeError pred =+  isJust (getUserTypeErrorMsg pred) || isJust (isUnsatisfiableCt_maybe pred)++-- | Is this type an unsatisfiable constraint?+-- If so, return the error message.+isUnsatisfiableCt_maybe :: Type -> Maybe ErrorMsgType+isUnsatisfiableCt_maybe t+  | Just (tc, [msg]) <- splitTyConApp_maybe t+  , tc `hasKey` unsatisfiableClassNameKey+  = Just msg+  | otherwise+  = Nothing++{- ************************************************************************ *                                                                      *                 Implication constraints@@ -1519,18 +1479,43 @@        -- The ic_need fields keep track of which Given evidence       -- is used by this implication or its children-      -- NB: including stuff used by nested implications that have since-      --     been discarded-      -- See Note [Needed evidence variables]-      -- and (RC2) in Note [Tracking redundant constraints]a-      ic_need_inner :: VarSet,    -- Includes all used Given evidence-      ic_need_outer :: VarSet,    -- Includes only the free Given evidence-                                  --  i.e. ic_need_inner after deleting-                                  --       (a) givens (b) binders of ic_binds+      -- See Note [Tracking redundant constraints]+      -- NB: these sets include stuff used by fully-solved nested implications+      --     that have since been discarded+      ic_need  :: EvNeedSet,        -- All needed Given evidence, from this implication+                                    --   or outer ones+                                    -- That is, /after/ deleting the binders of ic_binds,+                                    --   but /before/ deleting ic_givens +      ic_need_implic :: EvNeedSet,  -- Union of of the ic_need of all implications in ic_wanted+                                    -- /including/ any fully-solved implications that have been+                                    -- discarded by `pruneImplications`.  This discarding is why+                                    -- we need to keep this field in the first place.+       ic_status   :: ImplicStatus     } +data EvNeedSet = ENS { ens_dms :: VarSet   -- Needed only by default methods+                     , ens_fvs :: VarSet   -- Needed by things /other than/ default methods+                       -- See (TRC5) in Note [Tracking redundant constraints]+                 }++emptyEvNeedSet :: EvNeedSet+emptyEvNeedSet = ENS { ens_dms = emptyVarSet, ens_fvs = emptyVarSet }++unionEvNeedSet :: EvNeedSet -> EvNeedSet -> EvNeedSet+unionEvNeedSet (ENS { ens_dms = dm1, ens_fvs = fv1 })+               (ENS { ens_dms = dm2, ens_fvs = fv2 })+  = ENS { ens_dms = dm1 `unionVarSet` dm2, ens_fvs = fv1 `unionVarSet` fv2 }++extendEvNeedSet :: EvNeedSet -> Var -> EvNeedSet+extendEvNeedSet ens@(ENS { ens_fvs = fvs }) v = ens { ens_fvs = fvs `extendVarSet` v }++delGivensFromEvNeedSet :: EvNeedSet -> [Var] -> EvNeedSet+delGivensFromEvNeedSet (ENS { ens_dms = dms, ens_fvs = fvs }) givens+  = ENS { ens_dms = dms `delVarSetList` givens+        , ens_fvs = fvs `delVarSetList` givens }+ implicationPrototype :: CtLocEnv -> Implication implicationPrototype ct_loc_env    = Implic { -- These fields must be initialised@@ -1539,15 +1524,17 @@             , ic_info       = panic "newImplic:info"             , ic_warn_inaccessible = panic "newImplic:warn_inaccessible" -            , ic_env        = ct_loc_env+              -- Given by caller+            , ic_env = ct_loc_env+               -- The rest have sensible default values-            , ic_skols      = []-            , ic_given      = []-            , ic_wanted     = emptyWC-            , ic_given_eqs  = MaybeGivenEqs-            , ic_status     = IC_Unsolved-            , ic_need_inner = emptyVarSet-            , ic_need_outer = emptyVarSet }+            , ic_skols       = []+            , ic_given       = []+            , ic_wanted      = emptyWC+            , ic_given_eqs   = MaybeGivenEqs+            , ic_status      = IC_Unsolved+            , ic_need        = emptyEvNeedSet+            , ic_need_implic = emptyEvNeedSet }  data ImplicStatus   = IC_Solved     -- All wanteds in the tree are solved, all the way down@@ -1623,7 +1610,7 @@               , ic_given = given, ic_given_eqs = given_eqs               , ic_wanted = wanted, ic_status = status               , ic_binds = binds-              , ic_need_inner = need_in, ic_need_outer = need_out+              , ic_need = need, ic_need_implic = need_implic               , ic_info = info })    = hang (text "Implic" <+> lbrace)         2 (sep [ text "TcLevel =" <+> ppr tclvl@@ -1633,10 +1620,15 @@                , hang (text "Given =")  2 (pprEvVars given)                , hang (text "Wanted =") 2 (ppr wanted)                , text "Binds =" <+> ppr binds-               , whenPprDebug (text "Needed inner =" <+> ppr need_in)-               , whenPprDebug (text "Needed outer =" <+> ppr need_out)+               , text "need =" <+> ppr need+               , text "need_implic =" <+> ppr need_implic                , pprSkolInfo info ] <+> rbrace) +instance Outputable EvNeedSet where+  ppr (ENS { ens_dms = dms, ens_fvs = fvs })+    = text "ENS" <> braces (sep [text "ens_dms =" <+> ppr dms+                                , text "ens_fvs =" <+> ppr fvs])+ instance Outputable ImplicStatus where   ppr IC_Insoluble    = text "Insoluble"   ppr IC_BadTelescope = text "Bad telescope"@@ -1724,18 +1716,6 @@   implication. TL;DR: an explicit forall should generate an implication   quantified only over those explicitly quantified variables. -Note [Needed evidence variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Th ic_need_evs field holds the free vars of ic_binds, and all the-ic_binds in nested implications.--  * Main purpose: if one of the ic_givens is not mentioned in here, it-    is redundant.--  * solveImplication may drop an implication altogether if it has no-    remaining 'wanteds'. But we still track the free vars of its-    evidence binds, even though it has now disappeared.- Note [Shadowing in a constraint] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We assume NO SHADOWING in a constraint.  Specifically@@ -1799,8 +1779,222 @@ will be able to report a more informative error:     'Can't construct the infinite type beta ~ F alpha beta' + ************************************************************************ *                                                                      *+                     approximateWC+*                                                                      *+************************************************************************+-}++type ApproxWC = ( Bag Ct          -- Free quantifiable constraints+                , TcTyCoVarSet )  -- Free vars of non-quantifiable constraints+                                  -- due to shape, or enclosing equality+   -- Why do we need that TcTyCoVarSet of non-quantifiable constraints?+   -- See (DP1) in Note [decideAndPromoteTyVars] in GHC.Tc.Solver+approximateWC :: Bool -> WantedConstraints -> Bag Ct+approximateWC include_non_quantifiable cts+  = fst (approximateWCX include_non_quantifiable cts)++approximateWCX :: Bool -> WantedConstraints -> ApproxWC+-- The "X" means "extended";+--    we return both quantifiable and non-quantifiable constraints+-- See Note [ApproximateWC]+-- See Note [floatKindEqualities vs approximateWC]+approximateWCX include_non_quantifiable wc+  = float_wc False emptyVarSet wc (emptyBag, emptyVarSet)+  where+    float_wc :: Bool           -- True <=> there are enclosing equalities+             -> TcTyCoVarSet   -- Enclosing skolem binders+             -> WantedConstraints+             -> ApproxWC -> ApproxWC+    float_wc encl_eqs trapping_tvs (WC { wc_simple = simples, wc_impl = implics }) acc+      = foldBag_flip (float_ct     encl_eqs trapping_tvs) simples $+        foldBag_flip (float_implic encl_eqs trapping_tvs) implics $+        acc++    float_implic :: Bool -> TcTyCoVarSet -> Implication+                 -> ApproxWC -> ApproxWC+    float_implic encl_eqs trapping_tvs imp+      = float_wc new_encl_eqs new_trapping_tvs (ic_wanted imp)+      where+        new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp+        new_encl_eqs = encl_eqs || ic_given_eqs imp == MaybeGivenEqs++    float_ct :: Bool -> TcTyCoVarSet -> Ct+             -> ApproxWC -> ApproxWC+    float_ct encl_eqs skol_tvs ct acc@(quant, no_quant)+       | isGivenCt ct                                = acc+           -- There can be (insoluble) Given constraints in wc_simple,+           -- there so that we get error reports for unreachable code+           -- See `given_insols` in GHC.Tc.Solver.Solve.solveImplication+       | insolubleCt ct                       = acc+       | pred_tvs `intersectsVarSet` skol_tvs = acc+       | include_non_quantifiable             = add_to_quant+       | is_quantifiable encl_eqs (ctPred ct) = add_to_quant+       | otherwise                            = add_to_no_quant+       where+         pred     = ctPred ct+         pred_tvs = tyCoVarsOfType pred+         add_to_quant    = (ct `consBag` quant, no_quant)+         add_to_no_quant = (quant, no_quant `unionVarSet` pred_tvs)++    is_quantifiable encl_eqs pred+       = case classifyPredType pred of+           -- See the classification in Note [ApproximateWC]+           EqPred eq_rel ty1 ty2+             | encl_eqs  -> False  -- encl_eqs: See Wrinkle (W1)+             | otherwise -> quantify_equality eq_rel ty1 ty2++           ClassPred cls tys+             | Just {} <- isCallStackPred cls tys+               -- NEVER infer a CallStack constraint.  Otherwise we let+               -- the constraints bubble up to be solved from the outer+               -- context, or be defaulted when we reach the top-level.+               -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence+             -> False++             | otherwise+             -> True  -- See Wrinkle (W2)++           IrredPred {}  -> True  -- See Wrinkle (W2)++           ForAllPred {} -> warnPprTrace True "Unexpected ForAllPred" (ppr pred) $+                            False  -- See Wrinkle (W4)++    -- See Note [Quantifying over equality constraints]+    quantify_equality NomEq  ty1 ty2 = quant_fun ty1 || quant_fun ty2+    quantify_equality ReprEq _   _   = True++    quant_fun ty+      = case tcSplitTyConApp_maybe ty of+          Just (tc, _) -> isTypeFamilyTyCon tc+          _              -> False++{- Note [ApproximateWC]+~~~~~~~~~~~~~~~~~~~~~~~+approximateWC takes a constraint, typically arising from the RHS of a+let-binding whose type we are *inferring*, and extracts from it some *simple*+constraints that we might plausibly abstract over.  Of course the top-level+simple constraints are plausible, but we also float constraints out from inside,+if they are not captured by skolems.++The same function is used when doing type-class defaulting (see the call+to applyDefaultingRules) to extract constraints that might be defaulted.++We proceed by classifying the constraint:+  * ClassPred:+    * Never pick a CallStack constraint.+      See Note [Overview of implicit CallStacks]+    * Always pick an implicit-parameter constraint.+      Note [Inheriting implicit parameters]+    See wrinkle (W2)++  * EqPred: see Note [Quantifying over equality constraints]++  * IrredPred: we allow anything.++  * ForAllPred: never quantify over these++Wrinkle (W1)+  When inferring most-general types (in simplifyInfer), we+  do *not* quantify over equality constraint if the implication binds+  equality constraints, because that defeats the OutsideIn story.+  Consider data T a where { TInt :: T Int; MkT :: T a }+         f TInt = 3::Int+  We get the implication (a ~ Int => res ~ Int), where so far we've decided+     f :: T a -> res+  We don't want to float (res~Int) out because then we'll infer+     f :: T a -> Int+  which is only on of the possible types. (GHC 7.6 accidentally *did*+  float out of such implications, which meant it would happily infer+  non-principal types.)++Wrinkle (W2)+  We do allow /class/ constraints to float, even if the implication binds+  equalities.  This is a subtle point: see #23224.  In principle, a class+  constraint might ultimately be satisfiable from a constraint bound by an+  implication (see #19106 for an example of this kind), but it's extremely+  obscure and I was unable to construct a concrete example.  In any case, in+  super-subtle cases where this might make a difference, you would be much+  better advised to simply write a type signature.++Wrinkle (W3)+  In findDefaultableGroups we are not worried about the most-general type; and+  we /do/ want to float out of equalities (#12797).  Hence we just union the two+  returned lists.++Wrinkle (W4)+  In #26376 we had constraints+    [W] d1 : Functor f[tau:1]+    [W] d2 : Functor p[tau:1]+    [W] d3 : forall a. Functor (p[tau:1]) a   -- A quantified constraint+  We certainly don't want to /quantify/ over d3; but we /do/ want to+  quantify over `p`, so it would be a mistake to make the function monomorphic+  in `p` just because `p` is mentioned in this quantified constraint.++  Happily this problem cannot happen any more.  That quantified constraint `d3`+  dates from a time when we flirted with an all-or-nothing strategy for+  quantified constraints Nowadays we'll never see this: we'll have simplified+  that quantified constraint into a implication constraint.  (Exception:+  SPECIALISE pragmas: see (WFA4) in Note [Solving a Wanted forall-constraint].+  But there we don't use approximateWC.)++------ Historical note -----------+There used to be a second caveat, driven by #8155++   2. We do not float out an inner constraint that shares a type variable+      (transitively) with one that is trapped by a skolem.  Eg+          forall a.  F a ~ beta, Integral beta+      We don't want to float out (Integral beta).  Doing so would be bad+      when defaulting, because then we'll default beta:=Integer, and that+      makes the error message much worse; we'd get+          Can't solve  F a ~ Integer+      rather than+          Can't solve  Integral (F a)++      Moreover, floating out these "contaminated" constraints doesn't help+      when generalising either. If we generalise over (Integral b), we still+      can't solve the retained implication (forall a. F a ~ b).  Indeed,+      arguably that too would be a harder error to understand.++But this transitive closure stuff gives rise to a complex rule for+when defaulting actually happens, and one that was never documented.+Moreover (#12923), the more complex rule is sometimes NOT what+you want.  So I simply removed the extra code to implement the+contamination stuff.  There was zero effect on the testsuite (not even #8155).+------ End of historical note -----------++Note [Quantifying over equality constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should we quantify over an equality constraint (s ~ t)+in pickQuantifiablePreds?++* It is always /sound/ to quantify over a constraint -- those+  quantified constraints will need to be proved at each call site.++* We definitely don't want to quantify over (Maybe a ~ Bool), to get+     f :: forall a. (Maybe a ~ Bool) => blah+  That simply postpones a type error from the function definition site to+  its call site.  Fortunately we have already filtered out insoluble+  constraints: see `definite_error` in `simplifyInfer`.++* What about (a ~ T alpha b), where we are about to quantify alpha, `a` and+  `b` are in-scope skolems, and `T` is a data type.  It's pretty unlikely+  that this will be soluble at a call site, so we don't quantify over it.++* What about `(F beta ~ Int)` where we are going to quantify `beta`?+  Should we quantify over the (F beta ~ Int), to get+     f :: forall b. (F b ~ Int) => blah+  Aha!  Perhaps yes, because at the call site we will instantiate `b`, and+  perhaps we have `instance F Bool = Int`. So we *do* quantify over a+  type-family equality where the arguments mention the quantified variables.++This is all a bit ad-hoc.+++************************************************************************+*                                                                      *             Invariant checking (debug only) *                                                                      * ************************************************************************@@ -1876,9 +2070,11 @@     go (TyConSkol f1 n1)    (TyConSkol f2 n2)    = f1==f2 && n1==n2     go (DataConSkol n1)     (DataConSkol n2)     = n1==n2     go (InstSkol {})        (InstSkol {})        = True+    go (MethSkol n1 d1)     (MethSkol n2 d2)     = n1==n2 && d1==d2     go FamInstSkol          FamInstSkol          = True     go BracketSkol          BracketSkol          = True     go (RuleSkol n1)        (RuleSkol n2)        = n1==n2+    go (SpecESkol n1)       (SpecESkol n2)       = n1==n2     go (PatSkol c1 _)       (PatSkol c2 _)       = getName c1 == getName c2        -- Too tedious to compare the HsMatchContexts     go (InferSkol ids1)     (InferSkol ids2)     = equalLength ids1 ids2 &&@@ -2039,24 +2235,32 @@               -- See Note [Coercion holes] in GHC.Core.TyCo.Rep  data CtEvidence-  = CtGiven    -- Truly given, not depending on subgoals-      { ctev_pred :: TcPredType      -- See Note [Ct/evidence invariant]-      , ctev_evar :: EvVar           -- See Note [CtEvidence invariants]-      , ctev_loc  :: CtLoc }+  = CtGiven  GivenCtEvidence+  | CtWanted WantedCtEvidence +-- | Evidence for a Given constraint+data GivenCtEvidence =+  GivenCt+    { ctev_pred :: TcPredType      -- See Note [Ct/evidence invariant]+    , ctev_evar :: EvVar           -- See Note [CtEvidence invariants]+    , ctev_loc  :: CtLoc } -  | CtWanted   -- Wanted goal-      { ctev_pred      :: TcPredType     -- See Note [Ct/evidence invariant]-      , ctev_dest      :: TcEvDest       -- See Note [CtEvidence invariants]-      , ctev_loc       :: CtLoc-      , ctev_rewriters :: RewriterSet }  -- See Note [Wanteds rewrite Wanteds]+-- | Evidence for a Wanted constraint+data WantedCtEvidence =+  WantedCt+    { ctev_pred      :: TcPredType     -- See Note [Ct/evidence invariant]+    , ctev_dest      :: TcEvDest       -- See Note [CtEvidence invariants]+    , ctev_loc       :: CtLoc+    , ctev_rewriters :: RewriterSet }  -- See Note [Wanteds rewrite Wanteds]  ctEvPred :: CtEvidence -> TcPredType -- The predicate of a flavor-ctEvPred = ctev_pred+ctEvPred (CtGiven (GivenCt { ctev_pred = pred }))  = pred+ctEvPred (CtWanted (WantedCt { ctev_pred = pred })) = pred  ctEvLoc :: CtEvidence -> CtLoc-ctEvLoc = ctev_loc+ctEvLoc (CtGiven (GivenCt { ctev_loc = loc }))  = loc+ctEvLoc (CtWanted (WantedCt { ctev_loc = loc })) = loc  ctEvOrigin :: CtEvidence -> CtOrigin ctEvOrigin = ctLocOrigin . ctEvLoc@@ -2084,18 +2288,40 @@ -- If the provided CtEvidence is not for a Wanted, just -- return an empty set. ctEvRewriters :: CtEvidence -> RewriterSet-ctEvRewriters (CtWanted { ctev_rewriters = rewriters }) = rewriters-ctEvRewriters (CtGiven {})                              = emptyRewriterSet+ctEvRewriters (CtWanted (WantedCt { ctev_rewriters = rws })) = rws+ctEvRewriters (CtGiven {})  = emptyRewriterSet +ctHasNoRewriters :: Ct -> Bool+ctHasNoRewriters ev+  = case ctEvidence ev of+      CtWanted wev -> wantedCtHasNoRewriters wev+      CtGiven {}   -> True++wantedCtHasNoRewriters :: WantedCtEvidence -> Bool+wantedCtHasNoRewriters (WantedCt { ctev_rewriters = rws })+  = isEmptyRewriterSet rws++-- | Set the rewriter set of a Wanted constraint.+setWantedCtEvRewriters :: WantedCtEvidence -> RewriterSet -> WantedCtEvidence+setWantedCtEvRewriters ev rs = ev { ctev_rewriters = rs }+ ctEvExpr :: HasDebugCallStack => CtEvidence -> EvExpr-ctEvExpr ev@(CtWanted { ctev_dest = HoleDest _ })-            = Coercion $ ctEvCoercion ev+ctEvExpr (CtWanted ev@(WantedCt { ctev_dest = HoleDest _ }))+            = Coercion $ ctEvCoercion (CtWanted ev) ctEvExpr ev = evId (ctEvEvId ev) +givenCtEvCoercion :: GivenCtEvidence -> TcCoercion+givenCtEvCoercion _given@(GivenCt { ctev_evar = ev_id })+  = assertPpr (isCoVar ev_id)+    (text "givenCtEvCoercion used on non-equality Given constraint:" <+> ppr _given)+  $ mkCoVarCo ev_id+ ctEvCoercion :: HasDebugCallStack => CtEvidence -> TcCoercion-ctEvCoercion (CtGiven { ctev_evar = ev_id })-  = mkCoVarCo ev_id-ctEvCoercion (CtWanted { ctev_dest = dest })+ctEvCoercion (CtGiven _given@(GivenCt { ctev_evar = ev_id }))+  = assertPpr (isCoVar ev_id)+    (text "ctEvCoercion used on non-equality Given constraint:" <+> ppr (CtGiven _given))+  $ mkCoVarCo ev_id+ctEvCoercion (CtWanted (WantedCt { ctev_dest = dest }))   | HoleDest hole <- dest   = -- ctEvCoercion is only called on type equalities     -- and they always have HoleDests@@ -2104,20 +2330,24 @@   = pprPanic "ctEvCoercion" (ppr ev)  ctEvEvId :: CtEvidence -> EvVar-ctEvEvId (CtWanted { ctev_dest = EvVarDest ev }) = ev-ctEvEvId (CtWanted { ctev_dest = HoleDest h })   = coHoleCoVar h-ctEvEvId (CtGiven  { ctev_evar = ev })           = ev+ctEvEvId (CtWanted wtd)                         = wantedCtEvEvId wtd+ctEvEvId (CtGiven (GivenCt { ctev_evar = ev })) = ev +wantedCtEvEvId :: WantedCtEvidence -> EvVar+wantedCtEvEvId (WantedCt { ctev_dest = EvVarDest ev }) = ev+wantedCtEvEvId (WantedCt { ctev_dest = HoleDest h })   = coHoleCoVar h+ ctEvUnique :: CtEvidence -> Unique-ctEvUnique (CtGiven { ctev_evar = ev })    = varUnique ev-ctEvUnique (CtWanted { ctev_dest = dest }) = tcEvDestUnique dest+ctEvUnique (CtGiven (GivenCt { ctev_evar = ev }))     = varUnique ev+ctEvUnique (CtWanted (WantedCt { ctev_dest = dest })) = tcEvDestUnique dest  tcEvDestUnique :: TcEvDest -> Unique tcEvDestUnique (EvVarDest ev_var) = varUnique ev_var tcEvDestUnique (HoleDest co_hole) = varUnique (coHoleCoVar co_hole)  setCtEvLoc :: CtEvidence -> CtLoc -> CtEvidence-setCtEvLoc ctev loc = ctev { ctev_loc = loc }+setCtEvLoc (CtGiven (GivenCt pred evar _)) loc = CtGiven (GivenCt pred evar loc)+setCtEvLoc (CtWanted (WantedCt pred dest _ rwrs)) loc = CtWanted (WantedCt pred dest loc rwrs)  -- | Set the type of CtEvidence. --@@ -2125,13 +2355,13 @@ -- the evidence and the ctev_pred in sync with each other. -- See Note [CtEvidence invariants]. setCtEvPredType :: HasDebugCallStack => CtEvidence -> Type -> CtEvidence-setCtEvPredType old_ctev@(CtGiven { ctev_evar = ev }) new_pred-  = old_ctev { ctev_pred = new_pred-             , ctev_evar = setVarType ev new_pred }+setCtEvPredType (CtGiven old_ev@(GivenCt { ctev_evar = ev })) new_pred+  = CtGiven (old_ev { ctev_pred = new_pred+                    , ctev_evar = setVarType ev new_pred }) -setCtEvPredType old_ctev@(CtWanted { ctev_dest = dest }) new_pred-  = old_ctev { ctev_pred = new_pred-             , ctev_dest = new_dest }+setCtEvPredType (CtWanted old_ev@(WantedCt { ctev_dest = dest })) new_pred+  = CtWanted (old_ev { ctev_pred = new_pred+                     , ctev_dest = new_dest })   where     new_dest = case dest of       EvVarDest ev -> EvVarDest (setVarType ev new_pred)@@ -2141,15 +2371,20 @@   ppr (HoleDest h)   = text "hole" <> ppr h   ppr (EvVarDest ev) = ppr ev +instance Outputable GivenCtEvidence where+  ppr = ppr . CtGiven+instance Outputable WantedCtEvidence where+  ppr = ppr . CtWanted+ instance Outputable CtEvidence where   ppr ev = ppr (ctEvFlavour ev)-           <+> pp_ev <+> braces (ppr (ctl_depth (ctEvLoc ev)) <> pp_rewriters)+           <+> hang (pp_ev <+> braces (ppr (ctl_depth (ctEvLoc ev)) <> pp_rewriters))                          -- Show the sub-goal depth too-               <> dcolon <+> ppr (ctEvPred ev)+                  2 (dcolon <+> pprPredType (ctEvPred ev))     where       pp_ev = case ev of-             CtGiven { ctev_evar = v } -> ppr v-             CtWanted {ctev_dest = d } -> ppr d+             CtGiven ev -> ppr (ctev_evar ev)+             CtWanted ev -> ppr (ctev_dest ev)        rewriters = ctEvRewriters ev       pp_rewriters | isEmptyRewriterSet rewriters = empty@@ -2196,9 +2431,10 @@ rewriterSetFromCts cts   = foldr add emptyRewriterSet cts   where-    add ct rw_set = case ctEvidence ct of-         CtWanted { ctev_dest = HoleDest hole } -> rw_set `addRewriter` hole-         _                                      -> rw_set+    add ct rw_set =+      case ctEvidence ct of+        CtWanted (WantedCt { ctev_dest = HoleDest hole }) -> rw_set `addRewriter` hole+        _                                                 -> rw_set  {- ************************************************************************@@ -2289,19 +2525,38 @@ but we don't want Wanteds to rewrite Wanteds because doing so can create inscrutable error messages. To solve this dilemma: -* We allow Wanteds to rewrite Wanteds, but...+* We allow Wanteds to rewrite Wanteds, but each Wanted tracks the set of Wanteds+  it has been rewritten by, in its RewriterSet, stored in the ctev_rewriters+  field of the CtWanted constructor of CtEvidence.  (Only Wanteds have+  RewriterSets.) -* Each Wanted tracks the set of Wanteds it has been rewritten by, in its-  RewriterSet, stored in the ctev_rewriters field of the CtWanted-  constructor of CtEvidence.  (Only Wanteds have RewriterSets.)+* A RewriterSet is just a set of unfilled CoercionHoles. This is sufficient+  because only equalities (evidenced by coercion holes) are used for rewriting;+  other (dictionary) constraints cannot ever rewrite. +* The rewriter (in e.g. GHC.Tc.Solver.Rewrite.rewrite) tracks and returns a RewriterSet,+  consisting of the evidence (a CoercionHole) for any Wanted equalities used in+  rewriting.++* Then GHC.Tc.Solver.Solve.rewriteEvidence and GHC.Tc.Solver.Equality.rewriteEqEvidence+  add this RewriterSet to the rewritten constraint's rewriter set.++* We prevent the unifier from unifying any equality with a non-empty rewriter set;+  unification effectively turns a Wanted into a Given, and we lose all tracking.+  See (REWRITERS) in Note [Unification preconditions] in GHC.Tc.Utils.Unify and+  Note [Unify only if the rewriter set is empty] in GHC.Solver.Equality.+ * In error reporting, we simply suppress any errors that have been rewritten   by /unsolved/ wanteds. This suppression happens in GHC.Tc.Errors.mkErrorItem,-  which uses GHC.Tc.Zonk.Type.zonkRewriterSet to look through any filled+  which uses `GHC.Tc.Zonk.Type.zonkRewriterSet` to look through any filled   coercion holes. The idea is that we wish to report the "root cause" -- the   error that rewrote all the others. -* We prioritise Wanteds that have an empty RewriterSet:+* In `selectNextWorkItem`, priorities equalities with no rewiters.  See+  Note [Prioritise Wanteds with empty RewriterSet] in GHC.Tc.Types.Constraint+  wrinkle (PER1).++* In error reporting, we prioritise Wanteds that have an empty RewriterSet:   see Note [Prioritise Wanteds with empty RewriterSet].  Let's continue our first example above:@@ -2316,19 +2571,26 @@  The {w1} in the second line of output is the RewriterSet of w1. -A RewriterSet is just a set of unfilled CoercionHoles. This is sufficient-because only equalities (evidenced by coercion holes) are used for rewriting;-other (dictionary) constraints cannot ever rewrite. The rewriter (in-e.g. GHC.Tc.Solver.Rewrite.rewrite) tracks and returns a RewriterSet,-consisting of the evidence (a CoercionHole) for any Wanted equalities used in-rewriting.  Then GHC.Tc.Solver.Solve.rewriteEvidence and-GHC.Tc.Solver.Equality.rewriteEqEvidence add this RewriterSet to the rewritten-constraint's rewriter set.+Wrinkles: +(WRW1) When we find a constraint identical to one already in the inert set,+   we solve one from the other. Other things being equal, keep the one+   that has fewer (better still no) rewriters.+   See (CE4) in Note [Combining equalities] in GHC.Tc.Solver.Equality.++   To this accurately we should use `zonkRewriterSet` during canonicalisation,+   to eliminate rewriters that have now been solved.  Currently we only do so+   during error reporting; but perhaps we should change that.++(WRW2) When zonking a constraint (with `zonkCt` and `zonkCtEvidence`) we take+   the opportunity to zonk its `RewriterSet`, which eliminates solved ones.+   This doesn't guarantee that rewriter sets are always up to date -- see+   (WRW1) -- but it helps, and it de-clutters debug output.+ Note [Prioritise Wanteds with empty RewriterSet] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When extending the WorkList, in GHC.Tc.Solver.InertSet.extendWorkListEq,-we priorities constraints that have no rewriters. Here's why.+we prioritise constraints that have no rewriters. Here's why.  Consider this, which came up in T22793:   inert: {}@@ -2366,17 +2628,17 @@ been well if we'd started with the (not-rewritten) co_ayb and gotten it into the inert set. -With that in mind, we /prioritise/ the work-list to put constraints-with no rewriters first.  This prioritisation is done in-GHC.Tc.Solver.InertSet.extendWorkListEq, and extendWorkListEqs.+With that in mind, we /prioritise/ the work-list to put+constraints with no rewriters first.  This prioritisation+is done in `GHC.Tc.Solver.Monad.selectNextWorkItem`.  Wrinkles -(WRW1) Before checking for an empty RewriterSet, we zonk the RewriterSet,-  because some of those CoercionHoles may have been filled in since we last-  looked: see GHC.Tc.Solver.Monad.emitWork.+(PER1) When picking the next work item, before checking for an empty RewriterSet+  in GHC.Tc.Solver.Monad.selectNextWorkItem, we zonk the RewriterSet, because+  some of those CoercionHoles may have been filled in since we last looked. -(WRW2) Despite the prioritisation, it is hard to be /certain/ that we can't end up+(PER2) Despite the prioritisation, it is hard to be /certain/ that we can't end up   in a situation where all of the Wanteds have rewritten each other. In   order to report /some/ error in this case, we simply report all the   Wanteds. The user will get a perhaps-confusing error message, but they've@@ -2475,4 +2737,3 @@ eqCanRewriteFR (Wanted, NomEq) (Wanted, ReprEq) = False eqCanRewriteFR (Wanted, r1)    (Wanted, r2)     = eqCanRewrite r1 r2 eqCanRewriteFR (Wanted, _)     (Given, _)       = False-
compiler/GHC/Tc/Types/CtLoc.hs view
@@ -231,7 +231,6 @@                          , ctl_in_gen_code :: !Bool                          , ctl_rdr :: !LocalRdrEnv } - getCtLocEnvLoc :: CtLocEnv -> RealSrcSpan getCtLocEnvLoc = ctl_loc 
compiler/GHC/Tc/Types/ErrCtxt.hs view
@@ -1,16 +1,223 @@-module GHC.Tc.Types.ErrCtxt where+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE UndecidableInstances #-} +module GHC.Tc.Types.ErrCtxt+  ( ErrCtxt, ErrCtxtMsg(..)+  , UserSigType(..), FunAppCtxtFunArg(..)+  , TyConInstFlavour(..)+  )+  where+ import GHC.Prelude-import GHC.Types.Var.Env-import GHC.Tc.Zonk.Monad (ZonkM)-import GHC.Utils.Outputable+import GHC.Hs.Expr+import GHC.Hs.Extension +import GHC.Parser.Annotation ( LocatedN, SrcSpanAnnA )++import GHC.Tc.Errors.Types.PromotionErr ( TermLevelUseCtxt )+import GHC.Tc.Types.Origin   ( CtOrigin, UserTypeCtxt, ExpectedFunTyOrigin )+import GHC.Tc.Utils.TcType   ( TcType, TcTyCon )+import GHC.Tc.Zonk.Monad     ( ZonkM )++import GHC.Types.Basic       ( TyConFlavour )+import GHC.Types.Name        ( Name )+import GHC.Types.SrcLoc      ( SrcSpan )+import GHC.Types.Var         ( Id, TyCoVar )+import GHC.Types.Var.Env     ( TidyEnv )++import GHC.Unit.Types ( Module, InstantiatedModule )++import GHC.Core.Class    ( Class )+import GHC.Core.ConLike  ( ConLike )+import GHC.Core.PatSyn   ( PatSyn )+import GHC.Core.TyCon    ( TyCon )+import GHC.Core.TyCo.Rep ( Type, ThetaType, PredType )++import GHC.Unit.State ( UnitState )++import GHC.Data.FastString  ( FastString )+import GHC.Utils.Outputable ( Outputable(..) )++import Language.Haskell.Syntax.Basic ( FieldLabelString(..) )+import Language.Haskell.Syntax+import GHC.Boot.TH.Syntax qualified as TH++import qualified Data.List.NonEmpty as NE++--------------------------------------------------------------------------------+ -- | Additional context to include in an error message, e.g. -- "In the type signature ...", "In the ambiguity check for ...", etc.-type ErrCtxt = (Bool, TidyEnv -> ZonkM (TidyEnv, SDoc))+type ErrCtxt = (Bool, TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg))         -- Monadic so that we have a chance         -- to deal with bound type variables just before error         -- message construction          -- Bool:  True <=> this is a landmark context; do not         --                 discard it when trimming for display++--------------------------------------------------------------------------------+-- Error message contexts++data UserSigType p+  = UserLHsSigType !(LHsSigType p)+  | UserLHsType !(LHsType p)++instance OutputableBndrId p => Outputable (UserSigType (GhcPass p)) where+  ppr (UserLHsSigType ty) = ppr ty+  ppr (UserLHsType ty) = ppr ty++data FunAppCtxtFunArg+  = FunAppCtxtExpr !(HsExpr GhcRn) !(HsExpr GhcRn)+  | FunAppCtxtTy   !(LHsType GhcRn) !(LHsType GhcRn)++-- | Like 'TyConFlavour' but for instance declarations, with+-- the additional information of whether this we are dealing with+-- a default declaration.+data TyConInstFlavour+  = TyConInstFlavour+  { tyConInstFlavour :: !(TyConFlavour TyCon)+  , tyConInstIsDefault :: !Bool+  }++-- | The "context" of an error message, e.g. "In the expression <...>",+-- "In the pattern <...>", or "In the equations for closed type family <...>".+data ErrCtxtMsg+  -- | In an expression.+  = ExprCtxt !(HsExpr GhcRn)+  -- | In a user-written context.+  | ThetaCtxt !UserTypeCtxt !ThetaType+  -- | In a quantified constraint.+  | QuantifiedCtCtxt !PredType+  -- | When checking an inferred type.+  | InferredTypeCtxt !Name !TcType+  -- | In an inline pragma, or a fixity signature,+  -- or a type signature, or... (see 'Sig').+  | SigCtxt !(Sig GhcRn)+  -- | In a user-written type signature.+  | UserSigCtxt !UserTypeCtxt !(UserSigType GhcRn)+  -- | In a record update.+  | RecordUpdCtxt !(NE.NonEmpty ConLike) ![Name] ![TyCoVar]+  -- | In a class method.+  | ClassOpCtxt !Id !Type+  -- | In the instance type signature of a class method.+  | MethSigCtxt !Name !TcType !TcType+  -- | In a pattern type signature.+  | PatSigErrCtxt !TcType !TcType+  -- | In a pattern.+  | PatCtxt !(Pat GhcRn)+  -- | In a pattern synonym declaration.+  | PatSynDeclCtxt !Name+  -- | In a pattern matching context, e.g. a equation for a function binding,+  -- or a case alternative, ...+  | MatchCtxt !HsMatchContextRn+  -- | In a match in a pattern matching context,+  -- either for an expression or for an arrow command.+  | forall body. (Outputable body)+  => MatchInCtxt !(Match GhcRn body)+  -- | In a function application.+  | FunAppCtxt !FunAppCtxtFunArg !Int+  -- | In a function call.+  | FunTysCtxt !ExpectedFunTyOrigin !Type !Int !Int+  -- | In the result of a function call.+  | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int+  -- | In the declaration of a type constructor.+  | TyConDeclCtxt !Name !(TyConFlavour TyCon)+  -- | In a type or data family instance (or default instance).+  | TyConInstCtxt !Name !TyConInstFlavour+  -- | In the declaration of a data constructor.+  | DataConDefCtxt !(NE.NonEmpty (LocatedN Name))+  -- | In the result type of a data constructor.+  | DataConResTyCtxt !(NE.NonEmpty (LocatedN Name))+  -- | In the equations for a closed type family.+  | ClosedFamEqnCtxt !TyCon+  -- | In the expansion of a type synonym.+  | TySynErrCtxt !TyCon+  -- | In a role annotation.+  | RoleAnnotErrCtxt !Name+  -- | In an arrow command.+  | CmdCtxt !(HsCmd GhcRn)+  -- | In an instance declaration.+  | InstDeclErrCtxt !(Either (LHsType GhcRn) PredType)+  -- | In a default declaration.+  | DefaultDeclErrCtxt { ddec_in_type_list :: !Bool }+  -- | In the body of a static form.+  | StaticFormCtxt !(LHsExpr GhcRn)+  -- | In a pattern binding.+  | forall p. OutputableBndrId p+  => PatMonoBindsCtxt !(LPat (GhcPass p)) !(GRHSs GhcRn (LHsExpr GhcRn))+  -- | In a foreign import/export declaration.+  | ForeignDeclCtxt !(ForeignDecl GhcRn)+  -- | In a record field.+  | FieldCtxt !FieldLabelString+  -- | In a type.+  | TypeCtxt !(LHsType GhcRn)+  -- | In a kind.+  | KindCtxt !(LHsKind GhcRn)+  -- | In an ambiguity check.+  | AmbiguityCheckCtxt !UserTypeCtxt !Bool++  -- | In a term-level use of a 'Name'.+  | TermLevelUseCtxt !Name !TermLevelUseCtxt++  -- | When checking the type of the @main@ function.+  | MainCtxt !Name+  -- | Warning emitted when inferring use of visible dependent quantification.+  | VDQWarningCtxt !TcTyCon++  -- | In a statement.+  | forall body.+    ( Anno (StmtLR GhcRn GhcRn body) ~ SrcSpanAnnA+    , Outputable body+    ) => StmtErrCtxt !HsStmtContextRn !(StmtLR GhcRn GhcRn body)++  -- | In an rebindable syntax expression.+  | SyntaxNameCtxt !(HsExpr GhcRn) !CtOrigin !TcType !SrcSpan+  -- | In a RULE.+  | RuleCtxt !FastString+  -- | In a subtype check.+  | SubTypeCtxt !TcType !TcType++  -- | In an export.+  | forall p. OutputableBndrId p+  => ExportCtxt (IE (GhcPass p))+  -- | In an export of a pattern synonym.+  | PatSynExportCtxt !PatSyn+  -- | In an export of a pattern synonym record field.+  | PatSynRecSelExportCtxt !PatSyn !Name++  -- | In an annotation.+  | forall p. OutputableBndrId p+  => AnnCtxt (AnnDecl (GhcPass p))++  -- | In a specialise pragma.+  | SpecPragmaCtxt !(Sig GhcRn)++  -- | In a deriving clause.+  | DerivInstCtxt !PredType+  -- | In a standalone deriving clause.+  | StandaloneDerivCtxt !(LHsSigWcType GhcRn)+  -- | When typechecking the body of a derived instance.+  | DerivBindCtxt !Id !Class ![Type]++  -- | In an untyped Template Haskell quote.+  | UntypedTHBracketCtxt !(HsQuote GhcPs)+  -- | In a typed Template Haskell quote.+  | forall p. OutputableBndrId p+  => TypedTHBracketCtxt !(LHsExpr (GhcPass p))+  -- | In an untyped Template Haskell splice or quasi-quote.+  | UntypedSpliceCtxt !(HsUntypedSplice GhcPs)+  -- | In a typed Template Haskell splice.+  | forall p. OutputableBndrId p+  => TypedSpliceCtxt !(Maybe SplicePointName) !(HsTypedSplice (GhcPass p))+  -- | In the result of a typed Template Haskell splice.+  | TypedSpliceResultCtxt !(LHsExpr GhcTc)+  -- | In an argument to the Template Haskell @reifyInstances@ function.+  | ReifyInstancesCtxt !TH.Name ![TH.Type]++  -- | While merging Backpack signatures.+  | MergeSignaturesCtxt !UnitState !ModuleName ![InstantiatedModule]+  -- | While checking that a module implements a Backpack signature.+  | CheckImplementsCtxt !UnitState !Module !InstantiatedModule
compiler/GHC/Tc/Types/Evidence.hs view
@@ -15,7 +15,7 @@    -- * Evidence bindings   TcEvBinds(..), EvBindsVar(..),-  EvBindMap(..), emptyEvBindMap, extendEvBinds,+  EvBindMap(..), emptyEvBindMap, extendEvBinds, unionEvBindMap,   lookupEvBind, evBindMapBinds,   foldEvBindMap, nonDetStrictFoldEvBindMap,   filterEvBindMap,@@ -27,10 +27,14 @@    -- * EvTerm (already a CoreExpr)   EvTerm(..), EvExpr,-  evId, evCoercion, evCast, evDFunApp,  evDataConApp, evSelector,-  mkEvCast, evVarsOfTerm, mkEvScSelectors, evTypeable, findNeededEvVars,+  evId, evCoercion, evCast, evCastE, evDFunApp,  evDictApp, evSelector, evDelayedError,+  mkEvScSelectors, evTypeable,+  evWrapIPE, evUnwrapIPE, evUnaryDictAppE,+  mkEvCast,+  nestedEvIdsOfTerm, evTermFVs,    evTermCoercion, evTermCoercion_maybe,+  evExprCoercion, evExprCoercion_maybe,   EvCallStack(..),   EvTypeable(..), @@ -39,10 +43,9 @@    -- * TcCoercion   TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole,-  TcMCoercion, TcMCoercionN, TcMCoercionR, MultiplicityCheckCoercions,+  TcMCoercion, TcMCoercionN, TcMCoercionR,   Role(..), LeftOrRight(..), pickLR,   maybeSymCo,-  unwrapIP, wrapIP,    -- * QuoteWrapper   QuoteWrapper(..), applyQuoteWrapper, quoteWrapperTyVarTy@@ -50,28 +53,35 @@  import GHC.Prelude -import GHC.Types.Unique.DFM-import GHC.Types.Unique.FM-import GHC.Types.Var-import GHC.Types.Id( idScaledType )+import GHC.Tc.Utils.TcType++import GHC.Core import GHC.Core.Coercion.Axiom import GHC.Core.Coercion import GHC.Core.Ppr ()   -- Instance OutputableBndr TyVar-import GHC.Tc.Utils.TcType+import GHC.Core.Predicate import GHC.Core.Type import GHC.Core.TyCon-import GHC.Core.DataCon ( DataCon, dataConWrapId )-import GHC.Builtin.Names+import GHC.Core.Make    ( mkWildCase, mkRuntimeErrorApp, tYPE_ERROR_ID )+import GHC.Core.Class   ( classTyCon )+import GHC.Core.DataCon ( dataConWrapId )+import GHC.Core.Class (Class, classSCSelId )+import GHC.Core.FVs+import GHC.Core.InstEnv ( CanonicalEvidence(..) )++import GHC.Types.Unique.DFM+import GHC.Types.Unique.FM+import GHC.Types.Name( isInternalName )+import GHC.Types.Var+import GHC.Types.Id( idScaledType ) import GHC.Types.Var.Env import GHC.Types.Var.Set-import GHC.Core.Predicate import GHC.Types.Basic -import GHC.Core-import GHC.Core.Class (Class, classSCSelId )-import GHC.Core.FVs   ( exprSomeFreeVars )-import GHC.Core.InstEnv ( CanonicalEvidence(..) )+import GHC.Builtin.Names+import GHC.Builtin.Types( unitTy ) +import GHC.Utils.FV import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable@@ -110,11 +120,7 @@ type TcMCoercionN = MCoercionN  -- nominal type TcMCoercionR = MCoercionR  -- representational -type MultiplicityCheckCoercions = [TcCoercion]--- Coercions which must all be reflexivity after zonking.--- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify. - -- | If a 'SwapFlag' is 'IsSwapped', flip the orientation of a coercion maybeSymCo :: SwapFlag -> TcCoercion -> TcCoercion maybeSymCo IsSwapped  co = mkSymCo co@@ -176,10 +182,6 @@    | WpLet TcEvBinds             -- Non-empty (or possibly non-empty) evidence bindings,                                 -- so that the identity coercion is always exactly WpHole--  | WpMultCoercion Coercion     -- Require that a Coercion be reflexive; otherwise,-                                -- error in the desugarer. See GHC.Tc.Utils.Unify-                                -- Note [Coercions returned from tcSubMult]   deriving Data.Data  -- | The Semigroup instance is a bit fishy, since @WpCompose@, as a data@@ -202,28 +204,44 @@   mempty = WpHole  (<.>) :: HsWrapper -> HsWrapper -> HsWrapper-WpHole <.> c = c-c <.> WpHole = c-c1 <.> c2    = c1 `WpCompose` c2+WpHole    <.> c         = c+c         <.> WpHole    = c+WpCast c1 <.> WpCast c2 = WpCast (c1 `mkTransCo` c2)+  -- If we can represent the HsWrapper as a cast, try to do so: this may avoid+  -- unnecessary eta-expansion (see 'mkWpFun').+c1        <.> c2        = c1 `WpCompose` c2 --- | Smart constructor to create a 'WpFun' 'HsWrapper'.+-- | Smart constructor to create a 'WpFun' 'HsWrapper', which avoids introducing+-- a lambda abstraction if the two supplied wrappers are either identities or+-- casts. ----- PRECONDITION: the "from" type of the first wrapper must have a syntactically--- fixed RuntimeRep (see Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete).+-- PRECONDITION: either:+--+--  1. both of the 'HsWrapper's are identities or casts, or+--  2. both the "from" and "to" types of the first wrapper have a syntactically+--     fixed RuntimeRep (see Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete). mkWpFun :: HsWrapper -> HsWrapper         -> Scaled TcTypeFRR -- ^ the "from" type of the first wrapper-                            -- MUST have a fixed RuntimeRep         -> TcType           -- ^ Either "from" type or "to" type of the second wrapper                             --   (used only when the second wrapper is the identity)         -> HsWrapper-  -- NB: we can't check that the argument type has a fixed RuntimeRep with an assertion,-  -- because of [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep]-  -- in GHC.Tc.Utils.Concrete. mkWpFun WpHole       WpHole       _             _  = WpHole mkWpFun WpHole       (WpCast co2) (Scaled w t1) _  = WpCast (mk_wp_fun_co w (mkRepReflCo t1) co2) mkWpFun (WpCast co1) WpHole       (Scaled w _)  t2 = WpCast (mk_wp_fun_co w (mkSymCo co1)    (mkRepReflCo t2)) mkWpFun (WpCast co1) (WpCast co2) (Scaled w _)  _  = WpCast (mk_wp_fun_co w (mkSymCo co1)    co2)-mkWpFun co1          co2          t1            _  = WpFun co1 co2 t1+mkWpFun w_arg        w_res        t1            _  =+  -- In this case, we will desugar to a lambda+  --+  --   \x. w_res[ e w_arg[x] ]+  --+  -- To satisfy Note [Representation polymorphism invariants] in GHC.Core,+  -- it must be the case that both the lambda bound variable x and the function+  -- argument w_arg[x] have a fixed runtime representation, i.e. that both the+  -- "from" and "to" types of the first wrapper "w_arg" have a fixed runtime representation.+  --+  -- Unfortunately, we can't check this with an assertion here, because of+  -- [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.+  WpFun w_arg w_res t1  mkWpEta :: [Id] -> HsWrapper -> HsWrapper -- (mkWpEta [x1, x2] wrap) [e]@@ -271,12 +289,7 @@ -- but in that case we refrain from calling it. mkWpForAllCast :: [ForAllTyBinder] -> Type -> HsWrapper mkWpForAllCast bndrs res_ty-  = mkWpCastR (go bndrs)-  where-    go []                 = mkRepReflCo res_ty-    go (Bndr tv vis : bs) = mkForAllCo tv coreTyLamForAllTyFlag vis kind_co (go bs)-      where-        kind_co = mkNomReflCo (varType tv)+  = mkWpCastR (mkForAllVisCos bndrs (mkRepReflCo res_ty))  mkWpEvLams :: [Var] -> HsWrapper mkWpEvLams ids = mk_co_lam_fn WpEvLam ids@@ -321,7 +334,6 @@    go (WpTyLam {})        = emptyBag    go (WpTyApp {})        = emptyBag    go (WpLet   {})        = emptyBag-   go (WpMultCoercion {}) = emptyBag  collectHsWrapBinders :: HsWrapper -> ([Var], HsWrapper) -- Collect the outer lambda binders of a HsWrapper,@@ -366,11 +378,13 @@       --     (dictionaries etc)       -- Some Given, some Wanted -      ebv_tcvs :: IORef CoVarSet-      -- The free Given coercion vars needed by Wanted coercions that-      -- are solved by filling in their HoleDest in-place. Since they-      -- don't appear in ebv_binds, we keep track of their free-      -- variables so that we can report unused given constraints+      ebv_tcvs :: IORef [TcCoercion]+      -- When we solve a Wanted by filling in a CoercionHole, it is as+      -- if we were adding an evidence binding+      --       co_hole := coercion+      -- We keep all these RHS coercions in a list, alongside `ebv_binds`,+      --  so that we can report unused given constraints,+      --  in GHC.Tc.Solver.neededEvVars       -- See Note [Tracking redundant constraints] in GHC.Tc.Solver     } @@ -378,14 +392,19 @@        -- See above for comments on ebv_uniq, ebv_tcvs       ebv_uniq :: Unique,-      ebv_tcvs :: IORef CoVarSet+      ebv_tcvs :: IORef [TcCoercion]     }  instance Data.Data TcEvBinds where-  -- Placeholder; we can't travers into TcEvBinds+  -- Placeholder; we can't traverse into TcEvBinds   toConstr _   = abstractConstr "TcEvBinds"   gunfold _ _  = error "gunfold"   dataTypeOf _ = Data.mkNoRepType "TcEvBinds"+instance Data.Data EvBind where+  -- Placeholder; we can't traverse into EvBind+  toConstr _   = abstractConstr "TcEvBind"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = Data.mkNoRepType "EvBind"  {- Note [Coercion evidence only] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -437,6 +456,11 @@                                                (eb_lhs ev_bind)                                                ev_bind } +-- | Union two evidence binding maps+unionEvBindMap :: EvBindMap -> EvBindMap -> EvBindMap+unionEvBindMap (EvBindMap env1) (EvBindMap env2) =+  EvBindMap { ev_bind_varenv = plusDVarEnv env1 env2 }+ isEmptyEvBindMap :: EvBindMap -> Bool isEmptyEvBindMap (EvBindMap m) = isEmptyDVarEnv m @@ -505,17 +529,14 @@   | EvFun     -- /\as \ds. let binds in v       { et_tvs   :: [TyVar]       , et_given :: [EvVar]-      , et_binds :: TcEvBinds -- This field is why we need an EvFun-                              -- constructor, and can't just use EvExpr+      , et_binds :: TcEvBinds  -- This field is why we need an EvFun+                               -- constructor, and can't just use EvExpr       , et_body  :: EvVar }    deriving Data.Data  type EvExpr = CoreExpr --- An EvTerm is (usually) constructed by any of the constructors here--- and those more complicated ones who were moved to module GHC.Tc.Types.EvTerm- -- | Any sort of evidence Id, including coercions evId ::  EvId -> EvExpr evId = Var@@ -525,18 +546,63 @@ evCoercion :: TcCoercion -> EvTerm evCoercion co = EvExpr (Coercion co) --- | d |> co+{-# DEPRECATED mkEvCast "Please use evCast instead" #-}+-- We had gotten duplicate functions; let's get rid of mkEvCast in due course+mkEvCast :: EvExpr -> TcCoercion -> EvTerm+mkEvCast = evCast+ evCast :: EvExpr -> TcCoercion -> EvTerm-evCast et tc | isReflCo tc = EvExpr et-             | otherwise   = EvExpr (Cast et tc)+evCast et tc = EvExpr (evCastE et tc) --- Dictionary instance application+-- | d |> co+evCastE :: EvExpr -> TcCoercion -> EvExpr+evCastE ee co+  | assertPpr (coercionRole co == Representational)+              (vcat [text "Coercion of wrong role passed to evCastE:", ppr ee, ppr co]) $+    isReflCo co = ee+  | otherwise   = Cast ee co+ evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm-evDFunApp df tys ets = EvExpr $ Var df `mkTyApps` tys `mkApps` ets+-- Dictionary instance application, including when the "dictionary function"+-- is actually the data construtor for a dictionary+evDFunApp df tys ets = EvExpr (evDFunAppE df tys ets) -evDataConApp :: DataCon -> [Type] -> [EvExpr] -> EvTerm-evDataConApp dc tys ets = evDFunApp (dataConWrapId dc) tys ets+evDFunAppE :: DFunId -> [Type] -> [EvExpr] -> EvExpr+evDFunAppE df tys ets = Var df `mkTyApps` tys `mkApps` ets +evDictApp :: Class -> [Type] -> [EvExpr] -> EvTerm+evDictApp cls tys args = EvExpr (evDictAppE cls tys args)++evDictAppE :: Class -> [Type] -> [EvExpr] -> EvExpr+evDictAppE cls tys args+  = case tyConSingleDataCon_maybe (classTyCon cls) of+      Just dc -> evDFunAppE (dataConWrapId dc) tys args+      Nothing -> pprPanic "evDictApp" (ppr cls)++evUnaryDictAppE :: Class -> [Type] -> EvExpr -> EvExpr+-- See (UCM6) in Note [Unary class magic] in GHC.Core.TyCon+evUnaryDictAppE cls tys meth+  = evDictAppE cls tys [meth]++evWrapIPE :: PredType -> EvExpr -> EvExpr+-- Given  pred = IP s ty+  --      et_tm :: ty+-- Return an EvTerm of type (IP s ty)+evWrapIPE pred ev_tm+  = evUnaryDictAppE cls tys ev_tm+  where+    (cls, tys) = getClassPredTys pred++evUnwrapIPE :: PredType -> EvExpr -> EvExpr+-- Given  pred = IP s ty+  --      et_tm :: (IP s ty)+-- Return an EvTerm of type ty+evUnwrapIPE pred ev_tm+  = mkApps (Var ip_sel) (map Type tys ++ [ev_tm])+  where+    (ip_sel, tys) = decomposeIPPred pred++ -- Selector id plus the types at which it -- should be instantiated, used for HasField -- dictionaries; see Note [HasField instances]@@ -594,7 +660,7 @@ -}  -- | Where to store evidence for expression holes--- See Note [Holes] in GHC.Tc.Types.Constraint+-- See Note [Holes in expressions] in GHC.Hs.Expr. data HoleExprRef = HER (IORef EvTerm)   -- ^ where to write the erroring expression                        TcType           -- ^ expected type of that expression                        Unique           -- ^ for debug output only@@ -664,7 +730,6 @@ [Notice though that evidence variables that bind coercion terms  from super classes will be "given" and hence rigid] - Note [Overview of implicit CallStacks] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (See https://gitlab.haskell.org/ghc/ghc/wikis/explicit-call-stack/implicit-locations)@@ -676,12 +741,13 @@    type HasCallStack = (?callStack :: CallStack) -Implicit parameters of type GHC.Stack.Types.CallStack (the name is not-important) are solved in three steps:+Implicit parameters of type GHC.Stack.Types.CallStack (the /name/ of the+implicit parameter is not important, see (CS5) below) are solved as follows: -1. Explicit, user-written occurrences of `?stk :: CallStack`-   which have IPOccOrigin, are solved directly from the given IP,-   just like a regular IP; see GHC.Tc.Solver.Dict.tryInertDicts.+1. Plan NORMAL. Explicit, user-written occurrences of `?stk :: CallStack`, which+   have IPOccOrigin, are solved directly from the given IP, just like any other+   implicit-parameter constraint; see GHC.Tc.Solver.Dict.tryInertDicts. We can+   solve it from a Given or from another Wanted, if the two have the same type.     For example, the occurrence of `?stk` in @@ -690,44 +756,33 @@     will be solved for the `?stk` in `error`s context as before. -2. In a function call, instead of simply passing the given IP, we first-   append the current call-site to it. For example, consider a-   call to the callstack-aware `error` above.--     foo :: (?stk :: CallStack) => a-     foo = error "undefined!"--   Here we want to take the given `?stk` and append the current-   call-site, before passing it to `error`. In essence, we want to-   rewrite `foo "undefined!"` to--     let ?stk = pushCallStack <foo's location> ?stk-     in foo "undefined!"+2. Plan PUSH.  A /function call/ with a CallStack constraint, such as+   a call to `foo` where+        foo :: (?stk :: CallStack) => a+   will give rise to a Wanted constraint+        [W] d :: (?stk :: CallStack)    CtOrigin = OccurrenceOf "foo" -   We achieve this as follows:+   We do /not/ solve this constraint from Givens, or from other+   Wanteds.  Rather, have a built-in mechanism in that solves it thus:+        d := EvCsPushCall "foo" <details of call-site of `foo`> d2+        [W] d2 :: (?stk :: CallStack)    CtOrigin = IPOccOrigin -   * At a call of foo :: (?stk :: CallStack) => blah-     we emit a Wanted-        [W] d1 : IP "stk" CallStack-     with CtOrigin = OccurrenceOf "foo"+   That is, `d` is a call-stack that has the `foo` call-site pushed on top of+   `d2`, which can now be solved normally (as in (1) above).  This is done as follows:+     - In GHC.Tc.Solver.Dict.canDictCt we do the pushing.+     - We only look up canonical constraints in the inert set -   * We /solve/ this constraint, in GHC.Tc.Solver.Dict.canDictNC-     by emitting a NEW Wanted-        [W] d2 :: IP "stk" CallStack-     with CtOrigin = IPOccOrigin+3. For a CallStack constraint, we choose how to solve it based on its CtOrigin: -     and solve d1 = EvCsPushCall "foo" <foo's location> (EvId d1)+     * solve it normally (plan NORMAL above)+         - IPOccOrigin (discussed above)+         - GivenOrigin (see (CS1) below) -   * The new Wanted, for `d2` will be solved per rule (1), ie as a regular IP.+     * push an item on the stack and emit a new constraint (plan PUSH above)+         - OccurrenceOf "foo" (discused above)+         - anything else      (see (CS1) below) -3. We use the predicate isPushCallStackOrigin to identify whether we-   want to do (1) solve directly, or (2) push and then solve directly.-   Key point (see #19918): the CtOrigin where we want to push an item on the-   call stack can include IfThenElseOrigin etc, when RebindableSyntax is-   involved.  See the defn of fun_orig in GHC.Tc.Gen.App.tcInstFun; it is-   this CtOrigin that is pinned on the constraints generated by functions-   in the "expansion" for rebindable syntax. c.f. GHC.Rename.Expr-   Note [Handling overloaded and rebindable constructs]+   This choice is by the predicate isPushCallStackOrigin_maybe  4. We default any insoluble CallStacks to the empty CallStack. Suppose    `undefined` did not request a CallStack, ie@@ -763,21 +818,38 @@ in `g`, because `head` did not explicitly request a CallStack.  -Important Details:-- GHC should NEVER report an insoluble CallStack constraint.+Wrinkles -- GHC should NEVER infer a CallStack constraint unless one was requested+(CS1) Which CtOrigins should qualify for plan PUSH?  Certainly ones that arise+   from a function call like (f a b).++   But (see #19918) when RebindableSyntax is involved we can function call whose+   CtOrigin is somethign like `IfThenElseOrigin`. See the defn of fun_orig in+   GHC.Tc.Gen.App.tcInstFun; it is this CtOrigin that is pinned on the+   constraints generated by functions in the "expansion" for rebindable+   syntax. c.f. GHC.Rename.Expr Note [Handling overloaded and rebindable+   constructs].++   So isPushCallStackOrigin_maybe has a fall-through for "anything else", and+   assumes that we should adopt plan PUSH for it.++   However we should /not/ take this fall-through for Given constraints+   (#25675).  So isPushCallStackOrigin_maybe identifies Givens as plan NORMAL.++(CS2) GHC should NEVER report an insoluble CallStack constraint.++(CS3) GHC should NEVER infer a CallStack constraint unless one was requested   with a partial type signature (See GHC.Tc.Solver..pickQuantifiablePreds). -- A CallStack (defined in GHC.Stack.Types) is a [(String, SrcLoc)],+(CS4) A CallStack (defined in GHC.Stack.Types) is a [(String, SrcLoc)],   where the String is the name of the binder that is used at the   SrcLoc. SrcLoc is also defined in GHC.Stack.Types and contains the   package/module/file name, as well as the full source-span. Both   CallStack and SrcLoc are kept abstract so only GHC can construct new   values. -- We will automatically solve any wanted CallStack regardless of the-  name of the IP, i.e.+(CS5) We will automatically solve any wanted CallStack regardless of the+  /name/ of the IP, i.e.      f = show (?stk :: CallStack)     g = show (?loc :: CallStack)@@ -791,27 +863,18 @@   the printed CallStack will NOT include head's call-site. This reflects the   standard scoping rules of implicit-parameters. -- An EvCallStack term desugars to a CoreExpr of type `IP "some str" CallStack`.+(CS6) An EvCallStack term desugars to a CoreExpr of type `IP "some str" CallStack`.   The desugarer will need to unwrap the IP newtype before pushing a new   call-site onto a given stack (See GHC.HsToCore.Binds.dsEvCallStack) -- When we emit a new wanted CallStack from rule (2) we set its origin to+(CS7) When we emit a new wanted CallStack in plan PUSH we set its origin to   `IPOccOrigin ip_name` instead of the original `OccurrenceOf func`   (see GHC.Tc.Solver.Dict.tryInertDicts).    This is a bit shady, but is how we ensure that the new wanted is   solved like a regular IP.- -} -mkEvCast :: EvExpr -> TcCoercion -> EvTerm-mkEvCast ev lco-  | assertPpr (coercionRole lco == Representational)-              (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco]) $-    isReflCo lco = EvExpr ev-  | otherwise    = evCast ev lco-- mkEvScSelectors         -- Assume   class (..., D ty, ...) => C a b   :: Class -> [TcType]  -- C ty1 ty2   -> [(TcPredType,      -- D ty[ty1/a,ty2/b]@@ -831,25 +894,42 @@ isEmptyTcEvBinds (EvBinds b)    = isEmptyBag b isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds" +evExprCoercion_maybe :: EvExpr -> Maybe TcCoercion+-- Applied only to EvExprs of type (s~t)+-- See Note [Coercion evidence terms]+evExprCoercion_maybe (Var v)       = return (mkCoVarCo v)+evExprCoercion_maybe (Coercion co) = return co+evExprCoercion_maybe (Cast tm co)  = do { co' <- evExprCoercion_maybe tm+                                        ; return (mkCoCast co' co) }+evExprCoercion_maybe _             = Nothing++evExprCoercion :: EvExpr -> TcCoercion+evExprCoercion tm = case evExprCoercion_maybe tm of+                      Just co -> co+                      Nothing -> pprPanic "evExprCoercion" (ppr tm)+ evTermCoercion_maybe :: EvTerm -> Maybe TcCoercion -- Applied only to EvTerms of type (s~t) -- See Note [Coercion evidence terms] evTermCoercion_maybe ev_term-  | EvExpr e <- ev_term = go e+  | EvExpr e <- ev_term = evExprCoercion_maybe e   | otherwise           = Nothing-  where-    go :: EvExpr -> Maybe TcCoercion-    go (Var v)       = return (mkCoVarCo v)-    go (Coercion co) = return co-    go (Cast tm co)  = do { co' <- go tm-                          ; return (mkCoCast co' co) }-    go _             = Nothing  evTermCoercion :: EvTerm -> TcCoercion evTermCoercion tm = case evTermCoercion_maybe tm of                       Just co -> co                       Nothing -> pprPanic "evTermCoercion" (ppr tm) +-- Used with Opt_DeferTypeErrors+-- See Note [Deferring coercion errors to runtime]+-- in GHC.Tc.Solver+evDelayedError :: Type -> String -> EvTerm+evDelayedError ty msg+  = EvExpr $+    let fail_expr = mkRuntimeErrorApp tYPE_ERROR_ID unitTy msg+    in mkWildCase fail_expr (unrestricted unitTy) ty []+       -- See Note [Incompleteness and linearity] in GHC.HsToCore.Utils+       -- c.f. mkErrorAppDs in GHC.HsToCore.Utils  {- ********************************************************************* *                                                                      *@@ -857,41 +937,38 @@ *                                                                      * ********************************************************************* -} -findNeededEvVars :: EvBindMap -> VarSet -> VarSet--- Find all the Given evidence needed by seeds,--- looking transitively through binds-findNeededEvVars ev_binds seeds-  = transCloVarSet also_needs seeds-  where-   also_needs :: VarSet -> VarSet-   also_needs needs = nonDetStrictFoldUniqSet add emptyVarSet needs-     -- It's OK to use a non-deterministic fold here because we immediately-     -- forget about the ordering by creating a set+isNestedEvId :: Var -> Bool+-- Just returns /nested/ free evidence variables; i.e ones with Internal Names+-- Top-level ones (DFuns, dictionary selectors and the like) don't count+-- Evidence variables are always Ids; do not pick TyVars+isNestedEvId v = isId v && isInternalName (varName v) -   add :: Var -> VarSet -> VarSet-   add v needs-     | Just ev_bind <- lookupEvBind ev_binds v-     , EvBind { eb_info = EvBindGiven, eb_rhs = rhs } <- ev_bind-     = evVarsOfTerm rhs `unionVarSet` needs-     | otherwise-     = needs+nestedEvIdsOfTerm :: EvTerm -> VarSet+-- Returns only EvIds satisfying relevantEvId+nestedEvIdsOfTerm tm = fvVarSet (filterFV isNestedEvId (evTermFVs tm)) -evVarsOfTerm :: EvTerm -> VarSet-evVarsOfTerm (EvExpr e)         = exprSomeFreeVars isEvVar e-evVarsOfTerm (EvTypeable _ ev)  = evVarsOfTypeable ev-evVarsOfTerm (EvFun {})         = emptyVarSet -- See Note [Free vars of EvFun]+evTermFVs :: EvTerm -> FV+evTermFVs (EvExpr e)         = exprFVs e+evTermFVs (EvTypeable _ ev)  = evFVsOfTypeable ev+evTermFVs (EvFun { et_tvs = tvs, et_given = given+                 , et_binds = tc_ev_binds, et_body = v })+  = case tc_ev_binds of+      TcEvBinds {}  -> emptyFV  -- See Note [Free vars of EvFun]+      EvBinds binds -> addBndrsFV bndrs fvs+        where+          fvs = foldr (unionFV . evTermFVs . eb_rhs) (unitFV v) binds+          bndrs = foldr ((:) . eb_lhs) (tvs ++ given) binds -evVarsOfTerms :: [EvTerm] -> VarSet-evVarsOfTerms = mapUnionVarSet evVarsOfTerm+evTermFVss :: [EvTerm] -> FV+evTermFVss = mapUnionFV evTermFVs -evVarsOfTypeable :: EvTypeable -> VarSet-evVarsOfTypeable ev =+evFVsOfTypeable :: EvTypeable -> FV+evFVsOfTypeable ev =   case ev of-    EvTypeableTyCon _ e      -> mapUnionVarSet evVarsOfTerm e-    EvTypeableTyApp e1 e2    -> evVarsOfTerms [e1,e2]-    EvTypeableTrFun em e1 e2 -> evVarsOfTerms [em,e1,e2]-    EvTypeableTyLit e        -> evVarsOfTerm e-+    EvTypeableTyCon _ e      -> mapUnionFV evTermFVs e+    EvTypeableTyApp e1 e2    -> evTermFVss [e1,e2]+    EvTypeableTrFun em e1 e2 -> evTermFVss [em,e1,e2]+    EvTypeableTyLit e        -> evTermFVs e  {- Note [Free vars of EvFun] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -899,19 +976,22 @@ bindings et_binds may be a mutable variable.  Fortunately, we can just squeeze by.  Here's how. -* evVarsOfTerm is used only by GHC.Tc.Solver.neededEvVars.-* Each EvBindsVar in an et_binds field of an EvFun is /also/ in the-  ic_binds field of an Implication-* So we can track usage via the processing for that implication,-  (see Note [Tracking redundant constraints] in GHC.Tc.Solver).-  We can ignore usage from the EvFun altogether.+* /During/ typechecking, `evTermFVs` is used only by `GHC.Tc.Solver.neededEvVars`+  * Each EvBindsVar in an et_binds field of an EvFun is /also/ in the+    ic_binds field of an Implication+  * So we can track usage via the processing for that implication,+    (see Note [Tracking redundant constraints] in GHC.Tc.Solver).+    We can ignore usage from the EvFun altogether. -************************************************************************+* /After/ typechecking `evTermFVs` is used by `GHC.Iface.Ext.Ast`, but by+  then it has been zonked so we can get at the bindings.+-}++{- ********************************************************************* *                                                                      *                   Pretty printing *                                                                      *-************************************************************************--}+********************************************************************* -}  instance Outputable HsWrapper where   ppr co_fn = pprHsWrapper co_fn (no_parens (text "<>"))@@ -940,8 +1020,6 @@     help it (WpEvLam id)  = add_parens $ sep [ text "\\" <> pprLamBndr id <> dot, it False]     help it (WpTyLam tv)  = add_parens $ sep [text "/\\" <> pprLamBndr tv <> dot, it False]     help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False]-    help it (WpMultCoercion co)   = add_parens $ sep [it False, nest 2 (text "<multiplicity coercion>"-                                              <+> pprParendCo co)]  pprLamBndr :: Id -> SDoc pprLamBndr v = pprBndr LambdaBind v@@ -994,30 +1072,6 @@   ppr (EvTypeableTrFun tm t1 t2) = parens (ppr t1 <+> arr <+> ppr t2)     where       arr = pprArrowWithMultiplicity visArgTypeLike (Right (ppr tm))---------------------------------------------------------------------------- Helper functions for dealing with IP newtype-dictionaries--------------------------------------------------------------------------- | Create a 'Coercion' that unwraps an implicit-parameter--- dictionary to expose the underlying value.--- We expect the 'Type' to have the form `IP sym ty`,--- and return a 'Coercion' `co :: IP sym ty ~ ty`-unwrapIP :: Type -> CoercionR-unwrapIP ty =-  case unwrapNewTyCon_maybe tc of-    Just (_,_,ax) -> mkUnbranchedAxInstCo Representational ax tys []-    Nothing       -> pprPanic "unwrapIP" $-                       text "The dictionary for" <+> quotes (ppr tc)-                         <+> text "is not a newtype!"-  where-  (tc, tys) = splitTyConApp ty---- | Create a 'Coercion' that wraps a value in an implicit-parameter--- dictionary. See 'unwrapIP'.-wrapIP :: Type -> CoercionR-wrapIP ty = mkSymCo (unwrapIP ty)  ---------------------------------------------------------------------- -- A datatype used to pass information when desugaring quotations
compiler/GHC/Tc/Types/LclEnv.hs view
@@ -11,13 +11,13 @@   , getLclEnvLoc   , getLclEnvRdrEnv   , getLclEnvTcLevel-  , getLclEnvThStage+  , getLclEnvThLevel   , setLclEnvTcLevel   , setLclEnvLoc   , setLclEnvRdrEnv   , setLclEnvBinderStack   , setLclEnvErrCtxt-  , setLclEnvThStage+  , setLclEnvThLevel   , setLclEnvTypeEnv   , modifyLclEnvTcLevel @@ -108,7 +108,7 @@                 --   we can look up record field names  -        tcl_th_ctxt    :: ThStage,         -- Template Haskell context+        tcl_th_ctxt    :: ThLevel,         -- Template Haskell context         tcl_th_bndrs   :: ThBindEnv,       -- and binder info             -- The ThBindEnv records the TH binding level of in-scope Names             -- defined in this module (not imported)@@ -119,14 +119,13 @@          tcl_env  :: TcTypeEnv    -- The local type environment:                                  -- Ids and TyVars defined in this module-     } -getLclEnvThStage :: TcLclEnv -> ThStage-getLclEnvThStage = tcl_th_ctxt . tcl_lcl_ctxt+getLclEnvThLevel :: TcLclEnv -> ThLevel+getLclEnvThLevel = tcl_th_ctxt . tcl_lcl_ctxt -setLclEnvThStage :: ThStage -> TcLclEnv -> TcLclEnv-setLclEnvThStage s = modifyLclCtxt (\env -> env { tcl_th_ctxt = s })+setLclEnvThLevel :: ThLevel -> TcLclEnv -> TcLclEnv+setLclEnvThLevel l = modifyLclCtxt (\env -> env { tcl_th_ctxt = l })  getLclEnvThBndrs :: TcLclEnv -> ThBindEnv getLclEnvThBndrs = tcl_th_bndrs . tcl_lcl_ctxt@@ -188,7 +187,7 @@  type TcTypeEnv = NameEnv TcTyThing -type ThBindEnv = NameEnv (TopLevelFlag, ThLevel)+type ThBindEnv = NameEnv (TopLevelFlag, ThLevelIndex)    -- Domain = all Ids bound in this module (ie not imported)    -- The TopLevelFlag tells if the binding is syntactically top level.    -- We need to know this, because the cross-stage persistence story allows@@ -196,6 +195,7 @@    --    -- Nota bene: a ThLevel of 'outerLevel' is *not* the same as being    -- bound at top level!  See Note [Template Haskell levels] in GHC.Tc.Gen.Splice+  --------------------------- -- Arrow-notation context
compiler/GHC/Tc/Types/Origin.hs view
@@ -1,9 +1,10 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE StandaloneKindSignatures #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilyDependencies #-}  -- | Describes the provenance of types as they flow through the type-checker. -- The datatypes here are mainly used for error message generation.@@ -15,19 +16,22 @@    -- * SkolemInfo   SkolemInfo(..), SkolemInfoAnon(..), mkSkolemInfo, getSkolemInfo, pprSigSkolInfo, pprSkolInfo,-  unkSkol, unkSkolAnon, mkClsInstSkol,+  unkSkol, unkSkolAnon,    -- * CtOrigin   CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,   isVisibleOrigin, toInvisibleOrigin,-  pprCtOrigin, isGivenOrigin, isWantedWantedFunDepOrigin,+  pprCtOrigin, pprCtOriginBriefly,+  isGivenOrigin, isWantedWantedFunDepOrigin,   isWantedSuperclassOrigin,   ClsInstOrQC(..), NakedScFlag(..), NonLinearPatternReason(..),+  HsImplicitLiftSplice(..),+  StandaloneDeriv,    TypedThing(..), TyVarBndrs(..),    -- * CallStack-  isPushCallStackOrigin, callStackOriginFS,+  isPushCallStackOrigin_maybe,    -- * FixedRuntimeRep origin   FixedRuntimeRepOrigin(..),@@ -37,7 +41,7 @@   mkFRRUnboxedTuple, mkFRRUnboxedSum,    -- ** FixedRuntimeRep origin for rep-poly 'Id's-  RepPolyId(..), Polarity(..), Position(..),+  RepPolyId(..), Polarity(..), Position(..), mkArgPos,    -- ** Arrow command FixedRuntimeRep origin   FRRArrowContext(..), pprFRRArrowContext,@@ -58,7 +62,6 @@ import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.TyCon-import GHC.Core.Class import GHC.Core.InstEnv import GHC.Core.PatSyn import GHC.Core.Multiplicity ( scaledThing )@@ -77,13 +80,14 @@ import GHC.Utils.Panic import GHC.Stack import GHC.Utils.Monad-import GHC.Utils.Misc( HasDebugCallStack )+import GHC.Utils.Misc( HasDebugCallStack, nTimes ) import GHC.Types.Unique import GHC.Types.Unique.Supply  import Language.Haskell.Syntax.Basic (FieldLabelString(..))  import qualified Data.Kind as Hs+import Data.List.NonEmpty (NonEmpty (..))  {- ********************************************************************* *                                                                      *@@ -129,8 +133,6 @@   | PatSigCtxt          -- Type sig in pattern                         --   eg  f (x::t) = ...                         --   or  (x::t, y) = e-  | RuleSigCtxt FastString Name    -- LHS of a RULE forall-                        --    RULE "foo" forall (x :: a -> a). f (Just x) = ...   | ForSigCtxt Name     -- Foreign import or export signature   | DefaultDeclCtxt     -- Class or types in a default declaration   | InstDeclCtxt Bool   -- An instance declaration@@ -153,6 +155,9 @@                         --      data <S> => T a = MkT a   | DerivClauseCtxt     -- A 'deriving' clause   | TyVarBndrKindCtxt Name  -- The kind of a type variable being bound+  | RuleBndrTypeCtxt Name   -- The type of a term variable being bound in a RULE+                            -- or SPECIALISE pragma+                            --    RULE "foo" forall (x :: a -> a). f (Just x) = ...   | DataKindCtxt Name   -- The kind of a data/newtype (instance)   | TySynKindCtxt Name  -- The kind of the RHS of a type synonym   | TyFamResKindCtxt Name   -- The result kind of a type family@@ -194,11 +199,10 @@   pprUserTypeCtxt :: UserTypeCtxt -> SDoc-pprUserTypeCtxt (FunSigCtxt n _)  = text "the type signature for" <+> quotes (ppr n)-pprUserTypeCtxt (InfSigCtxt n)    = text "the inferred type for" <+> quotes (ppr n)-pprUserTypeCtxt (RuleSigCtxt _ n) = text "the type signature for" <+> quotes (ppr n)-pprUserTypeCtxt (ExprSigCtxt _)   = text "an expression type signature"-pprUserTypeCtxt KindSigCtxt       = text "a kind signature"+pprUserTypeCtxt (FunSigCtxt n _)   = text "the type signature for" <+> quotes (ppr n)+pprUserTypeCtxt (InfSigCtxt n)     = text "the inferred type for" <+> quotes (ppr n)+pprUserTypeCtxt (ExprSigCtxt _)    = text "an expression type signature"+pprUserTypeCtxt KindSigCtxt        = text "a kind signature" pprUserTypeCtxt (StandaloneKindSigCtxt n) = text "a standalone kind signature for" <+> quotes (ppr n) pprUserTypeCtxt TypeAppCtxt       = text "a type argument" pprUserTypeCtxt (ConArgCtxt c)    = text "the type of the constructor" <+> quotes (ppr c)@@ -217,6 +221,7 @@ pprUserTypeCtxt (PatSynCtxt n)    = text "the signature for pattern synonym" <+> quotes (ppr n) pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause" pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type variable" <+> quotes (ppr n)+pprUserTypeCtxt (RuleBndrTypeCtxt n)  = text "the type signature for" <+> quotes (ppr n) pprUserTypeCtxt (DataKindCtxt n)  = text "the kind annotation on the declaration for" <+> quotes (ppr n) pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n)@@ -286,7 +291,14 @@        ClsInstOrQC      -- Whether class instance or quantified constraint        PatersonSize     -- Head has the given PatersonSize +  | MethSkol Name Bool  -- Bound by the type of class method op+                        -- True  <=> it's a vanilla default method+                        -- False <=> it's a user-written, or generic-default, method+                        -- See (TRC5) in Note [Tracking redundant constraints]+                        --            in GHC.Tc.Solver.Solve+   | FamInstSkol         -- Bound at a family instance decl+   | PatSkol             -- An existential type variable bound by a pattern for       ConLike           -- a data constructor with an existential type.       HsMatchContextRn@@ -298,6 +310,7 @@   | IPSkol [HsIPName]   -- Binding site of an implicit parameter    | RuleSkol RuleName   -- The LHS of a RULE+  | SpecESkol Name      -- A SPECIALISE pragma    | InferSkol [(Name,TcType)]                         -- We have inferred a type for these (mutually recursive)@@ -345,9 +358,6 @@ getSkolemInfo :: SkolemInfo -> SkolemInfoAnon getSkolemInfo (SkolemInfo _ skol_anon) = skol_anon -mkClsInstSkol :: Class -> [Type] -> SkolemInfoAnon-mkClsInstSkol cls tys = InstSkol IsClsInst (pSizeClassPred cls tys)- instance Outputable SkolemInfo where   ppr (SkolemInfo _ sk_info ) = ppr sk_info @@ -364,11 +374,14 @@ pprSkolInfo (DerivSkol pred)  = text "the deriving clause for" <+> quotes (ppr pred) pprSkolInfo (InstSkol IsClsInst sz) = vcat [ text "the instance declaration"                                            , whenPprDebug (braces (ppr sz)) ]-pprSkolInfo (InstSkol (IsQC {}) sz) = vcat [ text "a quantified context"+pprSkolInfo (InstSkol (IsQC {}) sz) = vcat [ text "a quantified constraint"                                            , whenPprDebug (braces (ppr sz)) ]+pprSkolInfo (MethSkol name d) = text "the" <+> ppWhen d (text "default")+                                           <+> text "method declaration for" <+> ppr name pprSkolInfo FamInstSkol       = text "a family instance declaration" pprSkolInfo BracketSkol       = text "a Template Haskell bracket" pprSkolInfo (RuleSkol name)   = text "the RULE" <+> pprRuleName name+pprSkolInfo (SpecESkol name)  = text "a SPECIALISE pragma for" <+> quotes (ppr name) pprSkolInfo (PatSkol cl mc)   = sep [ pprPatSkolInfo cl                                     , text "in" <+> pprMatchContext mc ] pprSkolInfo (InferSkol ids)   = hang (text "the inferred type" <> plural ids <+> text "of")@@ -509,11 +522,11 @@    ----------- Below here, all are Origins for Wanted constraints ------------ -  | OccurrenceOf Name              -- Occurrence of an overloaded identifier-  | OccurrenceOfRecSel RdrName     -- Occurrence of a record selector-  | AppOrigin                      -- An application of some kind+  | OccurrenceOf Name          -- ^ Occurrence of an overloaded identifier+  | OccurrenceOfRecSel RdrName -- ^ Occurrence of a record selector+  | AppOrigin                  -- ^ An application of some kind -  | SpecPragOrigin UserTypeCtxt    -- Specialisation pragma for+  | SpecPragOrigin UserTypeCtxt    -- ^ Specialisation pragma for                                    -- function or instance  @@ -544,7 +557,7 @@                         -- IMPORTANT: These constraints will never cause errors;                         -- See Note [Constraints to ignore] in GHC.Tc.Errors   | SectionOrigin-  | HasFieldOrigin FastString+  | GetFieldOrigin FastString   | TupleOrigin         -- (..,..)   | ExprSigOrigin       -- e :: ty   | PatSigOrigin        -- p :: ty@@ -561,9 +574,9 @@       ClsInstOrQC   -- Whether class instance or quantified constraint       NakedScFlag -  | DerivClauseOrigin   -- Typechecking a deriving clause (as opposed to-                        -- standalone deriving).-  | DerivOriginDC DataCon Int Bool+  | DerivOrigin StandaloneDeriv+      -- Typechecking a `deriving` clause, or a standalone `deriving` declaration+  | DerivOriginDC DataCon Int StandaloneDeriv       -- Checking constraints arising from this data con and field index. The       -- Bool argument in DerivOriginDC and DerivOriginCoerce is True if       -- standalong deriving (with a wildcard constraint) is being used. This@@ -571,14 +584,10 @@       -- the argument is True, then don't recommend "use standalone deriving",       -- but rather "fill in the wildcard constraint yourself").       -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer-  | DerivOriginCoerce Id Type Type Bool-                        -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from-                        -- `ty1` to `ty2`.-  | StandAloneDerivOrigin -- Typechecking stand-alone deriving. Useful for-                          -- constraints coming from a wildcard constraint,-                          -- e.g., deriving instance _ => Eq (Foo a)-                          -- See Note [Inferring the instance context]-                          -- in GHC.Tc.Deriv.Infer+  | DerivOriginCoerce Id Type Type StandaloneDeriv+      -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from+      -- `ty1` to `ty2`.+   | DefaultOrigin       -- Typechecking a default decl   | DoOrigin            -- Arising from a do expression   | DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in@@ -626,10 +635,10 @@   | OmittedFieldOrigin (Maybe FieldLabel)   | UsageEnvironmentOf Name +  -- | See Detail (7) of Note [Type equality cycles] in GHC.Tc.Solver.Equality   | CycleBreakerOrigin       CtOrigin   -- origin of the original constraint -      -- See Detail (7) of Note [Type equality cycles] in GHC.Tc.Solver.Equality   | FRROrigin       FixedRuntimeRepOrigin @@ -643,6 +652,7 @@       Type   -- the instance-sig type       Type   -- the instantiated type of the method   | AmbiguityCheckOrigin UserTypeCtxt+  | ImplicitLiftOrigin HsImplicitLiftSplice  data NonLinearPatternReason   = LazyPatternReason@@ -651,13 +661,22 @@   | ViewPatternReason   | OtherPatternReason +type StandaloneDeriv = Bool+  -- False <=> a `deriving` clause on a data/newtype declaration+  --           e.g.  data T a = MkT a deriving( Eq )+  -- True <=> a standalone `deriving` clause with a wildcard constraint+  --          e.g   deriving instance _ => Eq (T a)+  -- See Note [Inferring the instance context]+  -- in GHC.Tc.Deriv.Infer+ -- | The number of superclass selections needed to get this Given. -- If @d :: C ty@   has @ScDepth=2@, then the evidence @d@ will look -- like @sc_sel (sc_sel dg)@, where @dg@ is a Given. type ScDepth = Int -data ClsInstOrQC = IsClsInst-                 | IsQC CtOrigin+data ClsInstOrQC+  = IsClsInst+  | IsQC PredType CtOrigin  -- The PredType is the forall-constraint we are trying to solve  data NakedScFlag = NakedSc | NotNakedSc       --   The NakedScFlag affects only GHC.Tc.Solver.InertSet.prohibitedSuperClassSolve@@ -707,17 +726,13 @@ instance Outputable CtOrigin where   ppr = pprCtOrigin -ctoHerald :: SDoc-ctoHerald = text "arising from"- -- | Extract a suitable CtOrigin from a HsExpr lexprCtOrigin :: LHsExpr GhcRn -> CtOrigin lexprCtOrigin (L _ e) = exprCtOrigin e  exprCtOrigin :: HsExpr GhcRn -> CtOrigin-exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name-exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (field_label $ unLoc $ dfoLabel f)-exprCtOrigin (HsUnboundVar {})    = Shouldn'tHappenOrigin "unbound variable"+exprCtOrigin (HsVar _ (L _ (WithUserRdr _ name))) = OccurrenceOf name+exprCtOrigin (HsGetField _ _ (L _ f)) = GetFieldOrigin (field_label $ unLoc $ dfoLabel f) exprCtOrigin (HsOverLabel _ l)  = OverLabelOrigin l exprCtOrigin (ExplicitList {})    = ListOrigin exprCtOrigin (HsIPVar _ ip)       = IPOccOrigin ip@@ -751,6 +766,7 @@ exprCtOrigin (HsProc {})         = Shouldn'tHappenOrigin "proc" exprCtOrigin (HsStatic {})       = Shouldn'tHappenOrigin "static expression" exprCtOrigin (HsEmbTy {})        = Shouldn'tHappenOrigin "type expression"+exprCtOrigin (HsHole _)          = Shouldn'tHappenOrigin "hole expression" exprCtOrigin (HsForAll {})       = Shouldn'tHappenOrigin "forall telescope"    -- See Note [Types in terms] exprCtOrigin (HsQual {})         = Shouldn'tHappenOrigin "constraint context"  -- See Note [Types in terms] exprCtOrigin (HsFunArr {})       = Shouldn'tHappenOrigin "function arrow"      -- See Note [Types in terms]@@ -775,12 +791,15 @@ grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss  -- | Extract a suitable CtOrigin from a list of guarded RHSs-lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin-lGRHSCtOrigin [L _ (GRHS _ _ (L _ e))] = exprCtOrigin e+lGRHSCtOrigin :: NonEmpty (LGRHS GhcRn (LHsExpr GhcRn)) -> CtOrigin+lGRHSCtOrigin (L _ (GRHS _ _ (L _ e)) :| []) = exprCtOrigin e lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS" +ctoHerald :: SDoc+ctoHerald = text "arising from"+ pprCtOrigin :: CtOrigin -> SDoc--- "arising from ..."+ pprCtOrigin (GivenOrigin sk)   = ctoHerald <+> ppr sk @@ -789,8 +808,9 @@          , whenPprDebug (braces (text "given-sc:" <+> ppr d <> comma <> ppr blk)) ]  pprCtOrigin (SpecPragOrigin ctxt)-  = case ctxt of-       FunSigCtxt n _ -> text "for" <+> quotes (ppr n)+  = ctoHerald <+>+    case ctxt of+       FunSigCtxt n _ -> text "a SPECIALISE pragma for" <+> quotes (ppr n)        SpecInstCtxt   -> text "a SPECIALISE INSTANCE pragma"        _              -> text "a SPECIALISE pragma"  -- Never happens I think @@ -812,7 +832,7 @@                , hang (quotes (ppr pred2)) 2 (pprCtOrigin orig2 <+> text "at" <+> ppr loc2) ])  pprCtOrigin AssocFamPatOrigin-  = text "when matching a family LHS with its class instance head"+  = ctoHerald <+> text "matching a family LHS with its class instance head"  pprCtOrigin (TypeEqOrigin { uo_actual = t1, uo_expected =  t2, uo_visible = vis })   = hang (ctoHerald <+> text "a type equality" <> whenPprDebug (brackets (ppr vis)))@@ -856,13 +876,13 @@        2 (text "the signature of" <+> quotes (ppr name))  pprCtOrigin (InstProvidedOrigin mod cls_inst)-  = vcat [ text "arising when attempting to show that"+  = vcat [ ctoHerald <+> text "attempting to show that"          , ppr cls_inst          , text "is provided by" <+> quotes (ppr mod)]  pprCtOrigin (ImpedanceMatching x)-  = vcat [ text "arising when matching required constraints"-         , text "in a group involving" <+> quotes (ppr x)]+  = vcat [ ctoHerald <+> text "matching required constraints"+         , text "in a binding group involving" <+> quotes (ppr x)]  pprCtOrigin (CycleBreakerOrigin orig)   = pprCtOrigin orig@@ -887,85 +907,91 @@   = vcat [ ctoHerald <+> text "the superclasses of an instance declaration"          , whenPprDebug (braces (text "sc-origin:" <> ppr nkd)) ] -pprCtOrigin (ScOrigin (IsQC orig) nkd)-  = vcat [ ctoHerald <+> text "the head of a quantified constraint"-         , whenPprDebug (braces (text "sc-origin:" <> ppr nkd))-         , pprCtOrigin orig ]+pprCtOrigin (ScOrigin (IsQC pred orig) nkd)+  = vcat [ whenPprDebug (text "IsQC" <> braces (text "sc-origin:" <> ppr nkd) <+> ppr pred)+         , hang (text "arising (via a quantified constraint) from")+              2 (pprCtOriginBriefly orig) ]+           -- Print `orig` briefly with pprCtOriginBriefly.  We'll print it more+           -- voluminously later: see GHC.Tc.Errors.Ppr.pprQCOriginExtra  pprCtOrigin (NonLinearPatternOrigin reason pat)   = hang (ctoHerald <+> text "a non-linear pattern" <+> quotes (ppr pat))        2 (pprNonLinearPatternReason reason)  pprCtOrigin simple_origin-  = ctoHerald <+> pprCtO simple_origin+  = ctoHerald <+> pprCtOriginBriefly simple_origin --- | Short one-liners-pprCtO :: HasDebugCallStack => CtOrigin -> SDoc-pprCtO (OccurrenceOf name)   = hsep [text "a use of", quotes (ppr name)]-pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)]-pprCtO AppOrigin             = text "an application"-pprCtO (IPOccOrigin name)    = hsep [text "a use of implicit parameter", quotes (ppr name)]-pprCtO (OverLabelOrigin l)   = hsep [text "the overloaded label"+-- | Print CtOrigin briefly, with a one-liner+pprCtOriginBriefly :: CtOrigin -> SDoc+pprCtOriginBriefly = ppr_br  -- ppr_br is a local function with a short name!++ppr_br :: CtOrigin -> SDoc+ppr_br (OccurrenceOf name)   = hsep [text "a use of", quotes (ppr name)]+ppr_br (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)]+ppr_br AppOrigin             = text "an application"+ppr_br (IPOccOrigin name)    = hsep [text "a use of implicit parameter", quotes (ppr name)]+ppr_br (OverLabelOrigin l)   = hsep [text "the overloaded label"                                     ,quotes (char '#' <> ppr l)]-pprCtO RecordUpdOrigin       = text "a record update"-pprCtO ExprSigOrigin         = text "an expression type signature"-pprCtO PatSigOrigin          = text "a pattern type signature"-pprCtO PatOrigin             = text "a pattern"-pprCtO ViewPatOrigin         = text "a view pattern"-pprCtO (LiteralOrigin lit)   = hsep [text "the literal", quotes (ppr lit)]-pprCtO (ArithSeqOrigin seq)  = hsep [text "the arithmetic sequence", quotes (ppr seq)]-pprCtO SectionOrigin         = text "an operator section"-pprCtO (HasFieldOrigin f)    = hsep [text "selecting the field", quotes (ppr f)]-pprCtO AssocFamPatOrigin     = text "the LHS of a family instance"-pprCtO TupleOrigin           = text "a tuple"-pprCtO NegateOrigin          = text "a use of syntactic negation"-pprCtO (ScOrigin IsClsInst _) = text "the superclasses of an instance declaration"-pprCtO (ScOrigin (IsQC {}) _) = text "the head of a quantified constraint"-pprCtO DerivClauseOrigin     = text "the 'deriving' clause of a data type declaration"-pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration"-pprCtO DefaultOrigin         = text "a 'default' declaration"-pprCtO DoOrigin              = text "a do statement"-pprCtO MCompOrigin           = text "a statement in a monad comprehension"-pprCtO ProcOrigin            = text "a proc expression"-pprCtO ArrowCmdOrigin        = text "an arrow command"-pprCtO AnnOrigin             = text "an annotation"-pprCtO (ExprHoleOrigin Nothing)    = text "an expression hole"-pprCtO (ExprHoleOrigin (Just occ)) = text "a use of" <+> quotes (ppr occ)-pprCtO (TypeHoleOrigin occ)  = text "a use of wildcard" <+> quotes (ppr occ)-pprCtO PatCheckOrigin        = text "a pattern-match completeness check"-pprCtO ListOrigin            = text "an overloaded list"-pprCtO IfThenElseOrigin      = text "an if-then-else expression"-pprCtO StaticOrigin          = text "a static form"-pprCtO (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)]-pprCtO (OmittedFieldOrigin Nothing) = text "an omitted anonymous field"-pprCtO (OmittedFieldOrigin (Just fl)) = hsep [text "omitted field" <+> quotes (ppr fl)]-pprCtO BracketOrigin         = text "a quotation bracket"+ppr_br RecordUpdOrigin       = text "a record update"+ppr_br ExprSigOrigin         = text "an expression type signature"+ppr_br PatSigOrigin          = text "a pattern type signature"+ppr_br PatOrigin             = text "a pattern"+ppr_br ViewPatOrigin         = text "a view pattern"+ppr_br (LiteralOrigin lit)   = hsep [text "the literal", quotes (ppr lit)]+ppr_br (ArithSeqOrigin seq)  = hsep [text "the arithmetic sequence", quotes (ppr seq)]+ppr_br SectionOrigin         = text "an operator section"+ppr_br (GetFieldOrigin f)    = hsep [text "selecting the field", quotes (ppr f)]+ppr_br AssocFamPatOrigin     = text "the LHS of a family instance"+ppr_br TupleOrigin           = text "a tuple"+ppr_br NegateOrigin          = text "a use of syntactic negation"+ppr_br (ScOrigin IsClsInst _) = text "the superclasses of an instance declaration"+ppr_br (ScOrigin (IsQC {}) _) = text "the head of a quantified constraint"+ppr_br (DerivOrigin standalone)+  | standalone               = text "a 'deriving' declaration"+  | otherwise                = text "the 'deriving' clause of a data type declaration"+ppr_br DefaultOrigin         = text "a 'default' declaration"+ppr_br DoOrigin              = text "a do statement"+ppr_br MCompOrigin           = text "a statement in a monad comprehension"+ppr_br ProcOrigin            = text "a proc expression"+ppr_br ArrowCmdOrigin        = text "an arrow command"+ppr_br AnnOrigin             = text "an annotation"+ppr_br (ExprHoleOrigin Nothing)    = text "an expression hole"+ppr_br (ExprHoleOrigin (Just occ)) = text "a use of" <+> quotes (ppr occ)+ppr_br (TypeHoleOrigin occ)  = text "a use of wildcard" <+> quotes (ppr occ)+ppr_br PatCheckOrigin        = text "a pattern-match completeness check"+ppr_br ListOrigin            = text "an overloaded list"+ppr_br IfThenElseOrigin      = text "an if-then-else expression"+ppr_br StaticOrigin          = text "a static form"+ppr_br (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)]+ppr_br (OmittedFieldOrigin Nothing) = text "an omitted anonymous field"+ppr_br (OmittedFieldOrigin (Just fl)) = hsep [text "omitted field" <+> quotes (ppr fl)]+ppr_br BracketOrigin            = text "a quotation bracket"+ppr_br (ImplicitLiftOrigin isp) = text "an implicit lift of" <+> quotes (ppr (implicit_lift_lid isp))  -- These ones are handled by pprCtOrigin, but we nevertheless sometimes--- get here via callStackOriginFS, when doing ambiguity checks--- A bit silly, but no great harm-pprCtO (GivenOrigin {})             = text "a given constraint"-pprCtO (GivenSCOrigin {})           = text "the superclass of a given constraint"-pprCtO (SpecPragOrigin {})          = text "a SPECIALISE pragma"-pprCtO (FunDepOrigin1 {})           = text "a functional dependency"-pprCtO (FunDepOrigin2 {})           = text "a functional dependency"-pprCtO (InjTFOrigin1 {})            = text "an injective type family"-pprCtO (TypeEqOrigin {})            = text "a type equality"-pprCtO (KindEqOrigin {})            = text "a kind equality"-pprCtO (DerivOriginDC {})           = text "a deriving clause"-pprCtO (DerivOriginCoerce {})       = text "a derived method"-pprCtO (DoPatOrigin {})             = text "a do statement"-pprCtO (MCompPatOrigin {})          = text "a monad comprehension pattern"-pprCtO (Shouldn'tHappenOrigin note) = text note-pprCtO (ProvCtxtOrigin {})          = text "a provided constraint"-pprCtO (InstProvidedOrigin {})      = text "a provided constraint"-pprCtO (CycleBreakerOrigin orig)    = pprCtO orig-pprCtO (FRROrigin {})               = text "a representation-polymorphism check"-pprCtO (WantedSuperclassOrigin {})  = text "a superclass constraint"-pprCtO (InstanceSigOrigin {})       = text "a type signature in an instance"-pprCtO (AmbiguityCheckOrigin {})    = text "a type ambiguity check"-pprCtO (ImpedanceMatching {})       = text "combining required constraints"-pprCtO (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)]+-- we call pprCtOriginBriefly directly (e.g. in callStackOriginFS)+ppr_br (GivenOrigin {})             = text "a given constraint"+ppr_br (GivenSCOrigin {})           = text "the superclass of a given constraint"+ppr_br (SpecPragOrigin {})          = text "a SPECIALISE pragma"+ppr_br (FunDepOrigin1 {})           = text "a functional dependency"+ppr_br (FunDepOrigin2 {})           = text "a functional dependency"+ppr_br (InjTFOrigin1 {})            = text "an injective type family"+ppr_br (TypeEqOrigin {})            = text "a type equality"+ppr_br (KindEqOrigin {})            = text "a kind equality"+ppr_br (DerivOriginDC {})           = text "a deriving clause"+ppr_br (DerivOriginCoerce m _ _ _)  = text "the coercion of derived method" <+> quotes (ppr m)+ppr_br (DoPatOrigin {})             = text "a do statement"+ppr_br (MCompPatOrigin {})          = text "a monad comprehension pattern"+ppr_br (Shouldn'tHappenOrigin note) = text note+ppr_br (ProvCtxtOrigin {})          = text "a provided constraint"+ppr_br (InstProvidedOrigin {})      = text "a provided constraint"+ppr_br (CycleBreakerOrigin orig)    = ppr_br orig+ppr_br (FRROrigin {})               = text "a representation-polymorphism check"+ppr_br (WantedSuperclassOrigin {})  = text "a superclass constraint"+ppr_br (InstanceSigOrigin {})       = text "a type signature in an instance"+ppr_br (AmbiguityCheckOrigin {})    = text "a type ambiguity check"+ppr_br (ImpedanceMatching {})       = text "combining required constraints"+ppr_br (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)]  pprNonLinearPatternReason :: HasDebugCallStack => NonLinearPatternReason -> SDoc pprNonLinearPatternReason LazyPatternReason = parens (text "non-variable lazy pattern aren't linear")@@ -983,18 +1009,22 @@ *                                                                      * ********************************************************************* -} -isPushCallStackOrigin :: CtOrigin -> Bool--- Do we want to solve this IP constraint directly (return False)--- or push the call site (return True)--- See Note [Overview of implicit CallStacks] in GHc.Tc.Types.Evidence-isPushCallStackOrigin (IPOccOrigin {}) = False-isPushCallStackOrigin _                = True---callStackOriginFS :: CtOrigin -> FastString--- This is the string that appears in the CallStack-callStackOriginFS (OccurrenceOf fun) = occNameFS (getOccName fun)-callStackOriginFS orig               = mkFastString (showSDocUnsafe (pprCtO orig))+isPushCallStackOrigin_maybe :: CtOrigin -> Maybe FastString+-- Do we want to solve this IP constraint normally (return Nothing)+-- or push the call site (returning the name of the function being called)+-- See Note [Overview of implicit CallStacks] esp (CS1) in GHC.Tc.Types.Evidence+isPushCallStackOrigin_maybe (GivenOrigin {})   = Nothing+isPushCallStackOrigin_maybe (GivenSCOrigin {}) = Nothing+isPushCallStackOrigin_maybe (IPOccOrigin {})   = Nothing+isPushCallStackOrigin_maybe (OccurrenceOf fun) = Just (occNameFS (getOccName fun))+isPushCallStackOrigin_maybe orig               = Just orig_fs+  -- This fall-through case is important to deal with call stacks+  --      that arise from rebindable syntax (#19919)+  -- Here the "name of the function being called" is approximated as+  --      the result of prettty-printing the CtOrigin; a bit messy,+  --      but we can perhaps improve it in the light of user feedback+  where+    orig_fs = mkFastString (showSDocUnsafe (pprCtOriginBriefly orig))  {- ************************************************************************@@ -1169,7 +1199,7 @@   -- See 'FRRArrowContext' for more details.   | FRRArrow !FRRArrowContext -  -- | A representation-polymorphic check arising from a call+  -- | A representation-polymorphism check arising from a call   -- to 'matchExpectedFunTys' or 'matchActualFunTy'.   --   -- See 'ExpectedFunTyOrigin' for more details.@@ -1178,6 +1208,13 @@       !Int         -- ^ argument position (1-indexed) +  -- | A representation-polymorphism check arising from eta-expansion+  -- performed as part of deep subsumption.+  | forall p. FRRDeepSubsumption+      { frrDSExpected :: Bool+      , frrDSPosition :: Position p+      }+ -- | The description of a representation-polymorphic 'Id'. data RepPolyId   -- | A representation-polymorphic 'PrimOp'.@@ -1215,8 +1252,8 @@ pprFixedRuntimeRepContext (FRRBinder binder)   = sep [ text "The binder"         , quotes (ppr binder) ]-pprFixedRuntimeRepContext (FRRRepPolyId nm id what)-  = pprFRRRepPolyId id nm what+pprFixedRuntimeRepContext (FRRRepPolyId nm id pos)+  = text "The" <+> ppr pos <+> text "of" <+> pprRepPolyId id nm pprFixedRuntimeRepContext FRRPatBind   = text "The pattern binding" pprFixedRuntimeRepContext FRRPatSynArg@@ -1258,6 +1295,13 @@   = pprFRRArrowContext arrowContext pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig arg_pos)   = pprExpectedFunTyOrigin funTyOrig arg_pos+pprFixedRuntimeRepContext (FRRDeepSubsumption is_exp pos)+  = hsep [ text "The", what, text "type of the"+         , ppr (Argument pos)+         , text "of the eta-expansion"+         ]+  where+    what = if is_exp then text "expected" else text "actual"  instance Outputable FixedRuntimeRepContext where   ppr = pprFixedRuntimeRepContext@@ -1286,34 +1330,117 @@ *                                                                      * ********************************************************************* -} +{- Note [Positional information in representation-polymorphism errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider an invalid instantiation of the 'catch#' primop:++  catch#+    :: forall {q :: RuntimeRep} {k :: Levity} (a :: TYPE q)+              (b :: TYPE (BoxedRep k)).+       (State# RealWorld -> (# State# RealWorld, a #))+       -> (b -> State# RealWorld -> (# State# RealWorld, a #))+       -> State# RealWorld+       -> (# State# RealWorld, a #)++  boo :: forall r (a :: TYPE r). ...+  boo = catch# @a++The instantiation is invalid because we insist that the quantified RuntimeRep+type variable 'q' be instantiated to a concrete RuntimeRep, as per+Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete.++We report this as the following error message:++  The result of the first argument of the primop ‘catch#’ does not have a fixed runtime representation.+  Its type is: (a :: TYPE r).++The positional information in this message, namely "The result of the first argument",+is produced by using the 'Position' datatype. In this case:++  pos :: Position Neg+  pos = Result (Argument Top)+  ppr pos = "result of the first argument"++Other examples:++  pos2 :: Position Neg+  pos2 = Argument (Result (Result Top))+  ppr pos2 = "3rd argument"++  pos3 :: Position Pos+  pos3 = Argument (Result (Argument (Result Top)))+  ppr pos3 = "2nd argument of the 2nd argument"++It's useful to keep track at the type-level whether we are in a positive or+negative position in the type, as for primops we can usually tolerate+representation-polymorphism in positive positions, but not in negative ones;+for example++  ($) :: forall {r} (a :: Type) (b :: TYPE r). (a -> b) -> a -> b+++This positional information is (currently) used to report representation-polymorphism+errors in precisely the following two situations:++  1. Representation-polymorphic Ids with no binding, as described in+     Note [Representation-polymorphic Ids with no binding] in GHC.Tc.Utils.Concrete.++     This uses the 'FRRRepPolyId' constructor of 'FixedRuntimeRepContext'.++  2. When inserting eta-expansions for deep subsumption.+     See Wrinkle [Representation-polymorphism checking during subtyping] in+     Note [FunTy vs FunTy case in tc_sub_type_deep] in GHC.Tc.Utils.Unify.++     This uses the 'FRRDeepSubsumption' constructor of 'FixedRuntimeRepContext'.+-}++-- | Are we in a positive (covariant) or negative (contravariant) position?+--+-- See Note [Positional information in representation-polymorphism errors]. data Polarity = Pos | Neg +-- | Flip the 'Polarity': turn positive into negative and vice-versa. type FlipPolarity :: Polarity -> Polarity-type family FlipPolarity p where+type family FlipPolarity p = r | r -> p where   FlipPolarity Pos = Neg   FlipPolarity Neg = Pos  -- | A position in which a type variable appears in a type; -- in particular, whether it appears in a positive or a negative position.+--+-- See Note [Positional information in representation-polymorphism errors]. type Position :: Polarity -> Hs.Type data Position p where-  -- | In the @i@-th argument of a function arrow-  Argument :: Int -> Position (FlipPolarity p) -> Position p+  -- | In the argument of a function arrow+  Argument :: Position p -> Position (FlipPolarity p)   -- | In the result of a function arrow   Result   :: Position p -> Position p   -- | At the top level of a type   Top      :: Position Pos+deriving stock instance Show (Position p)+instance Outputable (Position p) where+  ppr = go 1+    where+      go :: Int -> Position q -> SDoc+      go i (Argument (Result pos)) = go (i+1) (Argument pos)+      go i (Argument pos) = speakNth i <+> text "argument" <+> aux 1 pos+      go i (Result (Result pos)) = go i (Result pos)+      go i (Result pos) = text "result" <+> aux i pos+      go _ Top = text "top-level" -pprFRRRepPolyId :: RepPolyId -> Name -> Position Neg -> SDoc-pprFRRRepPolyId id nm (Argument i pos) =-  text "The" <+> what <+> speakNth i <+> text "argument of" <+> pprRepPolyId id nm+      aux :: Int -> Position q -> SDoc+      aux i pos = case pos of { Top -> empty; _ -> text "of the" <+> go i pos }++-- | @'mkArgPos' i p@ makes the 'Position' @p@ relative to the @ith@ argument.+--+-- Example: @ppr (mkArgPos 3 (Result Top)) == "in the result of the 3rd argument"@.+mkArgPos :: Int -> Position p -> Position (FlipPolarity p)+mkArgPos i = go   where-    what = case pos of-      Top       -> empty-      Result {} -> text "return type of the"-      _         -> text "nested return type inside the"-pprFRRRepPolyId id nm (Result {}) =-  text "The result of" <+> pprRepPolyId id nm+    go :: Position p -> Position (FlipPolarity p)+    go Top = Argument $ nTimes (i-1) Result Top+    go (Result p) = Result $ go p+    go (Argument p) = Argument $ go p  pprRepPolyId :: RepPolyId -> Name -> SDoc pprRepPolyId id nm = id_desc <+> quotes (ppr nm)@@ -1525,7 +1652,7 @@                          -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]    | BuiltinTypeableInstance TyCon   -- Built-in solver for Typeable (T t1 .. tn)-                         -- See Note [Well-staged instance evidence]+                         -- See Note [Well-levelled instance evidence]    | BuiltinInstance      -- Built-in solver for (C t1 .. tn) where C is                          --   KnownNat, .. etc (classes with no top-level evidence)
compiler/GHC/Tc/Types/TH.hs view
@@ -1,25 +1,30 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-} module GHC.Tc.Types.TH (     SpliceType(..)   , SpliceOrBracket(..)-  , ThStage(..)+  , ThLevel(.., TypedBrack, UntypedBrack)   , PendingStuff(..)-  , ThLevel-  , topStage-  , topAnnStage-  , topSpliceStage-  , thLevel-  , impLevel-  , outerLevel+  , ThLevelIndex+  , topLevel+  , topAnnLevel+  , topSpliceLevel+  , thLevelIndex+  , topLevelIndex+  , spliceLevelIndex+  , quoteLevelIndex+  , thLevelIndexFromImportLevel   ) where +import GHC.Prelude import GHCi.RemoteTypes import qualified GHC.Boot.TH.Syntax as TH import GHC.Tc.Types.Evidence import GHC.Utils.Outputable-import GHC.Prelude import GHC.Tc.Types.TcRef import GHC.Tc.Types.Constraint import GHC.Hs.Expr ( PendingTcSplice, PendingRnSplice )+import GHC.Types.ThLevelIndex  --------------------------- -- Template Haskell stages and levels@@ -28,16 +33,12 @@ data SpliceType = Typed | Untyped data SpliceOrBracket = IsSplice | IsBracket -data ThStage    -- See Note [Template Haskell state diagram]+data ThLevel    -- See Note [Template Haskell state diagram]                 -- and Note [Template Haskell levels] in GHC.Tc.Gen.Splice     -- Start at:   Comp     -- At bracket: wrap current stage in Brack-    -- At splice:  currently Brack: return to previous stage-    --             currently Comp/Splice: compile and run-  = Splice SpliceType -- Inside a top-level splice-                      -- This code will be run *at compile time*;-                      --   the result replaces the splice-                      -- Binding level = 0+    -- At splice:  wrap current stage in Splice+  = Splice SpliceType ThLevel -- Inside a splice    | RunSplice (TcRef [ForeignRef (TH.Q ())])       -- Set when running a splice, i.e. NOT when renaming or typechecking the@@ -55,14 +56,14 @@       -- See Note [Collecting modFinalizers in typed splices] in "GHC.Tc.Gen.Splice".    | Comp        -- Ordinary Haskell code-                -- Binding level = 1+                -- Binding level = 0    | Brack                       -- Inside brackets-      ThStage                   --   Enclosing stage+      ThLevel                   --  Enclosing level       PendingStuff  data PendingStuff-  = RnPendingUntyped              -- Renaming the inside of an *untyped* bracket+  = RnPending                     -- Renaming the inside of a bracket       (TcRef [PendingRnSplice])   -- Pending splices in here    | RnPendingTyped                -- Renaming the inside of a *typed* bracket@@ -77,44 +78,45 @@                                   -- variable is used for desugaring                                   -- `lift`. +isTypedPending :: PendingStuff -> Bool+isTypedPending (RnPending _) = False+isTypedPending (RnPendingTyped) = True+isTypedPending (TcPending _ _ _) = True -topStage, topAnnStage, topSpliceStage :: ThStage-topStage       = Comp-topAnnStage    = Splice Untyped-topSpliceStage = Splice Untyped+pattern UntypedBrack :: ThLevel -> TcRef [PendingRnSplice] -> ThLevel+pattern UntypedBrack lvl tc_ref = Brack lvl (RnPending tc_ref)+pattern TypedBrack :: ThLevel -> ThLevel+pattern TypedBrack lvl <- Brack lvl (isTypedPending -> True) -instance Outputable ThStage where-   ppr (Splice _)    = text "Splice"+topLevel, topAnnLevel, topSpliceLevel :: ThLevel+topLevel       = Comp+topAnnLevel    = Splice Untyped Comp+topSpliceLevel = Splice Untyped Comp+++instance Outputable ThLevel where+   ppr (Splice _ s)  = text "Splice" <> parens (ppr s)    ppr (RunSplice _) = text "RunSplice"    ppr Comp          = text "Comp"-   ppr (Brack s _)   = text "Brack" <> parens (ppr s)+   ppr (Brack s _) = text "Brack" <> parens (ppr s) -type ThLevel = Int-    -- NB: see Note [Template Haskell levels] in GHC.Tc.Gen.Splice-    -- Incremented when going inside a bracket,-    -- decremented when going inside a splice-    -- NB: ThLevel is one greater than the 'n' in Fig 2 of the-    --     original "Template meta-programming for Haskell" paper -impLevel, outerLevel :: ThLevel-impLevel = 0    -- Imported things; they can be used inside a top level splice-outerLevel = 1  -- Things defined outside brackets--thLevel :: ThStage -> ThLevel-thLevel (Splice _)    = 0-thLevel Comp          = 1-thLevel (Brack s _)   = thLevel s + 1-thLevel (RunSplice _) = 0 -- previously: panic "thLevel: called when running a splice"+thLevelIndex :: ThLevel -> ThLevelIndex+thLevelIndex (Splice _ s)  = decThLevelIndex (thLevelIndex s)+thLevelIndex Comp          = topLevelIndex+thLevelIndex (Brack s _) = incThLevelIndex (thLevelIndex s)+thLevelIndex (RunSplice _) = thLevelIndex (Splice Untyped Comp) -- previously: panic "thLevel: called when running a splice"                         -- See Note [RunSplice ThLevel]. + {- Note [RunSplice ThLevel] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The 'RunSplice' stage is set when executing a splice, and only when running a+The 'RunSplice' level is set when executing a splice, and only when running a splice. In particular it is not set when the splice is renamed or typechecked.  However, this is not true. `reifyInstances` for example does rename the given type, and these types may contain variables (#9262 allow free variables in reifyInstances).-Therefore here we assume that thLevel (RunSplice _) = 0.+Therefore here we assume that thLevel (RunSplice _) = 0 Proper fix would probably require renaming argument `reifyInstances` separately prior to evaluation of the overall splice. @@ -125,3 +127,4 @@ 'Brack' or 'Comp' are used instead.  -}+
compiler/GHC/Tc/Types/TcRef.hs view
compiler/GHC/Tc/Utils/TcType.hs view
@@ -24,14 +24,14 @@   --------------------------------   -- Types   TcType, TcSigmaType, TcTypeFRR, TcSigmaTypeFRR,-  TcRhoType, TcTauType, TcPredType, TcThetaType,+  TcRhoType, TcRhoTypeFRR, TcTauType, TcPredType, TcThetaType,   TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet,   TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcInvisTVBinder, TcReqTVBinder,   TcTyCon, MonoTcTyCon, PolyTcTyCon, TcTyConBinder, KnotTied, -  ExpType(..), ExpKind, InferResult(..),+  ExpType(..), ExpKind, InferResult(..), InferInstFlag(..), InferFRRFlag(..),   ExpTypeFRR, ExpSigmaType, ExpSigmaTypeFRR,-  ExpRhoType,+  ExpRhoType, ExpRhoTypeFRR,   mkCheckExpType,   checkingExpType_maybe, checkingExpType, @@ -53,7 +53,7 @@   isImmutableTyVar, isSkolemTyVar, isMetaTyVar,  isMetaTyVarTy, isTyVarTy,   tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar,  isTyConableTyVar,   ConcreteTvOrigin(..), isConcreteTyVar_maybe, isConcreteTyVar,-  isConcreteTyVarTy, isConcreteTyVarTy_maybe, isConcreteInfo,+  isConcreteTyVarTy, isConcreteTyVarTy_maybe, concreteInfo_maybe,   ConcreteTyVars, noConcreteTyVars,   isAmbiguousTyVar, isCycleBreakerTyVar, metaTyVarRef, metaTyVarInfo,   isFlexi, isIndirect, isRuntimeUnkSkol,@@ -88,9 +88,9 @@   isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy,   isFloatingPrimTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,   isIntegerTy, isNaturalTy,-  isBoolTy, isUnitTy, isCharTy,+  isBoolTy, isUnitTy, isAnyTy, isZonkAnyTy, isCharTy,   isTauTy, isTauTyCon, tcIsTyVarTy,-  isPredTy, isTyVarClassPred,+  isPredTy, isSimplePredTy, isTyVarClassPred,   checkValidClsArgs, hasTyVarHead,   isRigidTy, anyTy_maybe, @@ -130,7 +130,7 @@   pSizeZero, pSizeOne,   pSizeType, pSizeTypeX, pSizeTypes,   pSizeClassPred, pSizeClassPredX,-  pSizeTyConApp,+  pSizeTyConApp, pSizeHead,   noMoreTyVars, allDistinctTyVars,   TypeSize, sizeType, sizeTypes, scopedSort,   isTerminatingClass, isStuckTypeFamily,@@ -155,7 +155,7 @@   mkTyConTy, mkTyVarTy, mkTyVarTys,   mkTyCoVarTy, mkTyCoVarTys, -  isClassPred, isEqPrimPred, isIPLikePred, isEqPred,+  isClassPred, isEqPred, couldBeIPLike, isEqClassPred,   isEqualityClass, mkClassPred,   tcSplitQuantPredTy, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy,   isRuntimeRepVar, isFixedRuntimeRepKind,@@ -166,7 +166,7 @@   TvSubstEnv, emptySubst, mkEmptySubst,   zipTvSubst,   mkTvSubstPrs, notElemSubst, unionSubst,-  getTvSubstEnv, getSubstInScope, extendSubstInScope,+  getTvSubstEnv, substInScopeSet, extendSubstInScope,   extendSubstInScopeList, extendSubstInScopeSet, extendTvSubstAndInScope,   Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr,   Type.extendTvSubst,@@ -380,6 +380,7 @@ -- See Note [Return arguments with a fixed RuntimeRep. type TcSigmaTypeFRR = TcSigmaType     -- TODO: consider making this a newtype.+type TcRhoTypeFRR = TcRhoType  type TcRhoType      = TcType  -- Note [TcRhoType] type TcTauType      = TcType@@ -408,9 +409,13 @@        , ir_lvl  :: TcLevel          -- ^ See Note [TcLevel of ExpType] in GHC.Tc.Utils.TcMType -       , ir_frr  :: Maybe FixedRuntimeRepContext+       , ir_frr  :: InferFRRFlag          -- ^ See Note [FixedRuntimeRep context in ExpType] in GHC.Tc.Utils.TcMType +       , ir_inst :: InferInstFlag+         -- ^ True <=> when DeepSubsumption is on, deeply instantiate before filling,+         -- See Note [Instantiation of InferResult] in GHC.Tc.Utils.Unify+        , ir_ref  :: IORef (Maybe TcType) }          -- ^ The type that fills in this hole should be a @Type@,          -- that is, its kind should be @TYPE rr@ for some @rr :: RuntimeRep@.@@ -419,26 +424,48 @@          -- @rr@ must be concrete, in the sense of Note [Concrete types]          -- in GHC.Tc.Utils.Concrete. -type ExpSigmaType    = ExpType+data InferFRRFlag+  = IFRR_Check                -- Check that the result type has a fixed runtime rep+      FixedRuntimeRepContext  -- Typically used for function arguments and lambdas +  | IFRR_Any                  -- No need to check for fixed runtime-rep++data InferInstFlag  -- Specifies whether the inference should return an uninstantiated+                    -- SigmaType, or a (possibly deeply) instantiated RhoType+                    -- See Note [Instantiation of InferResult] in GHC.Tc.Utils.Unify++  = IIF_Sigma       -- Trying to infer a SigmaType+                    -- Don't instantiate at all, regardless of DeepSubsumption+                    -- Typically used when inferring the type of a pattern++  | IIF_ShallowRho  -- Trying to infer a shallow RhoType (no foralls or => at the top)+                    -- Top-instantiate (only, regardless of DeepSubsumption) before filling the hole+                    -- Typically used when inferring the type of an expression++  | IIF_DeepRho     -- Trying to infer a possibly-deep RhoType (depending on DeepSubsumption)+                    -- If DeepSubsumption is off, same as IIF_ShallowRho+                    -- If DeepSubsumption is on, instantiate deeply before filling the hole++type ExpSigmaType = ExpType+type ExpRhoType   = ExpType+      -- Invariant: in ExpRhoType, if -XDeepSubsumption is on,+      --            and we are in checking mode (i.e. the ExpRhoType is (Check rho)),+      --            then the `rho` is deeply skolemised+ -- | An 'ExpType' which has a fixed RuntimeRep. -- -- For a 'Check' 'ExpType', the stored 'TcType' must have -- a fixed RuntimeRep. For an 'Infer' 'ExpType', the 'ir_frr'--- field must be of the form @Just frr_orig@.-type ExpTypeFRR      = ExpType+-- field must be of the form @IFRR_Check frr_orig@.+type ExpTypeFRR = ExpType  -- | Like 'TcSigmaTypeFRR', but for an expected type. -- -- See 'ExpTypeFRR'. type ExpSigmaTypeFRR = ExpTypeFRR+type ExpRhoTypeFRR   = ExpTypeFRR   -- TODO: consider making this a newtype. -type ExpRhoType = ExpType-      -- Invariant: if -XDeepSubsumption is on,-      --            and we are checking (i.e. the ExpRhoType is (Check rho)),-      --            then the `rho` is deeply skolemised- -- | Like 'ExpType', but on kind level type ExpKind = ExpType @@ -447,12 +474,17 @@   ppr (Infer ir) = ppr ir  instance Outputable InferResult where-  ppr (IR { ir_uniq = u, ir_lvl = lvl, ir_frr = mb_frr })-    = text "Infer" <> mb_frr_text <> braces (ppr u <> comma <> ppr lvl)+  ppr (IR { ir_uniq = u, ir_lvl = lvl, ir_frr = mb_frr, ir_inst = inst })+    = text "Infer" <> parens (pp_inst <> pp_frr)+                   <> braces (ppr u <> comma <> ppr lvl)     where-      mb_frr_text = case mb_frr of-        Just _  -> text "FRR"-        Nothing -> empty+     pp_inst = case inst of+                IIF_Sigma      -> text "Sigma"+                IIF_ShallowRho -> text "ShallowRho"+                IIF_DeepRho    -> text "DeepRho"+     pp_frr = case mb_frr of+                IFRR_Check {} -> text ",FRR"+                IFRR_Any      -> empty  -- | Make an 'ExpType' suitable for checking. mkCheckExpType :: TcType -> ExpType@@ -606,7 +638,8 @@                   --     how this level number is used        Bool       -- True <=> this skolem type variable can be overlapped                   --          when looking up instances-                  -- See Note [Binding when looking up instances] in GHC.Core.InstEnv+                  -- See Note [Super skolems: binding when looking up instances]+                  --     in GHC.Core.InstEnv    | RuntimeUnk    -- Stands for an as-yet-unknown type in the GHCi                   -- interactive context@@ -648,7 +681,7 @@    | RuntimeUnkTv  -- ^ A unification variable used in the GHCi debugger.                    -- It /is/ allowed to unify with a polytype, unlike TauTv -   | CycleBreakerTv  -- Used to fix occurs-check problems in Givens+   | CycleBreakerTv  -- ^ Used to fix occurs-check problems in Givens                      -- See Note [Type equality cycles] in                      -- GHC.Tc.Solver.Equality @@ -1266,9 +1299,9 @@   | otherwise   = Nothing -isConcreteInfo :: MetaInfo -> Bool-isConcreteInfo (ConcreteTv {}) = True-isConcreteInfo _               = False+concreteInfo_maybe :: MetaInfo -> Maybe ConcreteTvOrigin+concreteInfo_maybe (ConcreteTv conc_orig) = Just conc_orig+concreteInfo_maybe _                      = Nothing  -- | Is this type variable a concrete type variable, i.e. -- it is a metavariable with 'ConcreteTv' 'MetaInfo'?@@ -1653,7 +1686,7 @@  = Left n  tcSplitFunTy :: Type -> (Scaled Type, Type)-tcSplitFunTy  ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty)+tcSplitFunTy  ty = expectJust (tcSplitFunTy_maybe ty)  tcFunArgTy :: Type -> Scaled Type tcFunArgTy ty = fst (tcSplitFunTy ty)@@ -1784,11 +1817,11 @@ evVarPred :: EvVar -> PredType evVarPred var = varType var   -- Historical note: I used to have an ASSERT here,-  -- checking (isEvVarType (varType var)).  But with something like+  -- checking (isPredTy (varType var)).  But with something like   --   f :: c => _ -> _   -- we end up with (c :: kappa), and (kappa ~ Constraint).  Until   -- we solve and zonk (which there is no particular reason to do for-  -- partial signatures, (isEvVarType kappa) will return False. But+  -- partial signatures, (isPredTy kappa) will return False. But   -- nothing is wrong.  So I just removed the ASSERT.  ---------------------------@@ -1818,7 +1851,7 @@ pickCapturedPreds qtvs theta   = filter captured theta   where-    captured pred = isIPLikePred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs)+    captured pred = couldBeIPLike pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs)   -- Superclasses@@ -1875,7 +1908,7 @@    -- These can arise when dealing with partial type signatures (e.g. T14715)    eq_extras pred      = case classifyPredType pred of-         EqPred r t1 t2               -> [mkPrimEqPredRole (eqRelRole r) t2 t1]+         EqPred r t1 t2               -> [mkEqPred r t2 t1]          ClassPred cls [k1,k2,t1,t2]            | cls `hasKey` heqTyConKey -> [mkClassPred cls [k2, k1, t2, t1]]          ClassPred cls [k,t1,t2]@@ -2005,7 +2038,7 @@     isFloatPrimTy, isDoublePrimTy,     isIntegerTy, isNaturalTy,     isIntTy, isWordTy, isBoolTy,-    isUnitTy, isCharTy :: Type -> Bool+    isUnitTy, isAnyTy, isZonkAnyTy, isCharTy :: Type -> Bool isFloatTy      = is_tc floatTyConKey isDoubleTy     = is_tc doubleTyConKey isFloatPrimTy  = is_tc floatPrimTyConKey@@ -2016,6 +2049,8 @@ isWordTy       = is_tc wordTyConKey isBoolTy       = is_tc boolTyConKey isUnitTy       = is_tc unitTyConKey+isAnyTy        = is_tc anyTyConKey+isZonkAnyTy    = is_tc zonkAnyTyConKey isCharTy       = is_tc charTyConKey  -- | Check whether the type is of the form @Any :: k@,@@ -2056,6 +2091,7 @@   | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal   | Just {} <- tcSplitAppTy_maybe ty        = True   | isForAllTy ty                           = True+  | Just {} <- isLitTy ty                   = True   | otherwise                               = False  {-@@ -2360,6 +2396,13 @@ pSizeTyFamApp tc  | isStuckTypeFamily tc = pSizeZero  | otherwise            = PS_TyFam tc++pSizeHead :: PredType -> PatersonSize+-- Getting the size of an instance head is a bit horrible+-- because of the special treament for class predicates+pSizeHead pred = case classifyPredType pred of+                      ClassPred cls tys -> pSizeClassPred cls tys+                      _                 -> pSizeType pred  pSizeClassPred :: Class -> [Type] -> PatersonSize pSizeClassPred = pSizeClassPredX emptyVarSet
compiler/GHC/Types/Annotations.hs view
@@ -31,7 +31,7 @@ import Data.Maybe import Data.Typeable import Data.Word        ( Word8 )-+import Control.DeepSeq  -- | Represents an annotation after it has been sufficiently desugared from -- it's initial form of 'GHC.Hs.Decls.AnnDecl'@@ -70,6 +70,10 @@         case h of             0 -> liftM NamedTarget  $ get bh             _ -> liftM ModuleTarget $ get bh++instance NFData name => NFData (AnnTarget name) where+  rnf (NamedTarget n) = rnf n+  rnf (ModuleTarget m) = rnf m  instance Outputable Annotation where     ppr ann = ppr (ann_target ann)
compiler/GHC/Types/Avail.hs view
@@ -22,7 +22,8 @@     filterAvails,     nubAvails,     sortAvails,-    DetOrdAvails(DetOrdAvails, DefinitelyDeterministicAvails)+    DetOrdAvails(DetOrdAvails, getDetOrdAvails, DefinitelyDeterministicAvails),+    emptyDetOrdAvails   ) where  import GHC.Prelude@@ -74,9 +75,25 @@ -- We guarantee a deterministic order by either using the order explicitly -- given by the user (e.g. in an explicit constructor export list) or instead -- by sorting the avails with 'sortAvails'.-newtype DetOrdAvails = DefinitelyDeterministicAvails Avails+newtype DetOrdAvails = DefinitelyDeterministicAvails { getDetOrdAvails :: Avails }   deriving newtype (Binary, Outputable, NFData) +instance Eq DetOrdAvails where+  a1 == a2 = compare a1 a2 == EQ+instance Ord DetOrdAvails where+  compare (DetOrdAvails a1) (DetOrdAvails a2) = go a1 a2+    where+      go [] [] = EQ+      go _  [] = LT+      go [] _  = GT+      go (a:as) (b:bs) =+        case (a, b) of+          (Avail {}, AvailTC {}) -> LT+          (AvailTC{}, Avail {}) -> GT+          (Avail n1, Avail n2) -> stableNameCmp n1 n2 S.<> go as bs+          (AvailTC n1 m1s, AvailTC n2 m2s) ->+            stableNameCmp n1 n2 S.<> foldMap (uncurry stableNameCmp) (zip m1s m2s) S.<> go as bs+ -- | It's always safe to match on 'DetOrdAvails' pattern DetOrdAvails :: Avails -> DetOrdAvails pattern DetOrdAvails x <- DefinitelyDeterministicAvails x@@ -245,3 +262,7 @@ instance NFData AvailInfo where   rnf (Avail n) = rnf n   rnf (AvailTC a b) = rnf a `seq` rnf b++-- | Create an empty DetOrdAvails+emptyDetOrdAvails :: DetOrdAvails+emptyDetOrdAvails = DefinitelyDeterministicAvails []
compiler/GHC/Types/Basic.hs view
@@ -21,6 +21,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE StandaloneDeriving #-}  module GHC.Types.Basic (         LeftOrRight(..),@@ -85,7 +87,7 @@         CompilerPhase(..), PhaseNum, beginPhase, nextPhase, laterPhase,          Activation(..), isActive, competesWith,-        isNeverActive, isAlwaysActive, activeInFinalPhase,+        isNeverActive, isAlwaysActive, activeInFinalPhase, activeInInitialPhase,         activateAfterInitial, activateDuringFinal, activeAfter,          RuleMatchInfo(..), isConLike, isFunLike,@@ -114,12 +116,14 @@         Levity(..), mightBeLifted, mightBeUnlifted,         TypeOrConstraint(..), -        TyConFlavour(..), TypeOrData(..), tyConFlavourAssoc_maybe,+        TyConFlavour(..), TypeOrData(..), NewOrData(..), tyConFlavourAssoc_maybe,          NonStandardDefaultingStrategy(..),         DefaultingStrategy(..), defaultNonStandardTyVars, -        ForeignSrcLang (..)+        ForeignSrcLang (..),++        ImportLevel(..), convImportLevel, convImportLevelSpec, allImportLevels    ) where  import GHC.Prelude@@ -134,12 +138,12 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Type (PromotionFlag(..), isPromoted) import Language.Haskell.Syntax.Basic (Boxity(..), isBoxed, ConTag) import {-# SOURCE #-} Language.Haskell.Syntax.Expr (HsDoFlavour)- import Control.DeepSeq ( NFData(..) ) import Data.Data import Data.Maybe import qualified Data.Semigroup as Semi +import Language.Haskell.Syntax.ImpExp {- ************************************************************************ *                                                                      *@@ -167,7 +171,12 @@                    0 -> return CLeft                    _ -> return CRight } +instance NFData LeftOrRight where+  rnf CLeft  = ()+  rnf CRight = () ++ {- ************************************************************************ *                                                                      *@@ -529,6 +538,10 @@           1 -> return IsData           _ -> panic "Binary FunctionOrData" +instance NFData FunctionOrData where+  rnf IsFunction = ()+  rnf IsData = ()+ {- ************************************************************************ *                                                                      *@@ -612,6 +625,11 @@            1 -> return MarkedCbv            _ -> panic "Invalid binary format" +instance NFData CbvMark where+  rnf MarkedCbv    = ()+  rnf NotMarkedCbv = ()++ isMarkedCbv :: CbvMark -> Bool isMarkedCbv MarkedCbv = True isMarkedCbv NotMarkedCbv = False@@ -871,6 +889,9 @@ instance Outputable OverlapFlag where    ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) +instance NFData OverlapFlag where+  rnf (OverlapFlag mode safe) = rnf mode `seq` rnf safe+ instance Outputable OverlapMode where    ppr (NoOverlap    _) = empty    ppr (Overlappable _) = text "[overlappable]"@@ -879,6 +900,14 @@    ppr (Incoherent   _) = text "[incoherent]"    ppr (NonCanonical _) = text "[noncanonical]" +instance NFData OverlapMode where+  rnf (NoOverlap s) = rnf s+  rnf (Overlappable s) = rnf s+  rnf (Overlapping s) = rnf s+  rnf (Overlaps s) = rnf s+  rnf (Incoherent s) = rnf s+  rnf (NonCanonical s) = rnf s+ instance Binary OverlapMode where     put_ bh (NoOverlap    s) = putByte bh 0 >> put_ bh s     put_ bh (Overlaps     s) = putByte bh 1 >> put_ bh s@@ -1032,7 +1061,12 @@         1 -> return UnboxedTuple         _ -> return ConstraintTuple +instance NFData TupleSort where+  rnf BoxedTuple      = ()+  rnf UnboxedTuple    = ()+  rnf ConstraintTuple = () + tupleSortBoxity :: TupleSort -> Boxity tupleSortBoxity BoxedTuple      = Boxed tupleSortBoxity UnboxedTuple    = Unboxed@@ -1755,12 +1789,7 @@ inlinePragmaSpec = inl_inline  inlinePragmaSource :: InlinePragma -> SourceText-inlinePragmaSource prag = case inl_inline prag of-                            Inline    x      -> x-                            Inlinable y      -> y-                            NoInline  z      -> z-                            Opaque    q      -> q-                            NoUserInlinePrag -> NoSourceText+inlinePragmaSource prag = inlineSpecSource (inl_inline prag)  inlineSpecSource :: InlineSpec -> SourceText inlineSpecSource spec = case spec of@@ -1860,6 +1889,14 @@                       ab <- get bh                       return (ActiveAfter src ab) +instance NFData Activation where+  rnf = \case+    AlwaysActive -> ()+    NeverActive -> ()+    ActiveBefore src aa -> rnf src `seq` rnf aa+    ActiveAfter src ab -> rnf src `seq` rnf ab+    FinalActive -> ()+ instance Outputable RuleMatchInfo where    ppr ConLike = text "CONLIKE"    ppr FunLike = text "FUNLIKE"@@ -1872,6 +1909,11 @@             if h == 1 then return ConLike                       else return FunLike +instance NFData RuleMatchInfo where+  rnf = \case+    ConLike -> ()+    FunLike -> ()+ instance Outputable InlineSpec where     ppr (Inline          src)  = text "INLINE" <+> pprWithSourceText src empty     ppr (NoInline        src)  = text "NOINLINE" <+> pprWithSourceText src empty@@ -1906,6 +1948,14 @@                         s <- get bh                         return (Opaque s) +instance NFData InlineSpec where+  rnf = \case+    Inline s -> rnf s+    NoInline s -> rnf s+    Inlinable s -> rnf s+    Opaque s -> rnf s+    NoUserInlinePrag -> ()+ instance Outputable InlinePragma where   ppr = pprInline @@ -1925,6 +1975,9 @@            d <- get bh            return (InlinePragma s a b c d) +instance NFData InlinePragma where+  rnf (InlinePragma s a b c d) = rnf s `seq` rnf a `seq` rnf b `seq` rnf c `seq` rnf d+ -- | Outputs string for pragma name for any of INLINE/INLINABLE/NOINLINE. This -- differs from the Outputable instance for the InlineSpec type where the pragma -- name string as well as the accompanying SourceText (if any) is printed.@@ -2017,6 +2070,13 @@             2 -> return StableSystemSrc             _ -> return VanillaSrc +instance NFData UnfoldingSource where+  rnf = \case+    CompulsorySrc -> ()+    StableUserSrc -> ()+    StableSystemSrc -> ()+    VanillaSrc -> ()+ instance Outputable UnfoldingSource where   ppr CompulsorySrc     = text "Compulsory"   ppr StableUserSrc     = text "StableUser"@@ -2161,7 +2221,20 @@   = TypeLike | ConstraintLike   deriving( Eq, Ord, Data ) +instance Binary TypeOrConstraint where+  put_ bh = \case+    TypeLike -> putByte bh 0+    ConstraintLike -> putByte bh 1+  get bh = getByte bh >>= \case+    0 -> pure TypeLike+    1 -> pure ConstraintLike+    _ -> panic "TypeOrConstraint.get: invalid value" +instance NFData TypeOrConstraint where+  rnf = \case+    TypeLike -> ()+    ConstraintLike -> ()+ {- ********************************************************************* *                                                                      *                           TyConFlavour@@ -2198,24 +2271,17 @@         = assoc ++ t_or_d ++ " family"         where           assoc = if isJust mb_par then "associated " else ""-          t_or_d = case type_or_data of { IAmType -> "type"; IAmData -> "data" }+          t_or_d = case type_or_data of+            IAmType -> "type"+            IAmData new_or_data ->+              case new_or_data of+                DataType -> "data"+                NewType  -> "newtype"       go ClosedTypeFamilyFlavour = "type family"       go TypeSynonymFlavour      = "type synonym"       go BuiltInTypeFlavour      = "built-in type"       go PromotedDataConFlavour  = "promoted data constructor" -instance NFData tc => NFData (TyConFlavour tc) where-  rnf ClassFlavour = ()-  rnf (TupleFlavour !_) = ()-  rnf SumFlavour = ()-  rnf DataTypeFlavour = ()-  rnf NewtypeFlavour = ()-  rnf AbstractTypeFlavour = ()-  rnf (OpenFamilyFlavour !_ mb_tc) = rnf mb_tc-  rnf ClosedTypeFamilyFlavour = ()-  rnf TypeSynonymFlavour = ()-  rnf BuiltInTypeFlavour = ()-  rnf PromotedDataConFlavour = ()  -- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour tyConFlavourAssoc_maybe :: TyConFlavour tc -> Maybe tc@@ -2225,14 +2291,26 @@ -- | Whether something is a type or a data declaration, -- e.g. a type family or a data family. data TypeOrData-  = IAmData+  = IAmData !NewOrData   | IAmType   deriving (Eq, Data) +-- | When we only care whether a data-type declaration is `data` or `newtype`,+-- but not what constructors it has.+data NewOrData+  = NewType                     -- ^ @newtype Blah ...@+  | DataType                    -- ^ @data Blah ...@+  deriving ( Eq, Data )                -- Needed because Demand derives Eq+ instance Outputable TypeOrData where-  ppr IAmData = text "data"+  ppr (IAmData newOrData) = ppr newOrData   ppr IAmType = text "type" +instance Outputable NewOrData where+ ppr = \case+    NewType  -> text "newtype"+    DataType -> text "data"+ {- ********************************************************************* *                                                                      *                         Defaulting options@@ -2361,3 +2439,26 @@ instance Outputable DefaultingStrategy where   ppr DefaultKindVars            = text "DefaultKindVars"   ppr (NonStandardDefaulting ns) = text "NonStandardDefaulting" <+> ppr ns++-- | ImportLevel++data ImportLevel = NormalLevel | SpliceLevel | QuoteLevel deriving (Eq, Ord, Data, Show, Enum, Bounded)++instance Outputable ImportLevel where+  ppr NormalLevel = text "normal"+  ppr SpliceLevel = text "splice"+  ppr QuoteLevel = text "quote"++deriving via (EnumBinary ImportLevel) instance Binary ImportLevel++allImportLevels :: [ImportLevel]+allImportLevels = [minBound..maxBound]++convImportLevel :: ImportDeclLevelStyle -> ImportLevel+convImportLevel (LevelStylePre level) = convImportLevelSpec level+convImportLevel (LevelStylePost level) = convImportLevelSpec level+convImportLevel NotLevelled = NormalLevel++convImportLevelSpec :: ImportDeclLevel -> ImportLevel+convImportLevelSpec ImportDeclQuote = QuoteLevel+convImportLevelSpec ImportDeclSplice = SpliceLevel
− compiler/GHC/Types/Breakpoint.hs 
@@ -1,53 +0,0 @@--- | Breakpoint related types-module GHC.Types.Breakpoint-  ( BreakpointId (..)-  , InternalBreakpointId (..)-  , toBreakpointId-  )-where--import GHC.Prelude-import GHC.Unit.Module---- | Breakpoint identifier.------ See Note [Breakpoint identifiers]-data BreakpointId = BreakpointId-  { bi_tick_mod   :: !Module  -- ^ Breakpoint tick module-  , bi_tick_index :: !Int     -- ^ Breakpoint tick index-  }---- | Internal breakpoint identifier------ See Note [Breakpoint identifiers]-data InternalBreakpointId = InternalBreakpointId-  { ibi_tick_mod   :: !Module  -- ^ Breakpoint tick module-  , ibi_tick_index :: !Int     -- ^ Breakpoint tick index-  , ibi_info_mod   :: !Module  -- ^ Breakpoint info module-  , ibi_info_index :: !Int     -- ^ Breakpoint info index-  }--toBreakpointId :: InternalBreakpointId -> BreakpointId-toBreakpointId ibi = BreakpointId-  { bi_tick_mod   = ibi_tick_mod ibi-  , bi_tick_index = ibi_tick_index ibi-  }----- Note [Breakpoint identifiers]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ Before optimization a breakpoint is identified uniquely with a tick module--- and a tick index. See BreakpointId. A tick module contains an array, indexed--- with the tick indexes, which indicates breakpoint status.------ When we generate ByteCode, we collect information for every breakpoint at--- their *occurrence sites* (see CgBreakInfo in GHC.ByteCode.Types) and these info--- are stored in the ModIface of the occurrence module. Because of inlining, we--- can't reuse the tick index to uniquely identify an occurrence; because of--- cross-module inlining, we can't assume that the occurrence module is the same--- as the tick module (#24712).------ So every breakpoint occurrence gets assigned a module-unique *info index* and--- we store it alongside the occurrence module (*info module*) in the--- InternalBreakpointId datatype.
compiler/GHC/Types/CostCentre.hs view
@@ -36,6 +36,7 @@ import GHC.Types.SrcLoc import GHC.Data.FastString import GHC.Types.CostCentre.State+import Control.DeepSeq  import Data.Data @@ -394,6 +395,21 @@     -- ok, because we only need the SrcSpan when declaring the     -- CostCentre in the original module, it is not used by importing     -- modules.++instance NFData CostCentre where+  rnf (NormalCC aa ab ac ad) = rnf aa `seq` rnf ab `seq` rnf ac `seq` rnf ad+  rnf (AllCafsCC ae ad) = rnf ae `seq` rnf ad++instance NFData CCFlavour where+  rnf CafCC = ()+  rnf (IndexedCC flav i) = rnf flav `seq` rnf i++instance NFData IndexedCCFlavour where+  rnf ExprCC = ()+  rnf DeclCC = ()+  rnf HpcCC = ()+  rnf LateCC = ()+  rnf CallerCC = ()  getAllCAFsCC :: Module -> (CostCentre, CostCentreStack) getAllCAFsCC this_mod =
compiler/GHC/Types/CostCentre/State.hs view
@@ -15,6 +15,7 @@  import Data.Data import GHC.Utils.Binary+import Control.DeepSeq  -- | Per-module state for tracking cost centre indices. --@@ -28,6 +29,9 @@ -- | An index into a given cost centre module,name,flavour set newtype CostCentreIndex = CostCentreIndex { unCostCentreIndex :: Int }   deriving (Eq, Ord, Data, Binary)++instance NFData CostCentreIndex where+  rnf (CostCentreIndex i) = rnf i  -- | Get a new index for a given cost centre name. getCCIndex :: FastString
compiler/GHC/Types/DefaultEnv.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase #-}  module GHC.Types.DefaultEnv    ( ClassDefaults (..)+   , DefaultProvenance (..)    , DefaultEnv    , emptyDefaultEnv    , isEmptyDefaultEnv@@ -12,6 +14,8 @@    , defaultList    , plusDefaultEnv    , mkDefaultEnv+   , insertDefaultEnv+   , isHaskell2010Default    ) where @@ -22,6 +26,7 @@ import GHC.Types.Name (Name, nameUnique, stableNameCmp) import GHC.Types.Name.Env import GHC.Types.Unique.FM (lookupUFM_Directly)+import GHC.Types.SrcLoc (SrcSpan) import GHC.Unit.Module.Warnings (WarningTxt) import GHC.Unit.Types (Module) import GHC.Utils.Outputable@@ -31,15 +36,79 @@ import Data.Function (on)  -- See Note [Named default declarations] in GHC.Tc.Gen.Default+ -- | Default environment mapping class name @Name@ to their default type lists+--+-- NB: this includes Haskell98 default declarations, at the 'Num' key. type DefaultEnv = NameEnv ClassDefaults +{- Note [DefaultProvenance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Each `ClassDefault` is annotated with its `DefaultProvenance`, which+says where the default came from.  Specifically+* `DP_Local loc h98`: the default came from an explicit `default` declaration in the module+   being compiled, at location `loc`, and the boolean `h98` indicates whether+   it was from a Haskell 98 default declaration (e.g. `default (Int, Double)`).+* `DP_Imported M`: the default was imported, it is explicitly exported by module `M`.+* `DP_Builtin`:  the default was automatically provided by GHC.+   see Note [Builtin class defaults] in GHC.Tc.Utils.Env++These annotations are used to disambiguate multiple defaults for the same class.+For example, consider the following modules:++  module M( default C ) where { default C( ... ) }+  module M2( default C) where { import M }+  module N( default C () where { default C(... ) }++  module A where { import M2 }+  module B where { import M2; import N }+  module A1 where { import N; default C ( ... ) }+  module B2 where { default C ( ... ); default C ( ... ) }++When compiling N, the default for C is annotated with DP_Local loc.+When compiling M2, the default for C is annotated with DP_Local M.+When compiling A, the default for C is annotated with DP_Imported M2.++Cases we needed to disambiguate:+  * Compiling B, two defaults for C: DP_Imported M2, DP_Imported N.+  * Compiling A1, two defaults for C: DP_Imported N, DP_Local loc.+  * Compiling B2, two defaults for C: DP_Local loc1, DP_Local loc2.++For how we disambiguate these cases,+See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module.+-}++-- | The provenance of a collection of default types for a class.+-- see Note [DefaultProvenance] for more details+data DefaultProvenance+  -- | A locally defined default declaration.+  = DP_Local+     { defaultDeclLoc :: SrcSpan -- ^ The 'SrcSpan' of the default declaration+     , defaultDeclH98 :: Bool    -- ^ Is this a Haskell 98 default declaration?+     }+  -- | Built-in class defaults.+  | DP_Builtin+  -- | Imported class defaults.+  | DP_Imported Module -- ^ The module from which the defaults were imported+  deriving (Eq, Data)++instance Outputable DefaultProvenance where+  ppr (DP_Local loc h98) = ppr loc <> (if h98 then text " (H98)" else empty)+  ppr DP_Builtin         = text "built-in"+  ppr (DP_Imported mod)  = ppr mod++isHaskell2010Default :: DefaultProvenance -> Bool+isHaskell2010Default = \case+  DP_Local { defaultDeclH98 = isH98 } -> isH98+  DP_Builtin -> True+  DP_Imported {} -> False++-- | Defaulting type assignments for the given class. data ClassDefaults   = ClassDefaults { cd_class   :: Class -- ^ The class whose defaults are being defined                   , cd_types   :: [Type]-                  , cd_module :: Maybe Module-                    -- ^ @Nothing@ for built-in,-                    -- @Just@ the current module or the module whence the default was imported+                  , cd_provenance :: DefaultProvenance+                    -- ^ Where the defaults came from                     -- see Note [Default exports] in GHC.Tc.Gen.Export                   , cd_warn    :: Maybe (WarningTxt GhcRn)                     -- ^ Warning emitted when the default is used@@ -65,6 +134,9 @@ defaultList :: DefaultEnv -> [ClassDefaults] defaultList = sortBy (stableNameCmp `on` className . cd_class) . nonDetNameEnvElts               -- sortBy recovers determinism++insertDefaultEnv :: ClassDefaults -> DefaultEnv -> DefaultEnv+insertDefaultEnv d env = extendNameEnv env (className $ cd_class d) d  lookupDefaultEnv :: DefaultEnv -> Name -> Maybe ClassDefaults lookupDefaultEnv env = lookupUFM_Directly env . nameUnique
compiler/GHC/Types/Demand.hs view
@@ -981,18 +981,10 @@ strictifyDictDmd :: Type -> Demand -> Demand strictifyDictDmd ty (n :* Prod b ds)   | not (isAbs n)-  , Just field_tys <- as_non_newtype_dict ty-  = C_1N :* mkProd b (zipWith strictifyDictDmd field_tys ds)+  , isTerminatingType ty+  , Just (_tc, _arg_tys, _data_con, field_tys) <- splitDataProductType_maybe ty+  = C_1N :* mkProd b (zipWith strictifyDictDmd (map scaledThing field_tys) ds)       -- main idea: ensure it's strict-  where-    -- Return a TyCon and a list of field types if the given-    -- type is a non-newtype dictionary type-    as_non_newtype_dict ty-      | isTerminatingType ty-      , Just (_tc, _arg_tys, _data_con, field_tys) <- splitDataProductType_maybe ty-      = Just (map scaledThing field_tys)-      | otherwise-      = Nothing strictifyDictDmd _  dmd = dmd  -- | Make a 'Demand' lazy.@@ -1389,33 +1381,16 @@  * it returns the demands on the arguments;    in the above example that is [SL, A] -Nasty wrinkle. Consider this code (#22475 has more realistic examples but-assume this is what the demand analyser sees)--   data T = MkT !Int Bool-   get :: T -> Bool-   get (MkT _ b) = b--   foo = let v::Int = I# 7-             t::T   = MkT v True-         in get t--Now `v` is unused by `get`, /but/ we can't give `v` an Absent demand,-else we'll drop the binding and replace it with an error thunk.-Then the code generator (more specifically GHC.Stg.InferTags.Rewrite)-will add an extra eval of MkT's argument to give-   foo = let v::Int = error "absent"-             t::T   = case v of v' -> MkT v' True-         in get t--Boo!  Because of this extra eval (added in STG-land), the truth is that `MkT`-may (or may not) evaluate its arguments (as established in #21497). Hence the-use of `bump` in dmdTransformDataConSig, which adds in a `C_01` eval. The-`C_01` says "may or may not evaluate" which is absolutely faithful to what-InferTags.Rewrite does.+When the data constructor worker has strict fields, an additional seq+will be inserted for each field (see (SFC3) in Note [Strict fields in Core]).+Hence we add an additional `seqDmd` for each strict field to emulate+field eval insertion. -In particular it is very important /not/ to make that a `C_11` eval,-see Note [Data-con worker strictness].+For example, consider `data SP a b = MkSP !a !b` and expression `MkSP x y`,+with the same sub-demand P(SL,A).+The strict fields bump up the strictness; we'd get [SL,1!A] for the field+demands. Note that the first demand was unaffected by the seq, whereas+the second, previously absent demand became `seqDmd` exactly. -}  {- *********************************************************************@@ -1615,6 +1590,29 @@    expression may not throw a precise exception (increasing precision of the    analysis), but that's just a favourable guess. +Note [Side-effects and strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Due to historic reasons and the continued effort not to cause performance+regressions downstream, Strictness Analysis is currently prone to discarding+observable side-effects (other than precise exceptions, see+Note [Precise exceptions and strictness analysis]) in some cases. For example,+  f :: MVar () -> Int -> IO Int+  f mv x = putMVar mv () >> (x `seq` return x)+The call to `putMVar` is an observable side-effect. Yet, Strictness Analysis+currently concludes that `f` is strict in `x` and uses call-by-value.+That means `f mv (error "boom")` will error out with the imprecise exception+rather performing the side-effect.++This is a conscious violation of the semantics described in the paper+"a semantics for imprecise exceptions"; so it would be great if we could+identify the offending primops and extend the idea in+Note [Which scrutinees may throw precise exceptions] to general side-effects.++Unfortunately, the existing has-side-effects classification for primops is+too conservative, listing `writeMutVar#` and even `readMutVar#` as+side-effecting. That is due to #3207. A possible way forward is described in+#17900, but no effort has been so far towards a resolution.+ Note [Exceptions and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to smart about catching exceptions, but we aren't anymore.@@ -1792,8 +1790,7 @@  -- | 'DmdEnv' is a monoid via 'plusDmdEnv' and 'nopDmdEnv'; this is its 'msum' plusDmdEnvs :: [DmdEnv] -> DmdEnv-plusDmdEnvs []   = nopDmdEnv-plusDmdEnvs pdas = foldl1' plusDmdEnv pdas+plusDmdEnvs = foldl1WithDefault' nopDmdEnv plusDmdEnv  multDmdEnv :: Card -> DmdEnv -> DmdEnv multDmdEnv C_11 env          = env@@ -1836,7 +1833,7 @@     n = max (dmdTypeDepth d1) (dmdTypeDepth d2)     (DmdType fv1 ds1) = etaExpandDmdType n d1     (DmdType fv2 ds2) = etaExpandDmdType n d2-    lub_ds  = zipWithEqual "lubDmdType" lubDmd ds1 ds2+    lub_ds  = zipWithEqual lubDmd ds1 ds2     lub_fv = lubDmdEnv fv1 fv2  discardArgDmds :: DmdType -> DmdEnv@@ -2397,26 +2394,30 @@     mk_body_ty n dmds = DmdType nopDmdEnv (zipWith (bump n) str_marks dmds)     bump n str dmd | isMarkedStrict str = multDmd n (plusDmd str_field_dmd dmd)                    | otherwise          = multDmd n dmd-    str_field_dmd = C_01 :* seqSubDmd -- Why not C_11? See Note [Data-con worker strictness]+    str_field_dmd = seqDmd -- See the bit about strict fields+                           -- in Note [Demand transformer for data constructors]  -- | A special 'DmdTransformer' for dictionary selectors that feeds the demand -- on the result into the indicated dictionary component (if saturated). -- See Note [Demand transformer for a dictionary selector]. dmdTransformDictSelSig :: DmdSig -> DmdTransformer--- NB: This currently doesn't handle newtype dictionaries.--- It should simply apply call_sd directly to the dictionary, I suppose.-dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* prod])) call_sd+++dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* dict_dmd])) call_sd+   -- NB: dict_dmd comes from the demand signature of the class-op+   --     which is created in GHC.Types.Id.Make.mkDictSelId    | (n, sd') <- peelCallDmd call_sd-   , Prod _ sig_ds <- prod+   , Prod _ sig_ds <- dict_dmd    = multDmdType n $      DmdType nopDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)]    | otherwise    = nopDmdType -- See Note [Demand transformer for a dictionary selector]   where-    enhance _  AbsDmd   = AbsDmd-    enhance _  BotDmd   = BotDmd-    enhance sd _dmd_var = C_11 :* sd  -- This is the one!-                                      -- C_11, because we multiply with n above+    enhance _   AbsDmd   = AbsDmd+    enhance _   BotDmd   = BotDmd+    enhance sd' _dmd_var = C_11 :* sd'  -- This is the one!+                           -- C_11, because we multiply with n above+ dmdTransformDictSelSig sig sd = pprPanic "dmdTransformDictSelSig: no args" (ppr sig $$ ppr sd)  {-@@ -2459,21 +2460,8 @@ the whole signature really means `\d. P(AAAdAAAAA)` for any incoming demand 'd'. -For single-method classes, which are represented by newtypes the signature-of 'op' won't look like P(...), so matching on Prod will fail.-That's fine: if we are doing strictness analysis we are also doing inlining,-so we'll have inlined 'op' into a cast.  So we can bale out in a conservative-way, returning nopDmdType. SG: Although we then probably want to apply the eval-demand 'd' directly to 'op' rather than turning it into 'topSubDmd'...--It is (just.. #8329) possible to be running strictness analysis *without*-having inlined class ops from single-method classes.  Suppose you are using-ghc --make; and the first module has a local -O0 flag.  So you may load a class-without interface pragmas, ie (currently) without an unfolding for the class-ops.   Now if a subsequent module in the --make sweep has a local -O flag-you might do strictness analysis, but there is no inlining for the class op.-This is weird, so I'm not worried about whether this optimises brilliantly; but-it should not fall over.+NB: even unary classes behave as if there was a data constructor, and so do+not need special handling here. See Note [Unary class magic] in GHC.Core.TyCon. -}  zapDmdEnv :: DmdEnv -> DmdEnv
compiler/GHC/Types/Error.hs view
@@ -30,13 +30,13 @@    , Severity (..)    , Diagnostic (..)    , UnknownDiagnostic (..)+   , UnknownDiagnosticFor    , mkSimpleUnknownDiagnostic    , mkUnknownDiagnostic    , embedUnknownDiagnostic    , DiagnosticMessage (..)    , DiagnosticReason (WarningWithFlag, ..)    , ResolvedDiagnosticReason(..)-   , DiagnosticHint (..)    , mkPlainDiagnostic    , mkPlainError    , mkDecoratedDiagnostic@@ -171,7 +171,7 @@                pprDiagnostic (errMsgDiagnostic envelope)              ] -instance Diagnostic e => ToJson (Messages e) where+instance (Diagnostic e) => ToJson (Messages e) where   json msgs =  JSArray . toList $ json <$> getMessages msgs  {- Note [Discarding Messages]@@ -251,11 +251,16 @@ -- A 'Diagnostic' carries the /actual/ description of the message (which, in -- GHC's case, it can be an error or a warning) and the /reason/ why such -- message was generated in the first place.-class (HasDefaultDiagnosticOpts (DiagnosticOpts a)) => Diagnostic a where+class (Outputable (DiagnosticHint a), HasDefaultDiagnosticOpts (DiagnosticOpts a)) => Diagnostic a where    -- | Type of configuration options for the diagnostic.   type DiagnosticOpts a +  -- | Type of hint this diagnostic can provide.+  -- By default, this is 'GhcHint'.+  type DiagnosticHint a+  type DiagnosticHint a = GhcHint+   -- | Extract the error message text from a 'Diagnostic'.   diagnosticMessage :: DiagnosticOpts a -> a -> DecoratedSDoc @@ -265,7 +270,7 @@    -- | Extract any hints a user might use to repair their   -- code to avoid this diagnostic.-  diagnosticHints   :: a -> [GhcHint]+  diagnosticHints   :: a -> [DiagnosticHint a]    -- | Get the 'DiagnosticCode' associated with this 'Diagnostic'.   -- This can return 'Nothing' for at least two reasons:@@ -282,37 +287,45 @@   diagnosticCode    :: a -> Maybe DiagnosticCode  -- | An existential wrapper around an unknown diagnostic.-data UnknownDiagnostic opts where+data UnknownDiagnostic opts hint where   UnknownDiagnostic :: (Diagnostic a, Typeable a)                     => (opts -> DiagnosticOpts a) -- Inject the options of the outer context                                                   -- into the options for the wrapped diagnostic.+                    -> (DiagnosticHint a -> hint)                     -> a-                    -> UnknownDiagnostic opts+                    -> UnknownDiagnostic opts hint -instance HasDefaultDiagnosticOpts opts => Diagnostic (UnknownDiagnostic opts) where-  type DiagnosticOpts (UnknownDiagnostic opts) = opts-  diagnosticMessage opts (UnknownDiagnostic f diag) = diagnosticMessage (f opts) diag-  diagnosticReason    (UnknownDiagnostic _ diag) = diagnosticReason  diag-  diagnosticHints     (UnknownDiagnostic _ diag) = diagnosticHints   diag-  diagnosticCode      (UnknownDiagnostic _ diag) = diagnosticCode    diag+type UnknownDiagnosticFor a = UnknownDiagnostic (DiagnosticOpts a) (DiagnosticHint a) +instance (HasDefaultDiagnosticOpts opts, Outputable hint) => Diagnostic (UnknownDiagnostic opts hint) where+  type DiagnosticOpts (UnknownDiagnostic opts _) = opts+  type DiagnosticHint (UnknownDiagnostic _ hint) = hint+  diagnosticMessage opts (UnknownDiagnostic f _ diag) = diagnosticMessage (f opts) diag+  diagnosticReason       (UnknownDiagnostic _ _ diag) = diagnosticReason diag+  diagnosticHints        (UnknownDiagnostic _ f diag) = map f (diagnosticHints diag)+  diagnosticCode         (UnknownDiagnostic _ _ diag) = diagnosticCode diag+ -- A fallback 'DiagnosticOpts' which can be used when there are no options -- for a particular diagnostic. data NoDiagnosticOpts = NoDiagnosticOpts instance HasDefaultDiagnosticOpts NoDiagnosticOpts where   defaultOpts = NoDiagnosticOpts --- | Make a "simple" unknown diagnostic which doesn't have any configuration options.-mkSimpleUnknownDiagnostic :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) => a -> UnknownDiagnostic b-mkSimpleUnknownDiagnostic = UnknownDiagnostic (const NoDiagnosticOpts)+-- | Make a "simple" unknown diagnostic which doesn't have any configuration options+-- and the same hint.+mkSimpleUnknownDiagnostic :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>+  a -> UnknownDiagnostic b (DiagnosticHint a)+mkSimpleUnknownDiagnostic = UnknownDiagnostic (const NoDiagnosticOpts) id --- | Make an unknown diagnostic which uses the same options as the context it will be embedded into.-mkUnknownDiagnostic :: (Typeable a, Diagnostic a) => a -> UnknownDiagnostic (DiagnosticOpts a)-mkUnknownDiagnostic = UnknownDiagnostic id+-- | Make an unknown diagnostic which uses the same options and hint+-- as the context it will be embedded into.+mkUnknownDiagnostic :: (Typeable a, Diagnostic a) =>+  a -> UnknownDiagnosticFor a+mkUnknownDiagnostic = UnknownDiagnostic id id  -- | Embed a more complicated diagnostic which requires a potentially different options type.-embedUnknownDiagnostic :: (Diagnostic a, Typeable a) => (opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts-embedUnknownDiagnostic = UnknownDiagnostic+embedUnknownDiagnostic :: (Diagnostic a, Typeable a) => (opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts (DiagnosticHint a)+embedUnknownDiagnostic f = UnknownDiagnostic f id  -------------------------------------------------------------------------------- @@ -321,12 +334,7 @@                        , nest 2 (vcat (unDecorated (diagnosticMessage opts e))) ]   where opts = defaultDiagnosticOpts @e --- | A generic 'Hint' message, to be used with 'DiagnosticMessage'.-data DiagnosticHint = DiagnosticHint !SDoc -instance Outputable DiagnosticHint where-  ppr (DiagnosticHint msg) = msg- -- | A generic 'Diagnostic' message, without any further classification or -- provenance: By looking at a 'DiagnosticMessage' we don't know neither -- /where/ it was generated nor how to interpret its payload (as it's just a@@ -594,8 +602,14 @@     where       diag = errMsgDiagnostic m       opts = defaultDiagnosticOpts @e-      style = mkErrStyle (errMsgContext m)-      ctx = defaultSDocContext {sdocStyle = style }+      ctx = defaultSDocContext {+          sdocStyle = mkErrStyle (errMsgContext m)+        , sdocCanUseUnicode = True+             -- Using Unicode makes it easier to consume the JSON output,+             -- e.g. a suggestion to use foldl' will be displayed as+             -- \u2018foldl'\u2019, which is not easily confused with+             -- the quoted ‘foldl’ (note: no tick).+        }       diagMsg = filter (not . isEmpty ctx) (unDecorated (diagnosticMessage (opts) diag))       renderToJSString :: SDoc -> JsonDoc       renderToJSString = JSString . (renderWithContext ctx)
compiler/GHC/Types/Error/Codes.hs view
@@ -16,23 +16,33 @@ -- A diagnostic code is a numeric unique identifier for a diagnostic. -- See Note [Diagnostic codes]. module GHC.Types.Error.Codes-  ( GhcDiagnosticCode, constructorCode, constructorCodes )+  ( -- * General diagnostic code infrastructure+    DiagnosticCodeNameSpace(NameSpaceTag, DiagnosticCodeFor, ConRecursIntoFor)+  , Outdated+  , constructorCode, constructorCodes+    -- * GHC diagnostic codes+  , GHC, GhcDiagnosticCode, ConRecursInto+  )   where  import GHC.Prelude-import GHC.Types.Error  ( DiagnosticCode(..), UnknownDiagnostic (..), diagnosticCode, NoDiagnosticOpts ) -import GHC.Hs.Extension ( GhcRn )+import GHC.Core.InstEnv         ( LookupInstanceErrReason )+import GHC.Hs.Extension         ( GhcRn )+import GHC.Types.Error          ( DiagnosticCode(..), UnknownDiagnostic (..)+                                , diagnosticCode, UnknownDiagnosticFor ) -import GHC.Core.InstEnv (LookupInstanceErrReason) import GHC.Iface.Errors.Types-import GHC.Driver.Errors.Types   ( DriverMessage, GhcMessageOpts, DriverMessageOpts )+import GHC.Driver.Errors.Types   ( DriverMessage ) import GHC.Parser.Errors.Types   ( PsMessage, PsHeaderMessage )-import GHC.HsToCore.Errors.Types ( DsMessage )+import GHC.HsToCore.Errors.Types ( DsMessage, UselessSpecialisePragmaReason ) import GHC.Tc.Errors.Types import GHC.Unit.Module.Warnings ( WarningTxt ) import GHC.Utils.Panic.Plain +-- Import all the structured error data types+import GHC.Driver.Errors.Types   ( GhcMessage )+ import Data.Kind    ( Type, Constraint ) import GHC.Exts     ( proxy# ) import GHC.Generics@@ -57,8 +67,12 @@   - a diagnostic code never gets deleted from the GhcDiagnosticCode type family     in GHC.Types.Error.Codes, even if it is no longer used.     Older versions of GHC might still display the code, and we don't want that-    old code to get confused with the error code of a different, new, error message.+    old code to get confused with the error code of a different, new, error message.* +Note that this module also provides a 'DiagnosticCodeNameSpace' typeclass which+allows diagnostic codes to be emitted in different namespaces than the GHC+namespace; see Note [Diagnostic code namespaces].+ [Instructions for adding a new diagnostic code]    After adding a constructor to a diagnostic datatype, such as PsMessage,@@ -99,33 +113,94 @@    Never remove a return value from the 'GhcDiagnosticCode' type family!   Outdated error messages must still be tracked to ensure uniqueness-  of diagnostic codes across GHC versions.+  of diagnostic codes across GHC versions. Instead, you should wrap the+  return value in the 'Outdated' type synonym. The presence of this type synonym+  is used by the 'codes' test to determine which diagnostic codes to check+  for testsuite coverage. -}  {- ********************************************************************* *                                                                      *-                 The GhcDiagnosticCode type family+                 DiagnosticCode infrastructure *                                                                      * ********************************************************************* -} --- | This function obtain a diagnostic code by looking up the constructor--- name using generics, and using the 'GhcDiagnosticCode' type family.-constructorCode :: (Generic diag, GDiagnosticCode (Rep diag))+{- Note [Diagnostic code namespaces]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The machinery for GHC diagnostic codes described in Note [Diagnostic codes]+works for other namespaces than the GHC namespaces; one example is GHCi-specific+diagnostic codes.++To achieve this, we parametrise all the machinery over a namespace type-level+argument, using the 'DiagnosticCodeNameSpace' class.+To provide diagnostic codes, one needs to supply an instance of this class,+which means supplying the following pieces of information:++  - a type that represents the namespace, e.g. `data GHC` can be used to+    represent the GHC namespace,+  - a type family equation for 'NameSpaceTag', e.g. 'NameSpaceTag GHC = "GHC"',+  - a diagnostic code type family, e.g. 'DiagnosticCodeFor GHC con = GhcDiagnosticCode con',+  - a type family that specifies how to recur into constructor arguments,+    e.g. 'ConRecursIntoFor GHC con = ConRecursInto con'.++This allows any tool that imports the GHC library to re-use the diagnostic+code machinery that GHC uses.+-}++-- | A constraint for a namespace which has its own diagnostic codes.+--+-- See Note [Diagnostic code namespaces].+type DiagnosticCodeNameSpace :: Type -> Constraint+class DiagnosticCodeNameSpace namespace where+  -- | The symbolic tag for a namespace.+  type NameSpaceTag namespace = (r :: Symbol) | r -> namespace+    -- NB: the injectivity annotation ensures uniqueness of namespaces,+    -- e.g. it prevents two different namespaces from using the same symbolic tag.+  -- | A diagnostic code in a given namespace.+  type DiagnosticCodeFor namespace (c :: Symbol) :: Nat+  -- | Specify that one should recur into an argument of a constructor+  -- in order to obtain a diagnostic code. See Note [Diagnostic codes].+  type ConRecursIntoFor namespace (c :: Symbol) :: Maybe Type++-- | Use this type synonym to mark a diagnostic code as outdated.+--+-- The presence of this type synonym is used by the 'codes' test to determine+-- which diagnostic codes to check for testsuite coverage.+type Outdated a = a++-- | This function obtains a diagnostic code by looking up the constructor+-- name using generics, and using the 'DiagnosticCode' type family.+constructorCode :: forall namespace diag+                .  (Generic diag, GDiagnosticCode namespace (Rep diag))                 => diag -> Maybe DiagnosticCode-constructorCode diag = gdiagnosticCode (from diag)+constructorCode diag = gdiagnosticCode @namespace (from diag)  -- | This function computes all diagnostic codes that occur inside a given--- type using generics and the 'GhcDiagnosticCode' type family.+-- type using generics and the 'DiagnosticCode' type family. -- -- For example, if @T = MkT1 | MkT2@, @GhcDiagnosticCode \"MkT1\" = 123@ and -- @GhcDiagnosticCode \"MkT2\" = 456@, then we will get--- > constructorCodes @T = fromList [ (123, \"MkT1\"), (456, \"MkT2\") ]-constructorCodes :: forall diag. (Generic diag, GDiagnosticCodes '[diag] (Rep diag))+-- > constructorCodes @GHC @T = fromList [ (DiagnosticCode "GHC" 123, \"MkT1\"), (DiagnosticCode "GHC" 456, \"MkT2\") ]+constructorCodes :: forall namespace diag+                 .  (Generic diag, GDiagnosticCodes namespace '[diag] (Rep diag))                  => Map DiagnosticCode String-constructorCodes = gdiagnosticCodes @'[diag] @(Rep diag)+constructorCodes = gdiagnosticCodes @namespace @'[diag] @(Rep diag)   -- See Note [diagnosticCodes: don't recur into already-seen types]   -- for the @'[diag] type argument. +{- *********************************************************************+*                                                                      *+                 The GhcDiagnosticCode type family+*                                                                      *+********************************************************************* -}++-- | The GHC namespace for diagnostic codes.+data GHC+instance DiagnosticCodeNameSpace GHC where+  type instance NameSpaceTag      GHC = "GHC"+  type instance DiagnosticCodeFor GHC con = GhcDiagnosticCode con+  type instance ConRecursIntoFor  GHC con =     ConRecursInto con+ -- | Type family computing the numeric diagnostic code for a given error message constructor. -- -- Its injectivity annotation ensures uniqueness of error codes.@@ -147,9 +222,6 @@   GhcDiagnosticCode "DsMaxPmCheckModelsReached"                     = 61505   GhcDiagnosticCode "DsNonExhaustivePatterns"                       = 62161   GhcDiagnosticCode "DsTopLevelBindsNotAllowed"                     = 48099-  GhcDiagnosticCode "DsUselessSpecialiseForClassMethodSelector"     = 93315-  GhcDiagnosticCode "DsUselessSpecialiseForNoInlineFunction"        = 38524-  GhcDiagnosticCode "DsMultiplicityCoercionsNotSupported"           = 59840   GhcDiagnosticCode "DsOrphanRule"                                  = 58181   GhcDiagnosticCode "DsRuleLhsTooComplicated"                       = 69441   GhcDiagnosticCode "DsRuleIgnoredDueToConstructor"                 = 00828@@ -166,6 +238,10 @@   GhcDiagnosticCode "DsAnotherRuleMightFireFirst"                   = 87502   GhcDiagnosticCode "DsIncompleteRecordSelector"                    = 17335 +    -- Constructors of 'UselessSpecialisePragmaReason'+  GhcDiagnosticCode "UselessSpecialiseForClassMethodSelector"       = 93315+  GhcDiagnosticCode "UselessSpecialiseForNoInlineFunction"          = 38524+  GhcDiagnosticCode "UselessSpecialiseNoSpecialisation"             = 66582    -- Parser diagnostic codes   GhcDiagnosticCode "PsErrParseLanguagePragma"                      = 68686@@ -219,6 +295,7 @@   GhcDiagnosticCode "PsErrUnallowedPragma"                          = 85314   GhcDiagnosticCode "PsErrImportPostQualified"                      = 87491   GhcDiagnosticCode "PsErrImportQualifiedTwice"                     = 05661+  GhcDiagnosticCode "PsErrSpliceOrQuoteTwice"                       = 26105   GhcDiagnosticCode "PsErrIllegalImportBundleForm"                  = 81284   GhcDiagnosticCode "PsErrInvalidRuleActivationMarker"              = 50396   GhcDiagnosticCode "PsErrMissingBlock"                             = 16849@@ -291,6 +368,9 @@   GhcDiagnosticCode "PsErrInvalidPun"                               = 52943   GhcDiagnosticCode "PsErrIllegalOrPat"                             = 29847   GhcDiagnosticCode "PsErrTypeSyntaxInPat"                          = 32181+  GhcDiagnosticCode "PsErrSpecExprMultipleTypeAscription"           = 62037+  GhcDiagnosticCode "PsWarnSpecMultipleTypeAscription"              = 73026+  GhcDiagnosticCode "PsWarnPatternNamespaceSpecifier"               = 68383    -- Driver diagnostic codes   GhcDiagnosticCode "DriverMissingHomeModules"                      = 32850@@ -332,17 +412,15 @@   GhcDiagnosticCode "UnsatisfiableError"                            = 22250   GhcDiagnosticCode "ReportHoleError"                               = 88464   GhcDiagnosticCode "FixedRuntimeRepError"                          = 55287-  GhcDiagnosticCode "BlockedEquality"                               = 06200   GhcDiagnosticCode "ExpectingMoreArguments"                        = 81325   GhcDiagnosticCode "UnboundImplicitParams"                         = 91416   GhcDiagnosticCode "AmbiguityPreventsSolvingCt"                    = 78125   GhcDiagnosticCode "CannotResolveInstance"                         = 39999   GhcDiagnosticCode "OverlappingInstances"                          = 43085   GhcDiagnosticCode "UnsafeOverlap"                                 = 36705-+  GhcDiagnosticCode "MultiplicityCoercionsNotSupported"             = 59840   -- Type mismatch errors   GhcDiagnosticCode "BasicMismatch"                                 = 18872-  GhcDiagnosticCode "KindMismatch"                                  = 89223   GhcDiagnosticCode "TypeEqMismatch"                                = 83865   GhcDiagnosticCode "CouldNotDeduce"                                = 05617 @@ -379,6 +457,7 @@   GhcDiagnosticCode "TcRnIllegalWildcardInType"                     = 65507   GhcDiagnosticCode "TcRnIllegalNamedWildcardInTypeArgument"        = 93411   GhcDiagnosticCode "TcRnIllegalImplicitTyVarInTypeArgument"        = 80557+  GhcDiagnosticCode "TcRnIllegalPunnedVarOccInTypeArgument"         = 09591   GhcDiagnosticCode "TcRnDuplicateFieldName"                        = 85524   GhcDiagnosticCode "TcRnIllegalViewPattern"                        = 22406   GhcDiagnosticCode "TcRnCharLiteralOutOfRange"                     = 17268@@ -429,6 +508,7 @@   GhcDiagnosticCode "TcRnExportHiddenComponents"                    = 94558   GhcDiagnosticCode "TcRnExportHiddenDefault"                       = 74775   GhcDiagnosticCode "TcRnDuplicateExport"                           = 47854+  GhcDiagnosticCode "TcRnDuplicateNamedDefaultExport"               = 31584   GhcDiagnosticCode "TcRnExportedParentChildMismatch"               = 88993   GhcDiagnosticCode "TcRnConflictingExports"                        = 69158   GhcDiagnosticCode "TcRnDuplicateFieldExport"                      = 97219@@ -488,7 +568,7 @@   GhcDiagnosticCode "TcRnMatchesHaveDiffNumArgs"                    = 91938   GhcDiagnosticCode "TcRnCannotBindScopedTyVarInPatSig"             = 46131   GhcDiagnosticCode "TcRnCannotBindTyVarsInPatBind"                 = 48361-  GhcDiagnosticCode "TcRnTooManyTyArgsInConPattern"                 = 01629+  GhcDiagnosticCode "TcRnTooManyTyArgsInConPattern"                 = Outdated 01629   GhcDiagnosticCode "TcRnMultipleInlinePragmas"                     = 96665   GhcDiagnosticCode "TcRnUnexpectedPragmas"                         = 88293   GhcDiagnosticCode "TcRnNonOverloadedSpecialisePragma"             = 35827@@ -526,11 +606,13 @@   GhcDiagnosticCode "TcRnMisplacedSigDecl"                          = 87866   GhcDiagnosticCode "TcRnUnexpectedDefaultSig"                      = 40700   GhcDiagnosticCode "TcRnDuplicateMinimalSig"                       = 85346+  GhcDiagnosticCode "TcRnSpecSigShape"                              = 93944   GhcDiagnosticCode "TcRnLoopySuperclassSolve"                      = Outdated 36038   GhcDiagnosticCode "TcRnUnexpectedStandaloneDerivingDecl"          = 95159   GhcDiagnosticCode "TcRnUnusedVariableInRuleDecl"                  = 65669   GhcDiagnosticCode "TcRnUnexpectedStandaloneKindSig"               = 45906   GhcDiagnosticCode "TcRnIllegalRuleLhs"                            = 63294+  GhcDiagnosticCode "TcRnRuleLhsEqualities"                         = 53522   GhcDiagnosticCode "TcRnDuplicateRoleAnnot"                        = 97170   GhcDiagnosticCode "TcRnDuplicateKindSig"                          = 43371   GhcDiagnosticCode "TcRnIllegalDerivStrategy"                      = 87139@@ -540,9 +622,9 @@   GhcDiagnosticCode "TcRnShadowedTyVarNameInFamResult"              = 99412   GhcDiagnosticCode "TcRnIncorrectTyVarOnLhsOfInjCond"              = 88333   GhcDiagnosticCode "TcRnUnknownTyVarsOnRhsOfInjCond"               = 48254-  GhcDiagnosticCode "TcRnBadlyStaged"                               = 28914-  GhcDiagnosticCode "TcRnBadlyStagedType"                           = 86357-  GhcDiagnosticCode "TcRnStageRestriction"                          = 18157+  GhcDiagnosticCode "TcRnBadlyLevelled"                             = 28914+  GhcDiagnosticCode "TcRnBadlyLevelledType"                         = 86357+  GhcDiagnosticCode "TcRnStageRestriction"                          = Outdated 18157   GhcDiagnosticCode "TcRnTyThingUsedWrong"                          = 10969   GhcDiagnosticCode "TcRnCannotDefaultKindVar"                      = 79924   GhcDiagnosticCode "TcRnUninferrableTyVar"                         = 16220@@ -605,24 +687,23 @@   GhcDiagnosticCode "TcRnImplicitRhsQuantification"                 = 16382   GhcDiagnosticCode "TcRnBadTyConTelescope"                         = 87279   GhcDiagnosticCode "TcRnPatersonCondFailure"                       = 22979-  GhcDiagnosticCode "TcRnDeprecatedInvisTyArgInConPat"              = 69797+  GhcDiagnosticCode "TcRnDeprecatedInvisTyArgInConPat"              = Outdated 69797   GhcDiagnosticCode "TcRnInvalidDefaultedTyVar"                     = 45625   GhcDiagnosticCode "TcRnIllegalTermLevelUse"                       = 01928   GhcDiagnosticCode "TcRnNamespacedWarningPragmaWithoutFlag"        = 14995-  GhcDiagnosticCode "TcRnInvisPatWithNoForAll"                      = 14964-  GhcDiagnosticCode "TcRnIllegalInvisibleTypePattern"               = 78249   GhcDiagnosticCode "TcRnNamespacedFixitySigWithoutFlag"            = 78534   GhcDiagnosticCode "TcRnOutOfArityTyVar"                           = 84925-  GhcDiagnosticCode "TcRnMisplacedInvisPat"                         = 11983   GhcDiagnosticCode "TcRnIllformedTypePattern"                      = 88754   GhcDiagnosticCode "TcRnIllegalTypePattern"                        = 70206   GhcDiagnosticCode "TcRnIllformedTypeArgument"                     = 29092   GhcDiagnosticCode "TcRnIllegalTypeExpr"                           = 35499   GhcDiagnosticCode "TcRnUnexpectedTypeSyntaxInTerms"               = 31244+  GhcDiagnosticCode "TcRnTypeApplicationsDisabled"                  = 23482 -  -- TcRnTypeApplicationsDisabled-  GhcDiagnosticCode "TypeApplication"                               = 23482-  GhcDiagnosticCode "TypeApplicationInPattern"                      = 17916+  -- TcRnIllegalInvisibleTypePattern+  GhcDiagnosticCode "InvisPatWithoutFlag"                           = 78249+  GhcDiagnosticCode "InvisPatNoForall"                              = 14964+  GhcDiagnosticCode "InvisPatMisplaced"                             = 11983    -- PatSynInvalidRhsReason   GhcDiagnosticCode "PatSynNotInvertible"                           = 69317@@ -631,7 +712,7 @@   -- TcRnBadFieldAnnotation/BadFieldAnnotationReason   GhcDiagnosticCode "LazyFieldsDisabled"                            = 81601   GhcDiagnosticCode "UnpackWithoutStrictness"                       = 10107-  GhcDiagnosticCode "BackpackUnpackAbstractType"                    = 40091+  GhcDiagnosticCode "UnusableUnpackPragma"                          = 40091    -- TcRnRoleValidationFailed/RoleInferenceFailedReason   GhcDiagnosticCode "TyVarRoleMismatch"                             = 22221@@ -676,6 +757,8 @@   GhcDiagnosticCode "BadImportNotExported"                          = 61689   GhcDiagnosticCode "BadImportAvailDataCon"                         = 35373   GhcDiagnosticCode "BadImportNotExportedSubordinates"              = 10237+  GhcDiagnosticCode "BadImportNonTypeSubordinates"                  = 51433+  GhcDiagnosticCode "BadImportNonDataSubordinates"                  = 46557   GhcDiagnosticCode "BadImportAvailTyCon"                           = 56449   GhcDiagnosticCode "BadImportAvailVar"                             = 12112 @@ -706,6 +789,8 @@   GhcDiagnosticCode "InvalidImplicitParamBinding"                   = 51603   GhcDiagnosticCode "DefaultDataInstDecl"                           = 39639   GhcDiagnosticCode "FunBindLacksEquations"                         = 52078+  GhcDiagnosticCode "EmptyGuard"                                    = 45149+  GhcDiagnosticCode "EmptyParStmt"                                  = 95595    -- TcRnDodgyImports/DodgyImportsReason   GhcDiagnosticCode "DodgyImportsEmptyParent"                       = 99623@@ -728,7 +813,7 @@      -- IllegalInstanceHead   GhcDiagnosticCode "InstHeadAbstractClass"                         = 51758-  GhcDiagnosticCode "InstHeadNonClass"                              = 53946+  GhcDiagnosticCode "InstHeadNonClassHead"                          = 53946   GhcDiagnosticCode "InstHeadTySynArgs"                             = 93557   GhcDiagnosticCode "InstHeadNonTyVarArgs"                          = 48406   GhcDiagnosticCode "InstHeadMultiParam"                            = 91901@@ -883,7 +968,7 @@   GhcDiagnosticCode "NestedTHBrackets"                              = 59185   GhcDiagnosticCode "AddTopDeclsUnexpectedDeclarationSplice"        = 17599   GhcDiagnosticCode "BadImplicitSplice"                             = 25277-  GhcDiagnosticCode "QuotedNameWrongStage"                          = 57695+  GhcDiagnosticCode "QuotedNameWrongStage"                          = Outdated 57695   GhcDiagnosticCode "IllegalStaticFormInSplice"                     = 12219    -- Zonker messages@@ -905,11 +990,13 @@   -- NB: never remove a return value from this type family!   -- We need to ensure uniquess of diagnostic codes across GHC versions,   -- and this includes outdated diagnostic codes for errors that GHC-  -- no longer reports. These are collected below.+  -- no longer reports. These are mostly collected below, but for ease+  -- of rebasing it is often better to simply declare a constructor outdated+  -- without moving it down here.    GhcDiagnosticCode "TcRnIllegalInstanceHeadDecl"                   = Outdated 12222   GhcDiagnosticCode "TcRnNoClassInstHead"                           = Outdated 56538-    -- The above two are subsumed by InstHeadNonClass [GHC-53946]+    -- The above two are subsumed by InstHeadNonClassHead [GHC-53946]    GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote"                = Outdated 40027   GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn"                   = Outdated 69639@@ -925,12 +1012,7 @@   GhcDiagnosticCode "TcRnHsigNoIface"                               = Outdated 93010   GhcDiagnosticCode "TcRnInterfaceLookupError"                      = Outdated 52243   GhcDiagnosticCode "TcRnForallIdentifier"                          = Outdated 64088---- | Use this type synonym to mark a diagnostic code as outdated.------ The presence of this type synonym is used by the 'codes' test to determine--- which diagnostic codes to check for testsuite coverage.-type Outdated a = a+  GhcDiagnosticCode "TypeApplicationInPattern"                      = Outdated 17916  {- ********************************************************************* *                                                                      *@@ -957,12 +1039,12 @@   ConRecursInto "GhcPsMessage"             = 'Just PsMessage   ConRecursInto "GhcTcRnMessage"           = 'Just TcRnMessage   ConRecursInto "GhcDsMessage"             = 'Just DsMessage-  ConRecursInto "GhcUnknownMessage"        = 'Just (UnknownDiagnostic GhcMessageOpts)+  ConRecursInto "GhcUnknownMessage"        = 'Just (UnknownDiagnosticFor GhcMessage)    ----------------------------------   -- Constructors of DriverMessage -  ConRecursInto "DriverUnknownMessage"     = 'Just (UnknownDiagnostic DriverMessageOpts)+  ConRecursInto "DriverUnknownMessage"     = 'Just (UnknownDiagnosticFor DriverMessage)   ConRecursInto "DriverPsHeaderMessage"    = 'Just PsMessage   ConRecursInto "DriverInterfaceError"     = 'Just IfaceMessage @@ -977,13 +1059,18 @@   ----------------------------------   -- Constructors of PsMessage -  ConRecursInto "PsUnknownMessage"         = 'Just (UnknownDiagnostic NoDiagnosticOpts)+  ConRecursInto "PsUnknownMessage"         = 'Just (UnknownDiagnosticFor PsMessage)   ConRecursInto "PsHeaderMessage"          = 'Just PsHeaderMessage    ----------------------------------+  -- Constructors of DsMessage++  ConRecursInto "DsUselessSpecialisePragma" = 'Just UselessSpecialisePragmaReason++  ----------------------------------   -- Constructors of TcRnMessage -  ConRecursInto "TcRnUnknownMessage"       = 'Just (UnknownDiagnostic TcRnMessageOpts)+  ConRecursInto "TcRnUnknownMessage"       = 'Just (UnknownDiagnosticFor TcRnMessage)      -- Recur into TcRnMessageWithInfo to get the underlying TcRnMessage   ConRecursInto "TcRnMessageWithInfo"      = 'Just TcRnMessageDetailed@@ -1008,7 +1095,7 @@   ConRecursInto "TcRnUnusedImport"         = 'Just UnusedImportReason   ConRecursInto "TcRnNonCanonicalDefinition" = 'Just NonCanonicalDefinition   ConRecursInto "TcRnIllegalInstance"        = 'Just IllegalInstanceReason-  ConRecursInto "TcRnTypeApplicationsDisabled" = 'Just TypeApplication+  ConRecursInto "TcRnIllegalInvisibleTypePattern" = 'Just BadInvisPatReason      -- Illegal instance reasons   ConRecursInto "IllegalClassInstance"        = 'Just IllegalClassInstanceReason@@ -1078,7 +1165,7 @@   ----------------------------------   -- Constructors of DsMessage -  ConRecursInto "DsUnknownMessage"         = 'Just (UnknownDiagnostic NoDiagnosticOpts)+  ConRecursInto "DsUnknownMessage"         = 'Just (UnknownDiagnosticFor DsMessage)    ----------------------------------   -- Constructors of ImportLookupBad@@ -1099,7 +1186,7 @@  {- Note [Diagnostic codes using generics] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Diagnostic codes are specified at the type-level using the injective+Diagnostic codes for GHC are specified at the type-level using the injective type family 'GhcDiagnosticCode'. This ensures uniqueness of diagnostic codes, giving quick feedback (in the form of a type error). @@ -1136,7 +1223,12 @@     first, and decide whether to recur into it using the     HasTypeQ type family.   - The two different behaviours are controlled by two main instances (*) and (**).-    - (*) recurses into a subtype, when we have a type family equation such as:+    - (*) directly uses the constructor name, by using the 'DiagnosticCodeFor'+      type family. The 'KnownConstructor' context (ERR2) on the instance provides+      a custom error message in case of a missing diagnostic code, which points+      GHC contributors to the documentation explaining how to add diagnostic codes+      for their diagnostics.+    - (**) recurses into a subtype, when we have a type family equation such as:          ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason @@ -1144,94 +1236,87 @@       type 'DeriveInstanceErrReason'.       The overlapping instance (ERR1) provides an error message in case a constructor       does not have the type specified by the 'ConRecursInto' type family.-    - (**) directly uses the constructor name, by using the 'GhcDiagnosticCode'-      type family. The 'KnownConstructor' context (ERR2) on the instance provides-      a custom error message in case of a missing diagnostic code, which points-      GHC contributors to the documentation explaining how to add diagnostic codes-      for their diagnostics. -}  -- | Use the generic representation of a type to retrieve the--- diagnostic code, using the 'GhcDiagnosticCode' type family.+-- diagnostic code, using 'DiagnosticCodeFor namespace' type family. -- -- See Note [Diagnostic codes using generics] in GHC.Types.Error.Codes.-type GDiagnosticCode :: (Type -> Type) -> Constraint-class GDiagnosticCode f where+type GDiagnosticCode :: Type -> (Type -> Type) -> Constraint+class GDiagnosticCode namespace f where   gdiagnosticCode :: f a -> Maybe DiagnosticCode -- | Use the generic representation of a type to retrieve the collection -- of all diagnostic codes it can give rise to.-type GDiagnosticCodes :: [Type] -> (Type -> Type) -> Constraint-class GDiagnosticCodes seen f where+type GDiagnosticCodes :: Type -> [Type] -> (Type -> Type) -> Constraint+class GDiagnosticCodes namespace seen f where   gdiagnosticCodes :: Map DiagnosticCode String -type ConstructorCode :: Symbol -> (Type -> Type)  -> Maybe Type -> Constraint-class ConstructorCode con f recur where+type ConstructorCode :: Type -> Symbol -> (Type -> Type)  -> Maybe Type -> Constraint+class ConstructorCode namespace con f recur where   gconstructorCode :: f a -> Maybe DiagnosticCode-type ConstructorCodes :: Symbol -> (Type -> Type) -> [Type] -> Maybe Type -> Constraint-class ConstructorCodes con f seen recur where+type ConstructorCodes :: Type -> Symbol -> (Type -> Type) -> [Type] -> Maybe Type -> Constraint+class ConstructorCodes namespace con f seen recur where   gconstructorCodes :: Map DiagnosticCode String -instance (KnownConstructor con, KnownSymbol con) => ConstructorCode con f 'Nothing where-  gconstructorCode _ = Just $ DiagnosticCode "GHC" $ natVal' @(GhcDiagnosticCode con) proxy#-instance (KnownConstructor con, KnownSymbol con) => ConstructorCodes con f seen 'Nothing where-  gconstructorCodes =-    Map.singleton-      (DiagnosticCode "GHC" $ natVal' @(GhcDiagnosticCode con) proxy#)-      (symbolVal' @con proxy#)- -- If we recur into the 'UnknownDiagnostic' existential datatype, -- unwrap the existential and obtain the error code. instance {-# OVERLAPPING #-}-         ( ConRecursInto con ~ 'Just (UnknownDiagnostic opts)-         , HasType (UnknownDiagnostic opts) con f )-      => ConstructorCode con f ('Just (UnknownDiagnostic opts)) where-  gconstructorCode diag = case getType @(UnknownDiagnostic opts) @con @f diag of-    UnknownDiagnostic _ diag -> diagnosticCode diag+         ( ConRecursIntoFor namespace con ~ 'Just (UnknownDiagnostic opts hint)+         , HasType namespace (UnknownDiagnostic opts hint) con f )+      => ConstructorCode namespace con f ('Just (UnknownDiagnostic opts hint)) where+  gconstructorCode diag = case getType @namespace @(UnknownDiagnostic opts hint) @con @f diag of+    UnknownDiagnostic _ _ diag -> diagnosticCode diag instance {-# OVERLAPPING #-}-         ( ConRecursInto con ~ 'Just (UnknownDiagnostic opts) )-      => ConstructorCodes con f seen ('Just (UnknownDiagnostic opts)) where+         ( ConRecursIntoFor namespace con ~ 'Just (UnknownDiagnostic opts hint) )+      => ConstructorCodes namespace con f seen ('Just (UnknownDiagnostic opts hint)) where   gconstructorCodes = Map.empty --- (*) Recursive instance: Recur into the given type.-instance ( ConRecursInto con ~ 'Just ty, HasType ty con f-         , Generic ty, GDiagnosticCode (Rep ty) )-      => ConstructorCode con f ('Just ty) where-  gconstructorCode diag = gdiagnosticCode (from $ getType @ty @con @f diag)-instance ( ConRecursInto con ~ 'Just ty, HasType ty con f-         , Generic ty, GDiagnosticCodes (Insert ty seen) (Rep ty)+-- | (*) Base instance: use the diagnostic code for this constructor in this namespace.+instance (KnownNameSpace namespace, KnownConstructor namespace con, KnownSymbol con)+      => ConstructorCode namespace con f 'Nothing where+  gconstructorCode _ = Just $ DiagnosticCode (symbolVal' @(NameSpaceTag namespace) proxy#) $ natVal' @(DiagnosticCodeFor namespace con) proxy#+instance ( KnownNameSpace namespace, KnownConstructor namespace con, KnownSymbol con) => ConstructorCodes namespace con f seen 'Nothing where+  gconstructorCodes =+    Map.singleton+      (DiagnosticCode (symbolVal' @(NameSpaceTag namespace) proxy#) $ natVal' @(DiagnosticCodeFor namespace con) proxy#)+      (symbolVal' @con proxy#)++-- | (**) Recursive instance: recur into the given type.+instance ( ConRecursIntoFor namespace con ~ 'Just ty, HasType namespace ty con f+         , Generic ty, GDiagnosticCode namespace (Rep ty) )+      => ConstructorCode namespace con f ('Just ty) where+  gconstructorCode diag = gdiagnosticCode @namespace (from $ getType @namespace @ty @con @f diag)+instance ( ConRecursIntoFor namespace con ~ 'Just ty, HasType namespace ty con f+         , Generic ty, GDiagnosticCodes namespace (Insert ty seen) (Rep ty)          , Seen seen ty )-      => ConstructorCodes con f seen ('Just ty) where+      => ConstructorCodes namespace con f seen ('Just ty) where   gconstructorCodes =     -- See Note [diagnosticCodes: don't recur into already-seen types]     if wasSeen @seen @ty     then Map.empty-    else gdiagnosticCodes @(Insert ty seen) @(Rep ty)+    else gdiagnosticCodes @namespace @(Insert ty seen) @(Rep ty) --- (**) Constructor instance: handle constructors directly.------ Obtain the code from the 'GhcDiagnosticCode'--- type family, applied to the name of the constructor.-instance (ConstructorCode con f recur, recur ~ ConRecursInto con, KnownSymbol con)-      => GDiagnosticCode (M1 i ('MetaCons con x y) f) where-  gdiagnosticCode (M1 x) = gconstructorCode @con @f @recur x-instance (ConstructorCodes con f seen recur, recur ~ ConRecursInto con, KnownSymbol con)-      => GDiagnosticCodes seen (M1 i ('MetaCons con x y) f) where-  gdiagnosticCodes = gconstructorCodes @con @f @seen @recur+instance (ConstructorCode namespace con f recur, recur ~ ConRecursIntoFor namespace con, KnownSymbol con)+      => GDiagnosticCode namespace (M1 i ('MetaCons con x y) f) where+  gdiagnosticCode (M1 x) = gconstructorCode @namespace @con @f @recur x+instance (ConstructorCodes namespace con f seen recur, recur ~ ConRecursIntoFor namespace con, KnownSymbol con)+      => GDiagnosticCodes namespace seen (M1 i ('MetaCons con x y) f) where+  gdiagnosticCodes = gconstructorCodes @namespace @con @f @seen @recur  -- Handle sum types (the diagnostic types are sums of constructors).-instance (GDiagnosticCode f, GDiagnosticCode g) => GDiagnosticCode (f :+: g) where-  gdiagnosticCode (L1 x) = gdiagnosticCode @f x-  gdiagnosticCode (R1 y) = gdiagnosticCode @g y-instance (GDiagnosticCodes seen f, GDiagnosticCodes seen g) => GDiagnosticCodes seen (f :+: g) where-  gdiagnosticCodes = Map.union (gdiagnosticCodes @seen @f) (gdiagnosticCodes @seen @g)+instance (GDiagnosticCode namespace f, GDiagnosticCode namespace g) => GDiagnosticCode namespace (f :+: g) where+  gdiagnosticCode (L1 x) = gdiagnosticCode @namespace @f x+  gdiagnosticCode (R1 y) = gdiagnosticCode @namespace @g y+instance (GDiagnosticCodes namespace seen f, GDiagnosticCodes namespace seen g) => GDiagnosticCodes namespace seen (f :+: g) where+  gdiagnosticCodes = Map.union (gdiagnosticCodes @namespace @seen @f) (gdiagnosticCodes @namespace @seen @g)  -- Discard metadata we don't need.-instance GDiagnosticCode f-      => GDiagnosticCode (M1 i ('MetaData nm mod pkg nt) f) where-  gdiagnosticCode (M1 x) = gdiagnosticCode @f x-instance GDiagnosticCodes seen f-      => GDiagnosticCodes seen (M1 i ('MetaData nm mod pkg nt) f) where-  gdiagnosticCodes = gdiagnosticCodes @seen @f+instance GDiagnosticCode namespace f+      => GDiagnosticCode namespace (M1 i ('MetaData nm mod pkg nt) f) where+  gdiagnosticCode (M1 x) = gdiagnosticCode @namespace @f x+instance GDiagnosticCodes namespace seen f+      => GDiagnosticCodes namespace seen (M1 i ('MetaData nm mod pkg nt) f) where+  gdiagnosticCodes = gdiagnosticCodes @namespace @seen @f  -- | Decide whether to pick the left or right branch -- when deciding how to recurse into a product.@@ -1258,30 +1343,30 @@   Alt ('Just a) _ = 'Just a   Alt _ b = b -type HasType :: Type -> Symbol -> (Type -> Type) -> Constraint-class HasType ty orig f where+type HasType :: Type -> Type -> Symbol -> (Type -> Type) -> Constraint+class HasType namespace ty orig f where   getType :: f a -> ty -instance HasType ty orig (M1 i s (K1 x ty)) where+instance HasType namespace ty orig (M1 i s (K1 x ty)) where   getType (M1 (K1 x)) = x-instance HasTypeProd ty (HasTypeQ ty f) orig f g => HasType ty orig (f :*: g) where-  getType = getTypeProd @ty @(HasTypeQ ty f) @orig+instance HasTypeProd namespace ty (HasTypeQ ty f) orig f g => HasType namespace ty orig (f :*: g) where+  getType = getTypeProd @namespace @ty @(HasTypeQ ty f) @orig  -- The lr parameter tells us whether to pick the left or right -- branch in a product, and is computed using 'HasTypeQ'. -- -- If it's @Just l@, then we have found the type in the left branch, -- so use that. Otherwise, look in the right branch.-class HasTypeProd ty lr orig f g where+class HasTypeProd namespace ty lr orig f g where   getTypeProd :: (f :*: g) a -> ty  -- Pick the left branch.-instance HasType ty orig  f => HasTypeProd ty ('Just l) orig f g where-  getTypeProd (x :*: _) = getType @ty @orig @f x+instance HasType namespace ty orig  f => HasTypeProd namespace ty ('Just l) orig f g where+  getTypeProd (x :*: _) = getType @namespace @ty @orig @f x  -- Pick the right branch.-instance HasType ty orig g => HasTypeProd ty 'Nothing orig f g where-  getTypeProd (_ :*: y) = getType @ty @orig @g y+instance HasType namespace ty orig g => HasTypeProd namespace ty 'Nothing orig f g where+  getTypeProd (_ :*: y) = getType @namespace @ty @orig @g y  {- Note [diagnosticCodes: don't recur into already-seen types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1305,7 +1390,7 @@  This would cause an infinite loop. We thus keep track of a list of types we have already encountered, and when we recur into a type we have already-encountered, we simply skip taking that union (see (*)).+encountered, we simply skip taking that union (see (**)).  Note that 'constructorCodes' starts by marking the initial type itself as "seen", which precisely avoids the loop above when calling 'constructorCodes @TcRnMessage'.@@ -1340,27 +1425,42 @@     ':$$: 'Text "does not have any argument of type '" ':<>: 'ShowType ty ':<>: 'Text "'."     ':$$: 'Text ""     ':$$: 'Text "This is likely due to an incorrect type family equation:"-    ':$$: 'Text "  ConRecursInto \"" ':<>: 'Text orig ':<>: 'Text "\" = " ':<>: 'ShowType ty )-  => HasType ty orig f where+    ':$$: 'Text "  ConRecursIntoFor " ':<>: 'ShowType namespace ':<>: Text " \"" ':<>: 'Text orig ':<>: 'Text "\" = " ':<>: 'ShowType ty )+  => HasType namespace ty orig f where   getType = panic "getType: unreachable"  -- (ERR2) Improve error messages for missing 'GhcDiagnosticCode' equations.-type KnownConstructor :: Symbol -> Constraint-type family KnownConstructor con where-  KnownConstructor con =+type KnownConstructor :: Type -> Symbol -> Constraint+type family KnownConstructor namespace con where+  KnownConstructor namespace con =     KnownNatOrErr       ( TypeError-        (     'Text "Missing diagnostic code for constructor "+        (     'Text "Missing " ':<>: 'ShowType namespace ':<>: Text " diagnostic code for constructor "         ':<>: 'Text "'" ':<>: 'Text con ':<>: 'Text "'."         ':$$: 'Text ""         ':$$: 'Text "Note [Diagnostic codes] in GHC.Types.Error.Codes"         ':$$: 'Text "contains instructions for adding a new diagnostic code."         )       )-      (GhcDiagnosticCode con)+      (DiagnosticCodeFor namespace con)  type KnownNatOrErr :: Constraint -> Nat -> Constraint type KnownNatOrErr err n = (Assert err n, KnownNat n)++-- (ERR3) Improve error messages for invalid namespaces.+type KnownNameSpace :: Type -> Constraint+type family KnownNameSpace namespace where+  KnownNameSpace namespace =+    ValidNameSpaceOrErr+      ( TypeError+        (     'Text "Please provide a 'DiagnosticCodeNameSpace' instance for " ':<>: 'ShowType namespace ':<>: Text ","+        ':$$: 'Text "including an associated type family equation for 'NameSpaceTag'."+        )+      )+      (NameSpaceTag namespace)++type ValidNameSpaceOrErr :: Constraint -> Symbol -> Constraint+type ValidNameSpaceOrErr err s = (Assert err s, KnownSymbol s)  -- Detecting a stuck type family using a data family. -- See https://blog.csongor.co.uk/report-stuck-families/.
compiler/GHC/Types/ForeignCall.hs view
@@ -30,6 +30,8 @@ import Data.Char import Data.Data +import Control.DeepSeq (NFData(..))+ {- ************************************************************************ *                                                                      *@@ -156,7 +158,7 @@   | StdCallConv   | PrimCallConv   | JavaScriptCallConv-  deriving (Eq, Data, Enum)+  deriving (Show, Eq, Data, Enum)  instance Outputable CCallConv where   ppr StdCallConv = text "stdcall"@@ -344,3 +346,31 @@     get bh = do s <- get bh                 h <- get bh                 return (Header s h)++instance NFData ForeignCall where+  rnf (CCall c) = rnf c++instance NFData Safety where+  rnf PlaySafe = ()+  rnf PlayInterruptible = ()+  rnf PlayRisky = ()++instance NFData CCallSpec where+  rnf (CCallSpec t c s) = rnf t `seq` rnf c `seq` rnf s++instance NFData CCallTarget where+  rnf (StaticTarget s a b c) = rnf s `seq` rnf a `seq` rnf b `seq` rnf c+  rnf DynamicTarget = ()++instance NFData CCallConv where+  rnf CCallConv = ()+  rnf StdCallConv = ()+  rnf PrimCallConv = ()+  rnf CApiConv = ()+  rnf JavaScriptCallConv = ()++instance NFData CType where+  rnf (CType s mh fs) = rnf s `seq` rnf mh `seq` rnf fs++instance NFData Header where+  rnf (Header s h) = rnf s `seq` rnf h
compiler/GHC/Types/GREInfo.hs view
@@ -111,7 +111,7 @@ -- -- See Note [GREInfo] data GREInfo-      -- | No particular information... e.g. a function+      -- | A variable (an 'Id' or a 'TyVar')     = Vanilla       -- | An unbound GRE... could be anything     | UnboundGRE@@ -126,12 +126,6 @@      deriving Data -instance NFData GREInfo where-  rnf Vanilla = ()-  rnf UnboundGRE = ()-  rnf (IAmTyCon tc) = rnf tc-  rnf (IAmConLike info) = rnf info-  rnf (IAmRecField info) = rnf info  plusGREInfo :: GREInfo -> GREInfo -> GREInfo plusGREInfo Vanilla Vanilla = Vanilla@@ -263,7 +257,7 @@   rnf ConHasPositionalArgs = ()   rnf (ConHasRecordFields flds) = rnf flds -mkConInfo :: ConLikeInfo -> Arity -> [FieldLabel] -> ConInfo+mkConInfo :: ConLikeInfo -> VisArity -> [FieldLabel] -> ConInfo mkConInfo con_ty n flds =   ConInfo { conLikeInfo  = con_ty           , conFieldInfo = mkConFieldInfo n flds }@@ -305,6 +299,9 @@   = DataConName { conLikeName_Name :: !Name }   | PatSynName  { conLikeName_Name :: !Name }   deriving (Eq, Data)++instance NamedThing ConLikeName where+  getName = conLikeName_Name  instance Outputable ConLikeName where   ppr = ppr . conLikeName_Name
compiler/GHC/Types/Hint.hs view
@@ -5,12 +5,14 @@   , AvailableBindings(..)   , InstantiationSuggestion(..)   , LanguageExtensionHint(..)+  , ImportItemSuggestion(..)   , ImportSuggestion(..)   , HowInScope(..)   , SimilarName(..)   , StarIsType(..)   , UntickedPromotedThing(..)   , AssumedDerivingStrategy(..)+  , SigLike(..)   , pprUntickedConstructor, isBareSymbol   , suggestExtension   , suggestExtensionWithInfo@@ -23,7 +25,7 @@   ) where  import Language.Haskell.Syntax.Expr (LHsExpr)-import Language.Haskell.Syntax (LPat, LIdP, LHsSigType, LHsSigWcType)+import Language.Haskell.Syntax (LPat, LIdP, LHsSigType, LHsSigWcType, Sig)  import GHC.Prelude @@ -32,7 +34,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.Module (ModuleName, Module) import GHC.Unit.Module.Imported (ImportedModsVal)-import GHC.Hs.Extension (GhcTc, GhcRn)+import GHC.Hs.Extension (GhcTc, GhcRn, GhcPs) import GHC.Core.Class (Class) import GHC.Core.Coercion import GHC.Core.FamInstEnv (FamFlavor)@@ -382,8 +384,7 @@       Test cases: T495, T8485, T2713, T5533.    -}   | SuggestMoveToDeclarationSite-      -- TODO: remove the SDoc argument.-      SDoc -- ^ fixity declaration, role annotation, type signature, ...+      SigLike -- ^ fixity declaration, role annotation, type signature, ...       RdrName -- ^ the 'RdrName' for the declaration site    {-| Suggest a similar name that the user might have meant,@@ -505,6 +506,14 @@   {-| Suggest add parens to pattern `e -> p :: t` -}   | SuggestParenthesizePatternRHS +  {-| Suggest splitting up a SPECIALISE pragmas with multiple type ascriptions+      into several individual SPECIALISE pragmas.+  -}+  | SuggestSplittingIntoSeveralSpecialisePragmas++  {-| Suggest using the `data` keyword -}+  | SuggestDataKeyword+ -- | The deriving strategy that was assumed when not explicitly listed in the --   source. This is used solely by the missing-deriving-strategies warning. --   There's no `Via` case because we never assume that.@@ -532,24 +541,32 @@ --      replacing <MyStr> as necessary.) data InstantiationSuggestion = InstantiationSuggestion !ModuleName !Module +data ImportItemSuggestion =+    ImportItemRemoveType+  | ImportItemRemoveData+  | ImportItemRemovePattern+  | ImportItemRemoveSubordinateType (NE.NonEmpty OccName)+  | ImportItemRemoveSubordinateData (NE.NonEmpty OccName)+  | ImportItemAddType+    -- Why no 'ImportItemAddData'?  Because the suggestion to add 'data' is+    -- represented by the 'ImportDataCon' constructor of 'ImportSuggestion'.+ -- | Suggest how to fix an import. data ImportSuggestion   -- | Some module exports what we want, but we aren't explicitly importing it.   = CouldImportFrom (NE.NonEmpty (Module, ImportedModsVal))   -- | Some module exports what we want, but we are explicitly hiding it.   | CouldUnhideFrom (NE.NonEmpty (Module, ImportedModsVal))-  -- | The module exports what we want, but it isn't a type.-  | CouldRemoveTypeKeyword ModuleName-  -- | The module exports what we want, but it's a type and we have @ExplicitNamespaces@ on.-  | CouldAddTypeKeyword ModuleName+  -- | The module exports what we want, but the import item requires modification.+  | CouldChangeImportItem ModuleName ImportItemSuggestion   -- | Suggest importing a data constructor to bring it into scope   | ImportDataCon       -- | Where to suggest importing the 'DataCon' from.-      ---      -- The 'Bool' tracks whether to suggest using an import of the form-      -- @import (pattern Foo)@, depending on whether @-XPatternSynonyms@-      -- was enabled.-      { ies_suggest_import_from :: Maybe (ModuleName, Bool)+      { ies_suggest_import_from :: Maybe ModuleName+        -- | Whether to suggest the use of the 'pattern' keyword.+      , ies_suggest_pattern_keyword :: Bool+        -- | Whether to suggest the use of the 'data' keyword.+      , ies_suggest_data_keyword :: Bool         -- | The 'OccName' of the parent of the data constructor.       , ies_parent :: OccName } @@ -563,6 +580,15 @@ data SimilarName   = SimilarName Name   | SimilarRdrName RdrName (Maybe HowInScope)++-- | Some kind of signature, such as a fixity signature, standalone+-- kind signature, COMPLETE pragma, role annotation, etc.+data SigLike+  = SigLikeSig (Sig GhcPs)+  | SigLikeStandaloneKindSig+  | SigLikeFixitySig+  | SigLikeDeprecation+  | SigLikeRoleAnnotation  -- | Something is promoted to the type-level without a promotion tick. data UntickedPromotedThing
compiler/GHC/Types/Hint/Ppr.hs view
@@ -4,7 +4,7 @@ {-# OPTIONS_GHC -Wno-orphans #-}   {- instance Outputable GhcHint -}  module GHC.Types.Hint.Ppr (-  perhapsAsPat+  perhapsAsPat, pprSigLike   -- also, and more interesting: instance Outputable GhcHint   ) where @@ -31,6 +31,7 @@ import qualified Data.Map.Strict as Map  import qualified GHC.LanguageExtensions as LangExt+import GHC.Hs.Binds (hsSigDoc)  instance Outputable GhcHint where   ppr = \case@@ -187,8 +188,8 @@      SuggestAddTick UntickedExplicitList       -> text "Add a promotion tick, e.g." <+> text "'[x,y,z]" <> dot-    SuggestMoveToDeclarationSite what rdr_name-      -> text "Move the" <+> what <+> text "to the declaration site of"+    SuggestMoveToDeclarationSite sig rdr_name+      -> text "Move the" <+> pprSigLike sig <+> text "to the declaration site of"          <+> quotes (ppr rdr_name) <> dot     SuggestSimilarNames tried_rdr_name similar_names       -> case similar_names of@@ -288,6 +289,10 @@         (hsep [text "deriving", ppr strat, text "instance", ppr deriv_sig])     SuggestParenthesizePatternRHS       -> text "Parenthesize the RHS of the view pattern"+    SuggestSplittingIntoSeveralSpecialisePragmas+      -> text "Split the SPECIALISE pragma into multiple pragmas, one for each type signature"+    SuggestDataKeyword+      -> text "Use the" <+> quotes (text "data") <+> "keyword instead."  perhapsAsPat :: SDoc perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"@@ -337,43 +342,66 @@         [ quotes (ppr mod) <+> parens (text "at" <+> ppr (imv_span imv))         | (mod,imv) <- NE.toList mods         ])-pprImportSuggestion occ_name (CouldAddTypeKeyword mod)-  = vcat [ text "Add the" <+> quotes (text "type")-          <+> text "keyword to the import statement:"-         , nest 2 $ text "import"-            <+> ppr mod-            <+> parens_sp (text "type" <+> pprPrefixOcc occ_name)-         ]-  where-    parens_sp d = parens (space <> d <> space)-pprImportSuggestion occ_name (CouldRemoveTypeKeyword mod)-  = vcat [ text "Remove the" <+> quotes (text "type")-             <+> text "keyword from the import statement:"-         , nest 2 $ text "import"-             <+> ppr mod-             <+> parens_sp (pprPrefixOcc occ_name) ]+pprImportSuggestion occ_name (CouldChangeImportItem mod kw)+  = case kw of+      ImportItemRemoveType    -> remove "type"+      ImportItemRemoveData    -> remove "data"+      ImportItemRemovePattern -> remove "pattern"+      ImportItemRemoveSubordinateType nontype1 -> remove_subordinate "type" (NE.toList nontype1)+      ImportItemRemoveSubordinateData nondata1 -> remove_subordinate "data" (NE.toList nondata1)+      ImportItemAddType       -> add "type"   where     parens_sp d = parens (space <> d <> space)-pprImportSuggestion dc_occ (ImportDataCon Nothing parent_occ)+    remove kw =+      vcat [ text "Remove the" <+> quotes (text kw)+              <+> text "keyword from the import statement:"+          , nest 2 $ text "import" <+> ppr mod <+> import_list ]+      where+        import_list = parens_sp (pprPrefixOcc occ_name)+    add kw =+      vcat [ text "Add the" <+> quotes (text kw)+              <+> text "keyword to the import statement:"+          , nest 2 $ text "import" <+> ppr mod <+> import_list ]+      where+        import_list = parens_sp (text kw <+> pprPrefixOcc occ_name)+    remove_subordinate kw sub_occs =+      vcat [ text "Remove the" <+> quotes (text kw)+              <+> text "keyword" <> plural sub_occs+              <+> text "from the subordinate import item" <> plural sub_occs <> colon+          , nest 2 $ text "import" <+> ppr mod <+> import_list ]+      where+        parent_item+          | isSymOcc occ_name = text "type" <+> pprPrefixOcc occ_name+          | otherwise         = pprPrefixOcc occ_name+        import_list = parens_sp (parent_item <+> sub_import_list)+        sub_import_list = parens_sp (hsep (punctuate comma (map pprPrefixOcc sub_occs)))+pprImportSuggestion dc_occ (ImportDataCon { ies_suggest_import_from = Nothing+                                          , ies_parent = parent_occ} )   = text "Import the data constructor" <+> quotes (ppr dc_occ) <+>     text "of" <+> quotes (ppr parent_occ)-pprImportSuggestion dc_occ (ImportDataCon (Just (mod, patsyns_enabled)) parent_occ)-  = vcat $ [ text "Use"-           , nest 2 $ text "import"-               <+> ppr mod-               <+> parens_sp (pprPrefixOcc parent_occ <> parens_sp (pprPrefixOcc dc_occ))-           , text "or"-           , nest 2 $ text "import"-               <+> ppr mod-               <+> parens_sp (pprPrefixOcc parent_occ <> text "(..)")-           ] ++ if patsyns_enabled-                then [ text "or"-                     , nest 2 $ text "import"-                         <+> ppr mod-                         <+> parens_sp (text "pattern" <+> pprPrefixOcc dc_occ)-                     ]-                else []+pprImportSuggestion dc_occ (ImportDataCon { ies_suggest_import_from = Just mod+                                          , ies_suggest_pattern_keyword = suggest_pattern+                                          , ies_suggest_data_keyword = suggest_data+                                          , ies_parent = parent_occ })+  = vcat $ basic_suggestion+            ++ (if suggest_pattern then pattern_suggestion else [])+            ++ (if suggest_data    then data_suggestion    else [])   where+    basic_suggestion =+      [ text "Use"+      , nest 2 $ import_stmt (pprPrefixOcc parent_occ <> parens_sp (pprPrefixOcc dc_occ))+      , text "or"+      , nest 2 $ import_stmt (pprPrefixOcc parent_occ <> text "(..)")+      ]+    pattern_suggestion =+      [ text "or"+      , nest 2 $ import_stmt (text "pattern" <+> pprPrefixOcc dc_occ)+      ]+    data_suggestion =+      [ text "or"+      , nest 2 $ import_stmt (text "data" <+> pprPrefixOcc dc_occ)+      ]+    import_stmt sub = text "import" <+> ppr mod <+> parens_sp sub     parens_sp d = parens (space <> d <> space)  -- | Pretty-print a 'SimilarName'.@@ -403,10 +431,21 @@     xs -> parens $ "implied by" <+> unquotedListWith "and" xs   where implied = map (quotes . ppr)                 . filter (\ext -> extensionDeprecation ext == ExtensionNotDeprecated)-                . map (\(impl, _, _) -> impl)-                . filter (\(_, t, orig) -> orig == extension && t == turnOn)-                $ impliedXFlags+                $ [impl | (impl, On orig) <- impliedXFlags, orig == extension]  pprPrefixUnqual :: Name -> SDoc pprPrefixUnqual name =   pprPrefixOcc (getOccName name)++pprSigLike :: SigLike -> SDoc+pprSigLike = \case+  SigLikeSig sig ->+    hsSigDoc sig+  SigLikeStandaloneKindSig ->+    text "standalone kind signature"+  SigLikeDeprecation ->+    text "deprecation"+  SigLikeFixitySig ->+    text "fixity signature"+  SigLikeRoleAnnotation ->+    text "role annotation"
compiler/GHC/Types/HpcInfo.hs view
@@ -1,9 +1,7 @@ -- | Haskell Program Coverage (HPC) support module GHC.Types.HpcInfo    ( HpcInfo (..)-   , AnyHpcUsage    , emptyHpcInfo-   , isHpcUsed    ) where @@ -16,19 +14,8 @@      , hpcInfoHash      :: Int      }   | NoHpcInfo-     { hpcUsed          :: AnyHpcUsage  -- ^ Is hpc used anywhere on the module \*tree\*?-     } --- | This is used to signal if one of my imports used HPC instrumentation--- even if there is no module-local HPC usage-type AnyHpcUsage = Bool -emptyHpcInfo :: AnyHpcUsage -> HpcInfo+emptyHpcInfo :: HpcInfo emptyHpcInfo = NoHpcInfo---- | Find out if HPC is used by this module or any of the modules--- it depends upon-isHpcUsed :: HpcInfo -> AnyHpcUsage-isHpcUsed (HpcInfo {})                   = True-isHpcUsed (NoHpcInfo { hpcUsed = used }) = used 
compiler/GHC/Types/Id.hs view
@@ -71,7 +71,7 @@         isPrimOpId, isPrimOpId_maybe,         isFCallId, isFCallId_maybe,         isDataConWorkId, isDataConWorkId_maybe,-        isDataConWrapId, isDataConWrapId_maybe,+        isDataConWrapId, isDataConWrapId_maybe, dataConWrapUnfolding_maybe,         isDataConId, isDataConId_maybe,         idDataCon,         isConLikeId, isWorkerLikeId, isDeadEndId, idIsFrom,@@ -129,10 +129,6 @@  import GHC.Prelude -import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding-                , isCompulsoryUnfolding, Unfolding( NoUnfolding )-                , IdUnfoldingFun, isEvaldUnfolding, hasSomeUnfolding, noUnfolding )- import GHC.Types.Id.Info import GHC.Types.Basic @@ -140,11 +136,14 @@ import GHC.Types.Var( Id, CoVar, JoinId,             InId,  InVar,             OutId, OutVar,-            idInfo, idDetails, setIdDetails, globaliseId,+            idInfo, idDetails, setIdDetails, globaliseId, idMult,             isId, isLocalId, isGlobalId, isExportedId,             setIdMult, updateIdTypeAndMult, updateIdTypeButNotMult, updateIdTypeAndMultM) import qualified GHC.Types.Var as Var +import GHC.Core ( CoreExpr, CoreRule, Unfolding(..), IdUnfoldingFun+                , isStableUnfolding, isCompulsoryUnfolding, isEvaldUnfolding+                , hasSomeUnfolding, noUnfolding, evaldUnfolding ) import GHC.Core.Type import GHC.Core.Predicate( isCoVarType ) import GHC.Core.DataCon@@ -158,13 +157,13 @@ import GHC.Types.ForeignCall import GHC.Types.SrcLoc import GHC.Types.Unique+import GHC.Types.Unique.Supply -import GHC.Stg.InferTags.TagSig+import GHC.Stg.EnforceEpt.TagSig  import GHC.Unit.Module import {-# SOURCE #-} GHC.Builtin.PrimOps (PrimOp) import GHC.Builtin.Uniques (mkBuiltinUnique)-import GHC.Types.Unique.Supply  import GHC.Data.Maybe import GHC.Data.FastString@@ -210,9 +209,6 @@ idType   :: Id -> Kind idType    = Var.varType -idMult :: Id -> Mult-idMult = Var.varMult- idScaledType :: Id -> Scaled Type idScaledType id = Scaled (idMult id) (idType id) @@ -250,7 +246,7 @@   | assert (isId id) $ isLocalId id && isInternalName name   = id   | otherwise-  = Var.mkLocalVar (idDetails id) (localiseName name) (Var.varMult id) (idType id) (idInfo id)+  = Var.mkLocalVar (idDetails id) (localiseName name) (Var.idMult id) (idType id) (idInfo id)   where     name = idName id @@ -544,6 +540,14 @@                         DataConWrapId con -> Just con                         _                 -> Nothing +dataConWrapUnfolding_maybe :: Id -> Maybe CoreExpr+dataConWrapUnfolding_maybe id+  | DataConWrapId {} <- idDetails id+  , CoreUnfolding { uf_tmpl = unf } <- realIdUnfolding id+  = Just unf+  | otherwise+  = Nothing+ isDataConId_maybe :: Id -> Maybe DataCon isDataConId_maybe id = case Var.idDetails id of                          DataConWorkId con -> Just con@@ -605,7 +609,11 @@ --                        PrimOpId _ lev_poly -> lev_poly    -- TEMPORARILY commented out                          FCallId _        -> True-                        DataConWorkId dc -> isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc+                        DataConWorkId dc -> isUnboxedTupleDataCon dc+                                            || isUnboxedSumDataCon dc+                                            || isUnaryClassDataCon dc+                                               -- Unary class dictionary constructors are eliminated+                                               -- See Note [Unary class magic] in GHC.Core.TyCon                         _                -> isCompulsoryUnfolding (realIdUnfolding id)   -- Note: this function must be very careful not to force   -- any of the fields that aren't the 'uf_src' field of
compiler/GHC/Types/Id/Info.hs view
@@ -21,8 +21,10 @@         -- * The IdDetails type         IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails,         JoinArity, isJoinIdDetails_maybe,+         RecSelParent(..), recSelParentName, recSelFirstConName,         recSelParentCons, idDetailsConcreteTvs,+        RecSelInfo(..), conLikesRecSelInfo,          -- * The IdInfo type         IdInfo,         -- Abstract@@ -111,11 +113,12 @@  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Stg.InferTags.TagSig+import GHC.Stg.EnforceEpt.TagSig import GHC.StgToCmm.Types (LambdaFormInfo)  import Data.Data ( Data ) import Data.Word+import Data.List as List( partition )  -- infixl so you can say (id `set` a `set` b) infixl  1 `setRuleInfo`,@@ -151,12 +154,9 @@     , sel_naughty    :: Bool    -- True <=> a "naughty" selector which can't actually exist, for example @x@ in:                                 --    data T = forall a. MkT { x :: a }                                 -- See Note [Naughty record selectors] in GHC.Tc.TyCl-    , sel_cons       :: ([ConLike], [ConLike])-                                -- If record selector is not defined for all constructors-                                -- of a parent type, this is the pair of lists of constructors that-                                -- it is and is not defined for. Otherwise, it's Nothing.-                                -- Cached here based on the RecSelParent.-    }                           -- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc+    , sel_cons       :: RecSelInfo+                        -- Partiality info, cached here based on the RecSelParent.+    }    | DataConWorkId DataCon       -- ^ The 'Id' is for a data constructor /worker/   | DataConWrapId DataCon       -- ^ The 'Id' is for a data constructor /wrapper/@@ -220,10 +220,15 @@         -- Worker like functions are create by W/W and SpecConstr and we can expect that they         -- aren't used unapplied.         -- See Note [CBV Function Ids]-        -- See Note [Tag Inference]+        -- See Note [EPT enforcement]         -- The [CbvMark] is always empty (and ignored) until after Tidy for ids from the current         -- module. +data RecSelInfo+  = RSI { rsi_def   :: [ConLike]   -- Record selector defined for these+        , rsi_undef :: [ConLike]   -- Record selector not defined for these+        }+ idDetailsConcreteTvs :: IdDetails -> ConcreteTyVars idDetailsConcreteTvs = \ case     PrimOpId _ conc_tvs -> conc_tvs@@ -232,16 +237,26 @@     DataConWrapId dc    -> dataConConcreteTyVars dc     _                   -> noConcreteTyVars +-- | The ConLikes that have *all* the given fields+conLikesRecSelInfo :: [ConLike] -> [FieldLabelString] -> RecSelInfo+conLikesRecSelInfo con_likes lbls+  = RSI { rsi_def = defs, rsi_undef = undefs }+  where+    !(defs,undefs) = List.partition has_flds con_likes +    has_flds dc = all (has_fld dc) lbls+    has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc)++ {- Note [CBV Function Ids]-~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~ A WorkerLikeId essentially allows us to constrain the calling convention for the given Id. Each such Id carries with it a list of CbvMarks with each element representing a value argument. Arguments who have a matching `MarkedCbv` entry in the list need to be passed evaluated+*properly tagged*.  CallByValueFunIds give us additional expressiveness which we use to improve-runtime. This is all part of the TagInference work. See also Note [Tag Inference].+runtime. This is all part of the EPT enforcement work. See also Note [EPT enforcement].  They allows us to express the fact that an argument is not only evaluated to WHNF once we entered it's RHS but also that an lifted argument is already *properly tagged* once we jump@@ -261,7 +276,7 @@   * Any `WorkerLikeId`   * Some `JoinId` bindings. -This works analogous to the Strict Field Invariant. See also Note [Strict Field Invariant].+This works analogous to the EPT Invariant. See also Note [EPT enforcement].  To make this work what we do is: * During W/W and SpecConstr any worker/specialized binding we introduce
compiler/GHC/Types/Id/Make.hs view
@@ -20,7 +20,7 @@          mkFCallId, -        unwrapNewTypeBody, wrapFamInstBody,+        wrapNewTypeBody, unwrapNewTypeBody, wrapFamInstBody,         DataConBoxer(..), vanillaDataConBoxer,         mkDataConRep, mkDataConWorkId,         DataConBangOpts (..), BangOpts (..),@@ -54,11 +54,12 @@ import GHC.Core.Multiplicity import GHC.Core.TyCo.Rep import GHC.Core.FamInstEnv+import GHC.Core.Predicate( isUnaryClass ) import GHC.Core.Coercion import GHC.Core.Reduction import GHC.Core.Make import GHC.Core.FVs     ( mkRuleInfo )-import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, coreAltsType )+import GHC.Core.Utils   ( exprType, mkCast, coreAltsType ) import GHC.Core.Unfold.Make import GHC.Core.SimpleOpt import GHC.Core.TyCon@@ -475,12 +476,12 @@ mkDictSelId :: Name          -- Name of one of the *value* selectors                              -- (dictionary superclass or method)             -> Class -> Id+-- Important: see Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance mkDictSelId name clas   = mkGlobalId (ClassOpId clas terminating) name sel_ty info   where     tycon          = classTyCon clas     sel_names      = map idName (classAllSelIds clas)-    new_tycon      = isNewTyCon tycon     [data_con]     = tyConDataCons tycon     tyvars         = dataConUserTyVarBinders data_con     n_ty_args      = length tyvars@@ -489,7 +490,7 @@      pred_ty = mkClassPred clas (mkTyVarTys (binderVars tyvars))     res_ty  = scaledThing (getNth arg_tys val_index)-    sel_ty  = mkInvisForAllTys tyvars $+    sel_ty  = mkForAllTys tyvars $               mkFunctionType ManyTy pred_ty res_ty              -- See Note [Type classes and linear types] @@ -502,23 +503,9 @@                 `setDmdSigInfo` strict_sig                 `setCprSigInfo` topCprSig -    info | new_tycon-         = base_info `setInlinePragInfo` alwaysInlinePragma-                     `setUnfoldingInfo`  mkInlineUnfoldingWithArity defaultSimpleOpts-                                           StableSystemSrc 1-                                           (mkDictSelRhs clas val_index)-                   -- See Note [Single-method classes] in GHC.Tc.TyCl.Instance-                   -- for why alwaysInlinePragma--         | otherwise-         = base_info `setRuleInfo` mkRuleInfo [rule]-                     `setInlinePragInfo` neverInlinePragma-                     `setUnfoldingInfo`  mkInlineUnfoldingWithArity defaultSimpleOpts-                                           StableSystemSrc 1-                                           (mkDictSelRhs clas val_index)-                   -- Add a magic BuiltinRule, but no unfolding-                   -- so that the rule is always available to fire.-                   -- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance+    info = base_info `setRuleInfo` mkRuleInfo [rule]+           -- No unfolding for a dictionary selector; the RULE does the work,+           -- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance      -- This is the built-in rule that goes     --      op (dfT d1 d2) --->  opT d1 d2@@ -531,11 +518,10 @@         -- The strictness signature is of the form U(AAAVAAAA) -> T         -- where the V depends on which item we are selecting         -- It's worth giving one, so that absence info etc is generated-        -- even if the selector isn't inlined+        -- even if the selector isn't inlined, which of course it isn't!      strict_sig = mkClosedDmdSig [arg_dmd] topDiv-    arg_dmd | new_tycon = evalDmd-            | otherwise = C_1N :* mkProd Unboxed dict_field_dmds+    arg_dmd = C_1N :* mkProd Unboxed dict_field_dmds             where               -- The evalDmd below is just a placeholder and will be replaced in               -- GHC.Types.Demand.dmdTransformDictSel@@ -545,24 +531,29 @@ mkDictSelRhs :: Class              -> Int         -- 0-indexed selector among (superclasses ++ methods)              -> CoreExpr+-- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance mkDictSelRhs clas val_index   = mkLams tyvars (Lam dict_id rhs_body)   where-    tycon          = classTyCon clas-    new_tycon      = isNewTyCon tycon-    [data_con]     = tyConDataCons tycon-    tyvars         = dataConUnivTyVars data_con-    arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses+    tycon      = classTyCon clas+    [data_con] = tyConDataCons tycon+    tyvars     = dataConUnivTyVars data_con+    arg_tys    = dataConRepArgTys data_con  -- Includes the dictionary superclasses -    the_arg_id     = getNth arg_ids val_index-    pred           = mkClassPred clas (mkTyVarTys tyvars)-    dict_id        = mkTemplateLocal 1 pred-    arg_ids        = mkTemplateLocalsNum 2 (map scaledThing arg_tys)+    the_arg_id = getNth arg_ids val_index+    pred       = mkClassPred clas (mkTyVarTys tyvars)+    dict_id    = mkTemplateLocal 1 pred+    arg_ids    = mkTemplateLocalsNum 2 (map scaledThing arg_tys) -    rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars)-                                                   (Var dict_id)-             | otherwise = mkSingleAltCase (Var dict_id) dict_id (DataAlt data_con)-                                           arg_ids (varToCoreExpr the_arg_id)+    rhs_body | isUnaryClass clas   -- Just having one sel_id isn't enough!+                                   -- E.g.  class (a ~# b) => a ~ b where {}+             , let sel_ids = classAllSelIds clas+             = assertPpr (val_index == 0)      (ppr clas) $+               assertPpr (length sel_ids == 1) (ppr clas) $+               Var (head sel_ids) `mkTyApps` mkTyVarTys tyvars `App` Var dict_id+             | otherwise+             = mkSingleAltCase (Var dict_id) dict_id (DataAlt data_con)+                               arg_ids (varToCoreExpr the_arg_id)                                 -- varToCoreExpr needed for equality superclass selectors                                 --   sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } @@ -572,9 +563,11 @@ -- from it --       sel_i t1..tk (D t1..tk op1 ... opm) = opi ---dictSelRule val_index n_ty_args _ id_unf _ args+-- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance+dictSelRule val_index n_ty_args _ in_scope_env _ args   | (dict_arg : _) <- drop n_ty_args args-  , Just (_, floats, _, _, con_args) <- exprIsConApp_maybe id_unf dict_arg+  , Just (_, floats, _, _, con_args)+             <- exprIsConApp_maybe in_scope_env dict_arg   = Just (wrapFloats floats $ getNth con_args val_index)   | otherwise   = Nothing@@ -589,16 +582,19 @@  mkDataConWorkId :: Name -> DataCon -> Id mkDataConWorkId wkr_name data_con-  | isNewTyCon tycon-  = mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_work_info-      -- See Note [Newtype workers]+  | isNewTyCon tycon       -- See Note [Newtype workers]+  = mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_info    | otherwise   = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info    where-    tycon  = dataConTyCon data_con  -- The representation TyCon-    wkr_ty = dataConRepType data_con+    tycon     = dataConTyCon data_con  -- The representation TyCon+    wkr_ty    = dataConRepType data_con+    univ_tvs  = dataConUnivTyVars data_con+    ex_tcvs   = dataConExTyCoVars data_con+    arg_tys   = dataConRepArgTys  data_con  -- Should be same as dataConOrigArgTys+    str_marks = dataConRepStrictness data_con      ----------- Workers for data types --------------     alg_wkr_info = noCafIdInfo@@ -606,12 +602,19 @@                    `setInlinePragInfo`     wkr_inline_prag                    `setUnfoldingInfo`      evaldUnfolding  -- Record that it's evaluated,                                                            -- even if arity = 0+                   `setDmdSigInfo`         wkr_sig+                      -- Workers eval their strict fields+                      -- See Note [Strict fields in Core]                    `setLFInfo`             wkr_lf_info-          -- No strictness: see Note [Data-con worker strictness] in GHC.Core.DataCon      wkr_inline_prag = defaultInlinePragma { inl_rule = ConLike }     wkr_arity = dataConRepArity data_con +    wkr_sig = mkClosedDmdSig wkr_dmds topDiv+    wkr_dmds = map mk_dmd str_marks+    mk_dmd MarkedStrict    = evalDmd+    mk_dmd NotMarkedStrict = topDmd+     -- See Note [LFInfo of DataCon workers and wrappers]     wkr_lf_info       | wkr_arity == 0 = LFCon data_con@@ -619,21 +622,17 @@                                             -- LFInfo stores post-unarisation arity      ----------- Workers for newtypes ---------------    univ_tvs = dataConUnivTyVars data_con-    ex_tcvs  = dataConExTyCoVars data_con-    arg_tys  = dataConRepArgTys  data_con  -- Should be same as dataConOrigArgTys-    nt_work_info = noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo-                  `setArityInfo` 1      -- Arity 1-                  `setInlinePragInfo`     dataConWrapperInlinePragma-                  `setUnfoldingInfo`      newtype_unf-                               -- See W1 in Note [LFInfo of DataCon workers and wrappers]-                  `setLFInfo` (panic "mkDataConWorkId: we shouldn't look at LFInfo for newtype worker ids")-    id_arg1      = mkScaledTemplateLocal 1 (head arg_tys)-    res_ty_args  = mkTyCoVarTys univ_tvs-    newtype_unf  = assertPpr (null ex_tcvs && isSingleton arg_tys)-                             (ppr data_con)+    nt_info  = noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo+               `setArityInfo` 1  -- Arity 1+               `setInlinePragInfo` dataConWrapperInlinePragma+               `setUnfoldingInfo`  mkCompulsoryUnfolding newtype_rhs+               `setLFInfo` (panic "mkDataConWorkId: no LFInfo for newtype worker ids")+                           -- See W1 in Note [LFInfo of DataCon workers and wrappers]++    id_arg1     = mkScaledTemplateLocal 1 (head arg_tys)+    res_ty_args = mkTyCoVarTys univ_tvs+    newtype_rhs =  assertPpr (null ex_tcvs && isSingleton arg_tys) (ppr data_con) $                               -- Note [Newtype datacons]-                   mkCompulsoryUnfolding $                    mkLams univ_tvs $ Lam id_arg1 $                    wrapNewTypeBody tycon res_ty_args (Var id_arg1) @@ -656,18 +655,18 @@ (Remember: `LFCon` means "a saturated constructor application")  (1) Data constructor workers and wrappers with arity > 0 are unambiguously-functions and should be given `LFReEntrant`, regardless of the runtime-relevance of the arguments.-  - For example, `Just :: a -> Maybe a` is given `LFReEntrant`,-             and `HNil :: (a ~# '[]) -> HList a` is given `LFReEntrant` too.+    functions and should be given `LFReEntrant`, regardless of the runtime+    relevance of the arguments.  For example:+       `Just :: a -> Maybe a`          is given `LFReEntrant`,+       `HNil :: (a ~# '[]) -> HList a` is given `LFReEntrant` too.  (2) A datacon /worker/ with zero arity is trivially fully saturated -- it takes-no arguments whatsoever (not even zero-width args), so it is given `LFCon`.+    no arguments whatsoever (not even zero-width args), so it is given `LFCon`.  (3) Perhaps surprisingly, a datacon /wrapper/ can be an `LFCon`. See Wrinkle (W1) below.-A datacon /wrapper/ with zero arity must be a fully saturated application of-the worker to zero-width arguments only (which are dropped after unarisation),-and therefore is also given `LFCon`.+    A datacon /wrapper/ with zero arity must be a fully saturated application of+    the worker to zero-width arguments only (which are dropped after unarisation),+    and therefore is also given `LFCon`.  For example, consider the following data constructors: @@ -789,10 +788,10 @@              -> FamInstEnvs              -> Name              -> DataCon-             -> UniqSM DataConRep+             -> UniqSM (DataConRep, [HsImplBang], [StrictnessMark]) mkDataConRep dc_bang_opts fam_envs wrap_name data_con   | not wrapper_reqd-  = return NoDataConRep+  = return (NoDataConRep, arg_ibangs, rep_strs)    | otherwise   = do { wrap_args <- mapM (newLocal (fsLit "conrep")) wrap_arg_tys@@ -849,24 +848,21 @@              wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs                         -- See Note [Compulsory newtype unfolding]                       | otherwise        = mkDataConUnfolding wrap_rhs-             wrap_rhs = mkLams wrap_tvs $-                        mkLams wrap_args $+             wrap_rhs = mkCoreTyLams wrap_tvbs $+                        mkCoreLams wrap_args $                         wrapFamInstBody tycon res_ty_args $                         wrap_body         ; return (DCR { dcr_wrap_id = wrap_id                      , dcr_boxer   = mk_boxer boxers-                     , dcr_arg_tys = rep_tys-                     , dcr_stricts = rep_strs-                       -- For newtypes, dcr_bangs is always [HsLazy].-                       -- See Note [HsImplBangs for newtypes].-                     , dcr_bangs   = arg_ibangs }) }+                     , dcr_arg_tys = rep_tys }+                , arg_ibangs, rep_strs) }    where     (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty)                  = dataConFullSig data_con     stupid_theta = dataConStupidTheta data_con-    wrap_tvs     = dataConUserTyVars data_con+    wrap_tvbs    = dataConUserTyVarBinders data_con     res_ty_args  = dataConResRepTyArgs data_con      tycon        = dataConTyCon data_con       -- The representation TyCon (not family)@@ -913,17 +909,20 @@         -- See wrinkle (W0) in Note [Type data declarations] in GHC.Rename.Module.       = False +      | isUnaryClassTyCon tycon   -- See (UCM8) in Note [Unary class magic]+      = False                     -- in GHC.Core.TyCon+       | otherwise       = (not new_tycon                      -- (Most) newtypes have only a worker, with the exception                      -- of some newtypes written with GADT syntax.                      -- See dataConUserTyVarsNeedWrapper below.-         && (any isBanged (ev_ibangs ++ arg_ibangs)))-                     -- Some forcing/unboxing (includes eq_spec)+         && (any isUnpacked (ev_ibangs ++ arg_ibangs)))+                     -- Some unboxing (includes eq_spec)        || isFamInstTyCon tycon -- Cast result -      || dataConUserTyVarsNeedWrapper data_con+      || dataConUserTyVarBindersNeedWrapper data_con                      -- If the data type was written with GADT syntax and                      -- orders the type variables differently from what the                      -- worker expects, it needs a data con wrapper to reorder@@ -1139,18 +1138,18 @@    -> HsImplBang  dataConSrcToImplBang bang_opts fam_envs arg_ty-                     (HsSrcBang ann (HsBang unpk NoSrcStrict))+                     (HsSrcBang ann unpk NoSrcStrict)   | bang_opt_strict_data bang_opts -- StrictData => strict field   = dataConSrcToImplBang bang_opts fam_envs arg_ty-                  (mkHsSrcBang ann unpk SrcStrict)+                  (HsSrcBang ann unpk SrcStrict)   | otherwise -- no StrictData => lazy field   = HsLazy -dataConSrcToImplBang _ _ _ (HsSrcBang _ (HsBang _ SrcLazy))+dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy)   = HsLazy  dataConSrcToImplBang bang_opts fam_envs arg_ty-                     (HsSrcBang _ (HsBang unpk_prag SrcStrict))+                     (HsSrcBang _ unpk_prag SrcStrict)   | isUnliftedType (scaledThing arg_ty)     -- NB: non-newtype data constructors can't have representation-polymorphic fields     -- so this is OK.@@ -1185,7 +1184,7 @@   = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))  dataConArgRep arg_ty (HsStrict _)-  = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))+  = ([(arg_ty, MarkedStrict)], (unitUnboxer, unitBoxer)) -- Seqs are inserted in STG  dataConArgRep arg_ty (HsUnpack Nothing)   = dataConArgUnpack arg_ty@@ -1215,9 +1214,6 @@                ; return (rep_ids, rep_expr `Cast` mkSymCo sco) }  -------------------------seqUnboxer :: Unboxer-seqUnboxer v = return ([v], mkDefaultCase (Var v) v)- unitUnboxer :: Unboxer unitUnboxer v = return ([v], \e -> e) @@ -1468,7 +1464,7 @@              -- We'd get a black hole if we used dataConImplBangs           ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool-         ok_arg dcs (Scaled _ ty, HsSrcBang _ (HsBang unpack_prag str_prag))+         ok_arg dcs (Scaled _ ty, HsSrcBang _ unpack_prag str_prag)            | strict_field str_prag            , Just data_cons <- unpackable_type_datacons (topNormaliseType fam_envs ty)            , should_unpack_conservative unpack_prag data_cons  -- Wrinkle (W3)@@ -1849,12 +1845,12 @@ -- See Note [Dict funs and default methods]  mkDictFunId dfun_name tvs theta clas tys-  = mkExportedLocalId (DFunId is_nt)+  = mkExportedLocalId (DFunId is_unary)                       dfun_name                       dfun_ty   where-    is_nt = isNewTyCon (classTyCon clas)-    dfun_ty = TcType.tcMkDFunSigmaTy tvs theta (mkClassPred clas tys)+    is_unary = isUnaryClass clas+    dfun_ty  = TcType.tcMkDFunSigmaTy tvs theta (mkClassPred clas tys)  {- ************************************************************************@@ -1948,7 +1944,7 @@           Case (Var x) x openBetaTy [Alt DEFAULT [] (Var y)]      concs = mkRepPolyIdConcreteTyVars-        [ ((openBetaTy, Argument 2 Top), runtimeRep2TyVar)]+        [ ((openBetaTy, mkArgPos 2 Top), runtimeRep2TyVar)]      arity = 2 @@ -2007,7 +2003,7 @@     arity = 2      concs = mkRepPolyIdConcreteTyVars-        [((openAlphaTy, Argument 2 Top), runtimeRep1TyVar)]+        [((openAlphaTy, mkArgPos 2 Top), runtimeRep1TyVar)]  ---------------------------------------------------------------------- {- Note [Wired-in Ids for rebindable syntax]@@ -2052,7 +2048,7 @@     arity = 2      concs = mkRepPolyIdConcreteTyVars-            [((openAlphaTy, Argument 2 Top), runtimeRep1TyVar)]+            [((openAlphaTy, mkArgPos 2 Top), runtimeRep1TyVar)]  -- See Note [Left and right sections] in GHC.Rename.Expr -- See Note [Wired-in Ids for rebindable syntax]@@ -2086,8 +2082,8 @@      concs =       mkRepPolyIdConcreteTyVars-        [ ((openAlphaTy, Argument 3 Top), runtimeRep1TyVar)-        , ((openBetaTy , Argument 2 Top), runtimeRep2TyVar)]+        [ ((openAlphaTy, mkArgPos 3 Top), runtimeRep1TyVar)+        , ((openBetaTy , mkArgPos 2 Top), runtimeRep2TyVar)]  -------------------------------------------------------------------------------- @@ -2117,7 +2113,7 @@           [Alt (DataAlt coercibleDataCon) [eq] (Cast (Var x) (mkCoVarCo eq))]      concs = mkRepPolyIdConcreteTyVars-            [((mkTyVarTy av, Argument 1 Top), rv)]+            [((mkTyVarTy av, mkArgPos 1 Top), rv)]  {- Note [seqId magic]@@ -2247,7 +2243,7 @@     Solution: in the desugarer, rewrite       noinline (f x y)  ==>  noinline f x y-   This is done in GHC.HsToCore.Utils.mkCoreAppDs.+   This is done in the `noinlineId` case of `GHC.HsToCore.Expr.ds_app_var`    This is only needed for noinlineId, not noInlineConstraintId (wrinkle    (W1) below), because the latter never shows up in user code. 
compiler/GHC/Types/Literal.hs view
@@ -9,8 +9,6 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- -- | Core literals module GHC.Types.Literal         (@@ -86,6 +84,7 @@ import Data.Data ( Data ) import GHC.Exts( isTrue#, dataToTag#, (<#) ) import Numeric ( fromRat )+import Control.DeepSeq  {- ************************************************************************@@ -206,6 +205,20 @@       h <- getByte bh       return (toEnum (fromIntegral h)) +instance NFData LitNumType where+    rnf (LitNumBigNat) = ()+    rnf (LitNumInt) = ()+    rnf (LitNumInt8) = ()+    rnf (LitNumInt16) = ()+    rnf (LitNumInt32) = ()+    rnf (LitNumInt64) = ()+    rnf (LitNumWord) = ()+    rnf (LitNumWord8) = ()+    rnf (LitNumWord16) = ()+    rnf (LitNumWord32) = ()+    rnf (LitNumWord64) = ()++ {- Note [BigNum literals] ~~~~~~~~~~~~~~~~~~~~~~@@ -290,6 +303,16 @@                     return (LitNumber nt i)               _ -> pprPanic "Binary:Literal" (int (fromIntegral h)) +instance NFData Literal where+    rnf (LitChar c) = rnf c+    rnf (LitNumber nt i) = rnf nt `seq` rnf i+    rnf (LitString s) = rnf s+    rnf LitNullAddr = ()+    rnf (LitFloat r) = rnf r+    rnf (LitDouble r) = rnf r+    rnf (LitLabel l1 k2) = rnf l1 `seq` rnf k2+    rnf (LitRubbish {}) = () -- LitRubbish is not contained within interface files.+                             -- See Note [Rubbish literals].  instance Outputable Literal where     ppr = pprLiteral id@@ -328,7 +351,12 @@ -- | Make a literal number using wrapping semantics if the value is out of -- bound. mkLitNumberWrap :: Platform -> LitNumType -> Integer -> Literal-mkLitNumberWrap platform nt i = case nt of+mkLitNumberWrap platform nt i = LitNumber nt $ mkLitNumberWrap' platform nt i++-- | Make a literal number using wrapping semantics if the value is out of+-- bound.+mkLitNumberWrap' :: Platform -> LitNumType -> Integer -> Integer+mkLitNumberWrap' platform nt i = case nt of   LitNumInt -> case platformWordSize platform of     PW4 -> wrap @Int32     PW8 -> wrap @Int64@@ -345,10 +373,10 @@   LitNumWord64  -> wrap @Word64   LitNumBigNat     | i < 0     -> panic "mkLitNumberWrap: trying to create a negative BigNat"-    | otherwise -> LitNumber nt i+    | otherwise -> i   where-    wrap :: forall a. (Integral a, Num a) => Literal-    wrap = LitNumber nt (toInteger (fromIntegral i :: a))+    wrap :: forall a. (Integral a, Num a) => Integer+    wrap = toInteger (fromIntegral i :: a)  -- | Wrap a literal number according to its type using wrapping semantics. litNumWrap :: Platform -> Literal -> Literal@@ -364,9 +392,7 @@ -- converting it back to its original type. litNumNarrow :: LitNumType -> Platform -> Literal -> Literal litNumNarrow pt platform (LitNumber nt i)-   = case mkLitNumberWrap platform pt i of-      LitNumber _ j -> mkLitNumberWrap platform nt j-      l             -> pprPanic "litNumNarrow: got invalid literal" (ppr l)+   = mkLitNumberWrap platform nt . mkLitNumberWrap' platform pt $ i litNumNarrow _ _ l = pprPanic "litNumNarrow: invalid literal" (ppr l)  @@ -429,9 +455,9 @@ --   the argument is wrapped and the overflow flag will be set. --   See Note [Word/Int underflow/overflow] mkLitIntWrapC :: Platform -> Integer -> (Literal, Bool)-mkLitIntWrapC platform i = (n, i /= i')+mkLitIntWrapC platform i = (LitNumber LitNumInt i', i /= i')   where-    n@(LitNumber _ i') = mkLitIntWrap platform i+    i' = mkLitNumberWrap' platform LitNumInt i  -- | Creates a 'Literal' of type @Word#@ mkLitWord :: Platform -> Integer -> Literal@@ -453,9 +479,9 @@ --   the argument is wrapped and the carry flag will be set. --   See Note [Word/Int underflow/overflow] mkLitWordWrapC :: Platform -> Integer -> (Literal, Bool)-mkLitWordWrapC platform i = (n, i /= i')+mkLitWordWrapC platform i = (LitNumber LitNumWord i', i /= i')   where-    n@(LitNumber _ i') = mkLitWordWrap platform i+    i' = mkLitNumberWrap' platform LitNumWord i  -- | Creates a 'Literal' of type @Int8#@ mkLitInt8 :: Integer -> Literal
compiler/GHC/Types/Meta.hs view
@@ -16,6 +16,8 @@ import GHC.Serialized   ( Serialized )  import GHC.Hs+import GHC.Utils.Outputable+import GHC.Utils.Panic   -- | The supported metaprogramming result types@@ -28,11 +30,42 @@  -- | data constructors not exported to ensure correct result type data MetaResult-  = MetaResE  { unMetaResE  :: LHsExpr GhcPs   }-  | MetaResP  { unMetaResP  :: LPat GhcPs      }-  | MetaResT  { unMetaResT  :: LHsType GhcPs   }-  | MetaResD  { unMetaResD  :: [LHsDecl GhcPs] }-  | MetaResAW { unMetaResAW :: Serialized      }+  = MetaResE  (LHsExpr GhcPs)+  | MetaResP  (LPat GhcPs)+  | MetaResT  (LHsType GhcPs)+  | MetaResD  [LHsDecl GhcPs]+  | MetaResAW Serialized++instance Outputable MetaResult where+    ppr (MetaResE e)   = text "MetaResE"  <> braces (ppr e)+    ppr (MetaResP p)   = text "MetaResP"  <> braces (ppr p)+    ppr (MetaResT t)   = text "MetaResT"  <> braces (ppr t)+    ppr (MetaResD d)   = text "MetaResD"  <> braces (ppr d)+    ppr (MetaResAW aw) = text "MetaResAW" <> braces (ppr aw)++-- These unMetaResE ext panics will triger if the MetaHook doesn't+-- take an expression to an expression, pattern to pattern etc.+--+-- ToDo: surely this could be expressed in the type system?+unMetaResE :: MetaResult -> LHsExpr GhcPs+unMetaResE (MetaResE e) = e+unMetaResE mr           = pprPanic "unMetaResE" (ppr mr)++unMetaResP :: MetaResult -> LPat GhcPs+unMetaResP (MetaResP p) = p+unMetaResP mr           = pprPanic "unMetaResP" (ppr mr)++unMetaResT :: MetaResult -> LHsType GhcPs+unMetaResT (MetaResT t) = t+unMetaResT mr           = pprPanic "unMetaResT" (ppr mr)++unMetaResD :: MetaResult -> [LHsDecl GhcPs]+unMetaResD (MetaResD d) = d+unMetaResD mr           = pprPanic "unMetaResD" (ppr mr)++unMetaResAW :: MetaResult -> Serialized+unMetaResAW (MetaResAW aw) = aw+unMetaResAW mr             = pprPanic "unMetaResAW" (ppr mr)  type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult 
compiler/GHC/Types/Name.hs view
@@ -1,6 +1,7 @@+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-orphans #-} -- instance NFData FieldLabel @@ -58,9 +59,9 @@         localiseName,         namePun_maybe, -        pprName,+        pprName, pprName_userQual,         nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt,-        pprFullName, pprTickyName,+        pprFullName, pprFullNameWithUnique, pprTickyName,          -- ** Predicates on 'Name's         isSystemName, isInternalName, isExternalName,@@ -110,7 +111,8 @@ import Data.Data import qualified Data.Semigroup as S import GHC.Types.Basic (Boxity(Boxed, Unboxed))-import GHC.Builtin.Uniques (isTupleTyConUnique, isSumTyConUnique, isTupleDataConLikeUnique)+import GHC.Builtin.Uniques ( isTupleTyConUnique, isCTupleTyConUnique,+                             isSumTyConUnique, isTupleDataConLikeUnique )  {- ************************************************************************@@ -221,7 +223,7 @@ Note [About the NameSorts] ~~~~~~~~~~~~~~~~~~~~~~~~~~ 1.  Initially:-    * All types, classes, data constructors get Extenal Names+    * All types, classes, data constructors get External Names     * Top-level Ids (including locally-defined ones) get External Names,     * All other local (non-top-level) Ids get Internal names @@ -263,7 +265,7 @@    A WiredIn Name contains contains a TyThing, so we don't have to look it up.     The BuiltInSyntax flag => It's a syntactic form, not "in scope" (e.g. [])-   All built-in syntax thigs are WiredIn.+   All built-in syntax things are WiredIn. -}  instance HasOccName Name where@@ -384,14 +386,17 @@   | getUnique name == getUnique listTyCon = Just (fsLit "[]")    | Just (boxity, ar) <- isTupleTyConUnique (getUnique name)-  , ar /= 1 =-    let-      (lpar, rpar) =-        case boxity of+  , ar /= 1+  = let (lpar, rpar) = case boxity of           Boxed -> ("(", ")")           Unboxed -> ("(#", "#)")     in Just (fsLit $ lpar ++ commas ar ++ rpar) +  | Just ar <- isCTupleTyConUnique (getUnique name)+  , ar /= 1+  = Just (fsLit $ "(" ++ commas ar ++ ")")+      -- constraint tuples look just like boxed tuples+   | Just ar <- isSumTyConUnique (getUnique name)   = Just (fsLit $ "(# " ++ bars ar ++ " #)")   where@@ -687,7 +692,10 @@     pprPrefixOcc = pprPrefixName  pprName :: forall doc. IsLine doc => Name -> doc-pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ})+pprName = pprName_userQual Nothing++pprName_userQual :: forall doc. IsLine doc => Maybe ModuleName -> Name -> doc+pprName_userQual user_qual name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ})   = docWithStyle codeDoc normalDoc   where    codeDoc = case sort of@@ -705,8 +713,8 @@      sdocOption sdocListTuplePuns $ \listTuplePuns ->        handlePuns listTuplePuns (namePun_maybe name) $        case sort of-         WiredIn mod _ builtin   -> pprExternal debug sty uniq mod occ True  builtin-         External mod            -> pprExternal debug sty uniq mod occ False UserSyntax+         WiredIn mod _ builtin   -> pprExternal debug sty uniq mod user_qual occ True  builtin+         External mod            -> pprExternal debug sty uniq mod user_qual occ False UserSyntax          System                  -> pprSystem   debug sty uniq occ          Internal                -> pprInternal debug sty uniq occ @@ -728,6 +736,18 @@          <> colon    <> ftext (moduleNameFS $ moduleName mod)          <> dot      <> ftext (occNameFS occ) +-- | Print fully qualified name (with unit-id and module, with the unique)+pprFullNameWithUnique :: Module -> Name -> SDoc+pprFullNameWithUnique this_mod Name{n_sort = sort, n_uniq = u, n_occ = occ} =+  let mod = case sort of+        WiredIn  m _ _ -> m+        External m     -> m+        System         -> this_mod+        Internal       -> this_mod+      in ftext (unitIdFS (moduleUnitId mod))+         <> colon    <> ftext (moduleNameFS $ moduleName mod)+         <> dot      <> ftext (occNameFS occ) <> text "_" <> pprUniqueAlways u+ -- | Print a ticky ticky styled name -- -- Module argument is the module to use for internal and system names. When@@ -743,8 +763,14 @@ pprNameUnqualified :: Name -> SDoc pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ -pprExternal :: Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc-pprExternal debug sty uniq mod occ is_wired is_builtin+pprExternal :: Bool -> PprStyle -> Unique+            -> Module -- ^ module the 'Name' is defined in+            -> Maybe ModuleName -- ^ user module qualification+            -> OccName+            -> Bool -- ^ wired-in?+            -> BuiltInSyntax+            -> SDoc+pprExternal debug sty uniq mod user_qual occ is_wired is_builtin   | debug         = pp_mod <> ppr_occ_name occ                      <> braces (hsep [if is_wired then text "(w)" else empty,                                       pprNameSpaceBrief (occNameSpace occ),@@ -752,10 +778,10 @@   | BuiltInSyntax <- is_builtin = ppr_occ_name occ  -- Never qualify builtin syntax   | otherwise                   =         if isHoleModule mod-            then case qualName sty mod occ of+            then case qualName sty mod user_qual occ of                     NameUnqual -> ppr_occ_name occ                     _ -> braces (pprModuleName (moduleName mod) <> dot <> ppr_occ_name occ)-            else pprModulePrefix sty mod occ <> ppr_occ_name occ+            else pprModulePrefix sty mod user_qual occ <> ppr_occ_name occ   where     pp_mod = ppUnlessOption sdocSuppressModulePrefixes                (pprModule mod <> dot)@@ -780,11 +806,11 @@                                 -- so print the unique  -pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc+pprModulePrefix :: PprStyle -> Module -> Maybe ModuleName -> OccName -> SDoc -- Print the "M." part of a name, based on whether it's in scope or not -- See Note [Printing original names] in GHC.Types.Name.Ppr-pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $-    case qualName sty mod occ of              -- See Outputable.QualifyName:+pprModulePrefix sty mod user_qual occ = ppUnlessOption sdocSuppressModulePrefixes $+    case qualName sty mod user_qual occ of              -- See Outputable.QualifyName:       NameQual modname -> pprModuleName modname <> dot       -- Name is in scope       NameNotInScope1  -> pprModule mod <> dot               -- Not in scope       NameNotInScope2  -> pprUnit (moduleUnit mod) <> colon           -- Module not in@@ -877,7 +903,7 @@ -- add parens or back-quotes as appropriate pprInfixName  n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) -pprPrefixName :: NamedThing a => a -> SDoc-pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name)+pprPrefixName :: (Outputable a, NamedThing a) => a -> SDoc+pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr thing)  where    name = getName thing
compiler/GHC/Types/Name/Cache.hs view
@@ -3,6 +3,8 @@ -- | The Name Cache module GHC.Types.Name.Cache   ( NameCache (..)+  , newNameCache+  , newNameCacheWith   , initNameCache   , takeUniqFromNameCache   , updateNameCache'@@ -13,6 +15,10 @@   , lookupOrigNameCache   , extendOrigNameCache'   , extendOrigNameCache++  -- * Known-key names+  , knownKeysOrigNameCache+  , isKnownOrigName_maybe   ) where @@ -23,13 +29,14 @@ import GHC.Types.Unique.Supply import GHC.Builtin.Types import GHC.Builtin.Names+import GHC.Builtin.Utils  import GHC.Utils.Outputable import GHC.Utils.Panic +import Control.Applicative import Control.Concurrent.MVar import Control.Monad-import Control.Applicative  {- @@ -57,36 +64,48 @@  Note [Built-in syntax and the OrigNameCache] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Built-in syntax refers to names that are always in scope and can't be imported+or exported. Such names come in two varieties: -Built-in syntax like unboxed sums and punned syntax like tuples are quite-ubiquitous. To lower their cost we use two tricks,+* Simple names (finite): `[]`, `:`, `->`+* Families of names (infinite):+    * boxed tuples `()`, `(,)`, `(,,)`, `(,,,)`, ...+    * unboxed tuples `(##)`, `(#,#)`, `(#,,#)`, ...+    * unboxed sum type syntax `(#|#)`, `(#||#)`, `(#|||#)`, ...+    * unboxed sum data syntax `(#_|#)`, `(#|_#)`, `(#_||#), ... -  a. We specially encode tuple and sum Names in interface files' symbol tables-     to avoid having to look up their names while loading interface files.-     Namely these names are encoded as by their Uniques. We know how to get from-     a Unique back to the Name which it represents via the mapping defined in-     the SumTupleUniques module. See Note [Symbol table representation of names]-     in GHC.Iface.Binary and for details.+Concretely, a built-in name is a WiredIn Name that has a BuiltInSyntax flag. -  b. We don't include them in the Orig name cache but instead parse their-     OccNames (in isBuiltInOcc_maybe and isPunOcc_maybe) to avoid bloating-     the name cache with them.+Historically, GHC used to avoid putting any built-in syntax in the OrigNameCache+to avoid dealing with infinite families of names (tuples and sums). This measure+has become inadequate with the introduction of NoListTuplePuns (GHC Proposal #475).+Nowadays tuples and sums also use Names that are WiredIn, but are not BuiltInSyntax: -Why is the second measure necessary? Good question; afterall, 1) the parser-emits built-in and punned syntax directly as Exact RdrNames, and 2) built-in-and punned syntax never needs to looked-up during interface loading due to (a).-It turns out that there are two reasons why we might look up an Orig RdrName-for built-in and punned syntax,+* boxed tuples      (tycons):   Unit, Solo, Tuple2, Tuple3, Tuple4, ...+* unboxed tuples    (tycons):   Unit#, Solo#, Tuple2#, Tuple3#, Tuple4#, ...+* constraint tuples (tycons):   CUnit, CSolo, CTuple2, CTuple3, CTuple4, ...+* one-tuples      (datacons):   MkSolo, MkSolo# -  * If you use setRdrNameSpace on an Exact RdrName it may be-    turned into an Orig RdrName.+We can't put infinitely many names in a finite data structure (OrigNameCache).+So we deal with them in lookupOrigNameCache by means of isInfiniteFamilyOrigName_maybe. -  * Template Haskell turns a BuiltInSyntax Name into a TH.NameG-    (GHC.HsToCore.Quote.globalVar), and parses a NameG into an Orig RdrName-    (GHC.ThToHs.thRdrName).  So, e.g. $(do { reify '(,); ... }) will-    go this route (#8954).+At the same time, simple finite built-in names (`[]`, `:`, `->`) can be put in+the OrigNameCache without any issues (they end up there because they're+knownKeyNames). It doesn't matter that they're built-in syntax. +One might wonder: what's the point of having any built-in syntax in the+OrigNameCache at all?  Good question; after all,+  1) The parser emits built-in and punned syntax directly as Exact RdrNames+  2) Template Haskell conversion (GHC.ThToHs) matches on built-in and punned+     syntax directly to immediately produce Exact names (GHC.ThToHs.thRdrName)+  3) Loading of interface files encodes names via Uniques, as detailed in+     Note [Symbol table representation of names] in GHC.Iface.Binary++It turns out that we end up looking up built-in syntax in the cache when we+generate Haddock documentation. E.g. if we don't find tuple data constructors+there, hyperlinks won't work as expected. Test case: haddockHtmlTest (Bug923.hs) -}+ -- | The NameCache makes sure that there is just one Unique assigned for -- each original name; i.e. (module-name, occ-name) pair and provides -- something of a lookup mechanism for those names.@@ -102,18 +121,14 @@ takeUniqFromNameCache (NameCache c _) = uniqFromTag c  lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name-lookupOrigNameCache nc mod occ-  | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_INTERNAL_TUPLE || mod == gHC_CLASSES-  , Just name <- isBuiltInOcc_maybe occ <|> isPunOcc_maybe mod occ-  =     -- See Note [Known-key names], 3(c) in GHC.Builtin.Names-        -- Special case for tuples; there are too many-        -- of them to pre-populate the original-name cache-    Just name--  | otherwise-  = case lookupModuleEnv nc mod of-        Nothing      -> Nothing-        Just occ_env -> lookupOccEnv occ_env occ+lookupOrigNameCache nc mod occ = lookup_infinite <|> lookup_normal+  where+    -- See Note [Known-key names], 3(c) in GHC.Builtin.Names+    -- and Note [Infinite families of known-key names]+    lookup_infinite = isInfiniteFamilyOrigName_maybe mod occ+    lookup_normal = do+      occ_env <- lookupModuleEnv nc mod+      lookupOccEnv occ_env occ  extendOrigNameCache' :: OrigNameCache -> Name -> OrigNameCache extendOrigNameCache' nc name@@ -126,8 +141,27 @@   where     combine _ occ_env = extendOccEnv occ_env occ name +-- | Initialize a new name cache+newNameCache :: IO NameCache+newNameCache = newNameCacheWith 'r' knownKeysOrigNameCache++-- | This is a version of `newNameCache` that lets you supply your+-- own unique tag and set of known key names. This can go wrong if the tag+-- supplied is one reserved by GHC for internal purposes. See #26055 for+-- an example.+--+-- Use `newNameCache` when possible.+newNameCacheWith :: Char -> OrigNameCache -> IO NameCache+newNameCacheWith c nc = NameCache c <$> newMVar nc++-- | This takes a tag for uniques to be generated and the list of knownKeyNames+-- These must be initialized properly to ensure that names generated from this+-- NameCache do not conflict with known key names.+--+-- Use `newNameCache` or `newNameCacheWith` instead+{-# DEPRECATED initNameCache "Use newNameCache or newNameCacheWith instead" #-} initNameCache :: Char -> [Name] -> IO NameCache-initNameCache c names = NameCache c <$> newMVar (initOrigNames names)+initNameCache c names = newNameCacheWith c (initOrigNames names)  initOrigNames :: [Name] -> OrigNameCache initOrigNames names = foldl' extendOrigNameCache' emptyModuleEnv names@@ -159,3 +193,10 @@   -> IO c updateNameCache name_cache !_mod !_occ upd_fn   = updateNameCache' name_cache upd_fn++{-# NOINLINE knownKeysOrigNameCache #-}+knownKeysOrigNameCache :: OrigNameCache+knownKeysOrigNameCache = initOrigNames knownKeyNames++isKnownOrigName_maybe :: Module -> OccName -> Maybe Name+isKnownOrigName_maybe = lookupOrigNameCache knownKeysOrigNameCache
compiler/GHC/Types/Name/Env.hs view
@@ -166,7 +166,7 @@ disjointNameEnv x y     = disjointUFM x y seqEltsNameEnv seqElt x = seqEltsUFM seqElt x -lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n)+lookupNameEnv_NF env n = expectJust (lookupNameEnv env n)  -- | Deterministic Name Environment --
compiler/GHC/Types/Name/Occurrence.hs view
@@ -49,8 +49,7 @@         mkClsOcc, mkClsOccFS,         mkDFunOcc,         setOccNameSpace,-        demoteOccName,-        demoteOccTvName,+        demoteOccName, demoteOccTcClsName, demoteOccTvName,         promoteOccName,         varToRecFieldOcc,         recFieldToVarOcc,@@ -93,6 +92,7 @@         plusOccEnv, plusOccEnv_C,         extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv,         alterOccEnv, minusOccEnv, minusOccEnv_C, minusOccEnv_C_Ns,+        sizeOccEnv,         pprOccEnv, forceOccEnv,         intersectOccEnv_C, @@ -316,16 +316,23 @@ pprNameSpaceBrief TcClsName    = text "tc" pprNameSpaceBrief (FldName {}) = text "fld" --- demoteNameSpace lowers the NameSpace if possible.  We can not know--- in advance, since a TvName can appear in an HsTyVar.+-- | 'demoteNameSpace' lowers the 'NameSpace' to the term-level, if possible.+-- -- See Note [Demotion] in GHC.Rename.Env. demoteNameSpace :: NameSpace -> Maybe NameSpace demoteNameSpace VarName = Nothing demoteNameSpace DataName = Nothing-demoteNameSpace TvName = Nothing+demoteNameSpace TvName = Just VarName demoteNameSpace TcClsName = Just DataName demoteNameSpace (FldName {}) = Nothing +demoteTcClsNameSpace :: NameSpace -> Maybe NameSpace+demoteTcClsNameSpace VarName = Nothing+demoteTcClsNameSpace DataName = Nothing+demoteTcClsNameSpace TvName = Nothing+demoteTcClsNameSpace TcClsName = Just DataName+demoteTcClsNameSpace (FldName {}) = Nothing+ -- demoteTvNameSpace lowers the NameSpace of a type variable. -- See Note [Demotion] in GHC.Rename.Env. demoteTvNameSpace :: NameSpace -> Maybe NameSpace@@ -507,6 +514,11 @@   space' <- demoteNameSpace space   return $ OccName space' name +demoteOccTcClsName :: OccName -> Maybe OccName+demoteOccTcClsName (OccName space name) = do+  space' <- demoteTcClsNameSpace space+  return $ OccName space' name+ demoteOccTvName :: OccName -> Maybe OccName demoteOccTvName (OccName space name) = do   space' <- demoteTvNameSpace space@@ -791,6 +803,10 @@         in if isNullUFM m            then Nothing            else Just m++sizeOccEnv :: OccEnv a -> Int+sizeOccEnv (MkOccEnv as) =+  nonDetStrictFoldUFM (\ m !acc -> acc + sizeUFM m) 0 as  instance Outputable a => Outputable (OccEnv a) where     ppr x = pprOccEnv ppr x
compiler/GHC/Types/Name/Ppr.hs view
@@ -13,6 +13,7 @@  import GHC.Unit import GHC.Unit.Env+import qualified GHC.Unit.Home.Graph as HUG  import GHC.Types.Name import GHC.Types.Name.Reader@@ -72,67 +73,74 @@ mkNamePprCtx ptc unit_env env  = QueryQualify       (mkQualName env)-      (mkQualModule unit_state home_unit)+      (mkQualModule unit_state unit_env)       (mkQualPackage unit_state)       (mkPromTick ptc env)   where-  unit_state = ue_units unit_env-  home_unit  = ue_homeUnit unit_env+  unit_state = ue_homeUnitState unit_env  mkQualName :: Outputable info => GlobalRdrEnvX info -> QueryQualifyName mkQualName env = qual_name where-  qual_name mod occ-        | [gre] <- unqual_gres-        , right_name gre-        = NameUnqual   -- If there's a unique entity that's in scope-                       -- unqualified with 'occ' AND that entity is-                       -- the right one, then we can use the unqualified name+  qual_name mod user_qual occ -        | [] <- unqual_gres-        , pretendNameIsInScopeForPpr-        , not (isDerivedOccName occ)-        = NameUnqual   -- See Note [pretendNameIsInScopeForPpr]+    -- Use the user-written qualification, if that's unambiguous.+    | Just qual <- user_qual+    , let user_rdr = mkRdrQual qual occ+    , [gre] <- lookupGRE env $ LookupRdrName user_rdr SameNameSpace+    , right_name gre+    = NameQual qual -        | [gre] <- qual_gres-        = NameQual (greQualModName gre)+    -- If there's a GRE that's in scope+    -- unqualified with 'occ' AND that entity is+    -- the right one, then use the unqualified name+    | [gre] <- unqual_gres+    , right_name gre+    = NameUnqual -        | null qual_gres-        = if null $ lookupGRE env $-               LookupRdrName (mkRdrQual (moduleName mod) occ) SameNameSpace-          then NameNotInScope1-          else NameNotInScope2+    | [] <- unqual_gres+    , pretendNameIsInScopeForPpr+    , not (isDerivedOccName occ)+    = NameUnqual   -- See Note [pretendNameIsInScopeForPpr] -        | otherwise-        = NameNotInScope1   -- Can happen if 'f' is bound twice in the module-                            -- Eg  f = True; g = 0; f = False-      where-        is_name :: Name -> Bool-        is_name name = assertPpr (isExternalName name) (ppr name) $-                       nameModule name == mod && nameOccName name == occ+    | [gre] <- qual_gres+    = NameQual (greQualModName gre) -        -- See Note [pretendNameIsInScopeForPpr]-        pretendNameIsInScopeForPpr :: Bool-        pretendNameIsInScopeForPpr =-          any is_name-            [ liftedTypeKindTyConName-            , constraintKindTyConName-            , heqTyConName-            , coercibleTyConName-            , eqTyConName-            , tYPETyConName-            , fUNTyConName, unrestrictedFunTyConName-            , oneDataConName-            , listTyConName-            , manyDataConName-            , soloDataConName ]-          || isJust (isTupleTyOcc_maybe mod occ)-          || isJust (isSumTyOcc_maybe mod occ)+    | null qual_gres+    = if null $ lookupGRE env $+           LookupRdrName (mkRdrQual (moduleName mod) occ) SameNameSpace+      then NameNotInScope1+      else NameNotInScope2 -        right_name gre = greDefinitionModule gre == Just mod+    | otherwise+    = NameNotInScope1   -- Can happen if 'f' is bound twice in the module+                        -- Eg  f = True; g = 0; f = False+    where+      is_name :: Name -> Bool+      is_name name = assertPpr (isExternalName name) (ppr name) $+                     nameModule name == mod && nameOccName name == occ -        unqual_gres = lookupGRE env (LookupRdrName (mkRdrUnqual occ) SameNameSpace)-        qual_gres   = filter right_name (lookupGRE env (LookupOccName occ SameNameSpace))+      -- See Note [pretendNameIsInScopeForPpr]+      pretendNameIsInScopeForPpr :: Bool+      pretendNameIsInScopeForPpr =+        any is_name+          [ liftedTypeKindTyConName+          , constraintKindTyConName+          , heqTyConName+          , coercibleTyConName+          , eqTyConName+          , tYPETyConName+          , fUNTyConName, unrestrictedFunTyConName+          , oneDataConName+          , listTyConName+          , manyDataConName+          , soloDataConName ]+        || isJust (isTupleTyOrigName_maybe mod occ)+        || isJust (isSumTyOrigName_maybe mod occ) +      right_name gre = greDefinitionModule gre == Just mod+      unqual_gres = lookupGRE env (LookupRdrName (mkRdrUnqual occ) SameNameSpace)+      qual_gres   = filter right_name (lookupGRE env (LookupOccName occ SameNameSpace))+     -- we can mention a module P:M without the P: qualifier iff     -- "import M" would resolve unambiguously to P:M.  (if P is the     -- current package we can just assume it is unqualified).@@ -207,10 +215,12 @@ -- | Creates a function for formatting modules based on two heuristics: -- (1) if the module is the current module, don't qualify, and (2) if there -- is only one exposed package which exports this module, don't qualify.-mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule-mkQualModule unit_state mhome_unit mod-     | Just home_unit <- mhome_unit-     , isHomeModule home_unit mod = False+mkQualModule :: UnitState -> UnitEnv -> QueryQualifyModule+mkQualModule unit_state unitEnv mod+       -- Check whether the unit of the module is in the HomeUnitGraph.+       -- If it is, then we consider this 'mod' to be "local" and don't+       -- want to qualify it.+     | HUG.memberHugUnit (moduleUnit mod) (ue_home_unit_graph unitEnv) = False       | [(_, pkgconfig)] <- lookup,        mkUnit pkgconfig == moduleUnit mod
compiler/GHC/Types/Name/Reader.hs view
@@ -5,6 +5,7 @@  {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}@@ -37,10 +38,15 @@         nameRdrName, getRdrName,          -- ** Destruction-        rdrNameOcc, rdrNameSpace, demoteRdrName, demoteRdrNameTv, promoteRdrName,+        rdrNameOcc, rdrNameSpace,+        demoteRdrName, demoteRdrNameTcCls, demoteRdrNameTv,+        promoteRdrName,         isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual,         isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, +        -- ** Preserving user-written qualification+        WithUserRdr(..), noUserRdr, unLocWithUserRdr, userRdrName,+         -- * Local mapping of 'RdrName' to 'Name.Name'         LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,         lookupLocalRdrEnv, lookupLocalRdrOcc,@@ -59,12 +65,11 @@         LookupGRE(..), lookupGRE,         WhichGREs(.., AllRelevantGREs, RelevantGREsFOS),         greIsRelevant,-        LookupChild(..),          lookupGRE_Name,         lookupGRE_FieldLabel,         getGRE_NameQualifier_maybes,-        transformGREs, pickGREs, pickGREsModExp,+        transformGREs, pickGREs, pickGREsModExp, pickLevelZeroGRE,          -- * GlobalRdrElts         availFromGRE,@@ -85,7 +90,7 @@         pprNameProvenance,         mkGRE, mkExactGRE, mkLocalGRE, mkLocalVanillaGRE, mkLocalTyConGRE,         mkLocalConLikeGRE, mkLocalFieldGREs,-        gresToNameSet,+        gresToNameSet, greLevels,          -- ** Shadowing         greClashesWith, shadowNames,@@ -98,13 +103,15 @@         fieldGRE_maybe, fieldGRELabel,          -- ** Parent information-        Parent(..), greParent_maybe,+        Parent(..), ParentGRE(..), greParent_maybe,         mkParent, availParent,         ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),-        importSpecLoc, importSpecModule, isExplicitItem, bestImport,+        importSpecLoc, importSpecModule, importSpecLevel, isExplicitItem, bestImport,+        ImportLevel(..),          -- * Utils-        opIsAt+        opIsAt,+   ) where  import GHC.Prelude@@ -119,7 +126,6 @@ import GHC.Types.FieldLabel import GHC.Types.Name import GHC.Types.Name.Env-    ( NameEnv, nonDetNameEnvElts, emptyNameEnv, extendNameEnv_Acc ) import GHC.Types.Name.Set import GHC.Types.PkgQual import GHC.Types.SrcLoc as SrcLoc@@ -127,15 +133,18 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Builtin.Uniques ( isFldNSUnique )+import GHC.Types.ThLevelIndex+import qualified Data.Set as Set  import GHC.Unit.Module  import GHC.Utils.Misc as Utils import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Binary  import Control.DeepSeq-import Control.Monad ( guard )+import Control.Monad ( guard , (>=>) ) import Data.Data import Data.List ( sort ) import qualified Data.List.NonEmpty as NE@@ -222,7 +231,9 @@ rdrNameSpace :: RdrName -> NameSpace rdrNameSpace = occNameSpace . rdrNameOcc --- demoteRdrName lowers the NameSpace of RdrName.+-- | 'demoteRdrName' attempts to lowers the 'NameSpace' of a 'RdrName'+-- to the term-level.+-- -- See Note [Demotion] in GHC.Rename.Env demoteRdrName :: RdrName -> Maybe RdrName demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ)@@ -230,6 +241,12 @@ demoteRdrName (Orig _ _) = Nothing demoteRdrName (Exact _) = Nothing +demoteRdrNameTcCls :: RdrName -> Maybe RdrName+demoteRdrNameTcCls (Unqual occ) = fmap Unqual (demoteOccTcClsName occ)+demoteRdrNameTcCls (Qual m occ) = fmap (Qual m) (demoteOccTcClsName occ)+demoteRdrNameTcCls (Orig _ _) = Nothing+demoteRdrNameTcCls (Exact _) = Nothing+ demoteRdrNameTv :: RdrName -> Maybe RdrName demoteRdrNameTv (Unqual occ) = fmap Unqual (demoteOccTvName occ) demoteRdrNameTv (Qual m occ) = fmap (Qual m) (demoteOccTvName occ)@@ -335,7 +352,7 @@     ppr (Exact name)   = ppr name     ppr (Unqual occ)   = ppr occ     ppr (Qual mod occ) = ppr mod <> dot <> ppr occ-    ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ)+    ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod Nothing occ <> ppr occ)  instance OutputableBndr RdrName where     pprBndr _ n@@ -456,6 +473,14 @@   = Just name    | otherwise+  -- As per the Haskell report (www.haskell.org/onlinereport/haskell2010/haskellch5.html#x11-980005),+  -- qualified names can only refer to:+  --+  --  - imported names, or+  --  - top-level declarations in the current module.+  --+  -- Thus, looking up in the LocalRdrEnv using a Qual or Orig RdrName will+  -- always fail.   = Nothing  lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name@@ -616,6 +641,11 @@ greInfo :: GlobalRdrElt -> GREInfo greInfo = gre_info +greLevels :: GlobalRdrEltX info -> Set.Set ImportLevel+greLevels g =+  if gre_lcl g then Set.singleton NormalLevel+               else Set.fromList (bagToList (fmap (is_level . is_decl) (gre_imp g)))+ -- | See Note [Parents] data Parent = NoParent             | ParentIs  { par_is :: !Name }@@ -1095,6 +1125,23 @@ allowGRE WantField gre   = isRecFldGRE gre +-- | A parent of a child, in contexts like import/export lists, class and+-- instance declarations, etc.+--+-- Not simply a 'GlobalRdrElt', because we don't always have a full+-- 'GlobalRdrElt' to hand (e.g. in 'GHC.Rename.Env.lookupInstDeclBndr').+data ParentGRE+  = ParentGRE+  { parentGRE_name :: Name+  , parentGRE_info :: GREInfo+  }++instance Outputable ParentGRE where+  ppr (ParentGRE name info) = ppr name <+> parens (ppr info)++instance Eq ParentGRE where+  ParentGRE name1 _ == ParentGRE name2 _ = name1 == name2+ -- | What should we look up in a 'GlobalRdrEnv'? Should we only look up -- names with the exact same 'OccName', or do we allow different 'NameSpace's? --@@ -1135,11 +1182,9 @@    -- | Look up children 'GlobalRdrElt's with a given 'Parent'.   LookupChildren-    :: OccName  -- ^ the 'OccName' to look up-    -> LookupChild-         -- ^ information to decide which 'GlobalRdrElt's-         -- are valid children after looking up-    -> LookupGRE info+    :: ParentGRE        -- ^ the parent+    -> OccName          -- ^ the child 'OccName' to look up+    -> LookupGRE GREInfo  -- | How should we look up in a 'GlobalRdrEnv'? -- Which 'NameSpace's are considered relevant for a given lookup?@@ -1194,33 +1239,6 @@                    , lookupVariablesForFields = fos == WantBoth                    , lookupTyConsAsWell = False } -data LookupChild-  = LookupChild-  { wantedParent :: Name-     -- ^ the parent we are looking up children of-  , lookupDataConFirst :: Bool-     -- ^ for type constructors, should we look in the data constructor-     -- namespace first?-  , prioritiseParent :: Bool-    -- ^ should we prioritise getting the right 'Parent'?-    ---    --  - @True@: prioritise getting the right 'Parent'-    --  - @False@: prioritise getting the right 'NameSpace'-    ---    -- See Note [childGREPriority].-  }--instance Outputable LookupChild where-  ppr (LookupChild { wantedParent = par-                   , lookupDataConFirst = dc-                   , prioritiseParent = prio_parent })-    = braces $ hsep-        [ text "LookupChild"-        , braces (text "parent:" <+> ppr par)-        , if dc then text "[dc_first]" else empty-        , if prio_parent then text "[prio_parent]" else empty-        ]- -- | After looking up something with the given 'NameSpace', is the resulting -- 'GlobalRdrElt' we have obtained relevant, according to the 'RelevantGREs' -- specification of which 'NameSpace's are relevant?@@ -1269,69 +1287,64 @@        class C a where { type (+++) :: a -> a ->; infixl 6 +++ }        (+++) :: Int -> Int -> Int; (+++) = (+) -In these two situations, there are two competing metrics for finding the "best"+In these two situations, there are two metrics for finding the "best" 'GlobalRdrElt' that a particular 'OccName' resolves to:    - does the resolved 'GlobalRdrElt' have the correct parent?   - does the resolved 'GlobalRdrElt' have the same 'NameSpace' as the 'OccName'? -(A) and (B) have competing requirements.--For the example of (A) above, we know that the child 'D' of 'T' must live-in the data namespace, so we look up the OccName 'OccName DataName "D"' and-prioritise the lookup results based on the 'NameSpace'.-This means we get an error message of the form:--  The type constructor 'T' is not the parent of the data constructor 'D'.--as opposed to the rather unhelpful and confusing:--  The type constructor 'T' is not the parent of the type constructor 'D'.--See test case T11970.+To resolve a children export item, we proceed by first prioritising GREs which+have the correct parent, and then break ties by looking at 'NameSpace's. -For the example of (B) above, the fixity declaration for +++ lies inside the-class, so we should prioritise looking up 'GlobalRdrElt's whose parent is 'C'.-Not doing so led to #23664.+Test cases:+  - T11970: pattern synonyms, classes etc+  - T10816, T23664, T24037: fixity declarations for associated types+  - T20427: promoted data constructors and TypeData -}  -- | Scoring priority function for looking up children 'GlobalRdrElt'. ----- We score by 'Parent' and 'NameSpace', with higher priorities having lower--- numbers. Which lexicographic order we use ('Parent' or 'NameSpace' first)--- is determined by the first argument; see Note [childGREPriority].-childGREPriority :: LookupChild -- ^ what kind of child do we want,-                                -- e.g. what should its parent be?-                 -> NameSpace   -- ^ what 'NameSpace' are we originally looking in?-                 -> GlobalRdrEltX info-                                -- ^ the result of looking up; it might be in a different-                                -- 'NameSpace', which is used to determine the score-                                -- (in the first component)+-- The returned score orders by 'Parent' first and then by 'NameSpace',+-- with higher priorities having lower numbers.+--+-- See Note [childGREPriority].+childGREPriority :: ParentGRE      -- ^ wanted parent+                 -> NameSpace      -- ^ what 'NameSpace' are we originally looking in?+                 -> GlobalRdrElt+                      -- ^ the result of looking up; it might be in a different+                      -- 'NameSpace', which is used to determine the score+                      -- (in the second component)                  -> Maybe (Int, Int)-childGREPriority (LookupChild { wantedParent = wanted_parent-                              , lookupDataConFirst = try_dc_first-                              , prioritiseParent = par_first })-  ns gre =-    case child_ns_prio $ greNameSpace gre of-      Nothing -> Nothing-      Just ns_prio ->-        let par_prio = parent_prio $ greParent gre-        in Just $ if par_first-                  then (par_prio, ns_prio)-                  else (ns_prio, par_prio)-          -- See Note [childGREPriority].+childGREPriority (ParentGRE wanted_parent parent_info) wanted_ns child_gre =+  (parent_prio, ) <$> child_ns_prio    where+      child_ns = greNameSpace child_gre++      -- Is the parent a class? Only class TyCons can have children that+      -- are in the TcCls NameSpace (associated types).+      is_class_parent =+        case parent_info of+          IAmTyCon ClassFlavour -> True+          _ -> False+       -- Pick out the possible 'NameSpace's in order of priority.-      child_ns_prio :: (NameSpace -> Maybe Int)-      child_ns_prio other_ns-        | other_ns == ns+      child_ns_prio :: Maybe Int+      child_ns_prio+        | child_ns == wanted_ns++        -- Is it OK to have a child in this NameSpace?+        --+        -- If it's in the TcCls NameSpace, then the parent must be a class,+        -- unless the child is a promoted data constructor (which can happen+        -- when exporting a TypeData declaration, see T20427).+        , not (isTcClsNameSpace child_ns) || is_class_parent || child_is_data         = Just 0-        | isTermVarOrFieldNameSpace ns-        , isTermVarOrFieldNameSpace other_ns+        | isTermVarOrFieldNameSpace wanted_ns+        , isTermVarOrFieldNameSpace child_ns         = Just 0-        | isValNameSpace varName-        , other_ns == tcName+        | isValNameSpace wanted_ns+        , is_class_parent && isTcClsNameSpace child_ns         -- When looking up children, we sometimes want a value name         -- to resolve to a type constructor.         -- For example, for an infix declaration "infixr 3 +!" or "infix 2 `Fun`"@@ -1341,19 +1354,49 @@         -- NameSpace, and "Fun" would be in the term-level data constructor         -- NameSpace.  See tests T10816, T23664, T24037.         = Just 1-        | ns == tcName-        , other_ns == dataName-        , try_dc_first -- try data namespace before type/class namespace?-        = Just (-1)+        | wanted_ns == tcName+        , child_is_data+        = Just $+            -- For classes we de-prioritise data constructors;+            -- otherwise we prioritise them.+            if is_class_parent+            then  1+            else -1         | otherwise         = Nothing -      parent_prio :: Parent -> Int-      parent_prio (ParentIs other_parent)-        | other_parent == wanted_parent = 0-        | otherwise                     = 1-      parent_prio NoParent              = 0+      parent_prio :: Int+      parent_prio =+        case greParent child_gre of+          ParentIs other_parent+            | other_parent == wanted_parent+            -> 0+            | otherwise+            -- The parent is wrong, so give this a low priority.+            -- Don't return 'Nothing': if there are no other options, this+            -- allows us to report an incorrect parent to the user, as opposed+            -- to an out-of-scope error.+            -> 1+          NoParent ->+            -- Higher priority than having the wrong parent entirely,+            -- but same priority as having the right parent. Why? See T25892:+            --+            --   module M1 where+            --     data D = K+            --   module M2 (D(M2.K)) where+            --     import qualified M1+            --     pattern K = M1.K+            --+            -- Here, we do not want the data constructor M1.K to take priority+            -- over the pattern synonym M2.K that we are trying to bundle.+            0 +      child_is_data =+        case greInfo child_gre of+          IAmConLike{} -> True+          IAmTyCon PromotedDataConFlavour -> True+          _ -> child_ns == dataName+ -- | Look something up in the Global Reader Environment. -- -- The 'LookupGRE' argument specifies what to look up, and in particular@@ -1377,10 +1420,10 @@       occ = nameOccName nm       lkup | all_ns    = concat $ lookupOccEnv_AllNameSpaces env occ            | otherwise = fromMaybe [] $ lookupOccEnv env occ-  LookupChildren occ which_child ->-    let ns = occNameSpace occ-        all_gres = concat $ lookupOccEnv_AllNameSpaces env occ-    in highestPriorityGREs (childGREPriority which_child ns) all_gres+  LookupChildren parent child_occ ->+    let ns = occNameSpace child_occ+        all_gres = concat $ lookupOccEnv_AllNameSpaces env child_occ+    in highestPriorityGREs (childGREPriority parent ns) all_gres  -- | Collect the 'GlobalRdrElt's with the highest priority according -- to the given function (lower value <=> higher priority).@@ -1561,8 +1604,15 @@ -- -- Used only for the 'module M' item in export list; --   see 'GHC.Tc.Gen.Export.exports_from_avail'-pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres+-- This function also only chooses GREs which are at level zero.+pickGREsModExp mod gres = mapMaybe (pickLevelZeroGRE >=> pickBothGRE mod) gres +pickLevelZeroGRE :: GlobalRdrEltX info -> Maybe (GlobalRdrEltX info)+pickLevelZeroGRE gre =+  if NormalLevel `Set.member` greLevels gre+    then Just gre+    else Nothing+ -- | isBuiltInSyntax filter out names for built-in syntax They -- just clutter up the environment (esp tuples), and the -- parser will generate Exact RdrNames for them, so the@@ -1778,6 +1828,7 @@                                    , is_as = old_mod_name                                    , is_pkg_qual = NoPkgQual                                    , is_qual = True+                                   , is_level = NormalLevel -- MP: Not 100% sure this is correct                                    , is_isboot = NotBoot                                    , is_dloc = greDefinitionSrcSpan old_gre } @@ -1940,12 +1991,34 @@         is_pkg_qual :: !PkgQual,    -- ^ Was this a package import?         is_qual     :: !Bool,       -- ^ Was this import qualified?         is_dloc     :: !SrcSpan,    -- ^ The location of the entire import declaration-        is_isboot   :: !IsBootInterface -- ^ Was this a SOURCE import?+        is_isboot   :: !IsBootInterface, -- ^ Was this a SOURCE import?+        is_level    :: !ImportLevel -- ^ Was this import level modified? splice/quote +-1     } deriving (Eq, Data) ++ instance NFData ImpDeclSpec where   rnf = rwhnf -- Already strict in all fields ++instance Binary ImpDeclSpec where+  put_ bh (ImpDeclSpec mod as pkg_qual qual _dloc isboot isstage) = do+    put_ bh mod+    put_ bh as+    put_ bh pkg_qual+    put_ bh qual+    put_ bh isboot+    put_ bh (fromEnum isstage)++  get bh = do+    mod <- get bh+    as <- get bh+    pkg_qual <- get bh+    qual <- get bh+    isboot <- get bh+    isstage <- toEnum <$> get bh+    return (ImpDeclSpec mod as pkg_qual qual noSrcSpan isboot isstage)+ -- | Import Item Specification -- -- Describes import info a particular Name@@ -2058,6 +2131,9 @@ importSpecModule :: ImportSpec -> ModuleName importSpecModule = moduleName . is_mod . is_decl +importSpecLevel :: ImportSpec -> ImportLevel+importSpecLevel = is_level . is_decl+ isExplicitItem :: ImpItemSpec -> Bool isExplicitItem ImpAll                        = False isExplicitItem (ImpSome {is_explicit = exp}) = exp@@ -2095,11 +2171,18 @@    ppr imp_spec      = text "imported" <+> qual         <+> text "from" <+> quotes (ppr (importSpecModule imp_spec))+        <+> level_ppr         <+> pprLoc (importSpecLoc imp_spec)      where        qual | is_qual (is_decl imp_spec) = text "qualified"             | otherwise                  = empty +       level = thLevelIndexFromImportLevel (is_level (is_decl imp_spec))+       level_ppr+        | level == topLevelIndex = empty+        | otherwise = text "at" <+> ppr level++ pprLoc :: SrcSpan -> SDoc pprLoc (RealSrcSpan s _)  = text "at" <+> ppr s pprLoc (UnhelpfulSpan {}) = empty@@ -2107,3 +2190,42 @@ -- | Indicate if the given name is the "@" operator opIsAt :: RdrName -> Bool opIsAt e = e == mkUnqual varName (fsLit "@")+++--------------------------------------------------------------------------------+-- Preserving user-written qualification++-- | 'WithUserRdr' allows us to keep track of the original user-written+-- 'RdrName', and in particular, any user-written module qualification.+--+-- See Note [IdOcc] in Language.Haskell.Syntax.Extension.+data WithUserRdr a = WithUserRdr RdrName a+  deriving stock (Functor, Foldable, Traversable)++instance NamedThing a => NamedThing (WithUserRdr a) where+  getName (WithUserRdr _rdr a) = getName a+instance Outputable (WithUserRdr Name) where+    ppr (WithUserRdr rdr name) =+      pprName_userQual (rdrQual_maybe rdr) name+instance OutputableBndr (WithUserRdr Name) where+    pprBndr _ (WithUserRdr rdr name) =+      pprName_userQual (rdrQual_maybe rdr) name+    pprInfixOcc :: WithUserRdr Name -> SDoc+    pprInfixOcc  = pprInfixName+    pprPrefixOcc = pprPrefixName++unLocWithUserRdr :: GenLocated l (WithUserRdr a) -> a+unLocWithUserRdr (L _ (WithUserRdr _ a)) = a++noUserRdr :: Name -> WithUserRdr Name+noUserRdr n = WithUserRdr (nameRdrName n) n++userRdrName :: WithUserRdr Name -> RdrName+userRdrName (WithUserRdr rdr _) = rdr++rdrQual_maybe :: RdrName -> Maybe ModuleName+rdrQual_maybe = \case+  Qual q _ -> Just q+  _        -> Nothing++--------------------------------------------------------------------------------
compiler/GHC/Types/PkgQual.hs view
@@ -6,6 +6,7 @@ import GHC.Prelude import GHC.Types.SourceText import GHC.Unit.Types+import GHC.Utils.Binary import GHC.Utils.Outputable  import Data.Data@@ -38,4 +39,21 @@     ThisPkg u  -> doubleQuotes (ppr u)     OtherPkg u -> doubleQuotes (ppr u) +instance Binary PkgQual where+  put_ bh NoPkgQual    = putByte bh 0+  put_ bh (ThisPkg u)  = do+    putByte bh 1+    put_ bh u+  put_ bh (OtherPkg u) = do+    putByte bh 2+    put_ bh u +  get bh = do+    tag <- getByte bh+    case tag of+      0 -> return NoPkgQual+      1 -> do u <- get bh+              return (ThisPkg u)+      2 -> do u <- get bh+              return (OtherPkg u)+      _ -> fail "instance Binary PkgQual: Invalid tag"
compiler/GHC/Types/ProfAuto.hs view
@@ -12,4 +12,4 @@   | ProfAutoTop        -- ^ top-level functions annotated only   | ProfAutoExports    -- ^ exported functions annotated only   | ProfAutoCalls      -- ^ annotate call-sites-  deriving (Eq,Enum)+  deriving (Eq,Enum, Show)
compiler/GHC/Types/RepType.hs view
@@ -698,7 +698,7 @@   = False   | [BoxedRep _] <- typePrimRep ty   , Just tc <- tyConAppTyCon_maybe (unwrapType ty)-  , isDataTyCon tc+  , isBoxedDataTyCon tc   = False   | otherwise   = True
compiler/GHC/Types/SafeHaskell.hs view
@@ -14,6 +14,7 @@  import GHC.Utils.Binary import GHC.Utils.Outputable+import Control.DeepSeq  import Data.Word @@ -31,6 +32,15 @@    | Sf_Ignore        -- ^ @-fno-safe-haskell@ state    deriving (Eq) +instance NFData SafeHaskellMode where+  rnf x = case x of+            Sf_None -> ()+            Sf_Unsafe -> ()+            Sf_Trustworthy -> ()+            Sf_Safe -> ()+            Sf_SafeInferred -> ()+            Sf_Ignore -> ()+ instance Show SafeHaskellMode where     show Sf_None         = "None"     show Sf_Unsafe       = "Unsafe"@@ -45,6 +55,10 @@ -- | Safe Haskell information for 'ModIface' -- Simply a wrapper around SafeHaskellMode to separate iface and flags newtype IfaceTrustInfo = TrustInfo SafeHaskellMode++instance NFData IfaceTrustInfo where+  rnf (TrustInfo shm) = rnf shm+  getSafeMode :: IfaceTrustInfo -> SafeHaskellMode getSafeMode (TrustInfo x) = x
compiler/GHC/Types/SourceFile.hs view
@@ -13,6 +13,7 @@ import GHC.Prelude import GHC.Utils.Binary import GHC.Unit.Types+import Control.DeepSeq  {- Note [HscSource types] ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -53,6 +54,10 @@   | Hsig   -- ^ .hsig file    deriving (Eq, Ord, Show) +instance NFData HsBootOrSig where+  rnf HsBoot = ()+  rnf Hsig = ()+ data HscSource    -- | .hs file    = HsSrcFile@@ -72,6 +77,10 @@ hscSourceToIsBoot :: HscSource -> IsBootInterface hscSourceToIsBoot HsBootFile = IsBoot hscSourceToIsBoot _ = NotBoot++instance NFData HscSource where+  rnf HsSrcFile = ()+  rnf (HsBootOrSig h) = rnf h  instance Binary HscSource where     put_ bh HsSrcFile = putByte bh 0
compiler/GHC/Types/SptEntry.hs view
@@ -14,4 +14,3 @@ instance Outputable SptEntry where   ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr -
compiler/GHC/Types/SrcLoc.hs view
@@ -223,8 +223,9 @@ -- We use 'BufPos' in in GHC.Parser.PostProcess.Haddock to associate Haddock -- comments with parts of the AST using location information (#17544). newtype BufPos = BufPos { bufPos :: Int }-  deriving (Eq, Ord, Show, Data)+  deriving (Eq, Ord, Show, Data, NFData) + -- | Source Location data SrcLoc   = RealSrcLoc !RealSrcLoc !(Strict.Maybe BufPos)  -- See Note [Why Maybe BufPos]@@ -373,11 +374,13 @@         }   deriving Eq --- | StringBuffer Source Span data BufSpan =   BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos }   deriving (Eq, Ord, Show, Data) +instance NFData BufSpan where+  rnf (BufSpan a1 a2) = rnf a1 `seq` rnf a2+ instance Semigroup BufSpan where   BufSpan start1 end1 <> BufSpan start2 end2 =     BufSpan (min start1 start2) (max end1 end2)@@ -439,8 +442,19 @@           end = JSObject [ ("line", JSInt srcSpanELine),                            ("column", JSInt srcSpanECol) ] +instance NFData RealSrcSpan where+  rnf (RealSrcSpan' file line col endLine endCol) = rnf file `seq` rnf line `seq` rnf col `seq` rnf endLine `seq` rnf endCol+ instance NFData SrcSpan where-  rnf x = x `seq` ()+  rnf (RealSrcSpan a1 a2) = rnf a1 `seq` rnf a2+  rnf (UnhelpfulSpan a1) = rnf a1++instance NFData UnhelpfulSpanReason where+  rnf (UnhelpfulNoLocationInfo) = ()+  rnf (UnhelpfulWiredIn) = ()+  rnf (UnhelpfulInteractive) = ()+  rnf (UnhelpfulGenerated) = ()+  rnf (UnhelpfulOther a1) = rnf a1  getBufSpan :: SrcSpan -> Strict.Maybe BufSpan getBufSpan (RealSrcSpan _ mbspan) = mbspan
+ compiler/GHC/Types/ThLevelIndex.hs view
@@ -0,0 +1,36 @@+module GHC.Types.ThLevelIndex where++import GHC.Prelude+import GHC.Utils.Outputable+import GHC.Types.Basic ( ImportLevel(..) )+import Data.Data++-- | The integer which represents the level+newtype ThLevelIndex = ThLevelIndex Int deriving (Eq, Ord, Data)+    -- NB: see Note [Template Haskell levels] in GHC.Tc.Gen.Splice+    -- Incremented when going inside a bracket,+    -- decremented when going inside a splice++instance Outputable ThLevelIndex where+    ppr (ThLevelIndex i) = int i++incThLevelIndex :: ThLevelIndex -> ThLevelIndex+incThLevelIndex (ThLevelIndex i) = ThLevelIndex (i + 1)++decThLevelIndex :: ThLevelIndex -> ThLevelIndex+decThLevelIndex (ThLevelIndex i) = ThLevelIndex (i - 1)++topLevelIndex :: ThLevelIndex+topLevelIndex = ThLevelIndex 0++spliceLevelIndex :: ThLevelIndex+spliceLevelIndex = decThLevelIndex topLevelIndex++quoteLevelIndex :: ThLevelIndex+quoteLevelIndex = incThLevelIndex topLevelIndex++-- | Convert a 'GHC.Types.Basic.ImportLevel' to a 'ThLevelIndex'+thLevelIndexFromImportLevel :: ImportLevel -> ThLevelIndex+thLevelIndexFromImportLevel NormalLevel = topLevelIndex+thLevelIndexFromImportLevel SpliceLevel = spliceLevelIndex+thLevelIndexFromImportLevel QuoteLevel  = quoteLevelIndex
compiler/GHC/Types/Tickish.hs view
@@ -21,11 +21,15 @@   isProfTick,   TickishPlacement(..),   tickishPlace,-  tickishContains+  tickishContains,++  -- * Breakpoint tick identifiers+  BreakpointId(..), BreakTickIndex ) where  import GHC.Prelude import GHC.Data.FastString+import Control.DeepSeq  import GHC.Core.Type @@ -40,7 +44,7 @@ import Language.Haskell.Syntax.Extension ( NoExtField )  import Data.Data-import GHC.Utils.Outputable (Outputable (ppr), text)+import GHC.Utils.Outputable (Outputable (ppr), text, (<+>))  {- ********************************************************************* *                                                                      *@@ -128,7 +132,7 @@   -- and (b) substituting (don't substitute for them)   | Breakpoint     { breakpointExt    :: XBreakpoint pass-    , breakpointId     :: !Int+    , breakpointId     :: !BreakpointId     , breakpointFVs    :: [XTickishId pass]                                 -- ^ the order of this list is important:                                 -- it matches the order of the lists in the@@ -136,7 +140,6 @@                                 --                                 -- Careful about substitution!  See                                 -- Note [substTickish] in "GHC.Core.Subst".-    , breakpointModule :: Module     }    -- | A source note.@@ -171,6 +174,35 @@ deriving instance Ord (GenTickish 'TickishPassCmm) deriving instance Data (GenTickish 'TickishPassCmm) +--------------------------------------------------------------------------------+-- Tick breakpoint index+--------------------------------------------------------------------------------++-- | Breakpoint tick index+-- newtype BreakTickIndex = BreakTickIndex Int+--   deriving (Eq, Ord, Data, Ix, NFData, Outputable)+type BreakTickIndex = Int++-- | Breakpoint identifier.+--+-- Indexes into the structures in the @'ModBreaks'@ created during desugaring+-- (after inserting the breakpoint ticks in the expressions).+-- See Note [Breakpoint identifiers]+data BreakpointId = BreakpointId+  { bi_tick_mod   :: !Module         -- ^ Breakpoint tick module+  , bi_tick_index :: !BreakTickIndex -- ^ Breakpoint tick index+  }+  deriving (Eq, Ord, Data)++instance Outputable BreakpointId where+  ppr BreakpointId{bi_tick_mod, bi_tick_index} =+    text "BreakpointId" <+> ppr bi_tick_mod <+> ppr bi_tick_index++instance NFData BreakpointId where+  rnf BreakpointId{bi_tick_mod, bi_tick_index} =+    rnf bi_tick_mod `seq` rnf bi_tick_index++--------------------------------------------------------------------------------  -- | A "counting tick" (where tickishCounts is True) is one that -- counts evaluations in some way.  We cannot discard a counting tick,
compiler/GHC/Types/TyThing.hs view
@@ -125,7 +125,8 @@     IfaceDecl for the data/newtype.  Ditto class methods.    * Record selectors are *not* implicit, because they get their own-    free-standing IfaceDecl.+    free-standing IfaceDecl. See Note [Record selectors] in+    GHC.Tc.TyCl.Utils.    * Associated data/type families are implicit because they are     included in the IfaceDecl of the parent class.  (NB: the@@ -266,9 +267,9 @@                                           Just (ATyCon tc)                                       RecSelId { sel_tycon = RecSelPatSyn ps } ->                                           Just (AConLike (PatSynCon ps))-                                      ClassOpId cls _             ->+                                      ClassOpId cls _  ->                                           Just (ATyCon (classTyCon cls))-                                      _other                      -> Nothing+                                      _other           -> Nothing tyThingParent_maybe _other = Nothing  tyThingsTyCoVars :: [TyThing] -> TyCoVarSet@@ -355,12 +356,12 @@             RecSelPatSyn ps -> unitUniqSet $ PatSynName (patSynName ps)             RecSelData   tc ->               let dcs = map RealDataCon $ tyConDataCons tc in-              case conLikesWithFields dcs [flLabel fl] of-                ([], _) -> pprPanic "tyThingGREInfo: no DataCons with this FieldLabel" $+              case rsi_def (conLikesRecSelInfo dcs [flLabel fl]) of+                []   -> pprPanic "tyThingGREInfo: no DataCons with this FieldLabel" $                         vcat [ text "id:"  <+> ppr id                              , text "fl:"  <+> ppr fl                              , text "dcs:" <+> ppr dcs ]-                (cons, _) -> mkUniqSet $ map conLikeConLikeName cons+                cons -> mkUniqSet $ map conLikeConLikeName cons        in IAmRecField $             RecFieldInfo               { recFieldLabel = fl
compiler/GHC/Types/TyThing/Ppr.hs view
@@ -192,7 +192,7 @@       | otherwise          = case nameModule_maybe name of              Just mod -> Just $ \occ -> getPprStyle $ \sty ->-               pprModulePrefix sty mod occ <> ppr occ+               pprModulePrefix sty mod Nothing occ <> ppr occ              Nothing  -> warnPprTrace True "pprTyThing" (ppr name) Nothing              -- Nothing is unexpected here; TyThings have External names 
compiler/GHC/Types/Unique.hs view
@@ -302,8 +302,14 @@  showUnique :: Unique -> String showUnique uniq-  = case unpkUnique uniq of-      (tag, u) -> tag : w64ToBase62 u+  = tagStr ++ w64ToBase62 u+  where+    (tag, u) = unpkUnique uniq+    -- Avoid emitting non-printable characters in pretty uniques.+    -- See #25989.+    tagStr+      | tag < 'A' || tag > 'z' = show (ord tag) ++ "_"+      | otherwise              = [tag]  pprUniqueAlways :: IsLine doc => Unique -> doc -- The "always" means regardless of -dsuppress-uniques
compiler/GHC/Types/Unique/FM.hs view
@@ -240,11 +240,13 @@ delFromUFM :: Uniquable key => UniqFM key elt -> key    -> UniqFM key elt delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m) -delListFromUFM :: Uniquable key => UniqFM key elt -> [key] -> UniqFM key elt+delListFromUFM :: (Uniquable key, Foldable f) => UniqFM key elt -> f key -> UniqFM key elt delListFromUFM = foldl' delFromUFM+{-# INLINE delListFromUFM #-} -delListFromUFM_Directly :: UniqFM key elt -> [Unique] -> UniqFM key elt+delListFromUFM_Directly :: Foldable f => UniqFM key elt -> f Unique -> UniqFM key elt delListFromUFM_Directly = foldl' delFromUFM_Directly+{-# INLINE delListFromUFM_Directly #-}  delFromUFM_Directly :: UniqFM key elt -> Unique -> UniqFM key elt delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)
compiler/GHC/Types/Var.hs view
@@ -40,12 +40,12 @@         TyVar, TcTyVar, TypeVar, KindVar, TKVar, TyCoVar,          -- * In and Out variants-        InVar,  InCoVar,  InId,  InTyVar,-        OutVar, OutCoVar, OutId, OutTyVar,+        InVar,  InCoVar,  InId,  InTyVar,  InTyCoVar,+        OutVar, OutCoVar, OutId, OutTyVar, OutTyCoVar,          -- ** Taking 'Var's apart         varName, varUnique, varType,-        varMult, varMultMaybe,+        varMultMaybe, idMult,          -- ** Modifying 'Var's         setVarName, setVarUnique, setVarType,@@ -82,7 +82,8 @@          -- * PiTyBinder         PiTyBinder(..), PiTyVarBinder,-        isInvisiblePiTyBinder, isVisiblePiTyBinder,+        isInvisiblePiTyBinder, isInvisibleAnonPiTyBinder,+        isVisiblePiTyBinder,         isTyBinder, isNamedPiTyBinder, isAnonPiTyBinder,         namedPiTyBinder_maybe, anonPiTyBinderType_maybe, piTyBinderType, @@ -131,6 +132,7 @@  import GHC.Hs.Specificity () import Language.Haskell.Syntax.Specificity+import Control.DeepSeq  import Data.Data @@ -204,10 +206,12 @@ type InVar      = Var type InTyVar    = TyVar type InCoVar    = CoVar+type InTyCoVar  = TyCoVar type InId       = Id type OutVar     = Var type OutTyVar   = TyVar type OutCoVar   = CoVar+type OutTyCoVar = TyCoVar type OutId      = Id  @@ -416,6 +420,10 @@ varMultMaybe (Id { varMult = mult }) = Just mult varMultMaybe _ = Nothing +idMult :: HasDebugCallStack => Id -> Mult+idMult (Id { varMult = mult }) = mult+idMult non_id                  = pprPanic "idMult" (ppr non_id)+ setVarUnique :: Var -> Unique -> Var setVarUnique var uniq   = var { realUnique = uniq,@@ -492,6 +500,12 @@       2 -> return FTF_C_T       _ -> return FTF_C_C +instance NFData FunTyFlag where+  rnf FTF_T_T = ()+  rnf FTF_T_C = ()+  rnf FTF_C_T = ()+  rnf FTF_C_C = ()+ mkFunTyFlag :: TypeOrConstraint -> TypeOrConstraint -> FunTyFlag mkFunTyFlag TypeLike       torc = visArg torc mkFunTyFlag ConstraintLike torc = invisArg torc@@ -558,11 +572,11 @@      False           True          FTF_T_C      True            False         FTF_C_T      True            True          FTF_C_C-where isPredTy is defined in GHC.Core.Type, and sees if t1's+where isPredTy is defined in GHC.Core.Predicate, and sees if t1's kind is Constraint.  See GHC.Core.Type.chooseFunTyFlag, and-GHC.Core.TyCo.Rep Note [Types for coercions, predicates, and evidence]+GHC.Core.Predicate Note [Types for coercions, predicates, and evidence] -The term (Lam b e) donesn't carry an FunTyFlag; instead it uses+The term (Lam b e) doesn't carry an FunTyFlag; instead it uses mkFunctionType when we want to get its types; see mkLamType.  This is just an engineering choice; we could cache here too if we wanted. @@ -727,6 +741,9 @@    get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) } +instance (NFData tv, NFData vis) => NFData (VarBndr tv vis) where+  rnf (Bndr tv vis) = rnf tv `seq` rnf vis+ instance NamedThing tv => NamedThing (VarBndr tv flag) where   getName (Bndr tv _) = getName tv @@ -752,7 +769,6 @@   ppr (Named (Bndr v Specified)) = char '@' <> ppr v   ppr (Named (Bndr v Inferred))  = braces (ppr v) - -- | 'PiTyVarBinder' is like 'PiTyBinder', but there can only be 'TyVar' -- in the 'Named' field. type PiTyVarBinder = PiTyBinder@@ -762,6 +778,10 @@ isInvisiblePiTyBinder (Named (Bndr _ vis)) = isInvisibleForAllTyFlag vis isInvisiblePiTyBinder (Anon _ af)          = isInvisibleFunArg af +isInvisibleAnonPiTyBinder :: PiTyBinder -> Bool+isInvisibleAnonPiTyBinder (Named {})  = False+isInvisibleAnonPiTyBinder (Anon _ af) = isInvisibleFunArg af+ -- | Does this binder bind a visible argument? isVisiblePiTyBinder :: PiTyBinder -> Bool isVisiblePiTyBinder = not . isInvisiblePiTyBinder@@ -1054,7 +1074,7 @@ idInfo (Id { id_info = info }) = info idInfo other                   = pprPanic "idInfo" (ppr other) -idDetails :: Id -> IdDetails+idDetails :: HasCallStack => Id -> IdDetails idDetails (Id { id_details = details }) = details idDetails other                         = pprPanic "idDetails" (ppr other) 
compiler/GHC/Types/Var.hs-boot view
@@ -2,7 +2,7 @@ module GHC.Types.Var where  import {-# SOURCE #-} GHC.Types.Name-import Language.Haskell.Syntax.Specificity (Specificity)+import Language.Haskell.Syntax.Specificity (Specificity, ForAllTyFlag)  data FunTyFlag data Var@@ -13,3 +13,4 @@ type TyCoVar = Id type TcTyVar = Var type InvisTVBinder = VarBndr TyVar Specificity+type TyVarBinder   = VarBndr TyVar ForAllTyFlag
compiler/GHC/Types/Var/Env.hs view
@@ -74,7 +74,8 @@          -- * TidyEnv and its operation         TidyEnv,-        emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList+        emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList,+        mapMaybeDVarEnv     ) where  import GHC.Prelude@@ -517,7 +518,7 @@ partitionVarEnv   :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a) -- | Only keep variables contained in the VarSet restrictVarEnv    :: VarEnv a -> VarSet -> VarEnv a-delVarEnvList     :: VarEnv a -> [Var] -> VarEnv a+delVarEnvList     :: Foldable f => VarEnv a -> f Var -> VarEnv a delVarEnv         :: VarEnv a -> Var -> VarEnv a minusVarEnv       :: VarEnv a -> VarEnv b -> VarEnv a plusVarEnv_C      :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a@@ -550,6 +551,8 @@ plusVarEnv_CD    = plusUFM_CD plusMaybeVarEnv_C = plusMaybeUFM_C delVarEnvList    = delListFromUFM+-- INLINE due to polymorphism+{-# INLINE delVarEnvList #-} delVarEnv        = delFromUFM minusVarEnv      = minusUFM plusVarEnv       = plusUFM@@ -579,7 +582,7 @@   where     keep u _ = u `elemVarSetByKey` vs -zipVarEnv tyvars tys   = mkVarEnv (zipEqual "zipVarEnv" tyvars tys)+zipVarEnv tyvars tys   = mkVarEnv (zipEqual tyvars tys) lookupVarEnv_NF env id = case lookupVarEnv env id of                          Just xx -> xx                          Nothing -> panic "lookupVarEnv_NF: Nothing"@@ -653,6 +656,9 @@  filterDVarEnv      :: (a -> Bool) -> DVarEnv a -> DVarEnv a filterDVarEnv = filterUDFM++mapMaybeDVarEnv :: (a -> Maybe b) -> DVarEnv a -> DVarEnv b+mapMaybeDVarEnv f = mapMaybeUDFM f  alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a alterDVarEnv = alterUDFM
compiler/GHC/Unit/Env.hs view
@@ -1,89 +1,162 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-}++-- | A 'UnitEnv' provides the complete interface into everything that is loaded+-- into a GHC session, including the 'HomeUnitGraph' for mapping home units to their+-- 'HomePackageTable's (which store information about all home modules), and+-- the 'ExternalPackageState' which provides access to all external packages+-- loaded.+--+-- This module is meant to be imported as @UnitEnv@ when calling @insertHpt@:+--+-- @+-- import GHC.Unit.Env (UnitEnv, HomeUnitGraph, HomeUnitEnv)+-- import GHC.Unit.Env as UnitEnv+-- @+--+-- Here is an overview of how the UnitEnv, ModuleGraph, HUG, HPT, and EPS interact:+--+-- @+-- ┌────────────────┐┌────────────────────┐┌───────────┐+-- │HomePackageTable││ExternalPackageState││ModuleGraph│+-- └┬───────────────┘└┬───────────────────┘└┬──────────┘+-- ┌▽────────────┐    │                     │+-- │HomeUnitGraph│    │                     │+-- └┬────────────┘    │                     │+-- ┌▽─────────────────▽─────────────────────▽┐+-- │UnitEnv                                  │+-- └┬─────────────-──────────────────────────┘+--  │+--  │+-- ┌▽──────────────────────────────────────▽┐+-- │HscEnv                                  │+-- └────────────────────────────────────────┘+-- @+--+-- The 'UnitEnv' references the 'HomeUnitGraph' (with all the home unit+-- modules), the 'ExternalPackageState' (information about all+-- non-home/external units), and the 'ModuleGraph' (which describes the+-- relationship between the modules being compiled).+-- The 'HscEnv' references this 'UnitEnv'.+-- The 'HomeUnitGraph' has one 'HomePackageTable' for every unit. module GHC.Unit.Env     ( UnitEnv (..)     , initUnitEnv-    , ueEPS-    , unsafeGetHomeUnit+    , ueEPS -- Not really needed, get directly type families and rule base!     , updateHug-    , updateHpt_lazy-    , updateHpt     -- * Unit Env helper functions-    , ue_units     , ue_currentHomeUnitEnv-    , ue_setUnits-    , ue_setUnitFlags-    , ue_unit_dbs-    , ue_all_home_unit_ids-    , ue_setUnitDbs     , ue_hpt-    , ue_homeUnit-    , ue_unsafeHomeUnit-    , ue_setFlags     , ue_setActiveUnit     , ue_currentUnit     , ue_findHomeUnitEnv-    , ue_updateHomeUnitEnv     , ue_unitHomeUnit-    , ue_unitFlags-    , ue_renameUnitId-    , ue_transitiveHomeDeps-    -- * HomeUnitEnv+    , ue_unitHomeUnit_maybe+    , ue_updateHomeUnitEnv+    , ue_all_home_unit_ids+    , ue_unsafeHomeUnit++    -- * HUG Re-export     , HomeUnitGraph     , HomeUnitEnv (..)-    , mkHomeUnitEnv-    , lookupHugByModule-    , hugElts-    , lookupHug-    , addHomeModInfoToHug-    -- * UnitEnvGraph-    , UnitEnvGraph (..)-    , UnitEnvGraphKey-    , unitEnv_insert-    , unitEnv_delete-    , unitEnv_adjust-    , unitEnv_new-    , unitEnv_singleton-    , unitEnv_map-    , unitEnv_member-    , unitEnv_lookup_maybe-    , unitEnv_lookup-    , unitEnv_keys-    , unitEnv_elts-    , unitEnv_hpts-    , unitEnv_foldWithKey-    , unitEnv_union-    , unitEnv_mapWithKey+     -- * Invariants     , assertUnitEnvInvariant     -- * Preload units info     , preloadUnitsInfo     , preloadUnitsInfo'     -- * Home Module functions-    , isUnitEnvInstalledModule )+    , isUnitEnvInstalledModule++    --------------------------------------------------------------------------------+    -- WIP above+    --------------------------------------------------------------------------------++    -- * Operations on the UnitEnv+    , renameUnitId++    -- ** Modifying the current active home unit+    , insertHpt+    , ue_setFlags++    -- * Queries++    -- ** Queries on the current active home unit+    , ue_homeUnitState+    , ue_unit_dbs+    , ue_homeUnit+    , ue_unitFlags++    -- ** Reachability+    , ue_transitiveHomeDeps++    --------------------------------------------------------------------------------+    -- Harder queries for the whole UnitEnv+    --------------------------------------------------------------------------------++    -- ** Instances, rules, type fams, annotations, etc..+    --+    -- | The @hug@ prefix means the function returns only things found in home+    -- units.+    , hugCompleteSigs+    , hugAllInstances+    , hugAllAnns++    -- * Legacy API+    --+    -- | This API is deprecated!+    , ue_units+    ) where  import GHC.Prelude+import qualified Data.Set as Set  import GHC.Unit.External import GHC.Unit.State import GHC.Unit.Home import GHC.Unit.Types import GHC.Unit.Home.ModInfo+import GHC.Unit.Home.PackageTable+import GHC.Unit.Home.Graph (HomeUnitGraph, HomeUnitEnv)+import qualified GHC.Unit.Home.Graph as HUG+import GHC.Unit.Module.Graph  import GHC.Platform import GHC.Settings import GHC.Data.Maybe-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map import GHC.Utils.Misc (HasDebugCallStack) import GHC.Driver.DynFlags import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Unit.Module.ModIface-import GHC.Unit.Module-import qualified Data.Set as Set +import GHC.Types.Annotations+import GHC.Types.CompleteMatch+import GHC.Core.InstEnv+import GHC.Core.FamInstEnv++--------------------------------------------------------------------------------+-- The hard queries+--------------------------------------------------------------------------------++-- | Find all the instance declarations (of classes and families) from+-- the Home Package Table filtered by the provided predicate function.+hugAllInstances :: UnitEnv -> IO (InstEnv, [FamInst])+hugAllInstances = HUG.allInstances . ue_home_unit_graph++-- | Find all the annotations in all home units+hugAllAnns :: UnitEnv -> IO AnnEnv+hugAllAnns = HUG.allAnns . ue_home_unit_graph++-- | Get all 'CompleteMatches' (arising from COMPLETE pragmas) present across+-- all home units.+hugCompleteSigs :: UnitEnv -> IO CompleteMatches+hugCompleteSigs = HUG.allCompleteSigs . ue_home_unit_graph++--------------------------------------------------------------------------------+-- UnitEnv+--------------------------------------------------------------------------------+ data UnitEnv = UnitEnv     { ue_eps :: {-# UNPACK #-} !ExternalUnitCache         -- ^ Information about the currently loaded external packages.@@ -92,6 +165,10 @@      , ue_current_unit    :: UnitId +    , ue_module_graph    :: ModuleGraph+        -- ^ The module graph of the current session+        -- See Note [Downsweep and the ModuleGraph] for when this is constructed.+     , ue_home_unit_graph :: !HomeUnitGraph         -- See Note [Multiple Home Units] @@ -111,39 +188,18 @@   return $ UnitEnv     { ue_eps             = eps     , ue_home_unit_graph = hug+    , ue_module_graph    = emptyMG     , ue_current_unit    = cur_unit     , ue_platform        = platform     , ue_namever         = namever     } --- | Get home-unit------ Unsafe because the home-unit may not be set-unsafeGetHomeUnit :: UnitEnv -> HomeUnit-unsafeGetHomeUnit ue = ue_unsafeHomeUnit ue--updateHpt_lazy :: (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv-updateHpt_lazy = ue_updateHPT_lazy--updateHpt :: (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv-updateHpt = ue_updateHPT- updateHug :: (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv updateHug = ue_updateHUG -ue_transitiveHomeDeps :: UnitId -> UnitEnv -> [UnitId]-ue_transitiveHomeDeps uid unit_env = Set.toList (loop Set.empty [uid])-  where-    loop acc [] = acc-    loop acc (uid:uids)-      | uid `Set.member` acc = loop acc uids-      | otherwise =-        let hue = homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env))-        in loop (Set.insert uid acc) (hue ++ uids)-- -- ----------------------------------------------------------------------------- -- Extracting information from the packages in scope+-- -----------------------------------------------------------------------------  -- Many of these functions take a list of packages: in those cases, -- the list is expected to contain the "dependent packages",@@ -159,7 +215,7 @@ preloadUnitsInfo' :: UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo] preloadUnitsInfo' unit_env ids0 = all_infos   where-    unit_state = ue_units unit_env+    unit_state = HUG.homeUnitEnv_units (ue_currentHomeUnitEnv unit_env)     ids      = ids0 ++ inst_ids     inst_ids = case ue_homeUnit unit_env of       Nothing -> []@@ -181,226 +237,50 @@ preloadUnitsInfo :: UnitEnv -> MaybeErr UnitErr [UnitInfo] preloadUnitsInfo unit_env = preloadUnitsInfo' unit_env [] --- -------------------------------------------------------------------------------data HomeUnitEnv = HomeUnitEnv-  { homeUnitEnv_units     :: !UnitState-      -- ^ External units--  , homeUnitEnv_unit_dbs :: !(Maybe [UnitDatabase UnitId])-      -- ^ Stack of unit databases for the target platform.-      ---      -- This field is populated with the result of `initUnits`.-      ---      -- 'Nothing' means the databases have never been read from disk.-      ---      -- Usually we don't reload the databases from disk if they are-      -- cached, even if the database flags changed!--  , homeUnitEnv_dflags :: DynFlags-    -- ^ The dynamic flag settings-  , homeUnitEnv_hpt :: HomePackageTable-    -- ^ The home package table describes already-compiled-    -- home-package modules, /excluding/ the module we-    -- are compiling right now.-    -- (In one-shot mode the current module is the only-    -- home-package module, so homeUnitEnv_hpt is empty.  All other-    -- modules count as \"external-package\" modules.-    -- However, even in GHCi mode, hi-boot interfaces are-    -- demand-loaded into the external-package table.)-    ---    -- 'homeUnitEnv_hpt' is not mutable because we only demand-load-    -- external packages; the home package is eagerly-    -- loaded, module by module, by the compilation manager.-    ---    -- The HPT may contain modules compiled earlier by @--make@-    -- but not actually below the current module in the dependency-    -- graph.-    ---    -- (This changes a previous invariant: changed Jan 05.)--  , homeUnitEnv_home_unit :: !(Maybe HomeUnit)-    -- ^ Home-unit-  }--instance Outputable HomeUnitEnv where-  ppr hug = pprHPT (homeUnitEnv_hpt hug)--homeUnitEnv_unsafeHomeUnit :: HomeUnitEnv -> HomeUnit-homeUnitEnv_unsafeHomeUnit hue = case homeUnitEnv_home_unit hue of-  Nothing -> panic "homeUnitEnv_unsafeHomeUnit: No home unit"-  Just h  -> h--mkHomeUnitEnv :: DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv-mkHomeUnitEnv dflags hpt home_unit = HomeUnitEnv-  { homeUnitEnv_units = emptyUnitState-  , homeUnitEnv_unit_dbs = Nothing-  , homeUnitEnv_dflags = dflags-  , homeUnitEnv_hpt = hpt-  , homeUnitEnv_home_unit = home_unit-  }---- | Test if the module comes from the home unit+-- -- | Test if the module comes from the home unit isUnitEnvInstalledModule :: UnitEnv -> InstalledModule -> Bool isUnitEnvInstalledModule ue m = maybe False (`isHomeInstalledModule` m) hu   where     hu = ue_unitHomeUnit_maybe (moduleUnit m) ue --type HomeUnitGraph = UnitEnvGraph HomeUnitEnv--lookupHugByModule :: Module -> HomeUnitGraph -> Maybe HomeModInfo-lookupHugByModule mod hug-  | otherwise = do-      env <- (unitEnv_lookup_maybe (toUnitId $ moduleUnit mod) hug)-      lookupHptByModule (homeUnitEnv_hpt env) mod--hugElts :: HomeUnitGraph -> [(UnitId, HomeUnitEnv)]-hugElts hug = unitEnv_elts hug--addHomeModInfoToHug :: HomeModInfo -> HomeUnitGraph -> HomeUnitGraph-addHomeModInfoToHug hmi hug = unitEnv_alter go hmi_unit hug-  where-    hmi_mod :: Module-    hmi_mod = mi_module (hm_iface hmi)--    hmi_unit = toUnitId (moduleUnit hmi_mod)-    _hmi_mn   = moduleName hmi_mod--    go :: Maybe HomeUnitEnv -> Maybe HomeUnitEnv-    go Nothing = pprPanic "addHomeInfoToHug" (ppr hmi_mod)-    go (Just hue) = Just (updateHueHpt (addHomeModInfoToHpt hmi) hue)--updateHueHpt :: (HomePackageTable -> HomePackageTable) -> HomeUnitEnv -> HomeUnitEnv-updateHueHpt f hue =-  let !hpt =  f (homeUnitEnv_hpt hue)-  in hue { homeUnitEnv_hpt = hpt }---lookupHug :: HomeUnitGraph -> UnitId -> ModuleName -> Maybe HomeModInfo-lookupHug hug uid mod = unitEnv_lookup_maybe uid hug >>= flip lookupHpt mod . homeUnitEnv_hpt---instance Outputable (UnitEnvGraph HomeUnitEnv) where-  ppr g = ppr [(k, length (homeUnitEnv_hpt  hue)) | (k, hue) <- (unitEnv_elts g)]---type UnitEnvGraphKey = UnitId--newtype UnitEnvGraph v = UnitEnvGraph-  { unitEnv_graph :: Map UnitEnvGraphKey v-  } deriving (Functor, Foldable, Traversable)--unitEnv_insert :: UnitEnvGraphKey -> v -> UnitEnvGraph v -> UnitEnvGraph v-unitEnv_insert unitId env unitEnv = unitEnv-  { unitEnv_graph = Map.insert unitId env (unitEnv_graph unitEnv)-  }--unitEnv_delete :: UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v-unitEnv_delete uid unitEnv =-    unitEnv-      { unitEnv_graph = Map.delete uid (unitEnv_graph unitEnv)-      }--unitEnv_adjust :: (v -> v) -> UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v-unitEnv_adjust f uid unitEnv = unitEnv-  { unitEnv_graph = Map.adjust f uid (unitEnv_graph unitEnv)-  }--unitEnv_alter :: (Maybe v -> Maybe v) -> UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v-unitEnv_alter f uid unitEnv = unitEnv-  { unitEnv_graph = Map.alter f uid (unitEnv_graph unitEnv)-  }--unitEnv_mapWithKey :: (UnitEnvGraphKey -> v -> b) -> UnitEnvGraph v -> UnitEnvGraph b-unitEnv_mapWithKey f (UnitEnvGraph u) = UnitEnvGraph $ Map.mapWithKey f u--unitEnv_new :: Map UnitEnvGraphKey v -> UnitEnvGraph v-unitEnv_new m =-  UnitEnvGraph-    { unitEnv_graph = m-    }--unitEnv_singleton :: UnitEnvGraphKey -> v -> UnitEnvGraph v-unitEnv_singleton active m = UnitEnvGraph-  { unitEnv_graph = Map.singleton active m-  }--unitEnv_map :: (v -> v) -> UnitEnvGraph v -> UnitEnvGraph v-unitEnv_map f m = m { unitEnv_graph = Map.map f (unitEnv_graph m)}--unitEnv_member :: UnitEnvGraphKey -> UnitEnvGraph v -> Bool-unitEnv_member u env = Map.member u (unitEnv_graph env)--unitEnv_lookup_maybe :: UnitEnvGraphKey -> UnitEnvGraph v -> Maybe v-unitEnv_lookup_maybe u env = Map.lookup u (unitEnv_graph env)--unitEnv_lookup :: UnitEnvGraphKey -> UnitEnvGraph v -> v-unitEnv_lookup u env = fromJust $ unitEnv_lookup_maybe u env--unitEnv_keys :: UnitEnvGraph v -> Set.Set UnitEnvGraphKey-unitEnv_keys env = Map.keysSet (unitEnv_graph env)--unitEnv_elts :: UnitEnvGraph v -> [(UnitEnvGraphKey, v)]-unitEnv_elts env = Map.toList (unitEnv_graph env)--unitEnv_hpts :: UnitEnvGraph HomeUnitEnv -> [HomePackageTable]-unitEnv_hpts env = map homeUnitEnv_hpt (Map.elems (unitEnv_graph env))--unitEnv_foldWithKey :: (b -> UnitEnvGraphKey -> a -> b) -> b -> UnitEnvGraph a -> b-unitEnv_foldWithKey f z (UnitEnvGraph g)= Map.foldlWithKey' f z g+-- -------------------------------------------------------+-- Operations on arbitrary elements of the home unit graph+-- ------------------------------------------------------- -unitEnv_union :: (a -> a -> a) -> UnitEnvGraph a -> UnitEnvGraph a -> UnitEnvGraph a-unitEnv_union f (UnitEnvGraph env1) (UnitEnvGraph env2) = UnitEnvGraph (Map.unionWith f env1 env2)+ue_findHomeUnitEnv :: HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv+ue_findHomeUnitEnv uid e = case HUG.lookupHugUnitId uid (ue_home_unit_graph e) of+  Nothing -> pprPanic "Unit unknown to the internal unit environment"+              $  text "unit (" <> ppr uid <> text ")"+              $$ ppr (HUG.allUnits (ue_home_unit_graph e))+  Just hue -> hue  -- ---------------------------------------------------------- Query and modify UnitState in HomeUnitEnv+-- Query and modify UnitState of active unit in HomeUnitEnv -- ------------------------------------------------------- -ue_units :: HasDebugCallStack => UnitEnv -> UnitState-ue_units = homeUnitEnv_units . ue_currentHomeUnitEnv--ue_setUnits :: UnitState -> UnitEnv -> UnitEnv-ue_setUnits units ue = ue_updateHomeUnitEnv f (ue_currentUnit ue) ue-  where-    f hue = hue { homeUnitEnv_units = units  }+ue_homeUnitState :: HasDebugCallStack => UnitEnv -> UnitState+ue_homeUnitState = HUG.homeUnitEnv_units . ue_currentHomeUnitEnv  ue_unit_dbs :: UnitEnv ->  Maybe [UnitDatabase UnitId]-ue_unit_dbs = homeUnitEnv_unit_dbs . ue_currentHomeUnitEnv--ue_setUnitDbs :: Maybe [UnitDatabase UnitId] -> UnitEnv -> UnitEnv-ue_setUnitDbs unit_dbs ue = ue_updateHomeUnitEnv f (ue_currentUnit ue) ue-  where-    f hue = hue { homeUnitEnv_unit_dbs = unit_dbs  }+ue_unit_dbs = HUG.homeUnitEnv_unit_dbs . ue_currentHomeUnitEnv  -- ------------------------------------------------------- -- Query and modify Home Package Table in HomeUnitEnv -- ------------------------------------------------------- +-- | Get the /current home unit/'s package table ue_hpt :: HasDebugCallStack => UnitEnv -> HomePackageTable-ue_hpt = homeUnitEnv_hpt . ue_currentHomeUnitEnv--ue_updateHPT_lazy :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv-ue_updateHPT_lazy f e = ue_updateUnitHPT_lazy f (ue_currentUnit e) e+ue_hpt = HUG.homeUnitEnv_hpt . ue_currentHomeUnitEnv -ue_updateHPT :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv-ue_updateHPT f e = ue_updateUnitHPT f (ue_currentUnit e) e+-- | Inserts a 'HomeModInfo' at the given 'ModuleName' on the+-- 'HomePackageTable' of the /current unit/ being compiled.+insertHpt :: HasDebugCallStack => HomeModInfo -> UnitEnv -> IO ()+insertHpt hmi e = do+  HUG.addHomeModInfoToHug hmi (ue_home_unit_graph e)  ue_updateHUG :: HasDebugCallStack => (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv ue_updateHUG f e = ue_updateUnitHUG f e -ue_updateUnitHPT_lazy :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitId -> UnitEnv -> UnitEnv-ue_updateUnitHPT_lazy f uid ue_env = ue_updateHomeUnitEnv update uid ue_env-  where-    update unitEnv = unitEnv { homeUnitEnv_hpt = f $ homeUnitEnv_hpt unitEnv }--ue_updateUnitHPT :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitId -> UnitEnv -> UnitEnv-ue_updateUnitHPT f uid ue_env = ue_updateHomeUnitEnv update uid ue_env-  where-    update unitEnv =-      let !res = f $ homeUnitEnv_hpt unitEnv-      in unitEnv { homeUnitEnv_hpt = res }- ue_updateUnitHUG :: HasDebugCallStack => (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv ue_updateUnitHUG f ue_env = ue_env { ue_home_unit_graph = f (ue_home_unit_graph ue_env)} @@ -408,52 +288,48 @@ -- Query and modify DynFlags in HomeUnitEnv -- ------------------------------------------------------- -ue_setFlags :: HasDebugCallStack => DynFlags -> UnitEnv -> UnitEnv-ue_setFlags dflags ue_env = ue_setUnitFlags (ue_currentUnit ue_env) dflags ue_env--ue_setUnitFlags :: HasDebugCallStack => UnitId -> DynFlags -> UnitEnv -> UnitEnv-ue_setUnitFlags uid dflags e =-  ue_updateUnitFlags (const dflags) uid e- ue_unitFlags :: HasDebugCallStack => UnitId -> UnitEnv -> DynFlags-ue_unitFlags uid ue_env = homeUnitEnv_dflags $ ue_findHomeUnitEnv uid ue_env+ue_unitFlags uid ue_env = HUG.homeUnitEnv_dflags $ ue_findHomeUnitEnv uid ue_env -ue_updateUnitFlags :: HasDebugCallStack => (DynFlags -> DynFlags) -> UnitId -> UnitEnv -> UnitEnv-ue_updateUnitFlags f uid e = ue_updateHomeUnitEnv update uid e-  where-    update hue = hue { homeUnitEnv_dflags = f $ homeUnitEnv_dflags hue }+-- | Sets the 'DynFlags' of the /current unit/ being compiled to the given ones+ue_setFlags :: HasDebugCallStack => DynFlags -> UnitEnv -> UnitEnv+ue_setFlags dflags env =+  env+    { ue_home_unit_graph = HUG.updateUnitFlags+                            (ue_currentUnit env)+                            (const dflags)+                            (ue_home_unit_graph env)+    }  -- ------------------------------------------------------- -- Query and modify home units in HomeUnitEnv -- -------------------------------------------------------  ue_homeUnit :: UnitEnv -> Maybe HomeUnit-ue_homeUnit = homeUnitEnv_home_unit . ue_currentHomeUnitEnv+ue_homeUnit = HUG.homeUnitEnv_home_unit . ue_currentHomeUnitEnv  ue_unsafeHomeUnit :: UnitEnv -> HomeUnit ue_unsafeHomeUnit ue = case ue_homeUnit ue of-  Nothing -> panic "unsafeGetHomeUnit: No home unit"+  Nothing -> panic "ue_unsafeHomeUnit: No home unit"   Just h  -> h +ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit+ue_unitHomeUnit uid = expectJust . ue_unitHomeUnit_maybe uid+ ue_unitHomeUnit_maybe :: UnitId -> UnitEnv -> Maybe HomeUnit ue_unitHomeUnit_maybe uid ue_env =-  homeUnitEnv_unsafeHomeUnit <$> (ue_findHomeUnitEnv_maybe uid ue_env)--ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit-ue_unitHomeUnit uid ue_env = homeUnitEnv_unsafeHomeUnit $ ue_findHomeUnitEnv uid ue_env+  HUG.homeUnitEnv_home_unit =<< HUG.lookupHugUnitId uid (ue_home_unit_graph ue_env) -ue_all_home_unit_ids :: UnitEnv -> Set.Set UnitId-ue_all_home_unit_ids = unitEnv_keys . ue_home_unit_graph -- ------------------------------------------------------- -- Query and modify the currently active unit -- -------------------------------------------------------  ue_currentHomeUnitEnv :: HasDebugCallStack => UnitEnv -> HomeUnitEnv ue_currentHomeUnitEnv e =-  case ue_findHomeUnitEnv_maybe (ue_currentUnit e) e of+  case HUG.lookupHugUnitId (ue_currentUnit e) (ue_home_unit_graph e) of     Just unitEnv -> unitEnv     Nothing -> pprPanic "packageNotFound" $-      (ppr $ ue_currentUnit e) $$ ppr (ue_home_unit_graph e)+      (ppr $ ue_currentUnit e) $$ ppr (HUG.allUnits (ue_home_unit_graph e))  ue_setActiveUnit :: UnitId -> UnitEnv -> UnitEnv ue_setActiveUnit u ue_env = assertUnitEnvInvariant $ ue_env@@ -464,84 +340,75 @@ ue_currentUnit = ue_current_unit  --- ---------------------------------------------------------- Operations on arbitrary elements of the home unit graph--- ---------------------------------------------------------ue_findHomeUnitEnv_maybe :: UnitId -> UnitEnv -> Maybe HomeUnitEnv-ue_findHomeUnitEnv_maybe uid e =-  unitEnv_lookup_maybe uid (ue_home_unit_graph e)--ue_findHomeUnitEnv :: HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv-ue_findHomeUnitEnv uid e = case unitEnv_lookup_maybe uid (ue_home_unit_graph e) of-  Nothing -> pprPanic "Unit unknown to the internal unit environment"-              $  text "unit (" <> ppr uid <> text ")"-              $$ pprUnitEnvGraph e-  Just hue -> hue- ue_updateHomeUnitEnv :: (HomeUnitEnv -> HomeUnitEnv) -> UnitId -> UnitEnv -> UnitEnv ue_updateHomeUnitEnv f uid e = e-  { ue_home_unit_graph = unitEnv_adjust f uid $ ue_home_unit_graph e+  { ue_home_unit_graph = HUG.unitEnv_adjust f uid $ ue_home_unit_graph e   } +ue_all_home_unit_ids :: UnitEnv -> Set.Set UnitId+ue_all_home_unit_ids = HUG.allUnits . ue_home_unit_graph  -- | Rename a unit id in the internal unit env. ----- @'ue_renameUnitId' oldUnit newUnit UnitEnv@, it is assumed that the 'oldUnit' exists in the map,+-- @'renameUnitId' oldUnit newUnit UnitEnv@, it is assumed that the 'oldUnit' exists in the home units map, -- otherwise we panic. -- The 'DynFlags' associated with the home unit will have its field 'homeUnitId' set to 'newUnit'.-ue_renameUnitId :: HasDebugCallStack => UnitId -> UnitId -> UnitEnv -> UnitEnv-ue_renameUnitId oldUnit newUnit unitEnv = case ue_findHomeUnitEnv_maybe oldUnit unitEnv of-  Nothing ->-    pprPanic "Tried to rename unit, but it didn't exist"-              $ text "Rename old unit \"" <> ppr oldUnit <> text "\" to \""<> ppr newUnit <> text "\""-              $$ nest 2 (pprUnitEnvGraph unitEnv)-  Just oldEnv ->-    let-      activeUnit :: UnitId-      !activeUnit = if ue_currentUnit unitEnv == oldUnit-                then newUnit-                else ue_currentUnit unitEnv+renameUnitId :: HasDebugCallStack => UnitId -> UnitId -> UnitEnv -> UnitEnv+renameUnitId oldUnit newUnit unitEnv =+  case HUG.renameUnitId oldUnit newUnit (ue_home_unit_graph unitEnv) of+    Nothing ->+      pprPanic "Tried to rename unit, but it didn't exist"+                $ text "Rename old unit \"" <> ppr oldUnit <> text "\" to \""<> ppr newUnit <> text "\""+                $$ nest 2 (ppr $ HUG.allUnits (ue_home_unit_graph unitEnv))+    Just newHug ->+      let+        activeUnit :: UnitId+        !activeUnit = if ue_currentUnit unitEnv == oldUnit+                  then newUnit+                  else ue_currentUnit unitEnv -      newInternalUnitEnv = oldEnv-        { homeUnitEnv_dflags = (homeUnitEnv_dflags oldEnv)-            { homeUnitId_ = newUnit-            }+      in+      unitEnv+        { ue_current_unit = activeUnit+        , ue_home_unit_graph =+            HUG.updateUnitFlags+              newUnit+              (\df -> df{ homeUnitId_ = newUnit })+              newHug         }-    in-    unitEnv-      { ue_current_unit = activeUnit-      , ue_home_unit_graph =-          unitEnv_insert newUnit newInternalUnitEnv-          $ unitEnv_delete oldUnit-          $ ue_home_unit_graph unitEnv-          }  -- ---------------------------------------------+-- Transitive closure+-- ---------------------------------------------++ue_transitiveHomeDeps :: UnitId -> UnitEnv -> [UnitId]+ue_transitiveHomeDeps uid e =+  case HUG.transitiveHomeDeps uid (ue_home_unit_graph e) of+    Nothing -> pprPanic "Unit unknown to the internal unit environment"+                $  text "unit (" <> ppr uid <> text ")"+                $$ ppr (HUG.allUnits $ ue_home_unit_graph e)+    Just deps -> deps++-- --------------------------------------------- -- Asserts to enforce invariants for the UnitEnv -- --------------------------------------------- +-- FIXME: Shouldn't this be a proper assertion only used in debug mode? assertUnitEnvInvariant :: HasDebugCallStack => UnitEnv -> UnitEnv assertUnitEnvInvariant u =-  if ue_current_unit u `unitEnv_member` ue_home_unit_graph u-    then u-    else pprPanic "invariant" (ppr (ue_current_unit u) $$ ppr (ue_home_unit_graph u))+  case HUG.lookupHugUnitId (ue_current_unit u) (ue_home_unit_graph u) of+    Just _ -> u+    Nothing ->+      pprPanic "invariant" (ppr (ue_current_unit u) $$ ppr (HUG.allUnits (ue_home_unit_graph u)))  -- ----------------------------------------------------------------------------- -- Pretty output functions -- ----------------------------------------------------------------------------- -pprUnitEnvGraph :: UnitEnv -> SDoc-pprUnitEnvGraph env = text "pprInternalUnitMap"-  $$ nest 2 (pprHomeUnitGraph $ ue_home_unit_graph env)--pprHomeUnitGraph :: HomeUnitGraph -> SDoc-pprHomeUnitGraph unitEnv = vcat (map (\(k, v) -> pprHomeUnitEnv k v) $ Map.assocs $ unitEnv_graph unitEnv)--pprHomeUnitEnv :: UnitId -> HomeUnitEnv -> SDoc-pprHomeUnitEnv uid env =-  ppr uid <+> text "(flags:" <+> ppr (homeUnitId_ $ homeUnitEnv_dflags env) <> text "," <+> ppr (fmap homeUnitId $ homeUnitEnv_home_unit env) <> text ")" <+> text "->"-  $$ nest 4 (pprHPT $ homeUnitEnv_hpt env)+-- pprUnitEnvGraph :: UnitEnv -> IO SDoc+-- pprUnitEnvGraph env = do+--   hugDoc <- HUG.pprHomeUnitGraph $ ue_home_unit_graph env+--   return $ text "pprInternalUnitMap" $$ nest 2 hugDoc  {- Note [Multiple Home Units]@@ -595,3 +462,12 @@ in order to allow users to offset their own relative paths.  -}++--------------------------------------------------------------------------------+-- * Legacy API+--------------------------------------------------------------------------------++{-# DEPRECATED ue_units "Renamed to ue_homeUnitState because of confusion between units(tate) and unit(s) plural" #-}+ue_units :: HasDebugCallStack => UnitEnv -> UnitState+ue_units = ue_homeUnitState+
compiler/GHC/Unit/Finder/Types.hs view
@@ -30,9 +30,9 @@                                -- ^ remove all the home modules from the cache; package modules are                                -- assumed to not move around during a session; also flush the file hash                                -- cache.-                               , addToFinderCache  :: InstalledModuleWithIsBoot -> InstalledFindResult -> IO ()+                               , addToFinderCache  :: InstalledModule -> InstalledFindResult -> IO ()                                -- ^ Add a found location to the cache for the module.-                               , lookupFinderCache :: InstalledModuleWithIsBoot -> IO (Maybe InstalledFindResult)+                               , lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult)                                -- ^ Look for a location in the cache.                                , lookupFileCache   :: FilePath -> IO Fingerprint                                -- ^ Look for the hash of a file in the cache. This should add it to the@@ -40,7 +40,7 @@                                }  data InstalledFindResult-  = InstalledFound ModLocation InstalledModule+  = InstalledFound ModLocation   | InstalledNoPackage UnitId   | InstalledNotFound [OsPath] (Maybe UnitId) 
+ compiler/GHC/Unit/Home/Graph.hs view
@@ -0,0 +1,381 @@+-- | A 'HomeUnitGraph' (HUG) collects information about all the home units.+-- Crucially, each node in a 'HomeUnitGraph' includes a 'HomePackageTable'.+--+-- Often, we don't want to query just a single 'HomePackageTable', but rather all+-- 'HomePackageTable's of all home units.+--+-- This module is responsible for maintaining this bridge between querying all+-- home units vs querying the home package table directly. Think 'lookupHug' vs+-- 'lookupHpt', 'hugAllInstances' vs 'hptAllInstances', where the @hug@ version+-- replies with information from all home units, and the @hpt@ version with+-- information pertaining to a single home unit.+--+-- Meant to be imported qualified as @HUG@.+-- Example usage:+--+-- @+-- import GHC.Unit.Home.Graph (HomeUnitGraph, HomeUnitEnv)+-- import qualified GHC.Unit.Home.Graph as HUG+-- usage = ... HUG.insertHug hug uid modname modinfo ...+-- @+module GHC.Unit.Home.Graph+  ( HomeUnitGraph+  , HomeUnitEnv(..)+  , mkHomeUnitEnv++  -- * Operations+  , addHomeModInfoToHug+  , restrictHug+  , renameUnitId+  , allUnits+  , updateUnitFlags++  -- ** Lookups+  , lookupHug+  , lookupHugByModule+  , lookupHugUnit+  , lookupHugUnitId+  , lookupAllHug+  , memberHugUnit+  , memberHugUnitId+  -- ** Reachability+  , transitiveHomeDeps++  -- * Very important queries+  , allInstances+  , allFamInstances+  , allAnns+  , allCompleteSigs++  -- * Utilities+  , hugSCCs+  , hugFromList++  -- ** Printing+  , pprHomeUnitGraph+  , pprHomeUnitEnv++  -- * Auxiliary internal structure+  , UnitEnvGraph(..)+  , unitEnv_lookup_maybe+  , unitEnv_foldWithKey+  , unitEnv_singleton+  , unitEnv_adjust+  , unitEnv_keys+  , unitEnv_insert+  , unitEnv_new+  , unitEnv_lookup+  , unitEnv_traverseWithKey+  , unitEnv_assocs+  ) where++import GHC.Prelude++import GHC.Driver.DynFlags+import GHC.Unit.Home+import GHC.Unit.Home.ModInfo+import GHC.Unit.Home.PackageTable+import GHC.Unit.Module+import GHC.Unit.Module.ModIface+import GHC.Unit.State+import GHC.Utils.Monad (mapMaybeM)+import GHC.Utils.Outputable+import GHC.Utils.Panic++import GHC.Core.FamInstEnv++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import GHC.Data.Maybe+import GHC.Data.Graph.Directed++import GHC.Types.Annotations+import GHC.Types.CompleteMatch+import GHC.Core.InstEnv+++-- | Get all 'CompleteMatches' (arising from COMPLETE pragmas) present across+-- all home units.+allCompleteSigs :: HomeUnitGraph -> IO CompleteMatches+allCompleteSigs hug = foldr go (pure []) hug where+  go hue = liftA2 (++) (hptCompleteSigs (homeUnitEnv_hpt hue))++-- | Find all the instance declarations (of classes and families) from+-- the Home Package Table filtered by the provided predicate function.+-- Used in @tcRnImports@, to select the instances that are in the+-- transitive closure of imports from the currently compiled module.+allInstances :: HomeUnitGraph -> IO (InstEnv, [FamInst])+allInstances hug = foldr go (pure (emptyInstEnv, [])) hug where+  go hue = liftA2 (\(a,b) (a',b') -> (a `unionInstEnv` a', b ++ b'))+                  (hptAllInstances (homeUnitEnv_hpt hue))++allFamInstances :: HomeUnitGraph -> IO (ModuleEnv FamInstEnv)+allFamInstances hug = foldr go (pure emptyModuleEnv) hug where+  go hue = liftA2 plusModuleEnv (hptAllFamInstances (homeUnitEnv_hpt hue))++allAnns :: HomeUnitGraph -> IO AnnEnv+allAnns hug = foldr go (pure emptyAnnEnv) hug where+  go hue = liftA2 plusAnnEnv (hptAllAnnotations (homeUnitEnv_hpt hue))++--------------------------------------------------------------------------------+-- HomeUnitGraph (HUG)+--------------------------------------------------------------------------------++type HomeUnitGraph = UnitEnvGraph HomeUnitEnv++data HomeUnitEnv = HomeUnitEnv+  { homeUnitEnv_units     :: !UnitState+      -- ^ External units++  , homeUnitEnv_unit_dbs :: !(Maybe [UnitDatabase UnitId])+      -- ^ Stack of unit databases for the target platform.+      --+      -- This field is populated with the result of `initUnits`.+      --+      -- 'Nothing' means the databases have never been read from disk.+      --+      -- Usually we don't reload the databases from disk if they are+      -- cached, even if the database flags changed!++  , homeUnitEnv_dflags :: DynFlags+    -- ^ The dynamic flag settings+  , homeUnitEnv_hpt :: HomePackageTable+    -- ^ The home package table describes already-compiled+    -- home-package modules, /excluding/ the module we+    -- are compiling right now.+    -- (In one-shot mode the current module is the only+    -- home-package module, so homeUnitEnv_hpt is empty.  All other+    -- modules count as \"external-package\" modules.+    -- However, even in GHCi mode, hi-boot interfaces are+    -- demand-loaded into the external-package table.)+    --+    -- 'homeUnitEnv_hpt' is not mutable because we only demand-load+    -- external packages; the home package is eagerly+    -- loaded, module by module, by the compilation manager.+    --+    -- The HPT may contain modules compiled earlier by @--make@+    -- but not actually below the current module in the dependency+    -- graph.+    --+    -- (This changes a previous invariant: changed Jan 05.)++  , homeUnitEnv_home_unit :: !(Maybe HomeUnit)+    -- ^ Home-unit+  }++mkHomeUnitEnv :: UnitState -> Maybe [UnitDatabase UnitId] -> DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv+mkHomeUnitEnv us dbs dflags hpt home_unit = HomeUnitEnv+  { homeUnitEnv_units = us+  , homeUnitEnv_unit_dbs = dbs+  , homeUnitEnv_dflags = dflags+  , homeUnitEnv_hpt = hpt+  , homeUnitEnv_home_unit = home_unit+  }++--------------------------------------------------------------------------------+-- * Operations on HUG+--------------------------------------------------------------------------------++-- | Add an entry to the 'HomePackageTable' under the unit of that entry.+addHomeModInfoToHug :: HomeModInfo -> HomeUnitGraph -> IO ()+addHomeModInfoToHug hmi hug =+  case unitEnv_lookup_maybe hmi_unit hug of+    Nothing -> pprPanic "addHomeInfoToHug" (ppr hmi_mod)+    Just hue -> do+      addHomeModInfoToHpt hmi (homeUnitEnv_hpt hue)+  where+    hmi_mod :: Module+    hmi_mod  = mi_module (hm_iface hmi)+    hmi_unit = toUnitId (moduleUnit hmi_mod)++-- | Thin each HPT variable to only contain keys from the given dependencies.+-- This is used at the end of upsweep to make sure that only completely successfully loaded+-- modules are visible for subsequent operations.+restrictHug :: [(UnitId, [HomeModInfo])] -> HomeUnitGraph -> IO ()+restrictHug deps hug = unitEnv_foldWithKey (\k uid hue -> restrict_one uid hue >> k) (return ()) hug+  where+    deps_map = Map.fromList deps+    restrict_one uid hue  =+      restrictHpt (homeUnitEnv_hpt hue) (Map.findWithDefault [] uid deps_map)++-- | Rename a unit id in the 'HomeUnitGraph'+--+-- @'renameUnitId' oldUnit newUnit hug@, if @oldUnit@ is not found in @hug@, returns 'Nothing'.+-- If it exists, the result maps @newUnit@ to the 'HomeUnitEnv' of the+-- @oldUnit@ (and @oldUnit@ is removed from @hug@)+renameUnitId :: UnitId -> UnitId -> HomeUnitGraph -> Maybe HomeUnitGraph+renameUnitId oldUnit newUnit hug = case unitEnv_lookup_maybe oldUnit hug of+  Nothing -> Nothing+  Just oldHue -> pure $+    unitEnv_insert newUnit oldHue $+    unitEnv_delete oldUnit hug++-- | Retrieve all 'UnitId's of units in the 'HomeUnitGraph'.+allUnits :: HomeUnitGraph -> Set.Set UnitId+allUnits = unitEnv_keys++-- | Set the 'DynFlags' of the 'HomeUnitEnv' for unit in the 'HomeModuleGraph'+updateUnitFlags :: UnitId -> (DynFlags -> DynFlags) -> HomeUnitGraph -> HomeUnitGraph+updateUnitFlags uid f = unitEnv_adjust update uid+  where+    update hue = hue { homeUnitEnv_dflags = f (homeUnitEnv_dflags hue) }++--------------------------------------------------------------------------------+-- ** Reachability+--------------------------------------------------------------------------------++-- | Compute the transitive closure of a unit in the 'HomeUnitGraph'.+-- If the argument unit is not present in the graph returns Nothing.+transitiveHomeDeps :: UnitId -> HomeUnitGraph -> Maybe [UnitId]+transitiveHomeDeps uid hug = case lookupHugUnitId uid hug of+  Nothing -> Nothing+  Just hue -> Just $+    Set.toList (loop (Set.singleton uid) (homeUnitDepends (homeUnitEnv_units hue)))+    where+      loop acc [] = acc+      loop acc (uid:uids)+        | uid `Set.member` acc = loop acc uids+        | otherwise =+          let hue = homeUnitDepends+                    . homeUnitEnv_units+                    . expectJust+                    $ lookupHugUnitId uid hug+          in loop (Set.insert uid acc) (hue ++ uids)++--------------------------------------------------------------------------------+-- ** Lookups+--------------------------------------------------------------------------------++-- | Lookup the 'HomeModInfo' of a 'Module' in the 'HomeUnitGraph' given its+-- 'UnitId' and 'ModuleName' (via the 'HomePackageTable' of the corresponding unit)+lookupHug :: HomeUnitGraph -> UnitId -> ModuleName -> IO (Maybe HomeModInfo)+lookupHug hug uid mod = do+  case unitEnv_lookup_maybe uid hug of+    Nothing -> pure Nothing+    Just hue -> lookupHpt (homeUnitEnv_hpt hue) mod++-- | Lookup the 'HomeModInfo' of a 'Module' in the 'HomeUnitGraph' (via the 'HomePackageTable' of the corresponding unit)+lookupHugByModule :: Module -> HomeUnitGraph -> IO (Maybe HomeModInfo)+lookupHugByModule mod hug =+  case lookupHugUnit (moduleUnit mod) hug of+    Nothing -> pure Nothing+    Just env -> lookupHptByModule (homeUnitEnv_hpt env) mod++-- | Lookup all 'HomeModInfo' that have the same 'ModuleName' as the given 'ModuleName'.+-- 'ModuleName's are not unique in the case of multiple home units, so there can be+-- more than one possible 'HomeModInfo'.+--+-- You should always prefer 'lookupHug' and 'lookupHugByModule' when possible.+lookupAllHug :: HomeUnitGraph -> ModuleName -> IO [HomeModInfo]+lookupAllHug hug mod = mapMaybeM (\uid -> lookupHug hug uid mod) (Set.toList $ unitEnv_keys hug)++-- | Lookup a 'HomeUnitEnv' by 'UnitId' in a 'HomeUnitGraph'+lookupHugUnitId :: UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv+lookupHugUnitId = unitEnv_lookup_maybe++-- | Check whether the 'UnitId' is present in the 'HomeUnitGraph'+memberHugUnitId :: UnitId -> HomeUnitGraph -> Bool+memberHugUnitId u = isJust . lookupHugUnitId u++-- | Lookup up the 'HomeUnitEnv' by the 'Unit' in the 'HomeUnitGraph'.+-- If the 'Unit' can be turned into a 'UnitId', we behave identical to 'lookupHugUnitId'.+--+-- A 'HoleUnit' is never part of the 'HomeUnitGraph', only instantiated 'Unit's+lookupHugUnit :: Unit -> HomeUnitGraph -> Maybe HomeUnitEnv+lookupHugUnit unit hug =+  if isHoleUnit unit+    then Nothing+    else lookupHugUnitId (toUnitId unit) hug++-- | Check whether the 'Unit' is present in the 'HomeUnitGraph'+--+-- A 'HoleUnit' is never part of the 'HomeUnitGraph', only instantiated 'Unit's+memberHugUnit :: Unit -> HomeUnitGraph -> Bool+memberHugUnit u = isJust . lookupHugUnit u++--------------------------------------------------------------------------------+-- * Internal representation map+--------------------------------------------------------------------------------+-- Note: we purposefully do not export functions like "elems" to maintain a+-- good clean interface with the HUG.++type UnitEnvGraphKey = UnitId++newtype UnitEnvGraph v = UnitEnvGraph+  { unitEnv_graph :: Map UnitEnvGraphKey v+  } deriving (Functor, Foldable, Traversable)++unitEnv_new :: Map UnitEnvGraphKey v -> UnitEnvGraph v+unitEnv_new m =+  UnitEnvGraph+    { unitEnv_graph = m+    }++unitEnv_insert :: UnitEnvGraphKey -> v -> UnitEnvGraph v -> UnitEnvGraph v+unitEnv_insert unitId env unitEnv = unitEnv+  { unitEnv_graph = Map.insert unitId env (unitEnv_graph unitEnv)+  }++unitEnv_delete :: UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v+unitEnv_delete uid unitEnv =+    unitEnv+      { unitEnv_graph = Map.delete uid (unitEnv_graph unitEnv)+      }++unitEnv_adjust :: (v -> v) -> UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v+unitEnv_adjust f uid unitEnv = unitEnv+  { unitEnv_graph = Map.adjust f uid (unitEnv_graph unitEnv)+  }++unitEnv_singleton :: UnitEnvGraphKey -> v -> UnitEnvGraph v+unitEnv_singleton active m = UnitEnvGraph+  { unitEnv_graph = Map.singleton active m+  }++unitEnv_lookup_maybe :: UnitEnvGraphKey -> UnitEnvGraph v -> Maybe v+unitEnv_lookup_maybe u env = Map.lookup u (unitEnv_graph env)++unitEnv_keys :: UnitEnvGraph v -> Set.Set UnitEnvGraphKey+unitEnv_keys env = Map.keysSet (unitEnv_graph env)++unitEnv_foldWithKey :: (b -> UnitEnvGraphKey -> a -> b) -> b -> UnitEnvGraph a -> b+unitEnv_foldWithKey f z (UnitEnvGraph g)= Map.foldlWithKey' f z g++unitEnv_lookup :: UnitEnvGraphKey -> UnitEnvGraph v -> v+unitEnv_lookup u env = expectJust $ unitEnv_lookup_maybe u env++unitEnv_traverseWithKey :: Applicative f => (UnitEnvGraphKey -> a -> f b) -> UnitEnvGraph a -> f (UnitEnvGraph b)+unitEnv_traverseWithKey f unitEnv =+  UnitEnvGraph <$> Map.traverseWithKey f (unitEnv_graph unitEnv)++unitEnv_assocs :: UnitEnvGraph a -> [(UnitEnvGraphKey, a)]+unitEnv_assocs (UnitEnvGraph x) = Map.assocs x++--------------------------------------------------------------------------------+-- * Utilities+--------------------------------------------------------------------------------++hugSCCs :: HomeUnitGraph -> [SCC UnitId]+hugSCCs hug = sccs where+  mkNode :: (UnitId, HomeUnitEnv) -> Node UnitId UnitId+  mkNode (uid, hue) = DigraphNode uid uid (homeUnitDepends (homeUnitEnv_units hue))+  nodes = map mkNode (Map.toList $ unitEnv_graph hug)++  sccs = stronglyConnCompFromEdgedVerticesOrd nodes++hugFromList :: [(UnitId, HomeUnitEnv)] -> HomeUnitGraph+hugFromList = UnitEnvGraph . Map.fromList++pprHomeUnitGraph :: HomeUnitGraph -> IO SDoc+pprHomeUnitGraph unitEnv = do+  docs <- mapM (\(k, v) -> pprHomeUnitEnv k v) $ Map.assocs $ unitEnv_graph unitEnv+  return $ vcat docs++pprHomeUnitEnv :: UnitId -> HomeUnitEnv -> IO SDoc+pprHomeUnitEnv uid env = do+  hptDoc <- pprHPT $ homeUnitEnv_hpt env+  return $+    ppr uid <+> text "(flags:" <+> ppr (homeUnitId_ $ homeUnitEnv_dflags env) <> text "," <+> ppr (fmap homeUnitId $ homeUnitEnv_home_unit env) <> text ")" <+> text "->"+    $$ nest 4 hptDoc+
compiler/GHC/Unit/Home/ModInfo.hs view
@@ -1,6 +1,8 @@--- | Info about modules in the "home" unit+-- | Info about modules in the "home" unit.+-- Stored in a 'HomePackageTable'. module GHC.Unit.Home.ModInfo-   ( HomeModInfo (..)+   (+     HomeModInfo (..)    , HomeModLinkable(..)    , homeModInfoObject    , homeModInfoByteCode@@ -8,24 +10,6 @@    , justBytecode    , justObjects    , bytecodeAndObjects-   , HomePackageTable-   , emptyHomePackageTable-   , lookupHpt-   , eltsHpt-   , concatHpt-   , filterHpt-   , allHpt-   , anyHpt-   , mapHpt-   , delFromHpt-   , addToHpt-   , addHomeModInfoToHpt-   , addListToHpt-   , lookupHptDirectly-   , lookupHptByModule-   , listToHpt-   , listHMIToHpt-   , pprHPT    ) where @@ -33,18 +17,13 @@  import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails-import GHC.Unit.Module  import GHC.Linker.Types ( Linkable(..), linkableIsNativeCodeOnly ) -import GHC.Types.Unique-import GHC.Types.Unique.DFM- import GHC.Utils.Outputable-import Data.List (sortOn)-import Data.Ord import GHC.Utils.Panic + -- | Information about modules in the package being compiled data HomeModInfo = HomeModInfo    { hm_iface    :: !ModIface@@ -128,79 +107,3 @@ flag to make sure that byte code is generated for your modules.  -}---- | Helps us find information about modules in the home package-type HomePackageTable = DModuleNameEnv HomeModInfo-   -- Domain = modules in the home unit that have been fully compiled-   -- "home" unit id cached (implicit) here for convenience---- | Constructs an empty HomePackageTable-emptyHomePackageTable :: HomePackageTable-emptyHomePackageTable  = emptyUDFM--lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo-lookupHpt = lookupUDFM--lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo-lookupHptDirectly = lookupUDFM_Directly--eltsHpt :: HomePackageTable -> [HomeModInfo]-eltsHpt = eltsUDFM---- | Like @concatMap f . 'eltsHpt'@, but filters out all 'HomeModInfo' for which--- @f@ returns the empty list before doing the sort inherent to 'eltsUDFM'.-concatHpt :: (HomeModInfo -> [a]) -> HomePackageTable -> [a]-concatHpt f = concat . eltsUDFM . mapMaybeUDFM g-  where-    g hmi = case f hmi of { [] -> Nothing; as -> Just as }--filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable-filterHpt = filterUDFM--allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool-allHpt = allUDFM--anyHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool-anyHpt = anyUDFM--mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable-mapHpt = mapUDFM--delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable-delFromHpt = delFromUDFM--addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable-addToHpt = addToUDFM--addHomeModInfoToHpt :: HomeModInfo -> HomePackageTable -> HomePackageTable-addHomeModInfoToHpt hmi hpt = addToHpt hpt (moduleName (mi_module (hm_iface hmi))) hmi--addListToHpt-  :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable-addListToHpt = addListToUDFM--listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable-listToHpt = listToUDFM--listHMIToHpt :: [HomeModInfo] -> HomePackageTable-listHMIToHpt hmis =-  listToHpt [(moduleName (mi_module (hm_iface hmi)), hmi) | hmi <- sorted_hmis]-  where-    -- Sort to put Non-boot things last, so they overwrite the boot interfaces-    -- in the HPT, other than that, the order doesn't matter-    sorted_hmis = sortOn (Down . mi_boot . hm_iface) hmis--lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo--- The HPT is indexed by ModuleName, not Module,--- we must check for a hit on the right Module-lookupHptByModule hpt mod-  = case lookupHpt hpt (moduleName mod) of-      Just hm | mi_module (hm_iface hm) == mod -> Just hm-      _otherwise                               -> Nothing--pprHPT :: HomePackageTable -> SDoc--- A bit arbitrary for now-pprHPT hpt = pprUDFM hpt $ \hms ->-    vcat [ ppr (mi_module (hm_iface hm))-         | hm <- hms ]-
+ compiler/GHC/Unit/Home/PackageTable.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE LambdaCase #-}+-- | The 'HomePackageTable' (HPT) contains information about all modules that are part+-- of a home package. At its core, the information for each module is a+-- 'HomeModInfo'.+--+-- During upsweep, the HPT is a monotonically increasing data structure: it+-- only ever gets extended by inserting modules which are loaded and for which+-- we discover the information required to construct a 'ModInfo'.+--+-- There should only ever exist one single HPT for any given home unit. It's+-- crucial we don't accidentally leak HPTs (e.g. by filtering it, which used to+-- happen -- #25511), so the HPT is mutable and only its reference should be shared.+-- This is alright because the modules don't change throughout compilation.+--+-- :::WARNING:::+-- If you intend to change this interface, consider carefully whether you are+-- exposing memory-leak footguns which may end up being misused in the compiler+-- eventually. For instance, if you really, really, end up needing a way to take+-- a snapshot of the IORef (think: do you really need to?), at least make+-- obvious in the name like `snapshotCopyHpt`.+--+-- Or, do you really need a function to traverse all modules in the HPT? It is+-- often better to keep the computation internal to this module, such as in+-- 'hptCollectObjects'...+module GHC.Unit.Home.PackageTable+  (+    HomePackageTable(..)+  , emptyHomePackageTable++    -- * Lookups in the HPT+  , lookupHpt+  , lookupHptByModule++    -- * Extending the HPT+  , addHomeModInfoToHpt+  , addHomeModInfosToHpt++    -- * Restrict the HPT+  , restrictHpt++    -- * Queries about home modules+  , hptCompleteSigs+  , hptAllInstances+  , hptAllFamInstances+  , hptAllAnnotations++    -- ** More Traversal-based queries+  , hptCollectDependencies+  , hptCollectObjects+  , hptCollectModules++    -- ** Memory dangerous queries+  , concatHpt++    -- * Utilities+  , pprHPT++    -- * Internals+    --+    -- | These provide access to the internals of the HomePackageTable to+    -- facilitate existing workflows that used the previous API. For instance,+    -- if you were listing out all elements or merging, you can keep doing so by reading+    -- the internal IO ref and then using the moduleenv contents directly.+    --+    -- In GHC itself these should be avoided, and other uses should justify why+    -- it is not sufficient to go through the intended insert-only API.+  , hptInternalTableRef+  , hptInternalTableFromRef++    -- * Legacy API+    --+    -- | This API is deprecated and meant to be removed.+  , addToHpt+  , addListToHpt+  ) where++import GHC.Prelude+import GHC.Data.Maybe++import Data.IORef+import Control.Monad ((<$!>))+import qualified Data.Set as Set++import GHC.Core.FamInstEnv+import GHC.Core.InstEnv+import GHC.Linker.Types+import GHC.Types.Annotations+import GHC.Types.CompleteMatch+import GHC.Types.Unique.DFM+import GHC.Unit.Home.ModInfo+import GHC.Unit.Module+import GHC.Unit.Module.Deps+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModIface+import GHC.Utils.Outputable+import GHC.Types.Unique (getUnique, getKey)+import qualified GHC.Data.Word64Set as W64++-- | Helps us find information about modules in the home package+newtype HomePackageTable = HPT {++    table :: IORef (DModuleNameEnv HomeModInfo)+    -- ^ Domain = modules in this home unit+    --+    -- This is an IORef because we want to avoid leaking HPTs (see the particularly bad #25511).+    -- Moreover, the HPT invariant allows mutability in this table without compromising thread safety or soundness.+    -- To recall:+    --   A query to the HPT should depend only on data relevant to that query, such that+    --   there being more or less unrelated entries in the HPT does not influence the result in any way.+    --+    -- Note that the HPT increases monotonically, except at certain barrier+    -- points like when 'restrictHpt' is called. At these barriers, it is safe+    -- to temporarily violate the HPT monotonicity.+    --+    -- The elements of this table may be updated (e.g. on rehydration).+  }++-- | Create a new 'HomePackageTable'.+--+-- Be careful not to share it across e.g. different units, since it uses a+-- mutable variable under the hood to keep the monotonically increasing list of+-- loaded modules.+emptyHomePackageTable :: IO HomePackageTable+-- romes:todo: use a MutableArray directly?+emptyHomePackageTable = do+  table <- newIORef emptyUDFM+  return HPT{table}++--------------------------------------------------------------------------------+-- * Lookups in the HPT+--------------------------------------------------------------------------------++-- | Lookup the 'HomeModInfo' of a module in the HPT, given its name.+lookupHpt :: HomePackageTable -> ModuleName -> IO (Maybe HomeModInfo)+lookupHpt HPT{table=hpt} mn = (`lookupUDFM` mn) <$!> readIORef hpt++-- | Lookup the 'HomeModInfo' of a 'Module' in the HPT.+lookupHptByModule :: HomePackageTable -> Module -> IO (Maybe HomeModInfo)+lookupHptByModule hpt mod+  = -- The HPT is indexed by ModuleName, not Module,+    -- we must check for a hit on the right Module+    lookupHpt hpt (moduleName mod) >>= pure . \case+      Just hm | mi_module (hm_iface hm) == mod -> Just hm+      _otherwise                               -> Nothing++--------------------------------------------------------------------------------+-- * Extending the HPT+--------------------------------------------------------------------------------++-- | Add a new module to the HPT.+--+-- An HPT is a monotonically increasing data structure, holding information about loaded modules in a package.+-- This is the main function by which the HPT is extended or updated.+--+-- When the module of the inserted 'HomeModInfo' does not exist, a new entry in+-- the HPT is created for that module name.+-- When the module already has an entry, inserting a new one entry in the HPT+-- will always overwrite the existing entry for that module.+addHomeModInfoToHpt :: HomeModInfo -> HomePackageTable -> IO ()+addHomeModInfoToHpt hmi hpt = addToHpt hpt (moduleName (mi_module (hm_iface hmi))) hmi++{-# DEPRECATED addToHpt "Deprecated in favour of 'addHomeModInfoToHpt', as the module at which a 'HomeModInfo' is inserted should always be derived from the 'HomeModInfo' itself." #-}+-- After deprecation cycle, move `addToHpt` to a `where` clause inside `addHomeModInfoToHpt`.+addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> IO ()+addToHpt HPT{table=hptr} mn hmi = do+  atomicModifyIORef' hptr (\hpt -> (addToUDFM hpt mn hmi, ()))+  -- If the key already existed in the map, this insertion is overwriting+  -- the HMI of a previously loaded module (likely in rehydration).++-- | 'addHomeModInfoToHpt' for multiple module infos.+addHomeModInfosToHpt :: HomePackageTable -> [HomeModInfo] -> IO ()+addHomeModInfosToHpt hpt = mapM_ (flip addHomeModInfoToHpt hpt)++-- | Thin each HPT variable to only contain keys from the given dependencies.+-- This is used at the end of upsweep to make sure that only completely successfully loaded+-- modules are visible for subsequent operations.+--+-- This is an exception to the invariant of the HPT -- that it grows+-- monotonically, never removing entries -- which is safe as long as it is only+-- called at barrier points, such as the end of upsweep, when all threads are+-- done and we want to clean up failed entries.+restrictHpt :: HomePackageTable -> [HomeModInfo] -> IO ()+restrictHpt HPT{table=hptr} hmis =+  let key_set = map (getKey . getUnique . hmi_mod) hmis+      hmi_mod hmi = moduleName (mi_module (hm_iface hmi))+  in atomicModifyIORef' hptr (\hpt -> (udfmRestrictKeysSet hpt (W64.fromList key_set), ()))++{-# DEPRECATED addListToHpt "Deprecated in favour of 'addHomeModInfosToHpt', as the module at which a 'HomeModInfo' is inserted should always be derived from the 'HomeModInfo' itself." #-}+-- After deprecation cycle, remove.+addListToHpt :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> IO ()+addListToHpt hpt = mapM_ (uncurry (addToHpt hpt))++----------------------------------------------------------------------------------+---- * Queries+----------------------------------------------------------------------------------++-- | Get all 'CompleteMatches' (arising from COMPLETE pragmas) present in all+-- modules from this unit's HPT.+hptCompleteSigs :: HomePackageTable -> IO CompleteMatches+hptCompleteSigs = concatHpt (md_complete_matches . hm_details)++-- | Find all the instance declarations (of classes and families) from this Home Package Table+hptAllInstances :: HomePackageTable -> IO (InstEnv, [FamInst])+hptAllInstances hpt = do+  hits <- flip concatHpt hpt $ \mod_info -> do+     let details = hm_details mod_info+     return (md_insts details, md_fam_insts details)+  let (insts, famInsts) = unzip hits+  return (foldl' unionInstEnv emptyInstEnv insts, concat famInsts)++-- | Find all the family instance declarations from the HPT+hptAllFamInstances :: HomePackageTable -> IO (ModuleEnv FamInstEnv)+hptAllFamInstances = fmap mkModuleEnv . concatHpt (\hmi -> [(hmiModule hmi, hmiFamInstEnv hmi)])+  where+    hmiModule     = mi_module . hm_iface+    hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv+                      . md_fam_insts . hm_details++-- | All annotations from the HPT+hptAllAnnotations :: HomePackageTable -> IO AnnEnv+hptAllAnnotations = fmap mkAnnEnv . concatHpt (md_anns . hm_details)+++--------------------------------------------------------------------------------+-- * Traversal-based queries+--------------------------------------------------------------------------------++-- | Collect the immediate dependencies of all modules in the HPT into a Set.+-- The immediate dependencies are given by the iface as @'dep_direct_pkgs' . 'mi_deps'@.+--+-- Note: This should be a query on the 'ModuleGraph', since we don't really+-- ever want to collect *all* dependencies. The current caller of this function+-- currently takes all dependencies only to then filter them with an ad-hoc transitive closure check.+-- See #25639+hptCollectDependencies :: HomePackageTable -> IO (Set.Set (IfaceImportLevel, UnitId))+hptCollectDependencies HPT{table} = do+  hpt <- readIORef table+  return $+    foldr (Set.union . dep_direct_pkgs . mi_deps . hm_iface) Set.empty hpt++-- | Collect the linkable object of all modules in the HPT.+-- The linkable objects are given by @'homeModInfoObject'@.+--+-- $O(n)$ in the number of modules in the HPT.+hptCollectObjects :: HomePackageTable -> IO [Linkable]+hptCollectObjects HPT{table} = do+  hpt <- readIORef table+  return $+    foldr ((:) . expectJust . homeModInfoObject) [] hpt++-- | Collect all module ifaces in the HPT+--+-- $O(n)$ in the number of modules in the HPT.+hptCollectModules :: HomePackageTable -> IO [Module]+hptCollectModules HPT{table} = do+  hpt <- readIORef table+  return $+    foldr ((:) . mi_module . hm_iface) [] hpt++--------------------------------------------------------------------------------+-- * Utilities+--------------------------------------------------------------------------------++-- | Pretty print a 'HomePackageTable'.+--+-- Make sure you really do need to print the whole HPT before infusing too much+-- code with IO.+--+-- For instance, in the HUG, it suffices to print the unit-keys present in the+-- unit map in failed lookups.+pprHPT :: HomePackageTable -> IO SDoc+-- A bit arbitrary for now+pprHPT HPT{table=hptr} = do+  hpt <- readIORef hptr+  return $!+    pprUDFM hpt $ \hms ->+      vcat [ ppr (mi_module (hm_iface hm))+           | hm <- hms ]++----------------------------------------------------------------------------------+-- THE TYPE OF FOOTGUNS WE DON'T WANT TO EXPOSE+----------------------------------------------------------------------------------++-- eltsHpt :: HomePackageTable -> [HomeModInfo]+-- filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable+-- mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable+-- delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable+-- listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable+-- listHMIToHpt :: [HomeModInfo] -> HomePackageTable++----------------------------------------------------------------------------------+-- Would be fine, but may lead to linearly traversing the HPT unnecessarily+-- (e.g. `lastLoadedKey` superseded bad usages)+----------------------------------------------------------------------------------++-- allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool+-- allHpt = allUDFM++-- anyHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool+-- anyHpt = anyUDFM++----------------------------------------------------------------------------------+-- Would be ok to expose this function very /careful/ with the argument function+----------------------------------------------------------------------------------++-- | Like @concatMap f . 'eltsHpt'@, but filters out all 'HomeModInfo' for which+-- @f@ returns the empty list before doing the sort inherent to 'eltsUDFM'.+--+-- If this function is ever exposed from the HPT module, make sure the+-- argument function doesn't introduce leaks.+concatHpt :: (HomeModInfo -> [a]) -> HomePackageTable -> IO [a]+concatHpt f HPT{table} = do+  hpt <- readIORef table+  return $ concat . eltsUDFM . mapMaybeUDFM g $ hpt+  where+    g hmi = case f hmi of { [] -> Nothing; as -> Just as }++--------------------------------------------------------------------------------+-- * Internals (see haddocks!)+--------------------------------------------------------------------------------++-- | Gets the internal 'IORef' which holds the 'HomeModInfo's of this HPT.+-- Use with care.+hptInternalTableRef :: HomePackageTable -> IORef (DModuleNameEnv HomeModInfo)+hptInternalTableRef = table++-- | Construct a HomePackageTable from the IORef.+-- Use with care, only if you can really justify going around the intended insert-only API.+hptInternalTableFromRef :: IORef (DModuleNameEnv HomeModInfo) -> IO HomePackageTable+hptInternalTableFromRef ref = do+  return HPT {+    table = ref+  }+
compiler/GHC/Unit/Info.hs view
@@ -236,7 +236,7 @@         -- This change elevates the need to add custom hooks         -- and handling specifically for the `rts` package.         addSuffix rts@"HSrts"       = rts       ++ (expandTag rts_tag)-        addSuffix rts@"HSrts-1.0.2" = rts       ++ (expandTag rts_tag)+        addSuffix rts@"HSrts-1.0.3" = rts       ++ (expandTag rts_tag)         addSuffix other_lib         = other_lib ++ (expandTag tag)          expandTag t | null t = ""
compiler/GHC/Unit/Module/Deps.hs view
@@ -1,21 +1,29 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE DerivingVia #-} -- | Dependencies and Usage of a module module GHC.Unit.Module.Deps-   ( Dependencies-   , mkDependencies-   , noDependencies-   , dep_direct_mods-   , dep_direct_pkgs-   , dep_sig_mods-   , dep_trusted_pkgs-   , dep_orphs-   , dep_plugin_pkgs-   , dep_finsts-   , dep_boot_mods+   ( Dependencies(dep_direct_mods+                  , dep_direct_pkgs+                  , dep_sig_mods+                  , dep_trusted_pkgs+                  , dep_orphs+                  , dep_plugin_pkgs+                  , dep_finsts+                  , dep_boot_mods+                  , Dependencies)    , dep_orphs_update    , dep_finsts_update+   , mkDependencies+   , noDependencies    , pprDeps    , Usage (..)+   , HomeModImport (..)+   , HomeModImportedAvails (..)    , ImportAvails (..)+   , IfaceImportLevel(..)+   , tcImportLevel    ) where @@ -23,8 +31,10 @@  import GHC.Data.FastString +import GHC.Types.Avail import GHC.Types.SafeHaskell import GHC.Types.Name+import GHC.Types.Basic  import GHC.Unit.Module.Imported import GHC.Unit.Module@@ -39,7 +49,11 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Bifunctor+import Control.DeepSeq+import GHC.Types.Name.Set ++ -- | Dependency information about ALL modules and packages below this one -- in the import hierarchy. This is the serialisable version of `ImportAvails`. --@@ -51,38 +65,38 @@ -- -- See Note [Transitive Information in Dependencies] data Dependencies = Deps-   { dep_direct_mods :: Set (UnitId, ModuleNameWithIsBoot)+   { dep_direct_mods_ :: Set (IfaceImportLevel, UnitId, ModuleNameWithIsBoot)       -- ^ All home-package modules which are directly imported by this one.       -- This may include modules from other units when using multiple home units -   , dep_direct_pkgs :: Set UnitId+   , dep_direct_pkgs_ :: Set (IfaceImportLevel, UnitId)       -- ^ All packages directly imported by this module       -- I.e. packages to which this module's direct imports belong.       -- Does not include other home units when using multiple home units.       -- Modules from these units will go in `dep_direct_mods` -   , dep_plugin_pkgs :: Set UnitId+   , dep_plugin_pkgs_ :: Set UnitId       -- ^ All units needed for plugins      ------------------------------------     -- Transitive information below here -   , dep_sig_mods :: ![ModuleName]+   , dep_sig_mods_ :: ![ModuleName]     -- ^ Transitive closure of hsig files in the home package  -   , dep_trusted_pkgs :: Set UnitId+   , dep_trusted_pkgs_ :: Set UnitId       -- Packages which we are required to trust       -- when the module is imported as a safe import       -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names -   , dep_boot_mods :: Set (UnitId, ModuleNameWithIsBoot)+   , dep_boot_mods_ :: Set (UnitId, ModuleNameWithIsBoot)       -- ^ All modules which have boot files below this one, and whether we       -- should use the boot file or not.       -- This information is only used to populate the eps_is_boot field.       -- See Note [Structure of dep_boot_mods] -   , dep_orphs  :: [Module]+   , dep_orphs_ :: [Module]       -- ^ Transitive closure of orphan modules (whether       -- home or external pkg).       --@@ -92,7 +106,7 @@       -- which relies on dep_orphs having the complete list!)       -- This does NOT include us, unlike 'imp_orphs'. -   , dep_finsts :: [Module]+   , dep_finsts_ :: [Module]       -- ^ Transitive closure of depended upon modules which       -- contain family instances (whether home or external).       -- This is used by 'checkFamInstConsistency'.  This@@ -104,7 +118,55 @@         -- Equality used only for old/new comparison in GHC.Iface.Recomp.addFingerprints         -- See 'GHC.Tc.Utils.ImportAvails' for details on dependencies. +pattern Dependencies :: Set (IfaceImportLevel, UnitId, ModuleNameWithIsBoot)+             -> Set (IfaceImportLevel, UnitId)+             -> Set UnitId+             -> [ModuleName]+             -> Set UnitId+             -> Set (UnitId, ModuleNameWithIsBoot)+             -> [Module]+             -> [Module]+             -> Dependencies+pattern Dependencies {dep_direct_mods, dep_direct_pkgs, dep_plugin_pkgs, dep_sig_mods, dep_trusted_pkgs, dep_boot_mods, dep_orphs, dep_finsts}+          <- Deps {dep_direct_mods_ = dep_direct_mods+                 , dep_direct_pkgs_ = dep_direct_pkgs+                 , dep_plugin_pkgs_ = dep_plugin_pkgs+                 , dep_sig_mods_ = dep_sig_mods+                 , dep_trusted_pkgs_ = dep_trusted_pkgs+                 , dep_boot_mods_ = dep_boot_mods+                 , dep_orphs_ = dep_orphs+                 , dep_finsts_ = dep_finsts}+{-# COMPLETE Dependencies #-} +instance NFData Dependencies where+  rnf (Deps dmods dpkgs ppkgs hsigms tps bmods orphs finsts)+    = rnf dmods+        `seq` rnf dpkgs+        `seq` rnf ppkgs+        `seq` rnf hsigms+        `seq` rnf tps+        `seq` rnf bmods+        `seq` rnf orphs+        `seq` rnf finsts+        `seq` ()++newtype IfaceImportLevel = IfaceImportLevel ImportLevel+  deriving (Eq, Ord)+  deriving Binary via EnumBinary ImportLevel++tcImportLevel :: IfaceImportLevel -> ImportLevel+tcImportLevel (IfaceImportLevel lvl) = lvl++instance NFData IfaceImportLevel where+  rnf (IfaceImportLevel lvl) = case lvl of+                                NormalLevel -> ()+                                QuoteLevel  -> ()+                                SpliceLevel -> ()++instance Outputable IfaceImportLevel where+  ppr (IfaceImportLevel lvl) = ppr lvl++ -- | Extract information from the rename and typecheck phases to produce -- a dependencies information for the module being compiled. --@@ -113,15 +175,19 @@ mkDependencies home_unit mod imports plugin_mods =   let (home_plugins, external_plugins) = partition (isHomeUnit home_unit . moduleUnit) plugin_mods       plugin_units = Set.fromList (map (toUnitId . moduleUnit) external_plugins)-      all_direct_mods = foldr (\mn m -> extendInstalledModuleEnv m mn (GWIB (moduleName mn) NotBoot))+      all_direct_mods = foldr (\(s, mn) m -> extendInstalledModuleEnv m mn (s, (GWIB (moduleName mn) NotBoot)))                               (imp_direct_dep_mods imports)-                              (map (fmap toUnitId) home_plugins)+                              (map (fmap (fmap toUnitId) . (Set.singleton SpliceLevel,)) home_plugins) -      modDepsElts = Set.fromList . installedModuleEnvElts+      modDepsElts_source :: Ord a => InstalledModuleEnv a -> Set.Set (InstalledModule, a)+      modDepsElts_source = Set.fromList . installedModuleEnvElts         -- It's OK to use nonDetEltsUFM here because sorting by module names         -- restores determinism -      direct_mods = first moduleUnit `Set.map` modDepsElts (delInstalledModuleEnv all_direct_mods (toUnitId <$> mod))+      modDepsElts :: Ord a => InstalledModuleEnv (Set.Set ImportLevel, a) -> Set.Set (IfaceImportLevel, UnitId,  a)+      modDepsElts e = Set.fromList [ (IfaceImportLevel s, moduleUnit im, a) | (im, (ss,a)) <- installedModuleEnvElts e, s <- Set.toList ss]++      direct_mods = modDepsElts (delInstalledModuleEnv all_direct_mods (toUnitId <$> mod))             -- M.hi-boot can be in the imp_dep_mods, but we must remove             -- it before recording the modules on which this one depends!             -- (We want to retain M.hi-boot in imp_dep_mods so that@@ -133,7 +199,7 @@             -- We must also remove self-references from imp_orphs. See             -- Note [Module self-dependency] -      direct_pkgs = imp_dep_direct_pkgs imports+      direct_pkgs = Set.map (\(lvl, uid) -> (IfaceImportLevel lvl, uid)) (imp_dep_direct_pkgs imports)        -- Set the packages required to be Safe according to Safe Haskell.       -- See Note [Tracking Trust Transitively] in GHC.Rename.Names@@ -141,18 +207,18 @@        -- If there's a non-boot import, then it shadows the boot import       -- coming from the dependencies-      source_mods = first moduleUnit `Set.map` modDepsElts (imp_boot_mods imports)+      source_mods = first moduleUnit `Set.map` modDepsElts_source (imp_boot_mods imports)        sig_mods = filter (/= (moduleName mod)) $ imp_sig_mods imports -  in Deps { dep_direct_mods  = direct_mods-          , dep_direct_pkgs  = direct_pkgs-          , dep_plugin_pkgs  = plugin_units-          , dep_sig_mods     = sort sig_mods-          , dep_trusted_pkgs = trust_pkgs-          , dep_boot_mods    = source_mods-          , dep_orphs        = sortBy stableModuleCmp dep_orphs-          , dep_finsts       = sortBy stableModuleCmp (imp_finsts imports)+  in Deps { dep_direct_mods_   = direct_mods+          , dep_direct_pkgs_  = direct_pkgs+          , dep_plugin_pkgs_  = plugin_units+          , dep_sig_mods_     = sort sig_mods+          , dep_trusted_pkgs_ = trust_pkgs+          , dep_boot_mods_    = source_mods+          , dep_orphs_        = sortBy stableModuleCmp dep_orphs+          , dep_finsts_       = sortBy stableModuleCmp (imp_finsts imports)             -- sort to get into canonical order             -- NB. remember to use lexicographic ordering           }@@ -161,14 +227,13 @@ dep_orphs_update :: Monad m => Dependencies -> ([Module] -> m [Module]) -> m Dependencies dep_orphs_update deps f = do   r <- f (dep_orphs deps)-  pure (deps { dep_orphs = sortBy stableModuleCmp r })+  pure (deps { dep_orphs_ = sortBy stableModuleCmp r })  -- | Update module dependencies containing family instances (used by Backpack) dep_finsts_update :: Monad m => Dependencies -> ([Module] -> m [Module]) -> m Dependencies dep_finsts_update deps f = do   r <- f (dep_finsts deps)-  pure (deps { dep_finsts = sortBy stableModuleCmp r })-+  pure (deps { dep_finsts_ = sortBy stableModuleCmp r })  instance Binary Dependencies where     put_ bh deps = do put_ bh (dep_direct_mods deps)@@ -188,36 +253,36 @@                 sms <- get bh                 os <- get bh                 fis <- get bh-                return (Deps { dep_direct_mods = dms-                             , dep_direct_pkgs = dps-                             , dep_plugin_pkgs = plugin_pkgs-                             , dep_sig_mods = hsigms-                             , dep_boot_mods = sms-                             , dep_trusted_pkgs = tps-                             , dep_orphs = os,-                               dep_finsts = fis })+                return (Deps { dep_direct_mods_ = dms+                             , dep_direct_pkgs_ = dps+                             , dep_plugin_pkgs_ = plugin_pkgs+                             , dep_sig_mods_ = hsigms+                             , dep_boot_mods_ = sms+                             , dep_trusted_pkgs_ = tps+                             , dep_orphs_ = os,+                               dep_finsts_ = fis })  noDependencies :: Dependencies noDependencies = Deps-  { dep_direct_mods  = Set.empty-  , dep_direct_pkgs  = Set.empty-  , dep_plugin_pkgs  = Set.empty-  , dep_sig_mods     = []-  , dep_boot_mods    = Set.empty-  , dep_trusted_pkgs = Set.empty-  , dep_orphs        = []-  , dep_finsts       = []+  { dep_direct_mods_  = Set.empty+  , dep_direct_pkgs_  = Set.empty+  , dep_plugin_pkgs_  = Set.empty+  , dep_sig_mods_     = []+  , dep_boot_mods_    = Set.empty+  , dep_trusted_pkgs_ = Set.empty+  , dep_orphs_        = []+  , dep_finsts_       = []   }  -- | Pretty-print unit dependencies pprDeps :: UnitState -> Dependencies -> SDoc-pprDeps unit_state (Deps { dep_direct_mods = dmods-                         , dep_boot_mods = bmods-                         , dep_plugin_pkgs = plgns-                         , dep_orphs = orphs-                         , dep_direct_pkgs = pkgs-                         , dep_trusted_pkgs = tps-                         , dep_finsts = finsts+pprDeps unit_state (Deps { dep_direct_mods_ = dmods+                         , dep_boot_mods_ = bmods+                         , dep_plugin_pkgs_ = plgns+                         , dep_orphs_ = orphs+                         , dep_direct_pkgs_ = pkgs+                         , dep_trusted_pkgs_ = tps+                         , dep_finsts_ = finsts                          })   = pprWithUnitState unit_state $     vcat [text "direct module dependencies:"  <+> ppr_set ppr_mod dmods,@@ -231,8 +296,8 @@           text "family instance modules:" <+> fsep (map ppr finsts)         ]   where-    ppr_mod (uid, (GWIB mod IsBoot))  = ppr uid <> colon <> ppr mod <+> text "[boot]"-    ppr_mod (uid, (GWIB mod NotBoot)) = ppr uid <> colon <> ppr mod+    ppr_mod (_, uid, (GWIB mod IsBoot))  = ppr uid <> colon <> ppr mod <+> text "[boot]"+    ppr_mod (lvl, uid, (GWIB mod NotBoot)) = ppr lvl <+> ppr uid <> colon <> ppr mod      ppr_set :: Outputable a => (a -> SDoc) -> Set a -> SDoc     ppr_set w = fsep . fmap w . Set.toAscList@@ -268,9 +333,9 @@             -- ^ Entities we depend on, sorted by occurrence name and fingerprinted.             -- NB: usages are for parent names only, e.g. type constructors             -- but not the associated data constructors.-        usg_exports  :: Maybe Fingerprint,-            -- ^ Fingerprint for the export list of this module,-            -- if we directly imported it (and hence we depend on its export list)+        usg_exports :: Maybe HomeModImport,+            -- ^ What we depend on from the exports of the module;+            -- see 'HomeModImport'.         usg_safe :: IsSafeImport             -- ^ Was this module imported as a safe import     }@@ -326,6 +391,13 @@         -- And of course, for modules that aren't imported directly we don't         -- depend on their export lists +instance NFData Usage where+  rnf (UsagePackageModule mod hash safe) = rnf mod `seq` rnf hash `seq` rnf safe `seq` ()+  rnf (UsageHomeModule mod uid hash entities exports safe) = rnf mod `seq` rnf uid `seq` rnf hash `seq` rnf entities `seq` rnf exports `seq` rnf safe `seq` ()+  rnf (UsageFile file hash label) = rnf file `seq` rnf hash `seq` rnf label `seq` ()+  rnf (UsageMergedRequirement mod hash) = rnf mod `seq` rnf hash `seq` ()+  rnf (UsageHomeModuleInterface mod uid hash) = rnf mod `seq` rnf uid `seq` rnf hash `seq` ()+ instance Binary Usage where     put_ bh usg@UsagePackageModule{} = do         putByte bh 0@@ -392,11 +464,79 @@             return UsageHomeModuleInterface { usg_mod_name = mod, usg_unit_id = uid, usg_iface_hash = hash }           i -> error ("Binary.get(Usage): " ++ show i) +-- | Records the imports that we depend on from a home module,+-- for recompilation checking.+--+-- See Note [When to recompile when export lists change?] in GHC.Iface.Recomp.+data HomeModImport+  = HomeModImport+    -- | Hash of orphans, dependencies, orphans of dependencies etc...+    --+    -- See Note [Orphan-like hash].+    --+    -- If this changes, we definitely need to recompile.+  { hmiu_orphanLikeHash :: Fingerprint+    -- | The avails we are importing; see 'HomeModImportedAvails'.+  , hmiu_importedAvails :: HomeModImportedAvails+  }+  deriving stock Eq -{--Note [Transitive Information in Dependencies]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- | Records all the 'Avail's we are importing from a home module.+data HomeModImportedAvails+  -- | All import lists are explicit import lists, but some identifiers+  -- may still be implicitly imported, e.g. @import M(a, b, T(..))@.+  --+  -- In this case, recompilation is keyed by the names we are importing,+  -- with their 'Avail' structure.+  = HMIA_Explicit+    { hmia_imported_avails :: DetOrdAvails+        -- ^ The avails we are importing+    , hmia_parents_with_implicits :: NameSet+        -- ^ The 'Name's of all 'AvailTC' imports which+        -- implicitly import children+    }+  -- | One import is a whole module import, or a @import module M hiding(..)@+  -- import.+  --+  -- In this case, recompilation is keyed on the hash of the exported avails+  -- of the module we are importing.+  | HMIA_Implicit+     { hmia_exportedAvailsHash :: Fingerprint+       -- ^ The export avails hash of the module we are importing+     }+  deriving stock Eq +instance Outputable HomeModImport where+  ppr (HomeModImport orphan_like imp_avails) =+    braces (text "orphan_like:" <+> ppr orphan_like <+> text ", imported avails:" <+> ppr imp_avails)+instance Outputable HomeModImportedAvails where+  ppr (HMIA_Explicit avails implicit_parents) =+    braces (text "explicit:" <+> ppr avails <+> text ", implicit_parents:" <+> ppr implicit_parents)+  ppr (HMIA_Implicit hash) = braces (text "implicit:" <+> ppr hash)+instance NFData HomeModImport where+  rnf (HomeModImport a b) = rnf a `seq` rnf b `seq` ()+instance NFData HomeModImportedAvails where+  rnf (HMIA_Explicit avails implicit_parents) = rnf avails `seq` rnf implicit_parents+  rnf (HMIA_Implicit hash) = rnf hash+instance Binary HomeModImport where+  put_ bh (HomeModImport a b) = put_ bh a >> put_ bh b+  get bh = do+    a <- get bh+    b <- get bh+    return $ HomeModImport a b+instance Binary HomeModImportedAvails where+  put_ bh (HMIA_Explicit avails implicit_parents) =+    putByte bh 0 >> put_ bh avails >> put_ bh (nameSetElemsStable implicit_parents)+  put_ bh (HMIA_Implicit hash  ) = putByte bh 1 >> put_ bh hash+  get bh = do+    tag <- getByte bh+    case tag of+      0 -> HMIA_Explicit <$> get bh <*> (mkNameSet <$> get bh)+      1 -> HMIA_Implicit <$> get bh+      _ -> error ("Binary.get(HomeModImportedAvails): " ++ show tag)++{- Note [Transitive Information in Dependencies]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is important to be careful what information we put in 'Dependencies' because ultimately it ends up serialised in an interface file. Interface files must always be kept up-to-date with the state of the world, so if `Dependencies` needs to be updated@@ -490,10 +630,10 @@           -- different packages. (currently not the case, but might be in the           -- future). -        imp_direct_dep_mods :: InstalledModuleEnv ModuleNameWithIsBoot,+        imp_direct_dep_mods :: InstalledModuleEnv (Set.Set ImportLevel, ModuleNameWithIsBoot),           -- ^ Home-package modules directly imported by the module being compiled. -        imp_dep_direct_pkgs :: Set UnitId,+        imp_dep_direct_pkgs :: Set (ImportLevel, UnitId),           -- ^ Packages directly needed by the module being compiled          imp_trust_own_pkg :: Bool,
compiler/GHC/Unit/Module/Env.hs view
@@ -33,17 +33,6 @@    , mergeInstalledModuleEnv    , plusInstalledModuleEnv    , installedModuleEnvElts--     -- * InstalledModuleWithIsBootEnv-   , InstalledModuleWithIsBootEnv-   , emptyInstalledModuleWithIsBootEnv-   , lookupInstalledModuleWithIsBootEnv-   , extendInstalledModuleWithIsBootEnv-   , filterInstalledModuleWithIsBootEnv-   , delInstalledModuleWithIsBootEnv-   , mergeInstalledModuleWithIsBootEnv-   , plusInstalledModuleWithIsBootEnv-   , installedModuleWithIsBootEnvElts    ) where @@ -293,57 +282,4 @@   -> InstalledModuleEnv elt plusInstalledModuleEnv f (InstalledModuleEnv xm) (InstalledModuleEnv ym) =   InstalledModuleEnv $ Map.unionWith f xm ym--------------------------------------------------------------------------- InstalledModuleWithIsBootEnv------------------------------------------------------------------------- | A map keyed off of 'InstalledModuleWithIsBoot'-newtype InstalledModuleWithIsBootEnv elt = InstalledModuleWithIsBootEnv (Map InstalledModuleWithIsBoot elt)--instance Outputable elt => Outputable (InstalledModuleWithIsBootEnv elt) where-  ppr (InstalledModuleWithIsBootEnv env) = ppr env---emptyInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a-emptyInstalledModuleWithIsBootEnv = InstalledModuleWithIsBootEnv Map.empty--lookupInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBoot -> Maybe a-lookupInstalledModuleWithIsBootEnv (InstalledModuleWithIsBootEnv e) m = Map.lookup m e--extendInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBoot -> a -> InstalledModuleWithIsBootEnv a-extendInstalledModuleWithIsBootEnv (InstalledModuleWithIsBootEnv e) m x = InstalledModuleWithIsBootEnv (Map.insert m x e)--filterInstalledModuleWithIsBootEnv :: (InstalledModuleWithIsBoot -> a -> Bool) -> InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBootEnv a-filterInstalledModuleWithIsBootEnv f (InstalledModuleWithIsBootEnv e) =-  InstalledModuleWithIsBootEnv (Map.filterWithKey f e)--delInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBoot -> InstalledModuleWithIsBootEnv a-delInstalledModuleWithIsBootEnv (InstalledModuleWithIsBootEnv e) m = InstalledModuleWithIsBootEnv (Map.delete m e)--installedModuleWithIsBootEnvElts :: InstalledModuleWithIsBootEnv a -> [(InstalledModuleWithIsBoot, a)]-installedModuleWithIsBootEnvElts (InstalledModuleWithIsBootEnv e) = Map.assocs e--mergeInstalledModuleWithIsBootEnv-  :: (elta -> eltb -> Maybe eltc)-  -> (InstalledModuleWithIsBootEnv elta -> InstalledModuleWithIsBootEnv eltc)  -- map X-  -> (InstalledModuleWithIsBootEnv eltb -> InstalledModuleWithIsBootEnv eltc) -- map Y-  -> InstalledModuleWithIsBootEnv elta-  -> InstalledModuleWithIsBootEnv eltb-  -> InstalledModuleWithIsBootEnv eltc-mergeInstalledModuleWithIsBootEnv f g h (InstalledModuleWithIsBootEnv xm) (InstalledModuleWithIsBootEnv ym)-  = InstalledModuleWithIsBootEnv $ Map.mergeWithKey-      (\_ x y -> (x `f` y))-      (coerce g)-      (coerce h)-      xm ym--plusInstalledModuleWithIsBootEnv :: (elt -> elt -> elt)-  -> InstalledModuleWithIsBootEnv elt-  -> InstalledModuleWithIsBootEnv elt-  -> InstalledModuleWithIsBootEnv elt-plusInstalledModuleWithIsBootEnv f (InstalledModuleWithIsBootEnv xm) (InstalledModuleWithIsBootEnv ym) =-  InstalledModuleWithIsBootEnv $ Map.unionWith f xm ym 
compiler/GHC/Unit/Module/Graph.hs view
@@ -2,416 +2,1048 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveTraversable #-} -module GHC.Unit.Module.Graph-   ( ModuleGraph-   , ModuleGraphNode(..)-   , nodeDependencies-   , emptyMG-   , mkModuleGraph-   , extendMG-   , extendMGInst-   , extendMG'-   , unionMG-   , isTemplateHaskellOrQQNonBoot-   , filterToposortToModules-   , mapMG-   , mgModSummaries-   , mgModSummaries'-   , mgLookupModule-   , mgTransDeps-   , showModMsg-   , moduleGraphNodeModule-   , moduleGraphNodeModSum-   , moduleGraphModulesBelow--   , moduleGraphNodes-   , SummaryNode-   , summaryNodeSummary--   , NodeKey(..)-   , nodeKeyUnitId-   , nodeKeyModName-   , ModNodeKey-   , mkNodeKey-   , msKey---   , moduleGraphNodeUnitId--   , ModNodeKeyWithUid(..)-   )-where--import GHC.Prelude-import GHC.Platform--import qualified GHC.LanguageExtensions as LangExt--import GHC.Data.Maybe-import GHC.Data.Graph.Directed--import GHC.Driver.Backend-import GHC.Driver.DynFlags--import GHC.Types.SourceFile ( hscSourceString )--import GHC.Unit.Module.ModSummary-import GHC.Unit.Types-import GHC.Utils.Outputable-import GHC.Utils.Misc ( partitionWith )--import System.FilePath-import qualified Data.Map as Map-import GHC.Types.Unique.DSet-import qualified Data.Set as Set-import Data.Set (Set)-import GHC.Unit.Module-import GHC.Linker.Static.Utils--import Data.Bifunctor-import Data.Function-import Data.List (sort)-import GHC.Data.List.SetOps---- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'.--- Edges between nodes mark dependencies arising from module imports--- and dependencies arising from backpack instantiations.-data ModuleGraphNode-  -- | Instantiation nodes track the instantiation of other units-  -- (backpack dependencies) with the holes (signatures) of the current package.-  = InstantiationNode UnitId InstantiatedUnit-  -- | There is a module summary node for each module, signature, and boot module being built.-  | ModuleNode [NodeKey] ModSummary-  -- | Link nodes are whether are are creating a linked product (ie executable/shared object etc) for a unit.-  | LinkNode [NodeKey] UnitId--moduleGraphNodeModule :: ModuleGraphNode -> Maybe ModuleName-moduleGraphNodeModule mgn = ms_mod_name <$> (moduleGraphNodeModSum mgn)--moduleGraphNodeModSum :: ModuleGraphNode -> Maybe ModSummary-moduleGraphNodeModSum (InstantiationNode {}) = Nothing-moduleGraphNodeModSum (LinkNode {})          = Nothing-moduleGraphNodeModSum (ModuleNode _ ms)      = Just ms--moduleGraphNodeUnitId :: ModuleGraphNode -> UnitId-moduleGraphNodeUnitId mgn =-  case mgn of-    InstantiationNode uid _iud -> uid-    ModuleNode _ ms           -> toUnitId (moduleUnit (ms_mod ms))-    LinkNode _ uid             -> uid--instance Outputable ModuleGraphNode where-  ppr = \case-    InstantiationNode _ iuid -> ppr iuid-    ModuleNode nks ms -> ppr (msKey ms) <+> ppr nks-    LinkNode uid _     -> text "LN:" <+> ppr uid--instance Eq ModuleGraphNode where-  (==) = (==) `on` mkNodeKey--instance Ord ModuleGraphNode where-  compare = compare `on` mkNodeKey--data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit-             | NodeKey_Module {-# UNPACK #-} !ModNodeKeyWithUid-             | NodeKey_Link !UnitId-  deriving (Eq, Ord)--instance Outputable NodeKey where-  ppr nk = pprNodeKey nk--pprNodeKey :: NodeKey -> SDoc-pprNodeKey (NodeKey_Unit iu) = ppr iu-pprNodeKey (NodeKey_Module mk) = ppr mk-pprNodeKey (NodeKey_Link uid)  = ppr uid--nodeKeyUnitId :: NodeKey -> UnitId-nodeKeyUnitId (NodeKey_Unit iu)   = instUnitInstanceOf iu-nodeKeyUnitId (NodeKey_Module mk) = mnkUnitId mk-nodeKeyUnitId (NodeKey_Link uid)  = uid--nodeKeyModName :: NodeKey -> Maybe ModuleName-nodeKeyModName (NodeKey_Module mk) = Just (gwib_mod $ mnkModuleName mk)-nodeKeyModName _ = Nothing--data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: !ModuleNameWithIsBoot-                                           , mnkUnitId     :: !UnitId } deriving (Eq, Ord)--instance Outputable ModNodeKeyWithUid where-  ppr (ModNodeKeyWithUid mnwib uid) = ppr uid <> colon <> ppr mnwib---- | A '@ModuleGraph@' contains all the nodes from the home package (only). See--- '@ModuleGraphNode@' for information about the nodes.------ Modules need to be compiled. hs-boots need to be typechecked before--- the associated "real" module so modules with {-# SOURCE #-} imports can be--- built. Instantiations also need to be typechecked to ensure that the module--- fits the signature. Substantiation typechecking is roughly comparable to the--- check that the module and its hs-boot agree.------ The graph is not necessarily stored in topologically-sorted order.  Use--- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this.-data ModuleGraph = ModuleGraph-  { mg_mss :: [ModuleGraphNode]-  , mg_trans_deps :: Map.Map NodeKey (Set.Set NodeKey)-    -- A cached transitive dependency calculation so that a lot of work is not-    -- repeated whenever the transitive dependencies need to be calculated (for example, hptInstances)-  }---- | Map a function 'f' over all the 'ModSummaries'.--- To preserve invariants 'f' can't change the isBoot status.-mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph-mapMG f mg@ModuleGraph{..} = mg-  { mg_mss = flip fmap mg_mss $ \case-      InstantiationNode uid iuid -> InstantiationNode uid iuid-      LinkNode uid nks -> LinkNode uid nks-      ModuleNode deps ms  -> ModuleNode deps (f ms)-  }--unionMG :: ModuleGraph -> ModuleGraph -> ModuleGraph-unionMG a b =-  let new_mss = nubOrdBy compare $ mg_mss a `mappend` mg_mss b-  in ModuleGraph {-        mg_mss = new_mss-      , mg_trans_deps = mkTransDeps new_mss-      }---mgTransDeps :: ModuleGraph -> Map.Map NodeKey (Set.Set NodeKey)-mgTransDeps = mg_trans_deps--mgModSummaries :: ModuleGraph -> [ModSummary]-mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ]--mgModSummaries' :: ModuleGraph -> [ModuleGraphNode]-mgModSummaries' = mg_mss---- | Look up a ModSummary in the ModuleGraph--- Looks up the non-boot ModSummary--- Linear in the size of the module graph-mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary-mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss-  where-    go (ModuleNode _ ms)-      | NotBoot <- isBootSummary ms-      , ms_mod ms == m-      = Just ms-    go _ = Nothing--emptyMG :: ModuleGraph-emptyMG = ModuleGraph [] Map.empty--isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool-isTemplateHaskellOrQQNonBoot ms =-  (xopt LangExt.TemplateHaskell (ms_hspp_opts ms)-    || xopt LangExt.QuasiQuotes (ms_hspp_opts ms)) &&-  (isBootSummary ms == NotBoot)---- | Add an ExtendedModSummary to ModuleGraph. Assumes that the new ModSummary is--- not an element of the ModuleGraph.-extendMG :: ModuleGraph -> [NodeKey] -> ModSummary -> ModuleGraph-extendMG ModuleGraph{..} deps ms = ModuleGraph-  { mg_mss = ModuleNode deps ms : mg_mss-  , mg_trans_deps = mkTransDeps (ModuleNode deps ms : mg_mss)-  }--mkTransDeps :: [ModuleGraphNode] -> Map.Map NodeKey (Set.Set NodeKey)-mkTransDeps mss =-  let (gg, _lookup_node) = moduleGraphNodes False mss-  in allReachable gg (mkNodeKey . node_payload)--extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph-extendMGInst mg uid depUnitId = mg-  { mg_mss = InstantiationNode uid depUnitId : mg_mss mg-  }--extendMGLink :: ModuleGraph -> UnitId -> [NodeKey] -> ModuleGraph-extendMGLink mg uid nks = mg { mg_mss = LinkNode nks uid : mg_mss mg }--extendMG' :: ModuleGraph -> ModuleGraphNode -> ModuleGraph-extendMG' mg = \case-  InstantiationNode uid depUnitId -> extendMGInst mg uid depUnitId-  ModuleNode deps ms -> extendMG mg deps ms-  LinkNode deps uid   -> extendMGLink mg uid deps--mkModuleGraph :: [ModuleGraphNode] -> ModuleGraph-mkModuleGraph = foldr (flip extendMG') emptyMG---- | This function filters out all the instantiation nodes from each SCC of a--- topological sort. Use this with care, as the resulting "strongly connected components"--- may not really be strongly connected in a direct way, as instantiations have been--- removed. It would probably be best to eliminate uses of this function where possible.-filterToposortToModules-  :: [SCC ModuleGraphNode] -> [SCC ModSummary]-filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case-  InstantiationNode _ _ -> Nothing-  LinkNode{} -> Nothing-  ModuleNode _deps node -> Just node-  where-    -- This higher order function is somewhat bogus,-    -- as the definition of "strongly connected component"-    -- is not necessarily respected.-    mapMaybeSCC :: (a -> Maybe b) -> SCC a -> Maybe (SCC b)-    mapMaybeSCC f = \case-      AcyclicSCC a -> AcyclicSCC <$> f a-      CyclicSCC as -> case mapMaybe f as of-        [] -> Nothing-        [a] -> Just $ AcyclicSCC a-        as -> Just $ CyclicSCC as--showModMsg :: DynFlags -> Bool -> ModuleGraphNode -> SDoc-showModMsg dflags _ (LinkNode {}) =-      let staticLink = case ghcLink dflags of-                          LinkStaticLib -> True-                          _ -> False--          platform  = targetPlatform dflags-          arch_os   = platformArchOS platform-          exe_file  = exeFileName arch_os staticLink (outputFile_ dflags)-      in text exe_file-showModMsg _ _ (InstantiationNode _uid indef_unit) =-  ppr $ instUnitInstanceOf indef_unit-showModMsg dflags recomp (ModuleNode _ mod_summary) =-  if gopt Opt_HideSourcePaths dflags-      then text mod_str-      else hsep $-         [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ')-         , char '('-         , text (op $ msHsFilePath mod_summary) <> char ','-         , message, char ')' ]--  where-    op       = normalise-    mod_str  = moduleNameString (moduleName (ms_mod mod_summary)) ++-               hscSourceString (ms_hsc_src mod_summary)-    dyn_file = op $ msDynObjFilePath mod_summary-    obj_file = op $ msObjFilePath mod_summary-    files    = [ obj_file ]-               ++ [ dyn_file | gopt Opt_BuildDynamicToo dflags ]-               ++ [ "interpreted" | gopt Opt_ByteCodeAndObjectCode dflags ]-    message = case backendSpecialModuleSource (backend dflags) recomp of-                Just special -> text special-                Nothing -> foldr1 (\ofile rest -> ofile <> comma <+> rest) (map text files)----type SummaryNode = Node Int ModuleGraphNode--summaryNodeKey :: SummaryNode -> Int-summaryNodeKey = node_key--summaryNodeSummary :: SummaryNode -> ModuleGraphNode-summaryNodeSummary = node_payload---- | Collect the immediate dependencies of a ModuleGraphNode,--- optionally avoiding hs-boot dependencies.--- If the drop_hs_boot_nodes flag is False, and if this is a .hs and there is--- an equivalent .hs-boot, add a link from the former to the latter.  This--- has the effect of detecting bogus cases where the .hs-boot depends on the--- .hs, by introducing a cycle.  Additionally, it ensures that we will always--- process the .hs-boot before the .hs, and so the HomePackageTable will always--- have the most up to date information.-nodeDependencies :: Bool -> ModuleGraphNode -> [NodeKey]-nodeDependencies drop_hs_boot_nodes = \case-    LinkNode deps _uid -> deps-    InstantiationNode uid iuid ->-      NodeKey_Module . (\mod -> ModNodeKeyWithUid (GWIB mod NotBoot) uid)  <$> uniqDSetToList (instUnitHoles iuid)-    ModuleNode deps _ms ->-      map drop_hs_boot deps-  where-    -- Drop hs-boot nodes by using HsSrcFile as the key-    hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature-                | otherwise          = IsBoot--    drop_hs_boot (NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid)) = (NodeKey_Module (ModNodeKeyWithUid (GWIB mn hs_boot_key) uid))-    drop_hs_boot x = x---- | Turn a list of graph nodes into an efficient queriable graph.--- The first boolean parameter indicates whether nodes corresponding to hs-boot files--- should be collapsed into their relevant hs nodes.-moduleGraphNodes :: Bool-  -> [ModuleGraphNode]-  -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)-moduleGraphNodes drop_hs_boot_nodes summaries =-  (graphFromEdgedVerticesUniq nodes, lookup_node)-  where-    -- Map from module to extra boot summary dependencies which need to be merged in-    (boot_summaries, nodes) = bimap Map.fromList id $ partitionWith go numbered_summaries--      where-        go (s, key) =-          case s of-                ModuleNode __deps ms | isBootSummary ms == IsBoot, drop_hs_boot_nodes-                  -- Using nodeDependencies here converts dependencies on other-                  -- boot files to dependencies on dependencies on non-boot files.-                  -> Left (ms_mod ms, nodeDependencies drop_hs_boot_nodes s)-                _ -> normal_case-          where-           normal_case =-              let lkup_key = ms_mod <$> moduleGraphNodeModSum s-                  extra = (lkup_key >>= \key -> Map.lookup key boot_summaries)--              in Right $ DigraphNode s key $ out_edge_keys $-                      (fromMaybe [] extra-                        ++ nodeDependencies drop_hs_boot_nodes s)--    numbered_summaries = zip summaries [1..]--    lookup_node :: NodeKey -> Maybe SummaryNode-    lookup_node key = Map.lookup key (unNodeMap node_map)--    lookup_key :: NodeKey -> Maybe Int-    lookup_key = fmap summaryNodeKey . lookup_node--    node_map :: NodeMap SummaryNode-    node_map = NodeMap $-      Map.fromList [ (mkNodeKey s, node)-                   | node <- nodes-                   , let s = summaryNodeSummary node-                   ]--    out_edge_keys :: [NodeKey] -> [Int]-    out_edge_keys = mapMaybe lookup_key-        -- If we want keep_hi_boot_nodes, then we do lookup_key with-        -- IsBoot; else False-newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }-  deriving (Functor, Traversable, Foldable)--mkNodeKey :: ModuleGraphNode -> NodeKey-mkNodeKey = \case-  InstantiationNode _ iu -> NodeKey_Unit iu-  ModuleNode _ x -> NodeKey_Module $ msKey x-  LinkNode _ uid   -> NodeKey_Link uid--msKey :: ModSummary -> ModNodeKeyWithUid-msKey ms = ModNodeKeyWithUid (ms_mnwib ms) (ms_unitid ms)--type ModNodeKey = ModuleNameWithIsBoot----- | This function returns all the modules belonging to the home-unit that can--- be reached by following the given dependencies. Additionally, if both the--- boot module and the non-boot module can be reached, it only returns the--- non-boot one.-moduleGraphModulesBelow :: ModuleGraph -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid-moduleGraphModulesBelow mg uid mn = filtered_mods $ [ mn |  NodeKey_Module mn <- modules_below]-  where-    td_map = mgTransDeps mg--    modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map--    filtered_mods = Set.fromDistinctAscList . filter_mods . sort--    -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list-    -- (cf Ord instance of GenWithIsBoot). Hence we only have to perform a-    -- linear sweep with a window of size 2 to remove boot modules for which we-    -- have the corresponding non-boot.-    filter_mods = \case-      (r1@(ModNodeKeyWithUid (GWIB m1 b1) uid1) : r2@(ModNodeKeyWithUid (GWIB m2 _) uid2): rs)-        | m1 == m2  && uid1 == uid2 ->-                       let !r' = case b1 of-                                  NotBoot -> r1-                                  IsBoot  -> r2-                       in r' : filter_mods rs-        | otherwise -> r1 : filter_mods (r2:rs)-      rs -> rs+-- | A module graph should be constructed once and never change from there onwards.+--+-- The only operations should be for building the 'ModuleGraph'+-- (once and for all -- no update-like/insert-like functions)+-- and querying the structure in various ways, e.g. to determine reachability.+--+-- We should avoid exposing fields like 'mg_mss' since it may be a footgun+-- trying to use the nodes directly... We do still expose it, but it feels like+-- all its use cases would be better served by a more proper ModuleGraph+-- abstraction+module GHC.Unit.Module.Graph+   (+    -- * Construct a module graph+    --+    -- | A module graph should be constructed once by downsweep and never modified.+     ModuleGraph(..)+   , emptyMG+   , mkModuleGraph+   , mkModuleGraphChecked++   -- * Invariant checking+   , checkModuleGraph+   , ModuleGraphInvariantError(..)++    -- * Nodes in a module graph+    --+    -- | The user-facing nodes in a module graph are 'ModuleGraphNode's.+    -- There are a few things which we can query out of each 'ModuleGraphNode':+    --+    -- - 'mgNodeDependencies' gets the immediate dependencies of this node+    -- - 'mgNodeUnitId' returns the 'UnitId' of that node+    -- - 'mgNodeModSum' extracts the 'ModSummary' of a node if exists+   , ModuleGraphNode(..)+   , mgNodeDependencies+   , mgNodeIsModule+   , mgNodeUnitId++   , ModuleNodeEdge(..)+   , mkModuleEdge+   , mkNormalEdge++   , ModuleNodeInfo(..)+   , moduleNodeInfoModule+   , moduleNodeInfoUnitId+   , moduleNodeInfoMnwib+   , moduleNodeInfoModuleName+   , moduleNodeInfoModNodeKeyWithUid+   , moduleNodeInfoHscSource+   , moduleNodeInfoLocation+   , isBootModuleNodeInfo+    -- * Module graph operations+   , lengthMG+   , isEmptyMG+    -- ** 'ModSummary' operations+    --+    -- | A couple of operations on the module graph allow access to the+    -- 'ModSummary's of the modules in it contained.+    --+    -- In particular, 'mapMG' and 'mapMGM' allow updating these 'ModSummary's+    -- (without changing the 'ModuleGraph' structure itself!).+    -- 'mgModSummaries' lists out all 'ModSummary's, and+    -- 'mgLookupModule' looks up a 'ModSummary' for a given module.+   , mapMG, mgMapM+   , mgModSummaries+   , mgLookupModule+   , mgLookupModuleName+   , mgHasHoles+   , showModMsg++    -- ** Reachability queries+    --+    -- | A module graph explains the structure and relationship between the+    -- modules being compiled. Often times, this structure is relevant to+    -- answer reachability queries -- is X reachable from Y; or, what is the+    -- transitive closure of Z?+   , mgReachable+   , mgReachableLoop+   , mgQuery+   , ZeroScopeKey(..)+   , mgQueryZero+   , mgQueryMany+   , mgQueryManyZero+   , mgMember++    -- ** Other operations+    --+    -- | These operations allow more-internal-than-ideal access to the+    -- ModuleGraph structure. Ideally, we could restructure the code using+    -- these functions to avoid deconstructing/reconstructing the ModuleGraph+    -- and instead extend the "proper interface" of the ModuleGraph to achieve+    -- what is currently done but through a better abstraction.+   , mgModSummaries'+   , moduleGraphNodes+   , moduleGraphModulesBelow -- needed for 'hptSomeThingsBelowUs',+                             -- but I think we could be more clever and cache+                             -- the graph-ixs of boot modules to efficiently+                             -- filter them out of the returned list.+                             -- hptInstancesBelow is re-doing that work every+                             -- time it's called.+   , filterToposortToModules+   , moduleGraphNodesZero+   , StageSummaryNode+   , stageSummaryNodeSummary+   , stageSummaryNodeKey+   , mkStageDeps++    -- * Keys into the 'ModuleGraph'+   , NodeKey(..)+   , mkNodeKey+   , nodeKeyUnitId+   , nodeKeyModName+   , ModNodeKey+   , ModNodeKeyWithUid(..)+   , mnkToModule+   , moduleToMnk+   , mnkToInstalledModule+   , installedModuleToMnk+   , mnkIsBoot+   , msKey+   , mnKey+   , miKey++   , ImportLevel(..)++    -- ** Internal node representation+    --+    -- | 'SummaryNode' is the internal representation for each node stored in+    -- the graph. It's not immediately clear to me why users do depend on them.+   , SummaryNode+   , summaryNodeSummary+   , summaryNodeKey++   )+where++import GHC.Prelude+import GHC.Platform++import GHC.Data.Maybe+import Data.Either+import GHC.Data.Graph.Directed+import GHC.Data.Graph.Directed.Reachability++import GHC.Driver.Backend+import GHC.Driver.DynFlags++import GHC.Types.SourceFile ( hscSourceString, isHsigFile, HscSource(..))+import GHC.Types.Basic++import GHC.Unit.Module.ModSummary+import GHC.Unit.Types+import GHC.Utils.Outputable+import GHC.Unit.Module.ModIface+import GHC.Utils.Misc ( partitionWith )++import System.FilePath+import qualified Data.Map as Map+import GHC.Types.Unique.DSet+import qualified Data.Set as Set+import Data.Set (Set)+import GHC.Unit.Module+import GHC.Unit.Module.ModNodeKey+import GHC.Unit.Module.Stage+import GHC.Linker.Static.Utils++import Data.Bifunctor+import Data.Function+import Data.List (sort)+import Data.List.NonEmpty ( NonEmpty (..) )+import qualified Data.List.NonEmpty as NE+import Control.Monad+import qualified GHC.LanguageExtensions as LangExt++-- | A '@ModuleGraph@' contains all the nodes from the home package (only). See+-- '@ModuleGraphNode@' for information about the nodes.+--+-- Modules need to be compiled. hs-boots need to be typechecked before+-- the associated "real" module so modules with {-# SOURCE #-} imports can be+-- built. Instantiations also need to be typechecked to ensure that the module+-- fits the signature. Substantiation typechecking is roughly comparable to the+-- check that the module and its hs-boot agree.+--+-- The graph is not necessarily stored in topologically-sorted order. Use+-- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this.+data ModuleGraph = ModuleGraph+  { mg_mss :: [ModuleGraphNode]+  , mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)+  , mg_loop_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)+  , mg_zero_graph :: (ReachabilityIndex ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode)++    -- `mg_graph` and `mg_loop_graph` cached transitive dependency calculations+    -- so that a lot of work is not repeated whenever the transitive+    -- dependencies need to be calculated (for example, hptInstances).+    --+    --- - `mg_graph` is a reachability index constructed from a module+    -- graph /with/ boot nodes (which make the graph acyclic), and+    --+    --- * `mg_loop_graph` is a reachability index for the graph /without/+    -- hs-boot nodes, that may be cyclic.++  , mg_has_holes :: !Bool+  -- Cached computation, whether any of the ModuleGraphNode are isHoleModule,+  -- This is only used for a hack in GHC.Iface.Load to do with backpack, please+  -- remove this at the earliest opportunity.+  }++-- | Why do we ever need to construct empty graphs? Is it because of one shot mode?+emptyMG :: ModuleGraph+emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing)+                         (graphReachability emptyGraph, const Nothing)+                         (graphReachability emptyGraph, const Nothing)+                         False++-- | Construct a module graph. This function should be the only entry point for+-- building a 'ModuleGraph', since it is supposed to be built once and never modified.+--+-- If you ever find the need to build a 'ModuleGraph' iteratively, don't+-- add insert and update functions to the API since they become footguns.+-- Instead, design an API that allows iterative construction without posterior+-- modification, perhaps like what is done for building arrays from mutable+-- arrays.+mkModuleGraph :: [ModuleGraphNode] -> ModuleGraph+mkModuleGraph = foldr (flip extendMG) emptyMG++-- | A version of mkModuleGraph that checks the module graph for invariants.+mkModuleGraphChecked :: [ModuleGraphNode] -> Either [ModuleGraphInvariantError] ModuleGraph+mkModuleGraphChecked nodes =+  let mg = mkModuleGraph nodes+  in case checkModuleGraph mg of+       [] -> Right mg+       errors -> Left errors++--------------------------------------------------------------------------------+-- * Module Graph Nodes+--------------------------------------------------------------------------------++-- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'.+-- Edges between nodes mark dependencies arising from module imports+-- and dependencies arising from backpack instantiations.+data ModuleGraphNode+  -- | Instantiation nodes track the instantiation of other units+  -- (backpack dependencies) with the holes (signatures) of the current package.+  = InstantiationNode UnitId InstantiatedUnit+  -- | There is a module node for each module being built.+  -- A node is either fixed or can be compiled.+  -- - Fixed modules are not compiled, the artifacts are just loaded from disk.+  --   It is up to your to make sure the artifacts are up to date and available.+  -- - Compile modules are compiled from source if needed.+  | ModuleNode [ModuleNodeEdge] ModuleNodeInfo+  -- | Link nodes are whether are are creating a linked product (ie executable/shared object etc) for a unit.+  | LinkNode [NodeKey] UnitId+  -- | Package dependency+  | UnitNode [UnitId] UnitId+++data ModuleNodeEdge = ModuleNodeEdge { edgeLevel :: ImportLevel+                                     , edgeTargetKey :: NodeKey }++mkModuleEdge :: ImportLevel -> NodeKey -> ModuleNodeEdge+mkModuleEdge level key = ModuleNodeEdge level key++-- | A 'normal' edge in the graph which isn't offset by an import stage.+mkNormalEdge :: NodeKey -> ModuleNodeEdge+mkNormalEdge = mkModuleEdge NormalLevel++instance Outputable ModuleNodeEdge where+  ppr (ModuleNodeEdge level key) =+    let level_str = case level of+                      NormalLevel -> ""+                      SpliceLevel -> "(S)"+                      QuoteLevel -> "(Q)"+    in text level_str <> ppr key++data ModuleGraphInvariantError =+        FixedNodeDependsOnCompileNode ModNodeKeyWithUid [NodeKey]+      | DuplicateModuleNodeKey NodeKey+      | DependencyNotInGraph NodeKey [NodeKey]+      deriving (Eq, Ord)++instance Outputable ModuleGraphInvariantError where+  ppr = \case+    FixedNodeDependsOnCompileNode key bad_deps ->+      text "Fixed node" <+> ppr key <+> text "depends on compile nodes" <+> ppr bad_deps+    DuplicateModuleNodeKey k ->+      text "Duplicate module node key" <+> ppr k+    DependencyNotInGraph from to ->+      text "Dependency not in graph" <+> ppr from <+> text "->" <+> ppr to++-- Used for invariant checking. Is a NodeKey fixed or compilable?+data ModuleNodeType = MN_Fixed | MN_Compile++instance Outputable ModuleNodeType where+  ppr = \case+    MN_Fixed -> text "Fixed"+    MN_Compile -> text "Compile"++moduleNodeType :: ModuleGraphNode -> ModuleNodeType+moduleNodeType (ModuleNode _ (ModuleNodeCompile _)) = MN_Compile+moduleNodeType (ModuleNode _ (ModuleNodeFixed _ _)) = MN_Fixed+moduleNodeType (UnitNode {}) = MN_Fixed+moduleNodeType _ = MN_Compile++checkModuleGraph :: ModuleGraph -> [ModuleGraphInvariantError]+checkModuleGraph ModuleGraph{..} =+  mapMaybe (checkFixedModuleInvariant node_types) mg_mss+  ++ mapMaybe (checkAllDependenciesInGraph node_types) mg_mss+  ++ duplicate_errs+  where+    duplicate_errs = rights (Map.elems node_types)++    node_types :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)+    node_types = Map.fromListWithKey go [ (mkNodeKey n, Left (moduleNodeType n)) | n <- mg_mss ]+      where+        -- Multiple nodes with the same key are not allowed.+        go :: NodeKey -> Either ModuleNodeType ModuleGraphInvariantError+                      -> Either ModuleNodeType ModuleGraphInvariantError+                      -> Either ModuleNodeType ModuleGraphInvariantError+        go k _ _ = Right (DuplicateModuleNodeKey k)++-- | Check that all dependencies in the graph are present in the node_types map.+-- This is a helper function used by checkModuleGraph.+checkAllDependenciesInGraph :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)+                            -> ModuleGraphNode+                            -> Maybe ModuleGraphInvariantError+checkAllDependenciesInGraph node_types node =+  let nodeKey = mkNodeKey node+      deps = mgNodeDependencies False node+      missingDeps = filter (\dep -> not (Map.member dep node_types)) deps+  in if null missingDeps+     then Nothing+     else Just (DependencyNotInGraph nodeKey missingDeps)+++-- | Check if for the fixed module node invariant:+--+--   Fixed nodes can only depend on other fixed nodes.+checkFixedModuleInvariant :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)+                -> ModuleGraphNode+                -> Maybe ModuleGraphInvariantError+checkFixedModuleInvariant node_types node = case node of+  ModuleNode deps (ModuleNodeFixed key _) ->+    let check_node dep = case Map.lookup dep node_types of+                           -- Dependency is not fixed+                           Just (Left MN_Compile) -> Just dep+                           _ -> Nothing+        bad_deps = mapMaybe check_node (map edgeTargetKey deps)+    in if null bad_deps+       then Nothing+       else Just (FixedNodeDependsOnCompileNode key bad_deps)++  _ -> Nothing+++{- Note [Module Types in the ModuleGraph]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Modules can be one of two different types in the module graph.++1. ModuleNodeCompile, modules with source files we can compile.+2. ModuleNodeFixed, modules which we presume are already compiled and available.++The ModuleGraph can contain a combination of these two types of nodes but must+obey the invariant that Fixed nodes only depend on other Fixed nodes. This invariant+can be checked by the `checkModuleGraph` function, but it's+the responsibility of the code constructing the ModuleGraph to ensure it is upheld.++At the moment, when using --make mode, GHC itself will only use `ModuleNodeCompile` nodes.++In oneshot mode, we don't have access to the source files of dependencies but sometimes need to know+information about the module graph still (for example, getLinkDeps).++In theory, the whole compiler will work if an API program uses ModuleNodeFixed nodes, and+there is a simple test in FixedNodes, which can be extended in future to cover+any missing cases.++-}+data ModuleNodeInfo = ModuleNodeFixed ModNodeKeyWithUid ModLocation+                    | ModuleNodeCompile ModSummary++-- | Extract the Module from a ModuleNodeInfo+moduleNodeInfoModule :: ModuleNodeInfo -> Module+moduleNodeInfoModule (ModuleNodeFixed key _) = mnkToModule key+moduleNodeInfoModule (ModuleNodeCompile ms) = ms_mod ms++-- | Extract the ModNodeKeyWithUid from a ModuleNodeInfo+moduleNodeInfoModNodeKeyWithUid :: ModuleNodeInfo -> ModNodeKeyWithUid+moduleNodeInfoModNodeKeyWithUid (ModuleNodeFixed key _) = key+moduleNodeInfoModNodeKeyWithUid (ModuleNodeCompile ms) = msKey ms++-- | Extract the HscSource from a ModuleNodeInfo, if we can determine it.+moduleNodeInfoHscSource :: ModuleNodeInfo -> Maybe HscSource+moduleNodeInfoHscSource (ModuleNodeFixed _ _) = Nothing+moduleNodeInfoHscSource (ModuleNodeCompile ms) = Just (ms_hsc_src ms)++-- | Extract the ModLocation from a ModuleNodeInfo+moduleNodeInfoLocation :: ModuleNodeInfo -> ModLocation+moduleNodeInfoLocation (ModuleNodeFixed _ loc) = loc+moduleNodeInfoLocation (ModuleNodeCompile ms) = ms_location ms++-- | Extract the IsBootInterface from a ModuleNodeInfo+isBootModuleNodeInfo :: ModuleNodeInfo -> IsBootInterface+isBootModuleNodeInfo (ModuleNodeFixed mnwib _) = mnkIsBoot mnwib+isBootModuleNodeInfo (ModuleNodeCompile ms) = isBootSummary ms++-- | Extract the ModuleName from a ModuleNodeInfo+moduleNodeInfoModuleName :: ModuleNodeInfo -> ModuleName+moduleNodeInfoModuleName m = moduleName (moduleNodeInfoModule m)++moduleNodeInfoUnitId :: ModuleNodeInfo -> UnitId+moduleNodeInfoUnitId (ModuleNodeFixed key _) = mnkUnitId key+moduleNodeInfoUnitId (ModuleNodeCompile ms) = ms_unitid ms++moduleNodeInfoMnwib :: ModuleNodeInfo -> ModuleNameWithIsBoot+moduleNodeInfoMnwib (ModuleNodeFixed key _) = mnkModuleName key+moduleNodeInfoMnwib (ModuleNodeCompile ms) = ms_mnwib ms++-- | Collect the immediate dependencies of a ModuleGraphNode,+-- optionally avoiding hs-boot dependencies.+-- If the drop_hs_boot_nodes flag is False, and if this is a .hs and there is+-- an equivalent .hs-boot, add a link from the former to the latter.  This+-- has the effect of detecting bogus cases where the .hs-boot depends on the+-- .hs, by introducing a cycle.  Additionally, it ensures that we will always+-- process the .hs-boot before the .hs, and so the HomePackageTable will always+-- have the most up to date information.+mgNodeDependencies :: Bool -> ModuleGraphNode -> [NodeKey]+mgNodeDependencies drop_hs_boot_nodes = \case+    LinkNode deps _uid -> deps+    InstantiationNode uid iuid ->+      [ NodeKey_Module (ModNodeKeyWithUid (GWIB mod NotBoot) uid) | mod <- uniqDSetToList (instUnitHoles iuid) ]+      ++ [ NodeKey_ExternalUnit (instUnitInstanceOf iuid) ]+    ModuleNode deps _ms ->+      map (drop_hs_boot . edgeTargetKey) deps+    UnitNode deps _ -> map NodeKey_ExternalUnit deps+  where+    -- Drop hs-boot nodes by using HsSrcFile as the key+    hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature+                | otherwise          = IsBoot++    drop_hs_boot (NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid)) = (NodeKey_Module (ModNodeKeyWithUid (GWIB mn hs_boot_key) uid))+    drop_hs_boot x = x++mgNodeIsModule :: ModuleGraphNode -> Maybe ModuleNodeInfo+mgNodeIsModule (InstantiationNode {}) = Nothing+mgNodeIsModule (LinkNode {})          = Nothing+mgNodeIsModule (ModuleNode _ ms)      = Just ms+mgNodeIsModule (UnitNode {})       = Nothing++mgNodeUnitId :: ModuleGraphNode -> UnitId+mgNodeUnitId mgn =+  case mgn of+    InstantiationNode uid _iud -> uid+    ModuleNode _ ms           -> toUnitId (moduleUnit (moduleNodeInfoModule ms))+    LinkNode _ uid             -> uid+    UnitNode _ uid          -> uid++instance Outputable ModuleGraphNode where+  ppr = \case+    InstantiationNode _ iuid -> ppr iuid+    ModuleNode nks ms -> ppr (mnKey ms) <+> ppr nks+    LinkNode uid _     -> text "LN:" <+> ppr uid+    UnitNode _ uid  -> text "P:" <+> ppr uid++instance Eq ModuleGraphNode where+  (==) = (==) `on` mkNodeKey++instance Ord ModuleGraphNode where+  compare = compare `on` mkNodeKey++--------------------------------------------------------------------------------+-- * Module Graph operations+--------------------------------------------------------------------------------+-- | Returns the number of nodes in a 'ModuleGraph'+lengthMG :: ModuleGraph -> Int+lengthMG = length . mg_mss++isEmptyMG :: ModuleGraph -> Bool+isEmptyMG = null . mg_mss++--------------------------------------------------------------------------------+-- ** ModSummaries+--------------------------------------------------------------------------------++-- | Map a function 'f' over all the 'ModSummaries'.+-- To preserve invariants, 'f' can't change the isBoot status.+mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph+mapMG f mg@ModuleGraph{..} = mg+  { mg_mss = flip fmap mg_mss $ \case+      InstantiationNode uid iuid -> InstantiationNode uid iuid+      LinkNode uid nks -> LinkNode uid nks+      ModuleNode deps (ModuleNodeFixed key loc)  -> ModuleNode deps (ModuleNodeFixed key loc)+      ModuleNode deps (ModuleNodeCompile ms) -> ModuleNode deps (ModuleNodeCompile (f ms))+      UnitNode deps uid -> UnitNode deps uid+  }++-- | Map a function 'f' over all the 'ModSummaries', in 'IO'.+-- To preserve invariants, 'f' can't change the isBoot status.+mgMapM :: (ModuleNodeInfo -> IO ModuleNodeInfo) -> ModuleGraph -> IO ModuleGraph+mgMapM f mg@ModuleGraph{..} = do+  mss' <- forM mg_mss $ \case+    InstantiationNode uid iuid -> pure $ InstantiationNode uid iuid+    LinkNode uid nks -> pure $ LinkNode uid nks+    ModuleNode deps ms  -> ModuleNode deps <$> (f ms)+    UnitNode deps uid -> pure $ UnitNode deps uid+  return $ mg { mg_mss = mss' }+++mgModSummaries :: ModuleGraph -> [ModSummary]+mgModSummaries mg = [ m | ModuleNode _ (ModuleNodeCompile m) <- mgModSummaries' mg ]++-- | Look up a non-boot ModSummary in the ModuleGraph.+--+-- Careful: Linear in the size of the module graph+-- MP: This should probably be level aware+mgLookupModule :: ModuleGraph -> Module -> Maybe ModuleNodeInfo+mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss+  where+    go (ModuleNode _ ms)+      | NotBoot <- isBootModuleNodeInfo ms+      , moduleNodeInfoModule ms == m+      = Just ms+    go _ = Nothing++-- | Lookup up a 'ModuleNameWithIsBoot' in the 'ModuleGraph'.+--+-- Multiple nodes in the 'ModuleGraph' can have the same 'ModuleName'+-- and 'IsBootInterface'.+--+-- Careful: Linear in the size of the module graph.+mgLookupModuleName :: ModuleGraph -> ModuleNameWithIsBoot -> [ModuleNodeInfo]+mgLookupModuleName ModuleGraph{..} m = mapMaybe go mg_mss+  where+    go (ModuleNode _ ms)+      | moduleNodeInfoMnwib ms == m+      = Just ms+    go _ = Nothing++mgMember :: ModuleGraph -> NodeKey -> Bool+mgMember graph k = isJust $ snd (mg_graph graph) k++-- | A function you should not need to use, or desire to use. Only used+-- in one place, `GHC.Iface.Load` to facilitate a misimplementation in Backpack.+mgHasHoles :: ModuleGraph -> Bool+mgHasHoles ModuleGraph{..} = mg_has_holes++--------------------------------------------------------------------------------+-- ** Reachability+--------------------------------------------------------------------------------++-- | Return all nodes reachable from the given 'NodeKey'.+--+-- @Nothing@ if the key couldn't be found in the graph.+mgReachable :: ModuleGraph -> NodeKey -> Maybe [ModuleGraphNode]+mgReachable mg nk = map summaryNodeSummary <$> modules_below where+  (td_map, lookup_node) = mg_graph mg+  modules_below =+    allReachable td_map <$> lookup_node nk++-- | Things which are reachable if hs-boot files are ignored. Used by 'getLinkDeps'+mgReachableLoop :: ModuleGraph -> [NodeKey] -> [ModuleGraphNode]+mgReachableLoop mg nk = map summaryNodeSummary modules_below where+  (td_map, lookup_node) = mg_loop_graph mg+  modules_below =+    allReachableMany td_map (mapMaybe lookup_node nk)+++-- | @'mgQueryZero' g root b@ answers the question: can we reach @b@ from @root@+-- in the module graph @g@, only using normal (level 0) imports?+mgQueryZero :: ModuleGraph+            -> ZeroScopeKey+            -> ZeroScopeKey+            -> Bool+mgQueryZero mg nka nkb = isReachable td_map na nb where+  (td_map, lookup_node) = mg_zero_graph mg+  na = expectJust $ lookup_node nka+  nb = expectJust $ lookup_node nkb+++-- | Reachability Query.+--+-- @mgQuery(g, a, b)@ asks:+-- Can we reach @b@ from @a@ in graph @g@?+--+-- Both @a@ and @b@ must be in @g@.+mgQuery :: ModuleGraph -- ^ @g@+        -> NodeKey -- ^ @a@+        -> NodeKey -- ^ @b@+        -> Bool -- ^ @b@ is reachable from @a@+mgQuery mg nka nkb = isReachable td_map na nb where+  (td_map, lookup_node) = mg_graph mg+  na = expectJust $ lookup_node nka+  nb = expectJust $ lookup_node nkb++-- | Many roots reachability Query.+--+-- @mgQuery(g, roots, b)@ asks:+-- Can we reach @b@ from any of the @roots@ in graph @g@?+--+-- Node @b@ must be in @g@.+mgQueryMany :: ModuleGraph -- ^ @g@+            -> [NodeKey] -- ^ @roots@+            -> NodeKey -- ^ @b@+            -> Bool -- ^ @b@ is reachable from @roots@+mgQueryMany mg roots nkb = isReachableMany td_map nroots nb where+  (td_map, lookup_node) = mg_graph mg+  nroots = mapMaybe lookup_node roots+  nb = expectJust $ lookup_node nkb++-- | Many roots reachability Query.+--+-- @mgQuery(g, roots, b)@ asks:+-- Can we reach @b@ from any of the @roots@ in graph @g@, only using normal (level 0) imports?+--+-- Node @b@ must be in @g@.+mgQueryManyZero :: ModuleGraph -- ^ @g@+            -> [ZeroScopeKey] -- ^ @roots@+            -> ZeroScopeKey -- ^ @b@+            -> Bool -- ^ @b@ is reachable from @roots@+mgQueryManyZero mg roots nkb = isReachableMany td_map nroots nb where+  (td_map, lookup_node) = mg_zero_graph mg+  nroots = mapMaybe lookup_node roots+  nb = expectJust $ lookup_node (pprTrace "mg" (ppr nkb) nkb)++--------------------------------------------------------------------------------+-- ** Other operations (read haddocks on export list)+--------------------------------------------------------------------------------++mgModSummaries' :: ModuleGraph -> [ModuleGraphNode]+mgModSummaries' = mg_mss++-- | Turn a list of graph nodes into an efficient queriable graph.+-- The first boolean parameter indicates whether nodes corresponding to hs-boot files+-- should be collapsed into their relevant hs nodes.+moduleGraphNodes :: Bool+  -> [ModuleGraphNode]+  -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)+moduleGraphNodes drop_hs_boot_nodes summaries =+  (graphFromEdgedVerticesUniq nodes, lookup_node)+  where+    -- Map from module to extra boot summary dependencies which need to be merged in+    (boot_summaries, nodes) = bimap Map.fromList id $ partitionWith go numbered_summaries++      where+        go (s, key) =+          case s of+                ModuleNode __deps ms | isBootModuleNodeInfo ms == IsBoot, drop_hs_boot_nodes+                  -- Using nodeDependencies here converts dependencies on other+                  -- boot files to dependencies on dependencies on non-boot files.+                  -> Left (moduleNodeInfoModule ms, mgNodeDependencies drop_hs_boot_nodes s)+                _ -> normal_case+          where+           normal_case =+              let lkup_key = moduleNodeInfoModule <$> mgNodeIsModule s+                  extra = (lkup_key >>= \key -> Map.lookup key boot_summaries)++              in Right $ DigraphNode s key $ out_edge_keys $+                      (fromMaybe [] extra+                        ++ mgNodeDependencies drop_hs_boot_nodes s)++    numbered_summaries = zip summaries [1..]++    lookup_node :: NodeKey -> Maybe SummaryNode+    lookup_node key = Map.lookup key (unNodeMap node_map)++    lookup_key :: NodeKey -> Maybe Int+    lookup_key = fmap summaryNodeKey . lookup_node++    node_map :: NodeMap SummaryNode+    node_map = NodeMap $+      Map.fromList [ (mkNodeKey s, node)+                   | node <- nodes+                   , let s = summaryNodeSummary node+                   ]++    out_edge_keys :: [NodeKey] -> [Int]+    out_edge_keys = mapMaybe lookup_key+        -- If we want keep_hi_boot_nodes, then we do lookup_key with+        -- IsBoot; else False+++-- | This function returns all the modules belonging to the home-unit that can+-- be reached by following the given dependencies. Additionally, if both the+-- boot module and the non-boot module can be reached, it only returns the+-- non-boot one.+moduleGraphModulesBelow :: ModuleGraph -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid+moduleGraphModulesBelow mg uid mn = filtered_mods [ mn |  NodeKey_Module mn <- modules_below]+  where+    modules_below = maybe [] (map mkNodeKey) (mgReachable mg (NodeKey_Module (ModNodeKeyWithUid mn uid)))+    filtered_mods = Set.fromDistinctAscList . filter_mods . sort++    -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list+    -- (cf Ord instance of GenWithIsBoot). Hence we only have to perform a+    -- linear sweep with a window of size 2 to remove boot modules for which we+    -- have the corresponding non-boot.+    filter_mods = \case+      (r1@(ModNodeKeyWithUid (GWIB m1 b1) uid1) : r2@(ModNodeKeyWithUid (GWIB m2 _) uid2): rs)+        | m1 == m2  && uid1 == uid2 ->+                       let !r' = case b1 of+                                  NotBoot -> r1+                                  IsBoot  -> r2+                       in r' : filter_mods rs+        | otherwise -> r1 : filter_mods (r2:rs)+      rs -> rs++-- | This function filters out all the instantiation nodes from each SCC of a+-- topological sort. Use this with care, as the resulting "strongly connected components"+-- may not really be strongly connected in a direct way, as instantiations have been+-- removed. It would probably be best to eliminate uses of this function where possible.+filterToposortToModules+  :: [SCC ModuleGraphNode] -> [SCC ModuleNodeInfo]+filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case+  ModuleNode _deps node -> Just node+  _ -> Nothing+  where+    -- This higher order function is somewhat bogus,+    -- as the definition of "strongly connected component"+    -- is not necessarily respected.+    mapMaybeSCC :: (a -> Maybe b) -> SCC a -> Maybe (SCC b)+    mapMaybeSCC f = \case+      AcyclicSCC a -> AcyclicSCC <$> f a+      CyclicSCC as -> case mapMaybe f as of+        [] -> Nothing+        [a] -> Just $ AcyclicSCC a+        as -> Just $ CyclicSCC as++--------------------------------------------------------------------------------+-- * Keys into ModuleGraph+--------------------------------------------------------------------------------++data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit+             | NodeKey_Module {-# UNPACK #-} !ModNodeKeyWithUid+             | NodeKey_Link !UnitId+             | NodeKey_ExternalUnit !UnitId+  deriving (Eq, Ord)++instance Outputable NodeKey where+  ppr (NodeKey_Unit iu)   = ppr iu+  ppr (NodeKey_Module mk) = ppr mk+  ppr (NodeKey_Link uid)  = ppr uid+  ppr (NodeKey_ExternalUnit uid) = ppr uid++mkNodeKey :: ModuleGraphNode -> NodeKey+mkNodeKey = \case+  InstantiationNode _ iu -> NodeKey_Unit iu+  ModuleNode _ x -> NodeKey_Module $ mnKey x+  LinkNode _ uid   -> NodeKey_Link uid+  UnitNode _ uid -> NodeKey_ExternalUnit uid++nodeKeyUnitId :: NodeKey -> UnitId+nodeKeyUnitId (NodeKey_Unit iu)   = instUnitInstanceOf iu+nodeKeyUnitId (NodeKey_Module mk) = mnkUnitId mk+nodeKeyUnitId (NodeKey_Link uid)  = uid+nodeKeyUnitId (NodeKey_ExternalUnit uid) = uid++nodeKeyModName :: NodeKey -> Maybe ModuleName+nodeKeyModName (NodeKey_Module mk) = Just (gwib_mod $ mnkModuleName mk)+nodeKeyModName _ = Nothing++msKey :: ModSummary -> ModNodeKeyWithUid+msKey ms = ModNodeKeyWithUid (ms_mnwib ms) (ms_unitid ms)++mnKey :: ModuleNodeInfo -> ModNodeKeyWithUid+mnKey (ModuleNodeFixed key _) = key+mnKey (ModuleNodeCompile ms) = msKey ms++miKey :: ModIface -> ModNodeKeyWithUid+miKey hmi = ModNodeKeyWithUid (mi_mnwib hmi) ((toUnitId $ moduleUnit (mi_module hmi)))++type ModNodeKey = ModuleNameWithIsBoot++--------------------------------------------------------------------------------+-- ** Internal node representation (exposed)+--------------------------------------------------------------------------------++type SummaryNode = Node Int ModuleGraphNode++summaryNodeKey :: SummaryNode -> Int+summaryNodeKey = node_key++summaryNodeSummary :: SummaryNode -> ModuleGraphNode+summaryNodeSummary = node_payload++--------------------------------------------------------------------------------+-- * Misc utilities+--------------------------------------------------------------------------------++showModMsg :: DynFlags -> Bool -> ModuleGraphNode -> SDoc+showModMsg dflags _ (LinkNode {}) =+      let staticLink = case ghcLink dflags of+                          LinkStaticLib -> True+                          _ -> False++          platform  = targetPlatform dflags+          arch_os   = platformArchOS platform+          exe_file  = exeFileName arch_os staticLink (outputFile_ dflags)+      in text exe_file+showModMsg _ _ (UnitNode _deps uid) = ppr uid+showModMsg _ _ (InstantiationNode _uid indef_unit) =+  ppr $ instUnitInstanceOf indef_unit+showModMsg dflags recomp (ModuleNode _ mni) =+  if gopt Opt_HideSourcePaths dflags+      then text mod_str+      else hsep $+         [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ')+         , char '('+         , text (moduleNodeInfoSource mni) <> char ','+         , moduleNodeInfoExtraMessage dflags recomp mni, char ')' ]+  where+    mod_str  = moduleNameString (moduleName (moduleNodeInfoModule mni)) +++               moduleNodeInfoBootString mni++-- | Extra information about a 'ModuleNodeInfo' to display in the progress message.+moduleNodeInfoExtraMessage :: DynFlags -> Bool -> ModuleNodeInfo -> SDoc+moduleNodeInfoExtraMessage dflags recomp (ModuleNodeCompile mod_summary) =+    let dyn_file = normalise $ msDynObjFilePath mod_summary+        obj_file = normalise $ msObjFilePath mod_summary+        files    = obj_file+                   :| [ dyn_file | gopt Opt_BuildDynamicToo dflags ]+                   ++ [ "interpreted" | gopt Opt_ByteCodeAndObjectCode dflags ]+    in case backendSpecialModuleSource (backend dflags) recomp of+              Just special -> text special+              Nothing -> foldr1 (\ofile rest -> ofile <> comma <+> rest) (NE.map text files)+moduleNodeInfoExtraMessage _ _ (ModuleNodeFixed {}) = text "fixed"+++-- | The source location of the module node to show to the user.+moduleNodeInfoSource :: ModuleNodeInfo -> FilePath+moduleNodeInfoSource (ModuleNodeCompile ms) = normalise $ msHsFilePath ms+moduleNodeInfoSource (ModuleNodeFixed _ loc) = normalise $ ml_hi_file loc++-- | The extra info about a module [boot] or [sig] to display.+moduleNodeInfoBootString :: ModuleNodeInfo -> String+moduleNodeInfoBootString (ModuleNodeCompile ms) = hscSourceString (ms_hsc_src ms)+moduleNodeInfoBootString mn@(ModuleNodeFixed {}) =+  hscSourceString (case isBootModuleNodeInfo mn of+                      IsBoot -> HsBootFile+                      NotBoot -> HsSrcFile)++--------------------------------------------------------------------------------+-- * Internal methods for module graph+--+-- These are *really* meant to be internal!+-- Don't expose them without careful consideration about the invariants+-- described in the export list haddocks.+--------------------------------------------------------------------------------++newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }+  deriving (Functor, Traversable, Foldable)++-- | Transitive dependencies, including SOURCE edges+mkTransDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)+mkTransDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodes False++-- | Transitive dependencies, ignoring SOURCE edges+mkTransLoopDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)+mkTransLoopDeps = first cyclicGraphReachability . moduleGraphNodes True++-- | Transitive dependencies, but only following "normal" level 0 imports.+-- This graph can be used to query what the transitive dependencies of a particular+-- level are within a module.+mkTransZeroDeps :: [ModuleGraphNode] -> (ReachabilityIndex ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode)+mkTransZeroDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodesZero++-- | Transitive dependencies, but with the stage that each module is required at.+mkStageDeps :: [ModuleGraphNode] -> (ReachabilityIndex StageSummaryNode, (NodeKey, ModuleStage) -> Maybe StageSummaryNode)+mkStageDeps = first cyclicGraphReachability . moduleGraphNodesStages++type ZeroSummaryNode = Node Int ZeroScopeKey++zeroSummaryNodeKey :: ZeroSummaryNode -> Int+zeroSummaryNodeKey = node_key++zeroSummaryNodeSummary :: ZeroSummaryNode -> ZeroScopeKey+zeroSummaryNodeSummary = node_payload++-- | The 'ZeroScopeKey' indicates the different scopes which we can refer to in a zero-scope query.+data ZeroScopeKey = ModuleScope ModNodeKeyWithUid ImportLevel | UnitScope UnitId+  deriving (Eq, Ord)++instance Outputable ZeroScopeKey where+  ppr (ModuleScope mk il) = text "ModuleScope" <+> ppr mk <+> ppr il+  ppr (UnitScope uid) = text "UnitScope" <+> ppr uid++-- | Turn a list of graph nodes into an efficient queriable graph.+-- This graph only has edges between level-0 imports+--+-- This query answers the question. If I am looking at level n in module M then which+-- modules are visible?+--+-- If you are looking at level -1  then the reachable modules are those imported at splice and+-- then any modules those modules import at zero. (Ie the zero scope for those modules)+moduleGraphNodesZero ::+     [ModuleGraphNode]+  -> (Graph ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode)+moduleGraphNodesZero summaries =+  (graphFromEdgedVerticesUniq nodes, lookup_node)+  where+    nodes = mapMaybe go numbered_summaries++      where+        go :: (((ModuleGraphNode, ImportLevel)), Int) -> Maybe ZeroSummaryNode+        go (((ModuleNode nks ms), s), key) = Just $+               DigraphNode (ModuleScope (mnKey ms) s) key $ out_edge_keys $+                    mapMaybe (classifyDeps s) nks+        go (((UnitNode uids uid), _s), key) =+          Just $ DigraphNode (UnitScope uid) key (mapMaybe lookup_key $ map UnitScope uids)+        go _ = Nothing++    -- This is the key part, a dependency edge also depends on the NormalLevel scope of an import.+    classifyDeps s (ModuleNodeEdge il (NodeKey_Module k)) | s == il = Just (ModuleScope k NormalLevel)+    classifyDeps s (ModuleNodeEdge il (NodeKey_ExternalUnit u)) | s == il = Just (UnitScope u)+    classifyDeps _ _ = Nothing++    numbered_summaries :: [((ModuleGraphNode, ImportLevel), Int)]+    numbered_summaries = zip (([(s, l) | s <- summaries, l <- [SpliceLevel, QuoteLevel, NormalLevel]])) [0..]++    lookup_node :: ZeroScopeKey -> Maybe ZeroSummaryNode+    lookup_node key = Map.lookup key node_map++    lookup_key :: ZeroScopeKey -> Maybe Int+    lookup_key = fmap zeroSummaryNodeKey . lookup_node++    node_map :: Map.Map ZeroScopeKey ZeroSummaryNode+    node_map =+      Map.fromList [ (s, node)+                   | node <- nodes+                   , let s = zeroSummaryNodeSummary node+                   ]++    out_edge_keys :: [ZeroScopeKey] -> [Int]+    out_edge_keys = mapMaybe lookup_key++type StageSummaryNode = Node Int (NodeKey, ModuleStage)++stageSummaryNodeKey :: StageSummaryNode -> Int+stageSummaryNodeKey = node_key++stageSummaryNodeSummary :: StageSummaryNode -> (NodeKey, ModuleStage)+stageSummaryNodeSummary = node_payload++-- | Turn a list of graph nodes into an efficient queriable graph.+-- This graph has edges between modules and the stage they are required at.+--+-- This graph can be used to answer the query, if I am compiling a module at stage+-- S, then what modules do I need at which stages for that?+-- Used by 'downsweep' in order to determine which modules need code generation if you+-- are using 'TemplateHaskell'.+--+-- The rules for this query can be read in more detail in the Explicit Level Imports proposal.+-- Briefly:+--  * If NoImplicitStagePersistence then Quote/Splice/Normal imports offset the required stage+--  * If ImplicitStagePersistence and TemplateHaskell then imported module are needed at all stages.+--  * Otherwise, an imported module is just needed at the normal stage.+--+--  * A module using TemplateHaskellQuotes required at C stage is also required at R+--    stage.+moduleGraphNodesStages ::+     [ModuleGraphNode]+  -> (Graph StageSummaryNode, (NodeKey, ModuleStage) -> Maybe StageSummaryNode)+moduleGraphNodesStages summaries =+  (graphFromEdgedVerticesUniq nodes, lookup_node)+  where+    nodes = map go numbered_summaries++      where+        go :: (((ModuleGraphNode, ModuleStage)), Int) -> StageSummaryNode+        go (s, key) = normal_case s+          where+           normal_case :: (ModuleGraphNode, ModuleStage)  -> StageSummaryNode+           normal_case ((m@(ModuleNode nks ms), s)) =+                  DigraphNode ((mkNodeKey m, s)) key $ out_edge_keys $+                       selfEdges ms s (mkNodeKey m) ++ concatMap (classifyDeps ms s) nks+           normal_case (m, s) =+             DigraphNode (mkNodeKey m, s) key (out_edge_keys . map (, s) $ mgNodeDependencies False m)++    isExplicitStageMS :: ModSummary -> Bool+    isExplicitStageMS ms = not (xopt LangExt.ImplicitStagePersistence (ms_hspp_opts ms))++    isTemplateHaskellQuotesMS :: ModSummary -> Bool+    isTemplateHaskellQuotesMS ms = xopt LangExt.TemplateHaskellQuotes (ms_hspp_opts ms)++    -- Accounting for persistence within a module.+    -- If a module is required @ C and it persists an idenfifier, it's also required+    -- at R.+    selfEdges (ModuleNodeCompile ms) s self_key+      | not (isExplicitStageMS ms)+        && (isTemplateHaskellQuotesMS ms+            || isTemplateHaskellOrQQNonBoot ms)+        = [(self_key, s') | s' <- onlyFutureStages s]+    selfEdges _ _ _ = []++    -- Case 1. No implicit stage persistnce is enabled+    classifyDeps (ModuleNodeCompile ms) s (ModuleNodeEdge il k)+      | isExplicitStageMS ms = case il of+                                SpliceLevel -> [(k, decModuleStage s)]+                                NormalLevel -> [(k, s)]+                                QuoteLevel  -> [(k, incModuleStage s)]+    -- Case 2a. TemplateHaskellQuotes case  (section 5.6 in the paper)+    classifyDeps (ModuleNodeCompile ms) s (ModuleNodeEdge _ k)+      | not (isExplicitStageMS ms)+      , not (isTemplateHaskellOrQQNonBoot ms)+      , isTemplateHaskellQuotesMS ms+      = [(k, s') | s' <- nowAndFutureStages s]+    -- Case 2b. Template haskell is enabled, with implicit stage persistence+    classifyDeps (ModuleNodeCompile ms) _ (ModuleNodeEdge _ k)+      | isTemplateHaskellOrQQNonBoot ms+      , not (isExplicitStageMS ms) =+        [(k, s) | s <- allStages]+    -- Case 3. No template haskell, therefore no additional dependencies.+    classifyDeps _ s (ModuleNodeEdge _ k) = [(k, s)]+++    numbered_summaries :: [((ModuleGraphNode, ModuleStage), Int)]+    numbered_summaries = zip (([(s, l) | s <- summaries, l <- allStages])) [0..]++    lookup_node :: (NodeKey, ModuleStage) -> Maybe StageSummaryNode+    lookup_node key = Map.lookup key node_map++    lookup_key ::  (NodeKey, ModuleStage) -> Maybe Int+    lookup_key = fmap stageSummaryNodeKey . lookup_node++    node_map :: Map.Map (NodeKey, ModuleStage) StageSummaryNode+    node_map =+      Map.fromList [ (s, node)+                   | node <- nodes+                   , let s = stageSummaryNodeSummary node+                   ]++    out_edge_keys :: [(NodeKey, ModuleStage)] -> [Int]+    out_edge_keys = mapMaybe lookup_key+        -- If we want keep_hi_boot_nodes, then we do lookup_key with+        -- IsBoot; else False+++-- | Add an ExtendedModSummary to ModuleGraph. Assumes that the new ModSummary is+-- not an element of the ModuleGraph.+extendMG :: ModuleGraph -> ModuleGraphNode -> ModuleGraph+extendMG ModuleGraph{..} node =+  ModuleGraph+    { mg_mss = node : mg_mss+    , mg_graph =  mkTransDeps (node : mg_mss)+    , mg_loop_graph = mkTransLoopDeps (node : mg_mss)+    , mg_zero_graph = mkTransZeroDeps (node : mg_mss)+    , mg_has_holes = mg_has_holes || maybe False isHsigFile (moduleNodeInfoHscSource =<< mgNodeIsModule node)+    }+
compiler/GHC/Unit/Module/Imported.hs view
@@ -43,6 +43,9 @@    , imv_is_safe     :: IsSafeImport       -- ^ whether this is a safe import +   , imv_is_level    :: ImportLevel+      -- ^ the level the module is imported at (splice, quote, or normal)+    , imv_is_hiding   :: Bool       -- ^ whether this is an "hiding" import 
compiler/GHC/Unit/Module/Location.hs view
@@ -13,8 +13,6 @@     )    , pattern ModLocation    , addBootSuffix-   , addBootSuffix_maybe-   , addBootSuffixLocn_maybe    , addBootSuffixLocn    , addBootSuffixLocnOut    , removeBootSuffix@@ -25,7 +23,6 @@ import GHC.Prelude  import GHC.Data.OsPath-import GHC.Unit.Types import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Data.FastString (mkFastString)@@ -99,26 +96,10 @@     Just path -> path     Nothing -> error "removeBootSuffix: no -boot suffix" --- | Add the @-boot@ suffix if the @Bool@ argument is @True@-addBootSuffix_maybe :: IsBootInterface -> OsPath -> OsPath-addBootSuffix_maybe is_boot path = case is_boot of-  IsBoot -> addBootSuffix path-  NotBoot -> path--addBootSuffixLocn_maybe :: IsBootInterface -> ModLocation -> ModLocation-addBootSuffixLocn_maybe is_boot locn = case is_boot of-  IsBoot -> addBootSuffixLocn locn-  _ -> locn- -- | Add the @-boot@ suffix to all file paths associated with the module addBootSuffixLocn :: ModLocation -> ModLocation addBootSuffixLocn locn-  = locn { ml_hs_file_ospath = fmap addBootSuffix (ml_hs_file_ospath locn)-         , ml_hi_file_ospath  = addBootSuffix (ml_hi_file_ospath locn)-         , ml_dyn_hi_file_ospath = addBootSuffix (ml_dyn_hi_file_ospath locn)-         , ml_obj_file_ospath = addBootSuffix (ml_obj_file_ospath locn)-         , ml_dyn_obj_file_ospath = addBootSuffix (ml_dyn_obj_file_ospath locn)-         , ml_hie_file_ospath = addBootSuffix (ml_hie_file_ospath locn) }+  = addBootSuffixLocnOut locn { ml_hs_file_ospath = fmap addBootSuffix (ml_hs_file_ospath locn) }  -- | Add the @-boot@ suffix to all output file paths associated with the -- module, not including the input file itself
compiler/GHC/Unit/Module/ModGuts.hs view
@@ -7,7 +7,7 @@  import GHC.Prelude -import GHC.ByteCode.Types+import GHC.HsToCore.Breakpoints import GHC.ForeignSrcLang  import GHC.Hs@@ -53,9 +53,8 @@         mg_exports   :: ![AvailInfo],    -- ^ What it exports         mg_deps      :: !Dependencies,   -- ^ What it depends on, directly or                                          -- otherwise-        mg_usages    :: ![Usage],        -- ^ What was used?  Used for interfaces.+        mg_usages    :: !(Maybe [Usage]), -- ^ What was used?  Used for interfaces. -        mg_used_th   :: !Bool,           -- ^ Did we run a TH splice?         mg_rdr_env   :: !GlobalRdrEnv,   -- ^ Top-level lexical environment          -- These fields all describe the things **declared in this module**
compiler/GHC/Unit/Module/ModIface.hs view
@@ -11,1049 +11,1266 @@ module GHC.Unit.Module.ModIface    ( ModIface    , ModIface_-      ( mi_module-      , mi_sig_of-      , mi_hsc_src-      , mi_deps-      , mi_usages-      , mi_exports-      , mi_used_th-      , mi_fixities-      , mi_warns-      , mi_anns-      , mi_decls-      , mi_defaults-      , mi_extra_decls-      , mi_foreign-      , mi_top_env-      , mi_insts-      , mi_fam_insts-      , mi_rules-      , mi_hpc-      , mi_trust-      , mi_trust_pkg-      , mi_complete_matches-      , mi_docs-      , mi_final_exts-      , mi_ext_fields-      , mi_src_hash-      , mi_hi_bytes-      )-   , pattern ModIface-   , restoreFromOldModIface-   , addSourceFingerprint-   , set_mi_module-   , set_mi_sig_of-   , set_mi_hsc_src-   , set_mi_src_hash-   , set_mi_hi_bytes-   , set_mi_deps-   , set_mi_usages-   , set_mi_exports-   , set_mi_used_th-   , set_mi_fixities-   , set_mi_warns-   , set_mi_anns-   , set_mi_insts-   , set_mi_fam_insts-   , set_mi_rules-   , set_mi_decls-   , set_mi_defaults-   , set_mi_extra_decls-   , set_mi_foreign-   , set_mi_top_env-   , set_mi_hpc-   , set_mi_trust-   , set_mi_trust_pkg-   , set_mi_complete_matches-   , set_mi_docs-   , set_mi_final_exts-   , set_mi_ext_fields-   , completePartialModIface-   , IfaceBinHandle(..)-   , PartialModIface-   , ModIfaceBackend (..)-   , IfaceDeclExts-   , IfaceBackendExts-   , IfaceExport-   , WhetherHasOrphans-   , WhetherHasFamInst-   , IfaceTopEnv (..)-   , IfaceImport(..)-   , mi_boot-   , mi_fix-   , mi_semantic_module-   , mi_free_holes-   , mi_mnwib-   , renameFreeHoles-   , emptyPartialModIface-   , emptyFullModIface-   , mkIfaceHashCache-   , emptyIfaceHashCache-   , forceModIface-   )-where--import GHC.Prelude--import GHC.Hs--import GHC.Iface.Syntax-import GHC.Iface.Ext.Fields--import GHC.Unit-import GHC.Unit.Module.Deps-import GHC.Unit.Module.Warnings-import GHC.Unit.Module.WholeCoreBindings (IfaceForeign (..), emptyIfaceForeign)--import GHC.Types.Avail-import GHC.Types.Fixity-import GHC.Types.Fixity.Env-import GHC.Types.HpcInfo-import GHC.Types.Name-import GHC.Types.Name.Reader (IfGlobalRdrEnv)-import GHC.Types.SafeHaskell-import GHC.Types.SourceFile-import GHC.Types.Unique.DSet-import GHC.Types.Unique.FM--import GHC.Data.Maybe-import qualified GHC.Data.Strict as Strict--import GHC.Utils.Fingerprint-import GHC.Utils.Binary--import Control.DeepSeq-import Control.Exception---{- Note [Interface file stages]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Interface files have two possible stages.--* A partial stage built from the result of the core pipeline.-* A fully instantiated form. Which also includes fingerprints and-  potentially information provided by backends.--We can build a full interface file two ways:-* Directly from a partial one:-  Then we omit backend information and mostly compute fingerprints.-* From a partial one + information produced by a backend.-  Then we store the provided information and fingerprint both.--}--type PartialModIface = ModIface_ 'ModIfaceCore-type ModIface = ModIface_ 'ModIfaceFinal---- | Extends a PartialModIface with information which is either:--- * Computed after codegen--- * Or computed just before writing the iface to disk. (Hashes)--- In order to fully instantiate it.-data ModIfaceBackend = ModIfaceBackend-  { mi_iface_hash :: !Fingerprint-    -- ^ Hash of the whole interface-  , mi_mod_hash :: !Fingerprint-    -- ^ Hash of the ABI only-  , mi_flag_hash :: !Fingerprint-    -- ^ Hash of the important flags used when compiling the module, excluding-    -- optimisation flags-  , mi_opt_hash :: !Fingerprint-    -- ^ Hash of optimisation flags-  , mi_hpc_hash :: !Fingerprint-    -- ^ Hash of hpc flags-  , mi_plugin_hash :: !Fingerprint-    -- ^ Hash of plugins-  , mi_orphan :: !WhetherHasOrphans-    -- ^ Whether this module has orphans-  , mi_finsts :: !WhetherHasFamInst-    -- ^ Whether this module has family instances. See Note [The type family-    -- instance consistency story].-  , mi_exp_hash :: !Fingerprint-    -- ^ Hash of export list-  , mi_orphan_hash :: !Fingerprint-    -- ^ Hash for orphan rules, class and family instances combined--    -- Cached environments for easy lookup. These are computed (lazily) from-    -- other fields and are not put into the interface file.-    -- Not really produced by the backend but there is no need to create them-    -- any earlier.-  , mi_decl_warn_fn :: !(OccName -> Maybe (WarningTxt GhcRn))-    -- ^ Cached lookup for 'mi_warns' for declaration deprecations-  , mi_export_warn_fn :: !(Name -> Maybe (WarningTxt GhcRn))-    -- ^ Cached lookup for 'mi_warns' for export deprecations-  , mi_fix_fn :: !(OccName -> Maybe Fixity)-    -- ^ Cached lookup for 'mi_fixities'-  , mi_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint))-    -- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that-    -- the thing isn't in decls. It's useful to know that when seeing if we are-    -- up to date wrt. the old interface. The 'OccName' is the parent of the-    -- name, if it has one.-  }--data ModIfacePhase-  = ModIfaceCore-  -- ^ Partial interface built based on output of core pipeline.-  | ModIfaceFinal---- | Selects a IfaceDecl representation.--- For fully instantiated interfaces we also maintain--- a fingerprint, which is used for recompilation checks.-type family IfaceDeclExts (phase :: ModIfacePhase) = decl | decl -> phase where-  IfaceDeclExts 'ModIfaceCore = IfaceDecl-  IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl)--type family IfaceBackendExts (phase :: ModIfacePhase) = bk | bk -> phase where-  IfaceBackendExts 'ModIfaceCore = ()-  IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend---- | In-memory byte array representation of a 'ModIface'.------ See Note [Sharing of ModIface] for why we need this.-data IfaceBinHandle (phase :: ModIfacePhase) where-  -- | A partial 'ModIface' cannot be serialised to disk.-  PartialIfaceBinHandle :: IfaceBinHandle 'ModIfaceCore-  -- | Optional 'FullBinData' that can be serialised to disk directly.-  ---  -- See Note [Private fields in ModIface] for when this fields needs to be cleared-  -- (e.g., set to 'Nothing').-  FullIfaceBinHandle :: !(Strict.Maybe FullBinData) -> IfaceBinHandle 'ModIfaceFinal---- | A 'ModIface' plus a 'ModDetails' summarises everything we know--- about a compiled module.  The 'ModIface' is the stuff *before* linking,--- and can be written out to an interface file. The 'ModDetails is after--- linking and can be completely recovered from just the 'ModIface'.------ When we read an interface file, we also construct a 'ModIface' from it,--- except that we explicitly make the 'mi_decls' and a few other fields empty;--- as when reading we consolidate the declarations etc. into a number of indexed--- maps and environments in the 'ExternalPackageState'.------ See Note [Strictness in ModIface] to learn about why some fields are--- strict and others are not.------ See Note [Private fields in ModIface] to learn why we don't export any of the--- fields.-data ModIface_ (phase :: ModIfacePhase)-  = PrivateModIface {-        mi_module_     :: !Module,             -- ^ Name of the module we are for-        mi_sig_of_     :: !(Maybe Module),     -- ^ Are we a sig of another mod?--        mi_hsc_src_    :: !HscSource,          -- ^ Boot? Signature?--        mi_deps_     :: Dependencies,-                -- ^ The dependencies of the module.  This is-                -- consulted for directly-imported modules, but not-                -- for anything else (hence lazy)--        mi_usages_   :: [Usage],-                -- ^ Usages; kept sorted so that it's easy to decide-                -- whether to write a new iface file (changing usages-                -- doesn't affect the hash of this module)-                -- NOT STRICT!  we read this field lazily from the interface file-                -- It is *only* consulted by the recompilation checker-                ---                -- The elements must be *deterministically* sorted to guarantee-                -- deterministic interface files--        mi_exports_  :: ![IfaceExport],-                -- ^ Exports-                -- Kept sorted by (mod,occ), to make version comparisons easier-                -- Records the modules that are the declaration points for things-                -- exported by this module, and the 'OccName's of those things---        mi_used_th_  :: !Bool,-                -- ^ Module required TH splices when it was compiled.-                -- This disables recompilation avoidance (see #481).--        mi_fixities_ :: [(OccName,Fixity)],-                -- ^ Fixities-                -- NOT STRICT!  we read this field lazily from the interface file--        mi_warns_    :: IfaceWarnings,-                -- ^ Warnings-                -- NOT STRICT!  we read this field lazily from the interface file--        mi_anns_     :: [IfaceAnnotation],-                -- ^ Annotations-                -- NOT STRICT!  we read this field lazily from the interface file---        mi_decls_    :: [IfaceDeclExts phase],-                -- ^ Type, class and variable declarations-                -- The hash of an Id changes if its fixity or deprecations change-                --      (as well as its type of course)-                -- Ditto data constructors, class operations, except that-                -- the hash of the parent class/tycon changes--        mi_extra_decls_ :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo],-                -- ^ Extra variable definitions which are **NOT** exposed but when-                -- combined with mi_decls allows us to restart code generation.-                -- See Note [Interface Files with Core Definitions] and Note [Interface File with Core: Sharing RHSs]--        mi_foreign_ :: !IfaceForeign,-                -- ^ Foreign stubs and files to supplement 'mi_extra_decls_'.-                -- See Note [Foreign stubs and TH bytecode linking]--        mi_defaults_ :: [IfaceDefault],-                -- ^ default declarations exported by the module--        mi_top_env_  :: !(Maybe IfaceTopEnv),-                -- ^ Just enough information to reconstruct the top level environment in-                -- the /original source/ code for this module. which-                -- is NOT the same as mi_exports, nor mi_decls (which-                -- may contains declarations for things not actually-                -- defined by the user).  Used for GHCi and for inspecting-                -- the contents of modules via the GHC API only.-                ---                -- (We need the source file to figure out the-                -- top-level environment, if we didn't compile this module-                -- from source then this field contains @Nothing@).-                ---                -- Strictly speaking this field should live in the-                -- 'HomeModInfo', but that leads to more plumbing.--                -- Instance declarations and rules-        mi_insts_       :: [IfaceClsInst],     -- ^ Sorted class instance-        mi_fam_insts_   :: [IfaceFamInst],  -- ^ Sorted family instances-        mi_rules_       :: [IfaceRule],     -- ^ Sorted rules--        mi_hpc_       :: !AnyHpcUsage,-                -- ^ True if this program uses Hpc at any point in the program.--        mi_trust_     :: !IfaceTrustInfo,-                -- ^ Safe Haskell Trust information for this module.--        mi_trust_pkg_ :: !Bool,-                -- ^ Do we require the package this module resides in be trusted-                -- to trust this module? This is used for the situation where a-                -- module is Safe (so doesn't require the package be trusted-                -- itself) but imports some trustworthy modules from its own-                -- package (which does require its own package be trusted).-                -- See Note [Trust Own Package] in GHC.Rename.Names-        mi_complete_matches_ :: ![IfaceCompleteMatch],--        mi_docs_ :: !(Maybe Docs),-                -- ^ Docstrings and related data for use by haddock, the ghci-                -- @:doc@ command, and other tools.-                ---                -- @Just _@ @<=>@ the module was built with @-haddock@.--        mi_final_exts_ :: !(IfaceBackendExts phase),-                -- ^ Either `()` or `ModIfaceBackend` for-                -- a fully instantiated interface.--        mi_ext_fields_ :: !ExtensibleFields,-                -- ^ Additional optional fields, where the Map key represents-                -- the field name, resulting in a (size, serialized data) pair.-                -- Because the data is intended to be serialized through the-                -- internal `Binary` class (increasing compatibility with types-                -- using `Name` and `FastString`, such as HIE), this format is-                -- chosen over `ByteString`s.-                ----        mi_src_hash_ :: !Fingerprint,-                -- ^ Hash of the .hs source, used for recompilation checking.-        mi_hi_bytes_ :: !(IfaceBinHandle phase)-                -- ^ A serialised in-memory buffer of this 'ModIface'.-                -- If this handle is given, we can avoid serialising the 'ModIface'-                -- when writing this 'ModIface' to disk, and write this buffer to disk instead.-                -- See Note [Sharing of ModIface].-     }---- Enough information to reconstruct the top level environment for a module-data IfaceTopEnv-  = IfaceTopEnv-  { ifaceTopExports :: !IfGlobalRdrEnv -- ^ all top level things in this module, including unexported stuff-  , ifaceImports :: ![IfaceImport]    -- ^ all the imports in this module-  }--instance NFData IfaceTopEnv where-  rnf (IfaceTopEnv a b) = rnf a `seq` rnf b--{--Note [Strictness in ModIface]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The ModIface is the Haskell representation of an interface (.hi) file.--* During compilation we write out ModIface values to disk for files-  that we have just compiled-* For packages that we depend on we load the ModIface from disk.--Some fields in the ModIface are deliberately lazy because when we read-an interface file we don't always need all the parts. For example, an-interface file contains information about documentation which is often-not needed during compilation. This is achieved using the lazyPut/lazyGet pair.-If the field was strict then we would pointlessly load this information into memory.--On the other hand, if we create a ModIface but **don't** write it to-disk then to avoid space leaks we need to make sure to deepseq all these lazy fields-because the ModIface might live for a long time (for instance in a GHCi session).-That's why in GHC.Driver.Main.hscMaybeWriteIface there is the call to-forceModIface.--}---- | Old-style accessor for whether or not the ModIface came from an hs-boot--- file.-mi_boot :: ModIface -> IsBootInterface-mi_boot iface = if mi_hsc_src iface == HsBootFile-    then IsBoot-    else NotBoot--mi_mnwib :: ModIface -> ModuleNameWithIsBoot-mi_mnwib iface = GWIB (moduleName $ mi_module iface) (mi_boot iface)---- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be--- found, 'defaultFixity' is returned instead.-mi_fix :: ModIface -> OccName -> Fixity-mi_fix iface name = mi_fix_fn (mi_final_exts iface) name `orElse` defaultFixity---- | The semantic module for this interface; e.g., if it's a interface--- for a signature, if 'mi_module' is @p[A=<A>]:A@, 'mi_semantic_module'--- will be @<A>@.-mi_semantic_module :: ModIface_ a -> Module-mi_semantic_module iface = case mi_sig_of iface of-                            Nothing -> mi_module iface-                            Just mod -> mod---- | The "precise" free holes, e.g., the signatures that this--- 'ModIface' depends on.-mi_free_holes :: ModIface -> UniqDSet ModuleName-mi_free_holes iface =-  case getModuleInstantiation (mi_module iface) of-    (_, Just indef)-        -- A mini-hack: we rely on the fact that 'renameFreeHoles'-        -- drops things that aren't holes.-        -> renameFreeHoles (mkUniqDSet cands) (instUnitInsts (moduleUnit indef))-    _   -> emptyUniqDSet-  where-    cands = dep_sig_mods $ mi_deps iface---- | Given a set of free holes, and a unit identifier, rename--- the free holes according to the instantiation of the unit--- identifier.  For example, if we have A and B free, and--- our unit identity is @p[A=<C>,B=impl:B]@, the renamed free--- holes are just C.-renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName-renameFreeHoles fhs insts =-    unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs))-  where-    hmap = listToUFM insts-    lookup_impl mod_name-        | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod-        -- It wasn't actually a hole-        | otherwise                           = emptyUniqDSet---- See Note [Strictness in ModIface] about where we use lazyPut vs put-instance Binary ModIface where-   put_ bh (PrivateModIface {-                 mi_module_    = mod,-                 mi_sig_of_    = sig_of,-                 mi_hsc_src_   = hsc_src,-                 mi_src_hash_ = _src_hash, -- Don't `put_` this in the instance-                                          -- because we are going to write it-                                          -- out separately in the actual file-                 mi_hi_bytes_  = _hi_bytes, -- We don't serialise the 'mi_hi_bytes_', as it itself-                                            -- may contain an in-memory byte array buffer for this-                                            -- 'ModIface'. If we used 'put_' on this 'ModIface', then-                                            -- we likely have a good reason, and do not want to reuse-                                            -- the byte array.-                                            -- See Note [Private fields in ModIface]-                 mi_deps_      = deps,-                 mi_usages_    = usages,-                 mi_exports_   = exports,-                 mi_used_th_   = used_th,-                 mi_fixities_  = fixities,-                 mi_warns_     = warns,-                 mi_anns_      = anns,-                 mi_decls_     = decls,-                 mi_extra_decls_ = extra_decls,-                 mi_foreign_   = foreign_,-                 mi_defaults_  = defaults,-                 mi_insts_     = insts,-                 mi_fam_insts_ = fam_insts,-                 mi_rules_     = rules,-                 mi_hpc_       = hpc_info,-                 mi_trust_     = trust,-                 mi_trust_pkg_ = trust_pkg,-                 mi_complete_matches_ = complete_matches,-                 mi_docs_      = docs,-                 mi_ext_fields_ = _ext_fields, -- Don't `put_` this in the instance so we-                                              -- can deal with it's pointer in the header-                                              -- when we write the actual file-                 mi_final_exts_ = ModIfaceBackend {-                   mi_iface_hash = iface_hash,-                   mi_mod_hash = mod_hash,-                   mi_flag_hash = flag_hash,-                   mi_opt_hash = opt_hash,-                   mi_hpc_hash = hpc_hash,-                   mi_plugin_hash = plugin_hash,-                   mi_orphan = orphan,-                   mi_finsts = hasFamInsts,-                   mi_exp_hash = exp_hash,-                   mi_orphan_hash = orphan_hash-                 }}) = do-        put_ bh mod-        put_ bh sig_of-        put_ bh hsc_src-        put_ bh iface_hash-        put_ bh mod_hash-        put_ bh flag_hash-        put_ bh opt_hash-        put_ bh hpc_hash-        put_ bh plugin_hash-        put_ bh orphan-        put_ bh hasFamInsts-        lazyPut bh deps-        lazyPut bh usages-        put_ bh exports-        put_ bh exp_hash-        put_ bh used_th-        put_ bh fixities-        lazyPut bh warns-        lazyPut bh anns-        put_ bh decls-        put_ bh extra_decls-        put_ bh defaults-        put_ bh foreign_-        put_ bh insts-        put_ bh fam_insts-        lazyPut bh rules-        put_ bh orphan_hash-        put_ bh hpc_info-        put_ bh trust-        put_ bh trust_pkg-        put_ bh complete_matches-        lazyPutMaybe bh docs--   get bh = do-        mod         <- get bh-        sig_of      <- get bh-        hsc_src     <- get bh-        iface_hash  <- get bh-        mod_hash    <- get bh-        flag_hash   <- get bh-        opt_hash    <- get bh-        hpc_hash    <- get bh-        plugin_hash <- get bh-        orphan      <- get bh-        hasFamInsts <- get bh-        deps        <- lazyGet bh-        usages      <- {-# SCC "bin_usages" #-} lazyGet bh-        exports     <- {-# SCC "bin_exports" #-} get bh-        exp_hash    <- get bh-        used_th     <- get bh-        fixities    <- {-# SCC "bin_fixities" #-} get bh-        warns       <- {-# SCC "bin_warns" #-} lazyGet bh-        anns        <- {-# SCC "bin_anns" #-} lazyGet bh-        decls       <- {-# SCC "bin_tycldecls" #-} get bh-        extra_decls <- get bh-        defaults    <- get bh-        foreign_    <- get bh-        insts       <- {-# SCC "bin_insts" #-} get bh-        fam_insts   <- {-# SCC "bin_fam_insts" #-} get bh-        rules       <- {-# SCC "bin_rules" #-} lazyGet bh-        orphan_hash <- get bh-        hpc_info    <- get bh-        trust       <- get bh-        trust_pkg   <- get bh-        complete_matches <- get bh-        docs        <- lazyGetMaybe bh-        return (PrivateModIface {-                 mi_module_      = mod,-                 mi_sig_of_      = sig_of,-                 mi_hsc_src_     = hsc_src,-                 mi_src_hash_ = fingerprint0, -- placeholder because this is dealt-                                             -- with specially when the file is read-                 mi_hi_bytes_    =-                                   -- We can't populate this field here, as we are-                                   -- missing the 'mi_ext_fields_' field, which is-                                   -- handled in 'getIfaceWithExtFields'.-                                   FullIfaceBinHandle Strict.Nothing,-                 mi_deps_        = deps,-                 mi_usages_      = usages,-                 mi_exports_     = exports,-                 mi_used_th_     = used_th,-                 mi_anns_        = anns,-                 mi_fixities_    = fixities,-                 mi_warns_       = warns,-                 mi_decls_       = decls,-                 mi_extra_decls_ = extra_decls,-                 mi_foreign_     = foreign_,-                 mi_top_env_     = Nothing,-                 mi_defaults_    = defaults,-                 mi_insts_       = insts,-                 mi_fam_insts_   = fam_insts,-                 mi_rules_       = rules,-                 mi_hpc_         = hpc_info,-                 mi_trust_       = trust,-                 mi_trust_pkg_   = trust_pkg,-                        -- And build the cached values-                 mi_complete_matches_ = complete_matches,-                 mi_docs_        = docs,-                 mi_ext_fields_  = emptyExtensibleFields, -- placeholder because this is dealt-                                                         -- with specially when the file is read-                 mi_final_exts_ = ModIfaceBackend {-                   mi_iface_hash = iface_hash,-                   mi_mod_hash = mod_hash,-                   mi_flag_hash = flag_hash,-                   mi_opt_hash = opt_hash,-                   mi_hpc_hash = hpc_hash,-                   mi_plugin_hash = plugin_hash,-                   mi_orphan = orphan,-                   mi_finsts = hasFamInsts,-                   mi_exp_hash = exp_hash,-                   mi_orphan_hash = orphan_hash,-                   mi_decl_warn_fn = mkIfaceDeclWarnCache $ fromIfaceWarnings warns,-                   mi_export_warn_fn = mkIfaceExportWarnCache $ fromIfaceWarnings warns,-                   mi_fix_fn = mkIfaceFixCache fixities,-                   mi_hash_fn = mkIfaceHashCache decls-                 }})----- | The original names declared of a certain module that are exported-type IfaceExport = AvailInfo--emptyPartialModIface :: Module -> PartialModIface-emptyPartialModIface mod-  = PrivateModIface-      { mi_module_      = mod,-        mi_sig_of_      = Nothing,-        mi_hsc_src_     = HsSrcFile,-        mi_src_hash_    = fingerprint0,-        mi_hi_bytes_    = PartialIfaceBinHandle,-        mi_deps_        = noDependencies,-        mi_usages_      = [],-        mi_exports_     = [],-        mi_used_th_     = False,-        mi_fixities_    = [],-        mi_warns_       = IfWarnSome [] [],-        mi_anns_        = [],-        mi_defaults_    = [],-        mi_insts_       = [],-        mi_fam_insts_   = [],-        mi_rules_       = [],-        mi_decls_       = [],-        mi_extra_decls_ = Nothing,-        mi_foreign_     = emptyIfaceForeign,-        mi_top_env_     = Nothing,-        mi_hpc_         = False,-        mi_trust_       = noIfaceTrustInfo,-        mi_trust_pkg_   = False,-        mi_complete_matches_ = [],-        mi_docs_        = Nothing,-        mi_final_exts_  = (),-        mi_ext_fields_  = emptyExtensibleFields-      }--emptyFullModIface :: Module -> ModIface-emptyFullModIface mod =-    (emptyPartialModIface mod)-      { mi_decls_ = []-      , mi_hi_bytes_ = FullIfaceBinHandle Strict.Nothing-      , mi_final_exts_ = ModIfaceBackend-        { mi_iface_hash = fingerprint0,-          mi_mod_hash = fingerprint0,-          mi_flag_hash = fingerprint0,-          mi_opt_hash = fingerprint0,-          mi_hpc_hash = fingerprint0,-          mi_plugin_hash = fingerprint0,-          mi_orphan = False,-          mi_finsts = False,-          mi_exp_hash = fingerprint0,-          mi_orphan_hash = fingerprint0,-          mi_decl_warn_fn = emptyIfaceWarnCache,-          mi_export_warn_fn = emptyIfaceWarnCache,-          mi_fix_fn = emptyIfaceFixCache,-          mi_hash_fn = emptyIfaceHashCache } }---- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface'-mkIfaceHashCache :: [(Fingerprint,IfaceDecl)]-                 -> (OccName -> Maybe (OccName, Fingerprint))-mkIfaceHashCache pairs-  = \occ -> lookupOccEnv env occ-  where-    env = foldl' add_decl emptyOccEnv pairs-    add_decl env0 (v,d) = foldl' add env0 (ifaceDeclFingerprints v d)-      where-        add env0 (occ,hash) = extendOccEnv env0 occ (occ,hash)--emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint)-emptyIfaceHashCache _occ = Nothing---- Take care, this instance only forces to the degree necessary to--- avoid major space leaks.-instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase))-         , NFData (IfaceDeclExts (phase :: ModIfacePhase))-         ) => NFData (ModIface_ phase) where-  rnf (PrivateModIface-               { mi_module_, mi_sig_of_, mi_hsc_src_, mi_hi_bytes_, mi_deps_, mi_usages_-               , mi_exports_, mi_used_th_, mi_fixities_, mi_warns_, mi_anns_-               , mi_decls_, mi_defaults_, mi_extra_decls_, mi_foreign_, mi_top_env_, mi_insts_-               , mi_fam_insts_, mi_rules_, mi_hpc_, mi_trust_, mi_trust_pkg_-               , mi_complete_matches_, mi_docs_, mi_final_exts_-               , mi_ext_fields_, mi_src_hash_ })-    =     rnf mi_module_-    `seq` rnf mi_sig_of_-    `seq`     mi_hsc_src_-    `seq`     mi_hi_bytes_-    `seq`     mi_deps_-    `seq`     mi_usages_-    `seq`     mi_exports_-    `seq` rnf mi_used_th_-    `seq`     mi_fixities_-    `seq` rnf mi_warns_-    `seq` rnf mi_anns_-    `seq` rnf mi_decls_-    `seq` rnf mi_defaults_-    `seq` rnf mi_extra_decls_-    `seq` rnf mi_foreign_-    `seq` rnf mi_top_env_-    `seq` rnf mi_insts_-    `seq` rnf mi_fam_insts_-    `seq` rnf mi_rules_-    `seq` rnf mi_hpc_-    `seq`     mi_trust_-    `seq` rnf mi_trust_pkg_-    `seq` rnf mi_complete_matches_-    `seq` rnf mi_docs_-    `seq`     mi_final_exts_-    `seq`     mi_ext_fields_-    `seq` rnf mi_src_hash_-    `seq` ()--instance NFData (ModIfaceBackend) where-  rnf (ModIfaceBackend{ mi_iface_hash, mi_mod_hash, mi_flag_hash, mi_opt_hash-                      , mi_hpc_hash, mi_plugin_hash, mi_orphan, mi_finsts, mi_exp_hash-                      , mi_orphan_hash, mi_decl_warn_fn, mi_export_warn_fn, mi_fix_fn-                      , mi_hash_fn})-    =     rnf mi_iface_hash-    `seq` rnf mi_mod_hash-    `seq` rnf mi_flag_hash-    `seq` rnf mi_opt_hash-    `seq` rnf mi_hpc_hash-    `seq` rnf mi_plugin_hash-    `seq` rnf mi_orphan-    `seq` rnf mi_finsts-    `seq` rnf mi_exp_hash-    `seq` rnf mi_orphan_hash-    `seq` rnf mi_decl_warn_fn-    `seq` rnf mi_export_warn_fn-    `seq` rnf mi_fix_fn-    `seq` rnf mi_hash_fn---forceModIface :: ModIface -> IO ()-forceModIface iface = () <$ (evaluate $ force iface)---- | Records whether a module has orphans. An \"orphan\" is one of:------ * An instance declaration in a module other than the definition---   module for one of the type constructors or classes in the instance head------ * A rewrite rule in a module other than the one defining---   the function in the head of the rule----type WhetherHasOrphans   = Bool---- | Does this module define family instances?-type WhetherHasFamInst = Bool---- ------------------------------------------------------------------------------- Modify a 'ModIface'.--- ------------------------------------------------------------------------------{--Note [Private fields in ModIface]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The fields of 'ModIface' are private, e.g., not exported, to make the API-impossible to misuse. A 'ModIface' can be "compressed" in-memory using-'shareIface', which serialises the 'ModIface' to an in-memory buffer.-This has the advantage of reducing memory usage of 'ModIface', reducing the-overall memory usage of GHC.-See Note [Sharing of ModIface].--This in-memory buffer can be reused, if and only if the 'ModIface' is not-modified after it has been "compressed"/shared via 'shareIface'. Instead of-serialising 'ModIface', we simply write the in-memory buffer to disk directly.--However, we can't rely that a 'ModIface' isn't modified after 'shareIface' has-been called. Thus, we make all fields of 'ModIface' private and modification-only happens via exported update functions, such as 'set_mi_decls'.-These functions unconditionally clear any in-memory buffer if used, forcing us-to serialise the 'ModIface' to disk again.--}---- | Given a 'PartialModIface', turn it into a 'ModIface' by completing--- missing fields.-completePartialModIface :: PartialModIface-  -> [(Fingerprint, IfaceDecl)]-  -> Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]-  -> ModIfaceBackend-  -> ModIface-completePartialModIface partial decls extra_decls final_exts = partial-  { mi_decls_ = decls-  , mi_extra_decls_ = extra_decls-  , mi_final_exts_ = final_exts-  , mi_hi_bytes_ = FullIfaceBinHandle Strict.Nothing-  }---- | Add a source fingerprint to a 'ModIface_' without invalidating the byte array--- buffer 'mi_hi_bytes'.--- This is a variant of 'set_mi_src_hash' which does invalidate the buffer.------ The 'mi_src_hash' is computed outside of 'ModIface_' based on the 'ModSummary'.-addSourceFingerprint :: Fingerprint -> ModIface_ phase -> ModIface_ phase-addSourceFingerprint val iface = iface { mi_src_hash_ = val }---- | Copy fields that aren't serialised to disk to the new 'ModIface_'.--- This includes especially hashes that are usually stored in the interface--- file header and 'mi_top_env'.------ We need this function after calling 'shareIface', to make sure the--- 'ModIface_' doesn't lose any information. This function does not discard--- the in-memory byte array buffer 'mi_hi_bytes'.-restoreFromOldModIface :: ModIface_ phase -> ModIface_ phase -> ModIface_ phase-restoreFromOldModIface old new = new-  { mi_top_env_ = mi_top_env_ old-  , mi_hsc_src_ = mi_hsc_src_ old-  , mi_src_hash_ = mi_src_hash_ old-  }--set_mi_module :: Module -> ModIface_ phase -> ModIface_ phase-set_mi_module val iface = clear_mi_hi_bytes $ iface { mi_module_ = val }--set_mi_sig_of :: Maybe Module -> ModIface_ phase -> ModIface_ phase-set_mi_sig_of val iface = clear_mi_hi_bytes $ iface { mi_sig_of_ = val }--set_mi_hsc_src :: HscSource -> ModIface_ phase -> ModIface_ phase-set_mi_hsc_src val iface = clear_mi_hi_bytes $ iface { mi_hsc_src_ = val }--set_mi_src_hash :: Fingerprint -> ModIface_ phase -> ModIface_ phase-set_mi_src_hash val iface = clear_mi_hi_bytes $ iface { mi_src_hash_ = val }--set_mi_hi_bytes :: IfaceBinHandle phase -> ModIface_ phase -> ModIface_ phase-set_mi_hi_bytes val iface = iface { mi_hi_bytes_ = val }--set_mi_deps :: Dependencies -> ModIface_ phase -> ModIface_ phase-set_mi_deps val iface = clear_mi_hi_bytes $ iface { mi_deps_ = val }--set_mi_usages :: [Usage] -> ModIface_ phase -> ModIface_ phase-set_mi_usages val iface = clear_mi_hi_bytes $ iface { mi_usages_ = val }--set_mi_exports :: [IfaceExport] -> ModIface_ phase -> ModIface_ phase-set_mi_exports val iface = clear_mi_hi_bytes $ iface { mi_exports_ = val }--set_mi_used_th :: Bool -> ModIface_ phase -> ModIface_ phase-set_mi_used_th val iface = clear_mi_hi_bytes $ iface { mi_used_th_ = val }--set_mi_fixities :: [(OccName, Fixity)] -> ModIface_ phase -> ModIface_ phase-set_mi_fixities val iface = clear_mi_hi_bytes $ iface { mi_fixities_ = val }--set_mi_warns :: IfaceWarnings -> ModIface_ phase -> ModIface_ phase-set_mi_warns val iface = clear_mi_hi_bytes $ iface { mi_warns_ = val }--set_mi_anns :: [IfaceAnnotation] -> ModIface_ phase -> ModIface_ phase-set_mi_anns val iface = clear_mi_hi_bytes $ iface { mi_anns_ = val }--set_mi_insts :: [IfaceClsInst] -> ModIface_ phase -> ModIface_ phase-set_mi_insts val iface = clear_mi_hi_bytes $ iface { mi_insts_ = val }--set_mi_fam_insts :: [IfaceFamInst] -> ModIface_ phase -> ModIface_ phase-set_mi_fam_insts val iface = clear_mi_hi_bytes $ iface { mi_fam_insts_ = val }--set_mi_rules :: [IfaceRule] -> ModIface_ phase -> ModIface_ phase-set_mi_rules val iface = clear_mi_hi_bytes $ iface { mi_rules_ = val }--set_mi_decls :: [IfaceDeclExts phase] -> ModIface_ phase -> ModIface_ phase-set_mi_decls val iface = clear_mi_hi_bytes $ iface { mi_decls_ = val }--set_mi_defaults :: [IfaceDefault] -> ModIface_ phase -> ModIface_ phase-set_mi_defaults val iface = clear_mi_hi_bytes $ iface { mi_defaults_ = val }--set_mi_extra_decls :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -> ModIface_ phase -> ModIface_ phase-set_mi_extra_decls val iface = clear_mi_hi_bytes $ iface { mi_extra_decls_ = val }--set_mi_foreign :: IfaceForeign -> ModIface_ phase -> ModIface_ phase-set_mi_foreign foreign_ iface = clear_mi_hi_bytes $ iface { mi_foreign_ = foreign_ }--set_mi_top_env :: Maybe IfaceTopEnv -> ModIface_ phase -> ModIface_ phase-set_mi_top_env val iface = clear_mi_hi_bytes $ iface { mi_top_env_ = val }--set_mi_hpc :: AnyHpcUsage -> ModIface_ phase -> ModIface_ phase-set_mi_hpc val iface = clear_mi_hi_bytes $ iface { mi_hpc_ = val }--set_mi_trust :: IfaceTrustInfo -> ModIface_ phase -> ModIface_ phase-set_mi_trust val iface = clear_mi_hi_bytes $ iface { mi_trust_ = val }--set_mi_trust_pkg :: Bool -> ModIface_ phase -> ModIface_ phase-set_mi_trust_pkg val iface = clear_mi_hi_bytes $ iface { mi_trust_pkg_ = val }--set_mi_complete_matches :: [IfaceCompleteMatch] -> ModIface_ phase -> ModIface_ phase-set_mi_complete_matches val iface = clear_mi_hi_bytes $ iface { mi_complete_matches_ = val }--set_mi_docs :: Maybe Docs -> ModIface_ phase -> ModIface_ phase-set_mi_docs val iface = clear_mi_hi_bytes $  iface { mi_docs_ = val }--set_mi_final_exts :: IfaceBackendExts phase -> ModIface_ phase -> ModIface_ phase-set_mi_final_exts val iface = clear_mi_hi_bytes $ iface { mi_final_exts_ = val }--set_mi_ext_fields :: ExtensibleFields -> ModIface_ phase -> ModIface_ phase-set_mi_ext_fields val iface = clear_mi_hi_bytes $ iface { mi_ext_fields_ = val }---- | Invalidate any byte array buffer we might have.-clear_mi_hi_bytes :: ModIface_ phase -> ModIface_ phase-clear_mi_hi_bytes iface = iface-  { mi_hi_bytes_ = case mi_hi_bytes iface of-      PartialIfaceBinHandle -> PartialIfaceBinHandle-      FullIfaceBinHandle _ -> FullIfaceBinHandle Strict.Nothing-  }---- ------------------------------------------------------------------------------- 'ModIface' pattern synonyms to keep breakage low.--- ------------------------------------------------------------------------------{--Note [Inline Pattern synonym of ModIface]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The introduction of the 'ModIface' pattern synonym originally caused an increase-in allocated bytes in multiple performance tests.-In some benchmarks, it was a 2~3% increase.--Without {-# INLINE ModIface #-}, the generated core reveals the reason for this increase.-We show the core for the 'mi_module' record selector:--@-  mi_module-    = \ @phase iface -> $w$mModIface iface mi_module1--  $w$mModIface-    = \ @phase iface cont ->-        case iface of-        { PrivateModIface a b ... z ->-        cont-          a-          b-          ...-          z-        }--  mi_module1-    = \ @phase-        a-        _-        ...-        _ ->-        a-@--Thus, we can see the '$w$mModIface' is not inlined, leading to an increase in-the allocated bytes.--However, with the pragma, the correct core is generated:--@-  mi_module = mi_module_-@---}---- See Note [Inline Pattern synonym of ModIface] for why we have all these--- inline pragmas.-{-# INLINE ModIface #-}-{-# INLINE mi_module #-}-{-# INLINE mi_sig_of #-}-{-# INLINE mi_hsc_src #-}-{-# INLINE mi_deps #-}-{-# INLINE mi_usages #-}-{-# INLINE mi_exports #-}-{-# INLINE mi_used_th #-}-{-# INLINE mi_fixities #-}-{-# INLINE mi_warns #-}-{-# INLINE mi_anns #-}-{-# INLINE mi_decls #-}-{-# INLINE mi_extra_decls #-}-{-# INLINE mi_foreign #-}-{-# INLINE mi_top_env #-}-{-# INLINE mi_insts #-}-{-# INLINE mi_fam_insts #-}-{-# INLINE mi_rules #-}-{-# INLINE mi_hpc #-}-{-# INLINE mi_trust #-}-{-# INLINE mi_trust_pkg #-}-{-# INLINE mi_complete_matches #-}-{-# INLINE mi_docs #-}-{-# INLINE mi_final_exts #-}-{-# INLINE mi_ext_fields #-}-{-# INLINE mi_src_hash #-}-{-# INLINE mi_hi_bytes #-}-{-# COMPLETE ModIface #-}--pattern ModIface ::-  Module -> Maybe Module -> HscSource -> Dependencies -> [Usage] ->-  [IfaceExport] -> Bool -> [(OccName, Fixity)] -> IfaceWarnings ->-  [IfaceAnnotation] -> [IfaceDeclExts phase] ->-  Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -> IfaceForeign ->-  [IfaceDefault] -> Maybe IfaceTopEnv -> [IfaceClsInst] -> [IfaceFamInst] -> [IfaceRule] ->-  AnyHpcUsage -> IfaceTrustInfo -> Bool -> [IfaceCompleteMatch] -> Maybe Docs ->-  IfaceBackendExts phase -> ExtensibleFields -> Fingerprint -> IfaceBinHandle phase ->-  ModIface_ phase-pattern ModIface-  { mi_module-  , mi_sig_of-  , mi_hsc_src-  , mi_deps-  , mi_usages-  , mi_exports-  , mi_used_th-  , mi_fixities-  , mi_warns-  , mi_anns-  , mi_decls-  , mi_extra_decls-  , mi_foreign-  , mi_defaults-  , mi_top_env-  , mi_insts-  , mi_fam_insts-  , mi_rules-  , mi_hpc-  , mi_trust-  , mi_trust_pkg-  , mi_complete_matches-  , mi_docs-  , mi_final_exts-  , mi_ext_fields-  , mi_src_hash-  , mi_hi_bytes-  } <- PrivateModIface-    { mi_module_ = mi_module-    , mi_sig_of_ = mi_sig_of-    , mi_hsc_src_ = mi_hsc_src-    , mi_deps_ = mi_deps-    , mi_usages_ = mi_usages-    , mi_exports_ = mi_exports-    , mi_used_th_ = mi_used_th-    , mi_fixities_ = mi_fixities-    , mi_warns_ = mi_warns-    , mi_anns_ = mi_anns-    , mi_decls_ = mi_decls-    , mi_extra_decls_ = mi_extra_decls-    , mi_foreign_ = mi_foreign-    , mi_defaults_ = mi_defaults-    , mi_top_env_ = mi_top_env-    , mi_insts_ = mi_insts-    , mi_fam_insts_ = mi_fam_insts-    , mi_rules_ = mi_rules-    , mi_hpc_ = mi_hpc-    , mi_trust_ = mi_trust-    , mi_trust_pkg_ = mi_trust_pkg-    , mi_complete_matches_ = mi_complete_matches-    , mi_docs_ = mi_docs-    , mi_final_exts_ = mi_final_exts-    , mi_ext_fields_ = mi_ext_fields-    , mi_src_hash_ = mi_src_hash-    , mi_hi_bytes_ = mi_hi_bytes+      ( mi_mod_info+      , mi_module+      , mi_sig_of+      , mi_hsc_src+      , mi_iface_hash+      , mi_deps+      , mi_public+      , mi_exports+      , mi_fixities+      , mi_warns+      , mi_anns+      , mi_decls+      , mi_defaults+      , mi_simplified_core+      , mi_top_env+      , mi_insts+      , mi_fam_insts+      , mi_rules+      , mi_trust+      , mi_trust_pkg+      , mi_complete_matches+      , mi_docs+      , mi_abi_hashes+      , mi_ext_fields+      , mi_hi_bytes+      , mi_self_recomp_info+      , mi_fix_fn+      , mi_decl_warn_fn+      , mi_export_warn_fn+      , mi_hash_fn+      )+   , pattern ModIface+   , set_mi_mod_info+   , set_mi_module+   , set_mi_sig_of+   , set_mi_hsc_src+   , set_mi_self_recomp+   , set_mi_hi_bytes+   , set_mi_deps+   , set_mi_exports+   , set_mi_fixities+   , set_mi_warns+   , set_mi_anns+   , set_mi_insts+   , set_mi_fam_insts+   , set_mi_rules+   , set_mi_decls+   , set_mi_defaults+   , set_mi_simplified_core+   , set_mi_top_env+   , set_mi_trust+   , set_mi_trust_pkg+   , set_mi_complete_matches+   , set_mi_docs+   , set_mi_abi_hashes+   , set_mi_ext_fields+   , set_mi_caches+   , set_mi_decl_warn_fn+   , set_mi_export_warn_fn+   , set_mi_fix_fn+   , set_mi_hash_fn+   , completePartialModIface+   , IfaceBinHandle(..)+   , PartialModIface+   , IfaceAbiHashes (..)+   , IfaceSelfRecomp (..)+   , IfaceCache (..)+   , IfaceSimplifiedCore (..)+   , withSelfRecomp+   , IfaceDeclExts+   , IfaceAbiHashesExts+   , IfaceExport+   , IfacePublic_(..)+   , IfacePublic+   , PartialIfacePublic+   , IfaceModInfo(..)+   , WhetherHasOrphans+   , WhetherHasFamInst+   , IfaceTopEnv (..)+   , IfaceImport(..)+   , mi_boot+   , mi_fix+   , mi_semantic_module+   , mi_mod_info_semantic_module+   , mi_free_holes+   , mi_mnwib+   , mi_flag_hash+   , mi_opt_hash+   , mi_hpc_hash+   , mi_plugin_hash+   , mi_src_hash+   , mi_usages+   , mi_mod_hash+   , mi_orphan+   , mi_finsts+   , mi_export_avails_hash+   , mi_orphan_like_hash+   , mi_orphan_hash+   , renameFreeHoles+   , emptyPartialModIface+   , emptyFullModIface+   , mkIfaceHashCache+   , emptyIfaceHashCache+   , forceModIface+   )+where++import GHC.Prelude++import GHC.Hs++import GHC.Iface.Syntax+import GHC.Iface.Flags+import GHC.Iface.Ext.Fields+import GHC.Iface.Recomp.Types++import GHC.Unit+import GHC.Unit.Module.Deps+import GHC.Unit.Module.Warnings+import GHC.Unit.Module.WholeCoreBindings (IfaceForeign (..))+++import GHC.Types.Avail+import GHC.Types.Fixity+import GHC.Types.Fixity.Env+import GHC.Types.Name+import GHC.Types.SafeHaskell+import GHC.Types.SourceFile+import GHC.Types.Unique.DSet+import GHC.Types.Unique.FM++import GHC.Data.Maybe+import qualified GHC.Data.Strict as Strict++import GHC.Utils.Fingerprint+import GHC.Utils.Binary++import Control.DeepSeq+import Control.Exception+++{- Note [Interface file stages]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Interface files have two possible stages.++* A partial stage built from the result of the core pipeline.+* A fully instantiated form. Which also includes fingerprints and+  potentially information provided by backends.++We can build a full interface file two ways:+* Directly from a partial one:+  Then we omit backend information and mostly compute fingerprints.+* From a partial one + information produced by a backend.+  Then we store the provided information and fingerprint both.+-}++type PartialModIface = ModIface_ 'ModIfaceCore+type ModIface = ModIface_ 'ModIfaceFinal++type PartialIfacePublic = IfacePublic_ 'ModIfaceCore+type IfacePublic = IfacePublic_ 'ModIfaceFinal++-- | Extends a PartialModIface with hashes of the ABI.+--+-- * The mi_mod_hash is the hash of the entire ABI+-- * THe other fields are more specific hashes of parts of the ABI+data IfaceAbiHashes = IfaceAbiHashes+  { mi_abi_mod_hash :: !Fingerprint+    -- ^ Hash of the ABI only+  , mi_abi_orphan :: !WhetherHasOrphans+    -- ^ Whether this module has orphans+  , mi_abi_finsts :: !WhetherHasFamInst+    -- ^ Whether this module has family instances. See Note [The type family+    -- instance consistency story].+  , mi_abi_export_avails_hash :: !Fingerprint+    -- ^ Hash of the exported avails (does not include e.g. instances)+  , mi_abi_orphan_like_hash :: !Fingerprint+    -- ^ Orphans, together with (non-orphan) type family instances of+    -- dependencies and a few other things; see Note [Orphan-like hash].+    --+    -- If this changes, we must recompile due to the impact+    -- on instance resolution.+  , mi_abi_orphan_hash :: !Fingerprint+    -- ^ Hash for orphan rules, class and family instances combined+    -- NOT transitive+  }++data IfaceCache = IfaceCache+  { mi_cache_decl_warn_fn :: !(OccName -> Maybe (WarningTxt GhcRn))+    -- ^ Cached lookup for 'mi_warns' for declaration deprecations+  , mi_cache_export_warn_fn :: !(Name -> Maybe (WarningTxt GhcRn))+    -- ^ Cached lookup for 'mi_warns' for export deprecations+  , mi_cache_fix_fn :: !(OccName -> Maybe Fixity)+    -- ^ Cached lookup for 'mi_fixities'+  , mi_cache_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint))+    -- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that+    -- the thing isn't in decls. It's useful to know that when seeing if we are+    -- up to date wrt. the old interface. The 'OccName' is the parent of the+    -- name, if it has one.+  }++data ModIfacePhase+  = ModIfaceCore+  -- ^ Partial interface built based on output of core pipeline.+  | ModIfaceFinal++-- | Selects a IfaceDecl representation.+-- For fully instantiated interfaces we also maintain+-- a fingerprint, which is used for recompilation checks.+type family IfaceDeclExts (phase :: ModIfacePhase) = decl | decl -> phase where+  IfaceDeclExts 'ModIfaceCore = IfaceDecl+  IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl)++type family IfaceAbiHashesExts (phase :: ModIfacePhase) = bk | bk -> phase where+  IfaceAbiHashesExts 'ModIfaceCore = ()+  IfaceAbiHashesExts 'ModIfaceFinal = IfaceAbiHashes++-- | In-memory byte array representation of a 'ModIface'.+--+-- See Note [Sharing of ModIface] for why we need this.+data IfaceBinHandle (phase :: ModIfacePhase) where+  -- | A partial 'ModIface' cannot be serialised to disk.+  PartialIfaceBinHandle :: IfaceBinHandle 'ModIfaceCore+  -- | Optional 'FullBinData' that can be serialised to disk directly.+  --+  -- See Note [Private fields in ModIface] for when this fields needs to be cleared+  -- (e.g., set to 'Nothing').+  FullIfaceBinHandle :: !(Strict.Maybe FullBinData) -> IfaceBinHandle 'ModIfaceFinal+++withSelfRecomp :: ModIface_ phase -> r -> (IfaceSelfRecomp -> r) -> r+withSelfRecomp iface nk jk =+  case mi_self_recomp_info iface of+    Nothing -> nk+    Just x -> jk x++++-- | A 'ModIface' summarises everything we know+-- about a compiled module.+--+-- See Note [Structure of ModIface] for information about what belongs in each field.+--+-- See Note [Strictness in ModIface] to learn about why all the fields are lazy.+--+-- See Note [Private fields in ModIface] to learn why we don't export any of the+-- fields.+data ModIface_ (phase :: ModIfacePhase)+  = PrivateModIface {+        mi_hi_bytes_ :: !(IfaceBinHandle phase),+                -- ^ A serialised in-memory buffer of this 'ModIface'.+                -- If this handle is given, we can avoid serialising the 'ModIface'+                -- when writing this 'ModIface' to disk, and write this buffer to disk instead.+                -- See Note [Sharing of ModIface].+        mi_iface_hash_  :: Fingerprint, -- A hash of the whole interface++        mi_mod_info_     :: IfaceModInfo,+                -- ^ Meta information about the module the interface file is for++        mi_deps_     :: Dependencies,+                -- ^ The dependencies of the module.  This is+                -- consulted for directly-imported modules, but not+                -- for anything else (hence lazy)+                -- MP: Needs to be refactored (#25844)++        mi_public_ :: IfacePublic_ phase,+                -- ^ The parts of interface which are used by other modules when+                -- importing this module. The main, original part of an interface.+++        mi_self_recomp_ :: Maybe IfaceSelfRecomp,+                -- ^ Information needed for checking self-recompilation.+                -- See Note [Self recompilation information in interface files]++        mi_simplified_core_ :: Maybe IfaceSimplifiedCore,+                -- ^ The part of the interface written when `-fwrite-if-simplified-core` is enabled.+                -- These parts are used to restart bytecode generation.++        mi_docs_ :: Maybe Docs,+                -- ^ Docstrings and related data for use by haddock, the ghci+                -- @:doc@ command, and other tools.+                --+                -- @Just _@ @<=>@ the module was built with @-haddock@.++        mi_top_env_  :: IfaceTopEnv,+                -- ^ Just enough information to reconstruct the top level environment in+                -- the /original source/ code for this module. which+                -- is NOT the same as mi_exports, nor mi_decls (which+                -- may contains declarations for things not actually+                -- defined by the user).  Used for GHCi and for inspecting+                -- the contents of modules via the GHC API only.++        mi_ext_fields_ :: ExtensibleFields+                -- ^ Additional optional fields, where the Map key represents+                -- the field name, resulting in a (size, serialized data) pair.+                -- Because the data is intended to be serialized through the+                -- internal `Binary` class (increasing compatibility with types+                -- using `Name` and `FastString`, such as HIE), this format is+                -- chosen over `ByteString`s.+     }++-- | Meta information about the module the interface file is for+data IfaceModInfo = IfaceModInfo {+  mi_mod_info_module :: Module, -- ^ Name of the module we are for+  mi_mod_info_sig_of :: Maybe Module, -- ^ Are we a sig of another mod?+  mi_mod_info_hsc_src :: HscSource -- ^ Boot? Signature?+}++-- | The public interface of a module which are used by other modules when importing this module.+-- The ABI of a module.+data IfacePublic_ phase = IfacePublic {+        mi_exports_  :: [IfaceExport],+                -- ^ Exports+                -- Kept sorted by (mod,occ), to make version comparisons easier+                -- Records the modules that are the declaration points for things+                -- exported by this module, and the 'OccName's of those things++        mi_fixities_ :: [(OccName,Fixity)],+                -- ^ Fixities+                -- NOT STRICT!  we read this field lazily from the interface file++        mi_warns_    :: IfaceWarnings,+                -- ^ Warnings+                -- NOT STRICT!  we read this field lazily from the interface file++        mi_anns_     :: [IfaceAnnotation],+                -- ^ Annotations+                -- NOT STRICT!  we read this field lazily from the interface file+++        mi_decls_    :: [IfaceDeclExts phase],+                -- ^ Type, class and variable declarations+                -- The hash of an Id changes if its fixity or deprecations change+                --      (as well as its type of course)+                -- Ditto data constructors, class operations, except that+                -- the hash of the parent class/tycon changes+++        mi_defaults_ :: [IfaceDefault],+                -- ^ default declarations exported by the module+++                -- Instance declarations and rules+        mi_insts_       :: [IfaceClsInst],     -- ^ Sorted class instance+        mi_fam_insts_   :: [IfaceFamInst],  -- ^ Sorted family instances+        mi_rules_       :: [IfaceRule],     -- ^ Sorted rules+++        mi_trust_     :: IfaceTrustInfo,+                -- ^ Safe Haskell Trust information for this module.++        mi_trust_pkg_ :: Bool,+                -- ^ Do we require the package this module resides in be trusted+                -- to trust this module? This is used for the situation where a+                -- module is Safe (so doesn't require the package be trusted+                -- itself) but imports some trustworthy modules from its own+                -- package (which does require its own package be trusted).+                -- See Note [Trust Own Package] in GHC.Rename.Names+        mi_complete_matches_ :: [IfaceCompleteMatch],+                -- ^ {-# COMPLETE #-} declarations++        mi_caches_ :: IfaceCache,+                -- ^ Cached lookups of some parts of mi_public++        mi_abi_hashes_ :: (IfaceAbiHashesExts phase)+                -- ^ Either `()` or `IfaceAbiHashes` for+                -- a fully instantiated interface.+                -- These fields are hashes of different parts of the public interface.+}++mkIfacePublic :: [IfaceExport]+                  -> [IfaceDeclExts 'ModIfaceFinal]+                  -> [(OccName, Fixity)]+                  -> IfaceWarnings+                  -> [IfaceAnnotation]+                  -> [IfaceDefault]+                  -> [IfaceClsInst]+                  -> [IfaceFamInst]+                  -> [IfaceRule]+                  -> IfaceTrustInfo+                  -> Bool+                  -> [IfaceCompleteMatch]+                  -> IfaceAbiHashes+                  -> IfacePublic+mkIfacePublic exports decls fixities warns anns defaults insts fam_insts rules trust trust_pkg complete_matches abi_hashes = IfacePublic {+  mi_exports_ = exports,+  mi_decls_ = decls,+  mi_fixities_ = fixities,+  mi_warns_ = warns,+  mi_anns_ = anns,+  mi_defaults_ = defaults,+  mi_insts_ = insts,+  mi_fam_insts_ = fam_insts,+  mi_rules_ = rules,+  mi_trust_ = trust,+  mi_trust_pkg_ = trust_pkg,+  mi_complete_matches_ = complete_matches,+  mi_caches_ = IfaceCache {+    mi_cache_decl_warn_fn = mkIfaceDeclWarnCache $ fromIfaceWarnings warns,+    mi_cache_export_warn_fn = mkIfaceExportWarnCache $ fromIfaceWarnings warns,+    mi_cache_fix_fn = mkIfaceFixCache fixities,+    mi_cache_hash_fn = mkIfaceHashCache decls+  },+  mi_abi_hashes_ = abi_hashes+}++-- | The information needed to restart bytecode generation.+-- Enabled by `-fwrite-if-simplified-core`.+data IfaceSimplifiedCore = IfaceSimplifiedCore {+  mi_sc_extra_decls :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]+  -- ^ Extra variable definitions which are **NOT** exposed but when+  -- combined with mi_decls allows us to restart code generation.+  -- See Note [Interface Files with Core Definitions] and Note [Interface File with Core: Sharing RHSs]+  , mi_sc_foreign :: IfaceForeign+  -- ^ Foreign stubs and files to supplement 'mi_extra_decls_'.+  -- See Note [Foreign stubs and TH bytecode linking]+}++-- Enough information to reconstruct the top level environment for a module+data IfaceTopEnv+  = IfaceTopEnv+  { ifaceTopExports :: DetOrdAvails -- ^ all top level things in this module, including unexported stuff+  , ifaceImports :: [IfaceImport]    -- ^ all the imports in this module+  }++instance NFData IfaceTopEnv where+  rnf (IfaceTopEnv a b) = rnf a `seq` rnf b++instance Binary IfaceTopEnv where+  put_ bh (IfaceTopEnv exports imports) = do+    put_ bh exports+    put_ bh imports+  get bh = do+    exports <- get bh+    imports <- get bh+    return (IfaceTopEnv exports imports)+++{-+Note [Structure of ModIface]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The ModIface structure is divided into several logical parts:++1. mi_mod_info: Basic module metadata (name, version, etc.)++2. mi_public: The public interface of the module, which includes:+   - Exports, declarations, fixities, warnings, annotations+   - Class and type family instances+   - Rewrite rules and COMPLETE pragmas+   - Safe Haskell and package trust information+   - ABI hashes for recompilation checking++4. mi_self_recomp: Information needed for self-recompilation checking+   (see Note [Self recompilation information in interface files])++5. mi_simplified_core: Optional simplified Core for bytecode generation+   (only present when -fwrite-if-simplified-core is enabled)++6. mi_docs: Optional documentation (only present when -haddock is enabled)++7. mi_top_env: Information about the top-level environment of the original source++8. mi_ext_fields: Additional fields for extensibility++This structure helps organize the interface data according to its purpose and usage+patterns. Different parts of the compiler use different fields. By separating them+logically in the interface we can arrange to only deserialize the fields that are needed.++Note [Strictness in ModIface]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The ModIface is the Haskell representation of an interface (.hi) file.++* During compilation we write out ModIface values to disk for files+  that we have just compiled+* For packages that we depend on we load the ModIface from disk.++All fields in the ModIface are deliberately lazy because when we read+an interface file we don't always need all the parts. For example, an+interface file contains information about documentation which is often+not needed during compilation. This is achieved using the lazyPut/lazyGet pair.+If the field was strict then we would pointlessly load this information into memory.++On the other hand, if we create a ModIface but **don't** write it to+disk then to avoid space leaks we need to make sure to deepseq all these lazy fields+because the ModIface might live for a long time (for instance in a GHCi session).+That's why in GHC.Driver.Main.hscMaybeWriteIface there is the call to+forceModIface.+-}++mi_flag_hash :: ModIface_ phase -> Maybe (FingerprintWithValue IfaceDynFlags)+mi_flag_hash = fmap mi_sr_flag_hash . mi_self_recomp_++mi_opt_hash :: ModIface_ phase -> Maybe Fingerprint+mi_opt_hash = fmap mi_sr_opt_hash . mi_self_recomp_++mi_hpc_hash :: ModIface_ phase -> Maybe Fingerprint+mi_hpc_hash = fmap mi_sr_hpc_hash . mi_self_recomp_++mi_src_hash :: ModIface_ phase -> Maybe Fingerprint+mi_src_hash = fmap mi_sr_src_hash . mi_self_recomp_++mi_usages :: ModIface_ phase -> Maybe [Usage]+mi_usages = fmap mi_sr_usages . mi_self_recomp_++mi_plugin_hash :: ModIface_ phase -> Maybe Fingerprint+mi_plugin_hash = fmap mi_sr_plugin_hash . mi_self_recomp_++-- | Accessor for the module hash of the ABI from a ModIface.+mi_mod_hash :: ModIface -> Fingerprint+mi_mod_hash iface = mi_abi_mod_hash (mi_abi_hashes iface)++-- | Accessor for whether this module has orphans from a ModIface.+mi_orphan :: ModIface -> WhetherHasOrphans+mi_orphan iface = mi_abi_orphan (mi_abi_hashes iface)++-- | Accessor for whether this module has family instances from a ModIface.+mi_finsts :: ModIface -> WhetherHasFamInst+mi_finsts iface = mi_abi_finsts (mi_abi_hashes iface)++-- | Accessor for the hash of exported avails.+mi_export_avails_hash :: ModIface -> Fingerprint+mi_export_avails_hash iface = mi_abi_export_avails_hash (mi_abi_hashes iface)++-- | Accessor for the hash of orphans and dependencies.+--+-- See Note [Orphan-like hash].+mi_orphan_like_hash :: ModIface -> Fingerprint+mi_orphan_like_hash iface = mi_abi_orphan_like_hash (mi_abi_hashes iface)++-- | Accessor for the hash of orphan rules, class and family instances combined from a ModIface.+mi_orphan_hash :: ModIface -> Fingerprint+mi_orphan_hash iface = mi_abi_orphan_hash (mi_abi_hashes iface)++-- | Old-style accessor for whether or not the ModIface came from an hs-boot+-- file.+mi_boot :: ModIface -> IsBootInterface+mi_boot iface = if mi_hsc_src iface == HsBootFile+    then IsBoot+    else NotBoot++mi_mnwib :: ModIface -> ModuleNameWithIsBoot+mi_mnwib iface = GWIB (moduleName $ mi_module iface) (mi_boot iface)++-- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be+-- found, 'defaultFixity' is returned instead.+mi_fix :: ModIface -> OccName -> Fixity+mi_fix iface name = mi_fix_fn iface name `orElse` defaultFixity++-- | The semantic module for this interface; e.g., if it's a interface+-- for a signature, if 'mi_module' is @p[A=<A>]:A@, 'mi_semantic_module'+-- will be @<A>@.+mi_mod_info_semantic_module :: IfaceModInfo -> Module+mi_mod_info_semantic_module iface = case mi_mod_info_sig_of iface of+                            Nothing -> mi_mod_info_module iface+                            Just mod -> mod++mi_semantic_module :: ModIface_ a -> Module+mi_semantic_module iface = mi_mod_info_semantic_module (mi_mod_info iface)++-- | The "precise" free holes, e.g., the signatures that this+-- 'ModIface' depends on.+mi_free_holes :: ModIface -> UniqDSet ModuleName+mi_free_holes iface =+  case getModuleInstantiation (mi_module iface) of+    (_, Just indef)+        -- A mini-hack: we rely on the fact that 'renameFreeHoles'+        -- drops things that aren't holes.+        -> renameFreeHoles (mkUniqDSet cands) (instUnitInsts (moduleUnit indef))+    _   -> emptyUniqDSet+  where+    cands = dep_sig_mods $ mi_deps iface++-- | Given a set of free holes, and a unit identifier, rename+-- the free holes according to the instantiation of the unit+-- identifier.  For example, if we have A and B free, and+-- our unit identity is @p[A=<C>,B=impl:B]@, the renamed free+-- holes are just C.+renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName+renameFreeHoles fhs insts =+    unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs))+  where+    hmap = listToUFM insts+    lookup_impl mod_name+        | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod+        -- It wasn't actually a hole+        | otherwise                           = emptyUniqDSet++-- See Note [Strictness in ModIface] about where we use lazyPut vs put+instance Binary ModIface where+   put_ bh (PrivateModIface+                { mi_hi_bytes_  = _hi_bytes, -- We don't serialise the 'mi_hi_bytes_', as it itself+                                            -- may contain an in-memory byte array buffer for this+                                            -- 'ModIface'. If we used 'put_' on this 'ModIface', then+                                            -- we likely have a good reason, and do not want to reuse+                                            -- the byte array.+                                            -- See Note [Private fields in ModIface]+                 mi_mod_info_    = mod_info,+                 mi_iface_hash_ = iface_hash,+                 mi_deps_      = deps,+                 mi_public_    = public,+                 mi_top_env_    = top_env,+                 mi_docs_      = docs,+                 mi_ext_fields_ = _ext_fields, -- Don't `put_` this in the instance so we+                                              -- can deal with it's pointer in the header+                                              -- when we write the actual file+                 mi_self_recomp_ = self_recomp,+                 mi_simplified_core_ = simplified_core+                 }) = do+        put_ bh mod_info+        put_ bh iface_hash+        lazyPut bh deps+        lazyPut bh public+        lazyPut bh top_env+        lazyPutMaybe bh docs+        lazyPutMaybe bh self_recomp+        lazyPutMaybe bh simplified_core++   get bh = do+        mod_info    <- get bh+        iface_hash  <- get bh+        deps        <- lazyGet bh+        public      <- lazyGet bh+        top_env     <- lazyGet bh+        docs        <- lazyGetMaybe bh+        self_recomp <- lazyGetMaybe bh+        simplified_core <- lazyGetMaybe bh++        return (PrivateModIface {+                 mi_mod_info_   = mod_info,+                 mi_iface_hash_ = iface_hash,+                 mi_deps_        = deps,+                 mi_public_      = public,+                 mi_simplified_core_ = simplified_core,+                 mi_docs_        = docs,+                 mi_top_env_     = top_env,+                 mi_self_recomp_ = self_recomp,+                -- placeholder because this is dealt+                -- with specially when the file is read+                 mi_ext_fields_  = emptyExtensibleFields,+                 -- We can't populate this field here, as we are+                 -- missing the 'mi_ext_fields_' field, which is+                 -- handled in 'getIfaceWithExtFields'.+                 mi_hi_bytes_    = FullIfaceBinHandle Strict.Nothing+                 })++instance Binary IfaceModInfo where+  put_ bh (IfaceModInfo { mi_mod_info_module = mod+                        , mi_mod_info_sig_of = sig_of+                        , mi_mod_info_hsc_src = hsc_src+                        }) = do+    put_ bh mod+    put_ bh sig_of+    put_ bh hsc_src++  get bh = do+    mod <- get bh+    sig_of <- get bh+    hsc_src <- get bh+    return (IfaceModInfo { mi_mod_info_module = mod+                         , mi_mod_info_sig_of = sig_of+                         , mi_mod_info_hsc_src = hsc_src+                         })+++instance Binary (IfacePublic_ 'ModIfaceFinal) where+  put_ bh (IfacePublic { mi_exports_ = exports+                       , mi_decls_ = decls+                       , mi_fixities_ = fixities+                       , mi_warns_ = warns+                       , mi_anns_ = anns+                       , mi_defaults_ = defaults+                       , mi_insts_ = insts+                       , mi_fam_insts_ = fam_insts+                       , mi_rules_ = rules+                       , mi_trust_ = trust+                       , mi_trust_pkg_ = trust_pkg+                       , mi_complete_matches_ = complete_matches+                       , mi_abi_hashes_ = abi_hashes+                       }) = do++    lazyPut bh exports+    lazyPut bh decls+    lazyPut bh fixities+    lazyPut bh warns+    lazyPut bh anns+    lazyPut bh defaults+    lazyPut bh insts+    lazyPut bh fam_insts+    lazyPut bh rules+    lazyPut bh trust+    lazyPut bh trust_pkg+    lazyPut bh complete_matches+    lazyPut bh abi_hashes++  get bh = do+    exports <- lazyGet bh+    decls <- lazyGet bh+    fixities <- lazyGet bh+    warns <- lazyGet bh+    anns <- lazyGet bh+    defaults <- lazyGet bh+    insts <- lazyGet bh+    fam_insts <- lazyGet bh+    rules <- lazyGet bh+    trust <- lazyGet bh+    trust_pkg <- lazyGet bh+    complete_matches <- lazyGet bh+    abi_hashes <- lazyGet bh+    return (mkIfacePublic exports decls fixities warns anns defaults insts fam_insts rules trust trust_pkg complete_matches abi_hashes)++instance Binary IfaceAbiHashes where+  put_ bh (IfaceAbiHashes { mi_abi_mod_hash = mod_hash+                              , mi_abi_orphan = orphan+                              , mi_abi_finsts = hasFamInsts+                              , mi_abi_export_avails_hash = vis_hash+                              , mi_abi_orphan_like_hash = invis_hash+                              , mi_abi_orphan_hash = orphan_hash+                              }) = do+    put_ bh mod_hash+    put_ bh orphan+    put_ bh hasFamInsts+    put_ bh vis_hash+    put_ bh invis_hash+    put_ bh orphan_hash+  get bh =  do+    mod_hash <- get bh+    orphan <- get bh+    hasFamInsts <- get bh+    vis_hash <- get bh+    invis_hash <- get bh+    orphan_hash <- get bh+    return $ IfaceAbiHashes  {+                   mi_abi_mod_hash = mod_hash,+                   mi_abi_orphan = orphan,+                   mi_abi_finsts = hasFamInsts,+                   mi_abi_export_avails_hash = vis_hash,+                   mi_abi_orphan_like_hash = invis_hash,+                   mi_abi_orphan_hash = orphan_hash+                   }++instance Binary IfaceSimplifiedCore where+  put_ bh (IfaceSimplifiedCore eds fs) = do+    put_ bh eds+    put_ bh fs++  get bh = do+    eds <- get bh+    fs <- get bh+    return (IfaceSimplifiedCore eds fs)++emptyPartialModIface :: Module -> PartialModIface+emptyPartialModIface mod+  = PrivateModIface+      { mi_mod_info_    = emptyIfaceModInfo mod,+        mi_iface_hash_  = fingerprint0,+        mi_hi_bytes_    = PartialIfaceBinHandle,+        mi_deps_        = noDependencies,+        mi_public_      = emptyPublicModIface (),+        mi_simplified_core_ = Nothing,+        mi_top_env_     = IfaceTopEnv emptyDetOrdAvails [] ,+        mi_docs_        = Nothing,+        mi_self_recomp_ = Nothing,+        mi_ext_fields_ = emptyExtensibleFields++      }++emptyIfaceModInfo :: Module -> IfaceModInfo+emptyIfaceModInfo mod = IfaceModInfo+  { mi_mod_info_module = mod+  , mi_mod_info_sig_of = Nothing+  , mi_mod_info_hsc_src = HsSrcFile+  }+++emptyPublicModIface :: IfaceAbiHashesExts phase -> IfacePublic_ phase+emptyPublicModIface abi_hashes = IfacePublic+  { mi_exports_ = []+  , mi_decls_ = []+  , mi_fixities_ = []+  , mi_warns_ = IfWarnSome [] []+  , mi_anns_ = []+  , mi_defaults_ = []+  , mi_insts_ = []+  , mi_fam_insts_ = []+  , mi_rules_ = []+  , mi_abi_hashes_ = abi_hashes+  , mi_trust_ = noIfaceTrustInfo+  , mi_trust_pkg_ = False+  , mi_caches_ = emptyModIfaceCache+  , mi_complete_matches_ = []+  }++emptyModIfaceCache :: IfaceCache+emptyModIfaceCache = IfaceCache {+  mi_cache_decl_warn_fn = emptyIfaceWarnCache,+  mi_cache_export_warn_fn = emptyIfaceWarnCache,+  mi_cache_fix_fn = emptyIfaceFixCache,+  mi_cache_hash_fn = emptyIfaceHashCache+}++emptyIfaceBackend :: IfaceAbiHashes+emptyIfaceBackend = IfaceAbiHashes+        { mi_abi_mod_hash = fingerprint0,+          mi_abi_orphan = False,+          mi_abi_finsts = False,+          mi_abi_export_avails_hash = fingerprint0,+          mi_abi_orphan_like_hash = fingerprint0,+          mi_abi_orphan_hash = fingerprint0+        }++emptyFullModIface :: Module -> ModIface+emptyFullModIface mod =+    (emptyPartialModIface mod)+      { mi_public_ = emptyPublicModIface emptyIfaceBackend+      , mi_hi_bytes_ = FullIfaceBinHandle Strict.Nothing+      }+++-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface'+mkIfaceHashCache :: [(Fingerprint,IfaceDecl)]+                 -> (OccName -> Maybe (OccName, Fingerprint))+mkIfaceHashCache pairs+  = \occ -> lookupOccEnv env occ+  where+    env = foldl' add_decl emptyOccEnv pairs+    add_decl env0 (v,d) = foldl' add env0 (ifaceDeclFingerprints v d)+      where+        add env0 (occ,hash) = extendOccEnv env0 occ (occ,hash)++emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint)+emptyIfaceHashCache _occ = Nothing++-- ModIface is completely forced since it will live in memory for a long time.+-- If forcing it uses a lot of memory, then store less things in ModIface.+instance ( NFData (IfaceAbiHashesExts (phase :: ModIfacePhase))+         , NFData (IfaceDeclExts (phase :: ModIfacePhase))+         ) => NFData (ModIface_ phase) where+  rnf (PrivateModIface a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)+    = (a1 :: IfaceBinHandle phase)+    `seq` rnf a2+    `seq` rnf a3+    `seq` rnf a4+    `seq` rnf a5+    `seq` rnf a6+    `seq` rnf a7+    `seq` rnf a8+    `seq` rnf a9+    `seq` rnf a10++instance NFData IfaceModInfo where+  rnf (IfaceModInfo a1 a2 a3)+    =  rnf a1+    `seq` rnf a2+    `seq` rnf a3+++instance NFData IfaceSimplifiedCore where+  rnf (IfaceSimplifiedCore eds fs) = rnf eds `seq` rnf fs++instance NFData IfaceAbiHashes where+  rnf (IfaceAbiHashes a1 a2 a3 a4 a5 a6)+    =  rnf a1+    `seq` rnf a2+    `seq` rnf a3+    `seq` rnf a4+    `seq` rnf a5+    `seq` rnf a6++instance (NFData (IfaceAbiHashesExts phase), NFData (IfaceDeclExts phase)) => NFData (IfacePublic_ phase) where+  rnf (IfacePublic a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14)+    =  rnf a1+    `seq` rnf a2+    `seq` rnf a3+    `seq` rnf a4+    `seq` rnf a5+    `seq` rnf a6+    `seq` rnf a7+    `seq` rnf a8+    `seq` rnf a9+    `seq` rnf a10+    `seq` rnf a11+    `seq` rnf a12+    `seq` rnf a13+    `seq` rnf a14++instance NFData IfaceCache where+  rnf (IfaceCache a1 a2 a3 a4)+    =  rnf a1+    `seq` rnf a2+    `seq` rnf a3+    `seq` rnf a4++++forceModIface :: ModIface -> IO ()+forceModIface iface = () <$ (evaluate $ force iface)++-- | Records whether a module has orphans. An \"orphan\" is one of:+--+-- * An instance declaration in a module other than the definition+--   module for one of the type constructors or classes in the instance head+--+-- * A rewrite rule in a module other than the one defining+--   the function in the head of the rule+--+type WhetherHasOrphans   = Bool++-- | Does this module define family instances?+type WhetherHasFamInst = Bool++-- ----------------------------------------------------------------------------+-- Modify a 'ModIface'.+-- ----------------------------------------------------------------------------++{-+Note [Private fields in ModIface]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The fields of 'ModIface' are private, e.g., not exported, to make the API+impossible to misuse. A 'ModIface' can be "compressed" in-memory using+'shareIface', which serialises the 'ModIface' to an in-memory buffer.+This has the advantage of reducing memory usage of 'ModIface', reducing the+overall memory usage of GHC.+See Note [Sharing of ModIface].++This in-memory buffer can be reused, if and only if the 'ModIface' is not+modified after it has been "compressed"/shared via 'shareIface'. Instead of+serialising 'ModIface', we simply write the in-memory buffer to disk directly.++However, we can't rely that a 'ModIface' isn't modified after 'shareIface' has+been called. Thus, we make all fields of 'ModIface' private and modification+only happens via exported update functions, such as 'set_mi_decls'.+These functions unconditionally clear any in-memory buffer if used, forcing us+to serialise the 'ModIface' to disk again.+-}++-- | Given a 'PartialModIface', turn it into a 'ModIface' by completing+-- missing fields.+completePartialModIface :: PartialModIface+  -> Fingerprint+  -> [(Fingerprint, IfaceDecl)]+  -> Maybe IfaceSimplifiedCore+  -> IfaceAbiHashes+  -> IfaceCache+  -> ModIface+completePartialModIface partial iface_hash decls extra_decls final_exts cache = partial+  { mi_public_ = completePublicModIface decls final_exts cache (mi_public_ partial)+  , mi_simplified_core_ = extra_decls+  , mi_hi_bytes_ = FullIfaceBinHandle Strict.Nothing+  , mi_iface_hash_ = iface_hash+  }+  where++-- | Given a 'PartialIfacePublic', turn it into an 'IfacePublic' by completing+-- missing fields.+completePublicModIface :: [(Fingerprint, IfaceDecl)]+                       -> IfaceAbiHashes+                       -> IfaceCache+                       -> PartialIfacePublic+                       -> IfacePublic+completePublicModIface decls abi_hashes cache partial = partial+  { mi_decls_ = decls+  , mi_abi_hashes_  = abi_hashes+  , mi_caches_ = cache+  }++set_mi_mod_info :: IfaceModInfo -> ModIface_ phase -> ModIface_ phase+set_mi_mod_info val iface = clear_mi_hi_bytes $ iface { mi_mod_info_ = val }++set_mi_self_recomp :: Maybe IfaceSelfRecomp-> ModIface_ phase -> ModIface_ phase+set_mi_self_recomp val iface = clear_mi_hi_bytes $ iface { mi_self_recomp_ = val }++set_mi_hi_bytes :: IfaceBinHandle phase -> ModIface_ phase -> ModIface_ phase+set_mi_hi_bytes val iface = iface { mi_hi_bytes_ = val }++set_mi_deps :: Dependencies -> ModIface_ phase -> ModIface_ phase+set_mi_deps val iface = clear_mi_hi_bytes $ iface { mi_deps_ = val }++set_mi_public :: (IfacePublic_ phase -> IfacePublic_ phase) -> ModIface_ phase -> ModIface_ phase+set_mi_public f iface = clear_mi_hi_bytes $ iface { mi_public_ = f (mi_public_ iface) }++set_mi_simplified_core :: Maybe IfaceSimplifiedCore -> ModIface_ phase -> ModIface_ phase+set_mi_simplified_core val iface = clear_mi_hi_bytes $ iface { mi_simplified_core_ = val }++set_mi_top_env :: IfaceTopEnv -> ModIface_ phase -> ModIface_ phase+set_mi_top_env val iface = clear_mi_hi_bytes $ iface { mi_top_env_ = val }++set_mi_docs :: Maybe Docs -> ModIface_ phase -> ModIface_ phase+set_mi_docs val iface = clear_mi_hi_bytes $  iface { mi_docs_ = val }++set_mi_ext_fields :: ExtensibleFields -> ModIface_ phase -> ModIface_ phase+set_mi_ext_fields val iface = clear_mi_hi_bytes $ iface { mi_ext_fields_ = val }++{- Settings for mi_public interface fields -}++set_mi_exports :: [IfaceExport] -> ModIface_ phase -> ModIface_ phase+set_mi_exports val = set_mi_public (\iface -> iface { mi_exports_ = val })++set_mi_fixities :: [(OccName, Fixity)] -> ModIface_ phase -> ModIface_ phase+set_mi_fixities val = set_mi_public (\iface -> iface { mi_fixities_ = val })++set_mi_warns :: IfaceWarnings -> ModIface_ phase -> ModIface_ phase+set_mi_warns val = set_mi_public (\iface -> iface { mi_warns_ = val })++set_mi_anns :: [IfaceAnnotation] -> ModIface_ phase -> ModIface_ phase+set_mi_anns val = set_mi_public (\iface -> iface { mi_anns_ = val })++set_mi_insts :: [IfaceClsInst] -> ModIface_ phase -> ModIface_ phase+set_mi_insts val = set_mi_public (\iface -> iface { mi_insts_ = val })++set_mi_fam_insts :: [IfaceFamInst] -> ModIface_ phase -> ModIface_ phase+set_mi_fam_insts val = set_mi_public (\iface -> iface { mi_fam_insts_ = val })++set_mi_rules :: [IfaceRule] -> ModIface_ phase -> ModIface_ phase+set_mi_rules val = set_mi_public (\iface -> iface { mi_rules_ = val })++set_mi_decls :: [IfaceDeclExts phase] -> ModIface_ phase -> ModIface_ phase+set_mi_decls val = set_mi_public (\iface -> iface { mi_decls_ = val })++set_mi_defaults :: [IfaceDefault] -> ModIface_ phase -> ModIface_ phase+set_mi_defaults val = set_mi_public (\iface -> iface { mi_defaults_ = val })++set_mi_trust :: IfaceTrustInfo -> ModIface_ phase -> ModIface_ phase+set_mi_trust val = set_mi_public (\iface -> iface { mi_trust_ = val })++set_mi_trust_pkg :: Bool -> ModIface_ phase -> ModIface_ phase+set_mi_trust_pkg val = set_mi_public (\iface -> iface { mi_trust_pkg_ = val })++set_mi_complete_matches :: [IfaceCompleteMatch] -> ModIface_ phase -> ModIface_ phase+set_mi_complete_matches val = set_mi_public (\iface -> iface { mi_complete_matches_ = val })++set_mi_abi_hashes :: IfaceAbiHashesExts phase -> ModIface_ phase -> ModIface_ phase+set_mi_abi_hashes val = set_mi_public (\iface -> iface { mi_abi_hashes_ = val })++{- Setters for mi_caches interface fields -}++set_mi_decl_warn_fn :: (OccName -> Maybe (WarningTxt GhcRn)) -> ModIface_ phase -> ModIface_ phase+set_mi_decl_warn_fn val = set_mi_public (\iface -> iface { mi_caches_ = (mi_caches_ iface) { mi_cache_decl_warn_fn = val } })++set_mi_export_warn_fn :: (Name -> Maybe (WarningTxt GhcRn)) -> ModIface_ phase -> ModIface_ phase+set_mi_export_warn_fn val = set_mi_public (\iface -> iface { mi_caches_ = (mi_caches_ iface) { mi_cache_export_warn_fn = val } })++set_mi_fix_fn :: (OccName -> Maybe Fixity) -> ModIface_ phase -> ModIface_ phase+set_mi_fix_fn val = set_mi_public (\iface -> iface { mi_caches_ = (mi_caches_ iface) { mi_cache_fix_fn = val } })++set_mi_hash_fn :: (OccName -> Maybe (OccName, Fingerprint)) -> ModIface_ phase -> ModIface_ phase+set_mi_hash_fn val = set_mi_public (\iface -> iface { mi_caches_ = (mi_caches_ iface) { mi_cache_hash_fn = val } })++set_mi_caches :: IfaceCache -> ModIface_ phase -> ModIface_ phase+set_mi_caches val = set_mi_public (\iface -> iface { mi_caches_ = val })++{-++-}++{- Setters for mi_mod_info interface fields -}++set_mi_module :: Module -> ModIface_ phase -> ModIface_ phase+set_mi_module val = set_mi_mod_info_field (\info -> info { mi_mod_info_module = val })++set_mi_sig_of :: Maybe Module -> ModIface_ phase -> ModIface_ phase+set_mi_sig_of val = set_mi_mod_info_field (\info -> info { mi_mod_info_sig_of = val })++set_mi_hsc_src :: HscSource -> ModIface_ phase -> ModIface_ phase+set_mi_hsc_src val = set_mi_mod_info_field (\info -> info { mi_mod_info_hsc_src = val })++-- | Helper function for setting fields in mi_mod_info_+set_mi_mod_info_field :: (IfaceModInfo -> IfaceModInfo) -> ModIface_ phase -> ModIface_ phase+set_mi_mod_info_field f iface = clear_mi_hi_bytes $ iface { mi_mod_info_ = f (mi_mod_info_ iface) }+++++-- | Invalidate any byte array buffer we might have.+clear_mi_hi_bytes :: ModIface_ phase -> ModIface_ phase+clear_mi_hi_bytes iface = iface+  { mi_hi_bytes_ = case mi_hi_bytes iface of+      PartialIfaceBinHandle -> PartialIfaceBinHandle+      FullIfaceBinHandle _ -> FullIfaceBinHandle Strict.Nothing+  }++-- ----------------------------------------------------------------------------+-- 'ModIface' pattern synonyms to keep breakage low.+-- ----------------------------------------------------------------------------++{-+Note [Inline Pattern synonym of ModIface]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The introduction of the 'ModIface' pattern synonym originally caused an increase+in allocated bytes in multiple performance tests.+In some benchmarks, it was a 2~3% increase.++Without {-# INLINE ModIface #-}, the generated core reveals the reason for this increase.+We show the core for the 'mi_module' record selector:++@+  mi_module+    = \ @phase iface -> $w$mModIface iface mi_module1++  $w$mModIface+    = \ @phase iface cont ->+        case iface of+        { PrivateModIface a b ... z ->+        cont+          a+          b+          ...+          z+        }++  mi_module1+    = \ @phase+        a+        _+        ...+        _ ->+        a+@++Thus, we can see the '$w$mModIface' is not inlined, leading to an increase in+the allocated bytes.++However, with the pragma, the correct core is generated:++@+  mi_module = mi_module_+@++-}++-- See Note [Inline Pattern synonym of ModIface] for why we have all these+-- inline pragmas.+{-# INLINE mi_mod_info #-}+{-# INLINE mi_iface_hash #-}+{-# INLINE mi_module #-}+{-# INLINE mi_sig_of #-}+{-# INLINE mi_hsc_src #-}+{-# INLINE mi_deps #-}+{-# INLINE mi_public #-}+{-# INLINE mi_exports #-}+{-# INLINE mi_fixities #-}+{-# INLINE mi_warns #-}+{-# INLINE mi_anns #-}+{-# INLINE mi_decls #-}+{-# INLINE mi_simplified_core #-}+{-# INLINE mi_defaults #-}+{-# INLINE mi_top_env #-}+{-# INLINE mi_insts #-}+{-# INLINE mi_fam_insts #-}+{-# INLINE mi_rules #-}+{-# INLINE mi_trust #-}+{-# INLINE mi_trust_pkg #-}+{-# INLINE mi_complete_matches #-}+{-# INLINE mi_docs #-}+{-# INLINE mi_abi_hashes #-}+{-# INLINE mi_ext_fields #-}+{-# INLINE mi_hi_bytes #-}+{-# INLINE mi_self_recomp_info #-}+{-# INLINE mi_fix_fn #-}+{-# INLINE mi_hash_fn #-}+{-# INLINE mi_decl_warn_fn #-}+{-# INLINE mi_export_warn_fn #-}+{-# INLINE ModIface #-}+{-# COMPLETE ModIface #-}++pattern ModIface ::+  IfaceModInfo+  -> Module+  -> Maybe Module+  -> HscSource+  -> Fingerprint+  -> Dependencies+  -> IfacePublic_ phase+  -> [IfaceExport]+  -> [(OccName, Fixity)]+  -> IfaceWarnings+  -> [IfaceAnnotation]+  -> [IfaceDeclExts phase]+  -> Maybe IfaceSimplifiedCore+  -> [IfaceDefault]+  -> IfaceTopEnv+  -> [IfaceClsInst]+  -> [IfaceFamInst]+  -> [IfaceRule]+  -> IfaceTrustInfo+  -> Bool+  -> [IfaceCompleteMatch]+  -> Maybe Docs+  -> IfaceAbiHashesExts phase+  -> ExtensibleFields+  -> IfaceBinHandle phase+  -> Maybe IfaceSelfRecomp+  -> (OccName -> Maybe Fixity)+  -> (OccName -> Maybe (OccName, Fingerprint))+  -> (OccName -> Maybe (WarningTxt GhcRn))+  -> (Name -> Maybe (WarningTxt GhcRn)) ->+  ModIface_ phase+pattern ModIface+  { mi_mod_info+  , mi_module+  , mi_sig_of+  , mi_hsc_src+  , mi_iface_hash+  , mi_deps+  , mi_public+  , mi_exports+  , mi_fixities+  , mi_warns+  , mi_anns+  , mi_decls+  , mi_simplified_core+  , mi_defaults+  , mi_top_env+  , mi_insts+  , mi_fam_insts+  , mi_rules+  , mi_trust+  , mi_trust_pkg+  , mi_complete_matches+  , mi_docs+  , mi_abi_hashes+  , mi_ext_fields+  , mi_hi_bytes+  , mi_self_recomp_info+  , mi_fix_fn+  , mi_hash_fn+  , mi_decl_warn_fn+  , mi_export_warn_fn+  } <- PrivateModIface+    { mi_mod_info_ = mi_mod_info@IfaceModInfo { mi_mod_info_module = mi_module+                                              , mi_mod_info_sig_of = mi_sig_of+                                              , mi_mod_info_hsc_src = mi_hsc_src }+    , mi_iface_hash_ = mi_iface_hash+    , mi_deps_ = mi_deps+    , mi_public_ = mi_public@IfacePublic {+        mi_exports_ = mi_exports+      , mi_fixities_ = mi_fixities+      , mi_warns_ = mi_warns+      , mi_anns_ = mi_anns+      , mi_decls_ = mi_decls+      , mi_defaults_ = mi_defaults+      , mi_insts_ = mi_insts+      , mi_fam_insts_ = mi_fam_insts+      , mi_rules_ = mi_rules+      , mi_trust_ = mi_trust+      , mi_trust_pkg_ = mi_trust_pkg+      , mi_complete_matches_ = mi_complete_matches+      , mi_caches_ = IfaceCache {+          mi_cache_decl_warn_fn = mi_decl_warn_fn,+          mi_cache_export_warn_fn = mi_export_warn_fn,+          mi_cache_fix_fn = mi_fix_fn,+          mi_cache_hash_fn = mi_hash_fn+        }+      , mi_abi_hashes_ = mi_abi_hashes+    }+    , mi_docs_ = mi_docs+    , mi_ext_fields_ = mi_ext_fields+    , mi_hi_bytes_ = mi_hi_bytes+    , mi_self_recomp_ = mi_self_recomp_info+    , mi_simplified_core_ = mi_simplified_core+    , mi_top_env_ = mi_top_env     }
+ compiler/GHC/Unit/Module/ModNodeKey.hs view
@@ -0,0 +1,35 @@+module GHC.Unit.Module.ModNodeKey+  ( ModNodeKeyWithUid(..)+  , mnkToModule+  , moduleToMnk+  , mnkIsBoot+  , mnkToInstalledModule+  , installedModuleToMnk+  ) where++import GHC.Prelude+import GHC.Utils.Outputable+import GHC.Unit.Types++data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: !ModuleNameWithIsBoot+                                           , mnkUnitId     :: !UnitId } deriving (Eq, Ord)++mnkToModule :: ModNodeKeyWithUid -> Module+mnkToModule (ModNodeKeyWithUid mnwib uid) = Module (RealUnit (Definite uid)) (gwib_mod mnwib)++mnkToInstalledModule :: ModNodeKeyWithUid -> InstalledModule+mnkToInstalledModule (ModNodeKeyWithUid mnwib uid) = Module uid (gwib_mod mnwib)++-- | Already InstalledModules are always NotBoot+installedModuleToMnk :: InstalledModule -> ModNodeKeyWithUid+installedModuleToMnk mod = ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnit mod)++moduleToMnk :: Module -> IsBootInterface -> ModNodeKeyWithUid+moduleToMnk mod is_boot = ModNodeKeyWithUid (GWIB (moduleName mod) is_boot) (moduleUnitId mod)++mnkIsBoot :: ModNodeKeyWithUid -> IsBootInterface+mnkIsBoot (ModNodeKeyWithUid mnwib _) = gwib_isBoot mnwib++instance Outputable ModNodeKeyWithUid where+  ppr (ModNodeKeyWithUid mnwib uid) = ppr uid <> colon <> ppr mnwib+
compiler/GHC/Unit/Module/ModSummary.hs view
@@ -24,12 +24,14 @@    , msDynObjFileOsPath    , msDeps    , isBootSummary+   , isTemplateHaskellOrQQNonBoot    , findTarget    ) where  import GHC.Prelude +import qualified GHC.LanguageExtensions as LangExt import GHC.Hs  import GHC.Driver.DynFlags@@ -41,6 +43,7 @@ import GHC.Types.SrcLoc import GHC.Types.Target import GHC.Types.PkgQual+import GHC.Types.Basic  import GHC.Data.Maybe import GHC.Data.OsPath (OsPath)@@ -77,12 +80,10 @@           -- See Note [When source is considered modified] and #9243         ms_hie_date   :: Maybe UTCTime,           -- ^ Timestamp of hie file, if we have one-        ms_srcimps      :: [(PkgQual, Located ModuleName)], -- FIXME: source imports are never from an external package, why do we allow PkgQual?+        ms_srcimps      :: [Located ModuleName],           -- ^ Source imports of the module-        ms_textual_imps :: [(PkgQual, Located ModuleName)],+        ms_textual_imps :: [(ImportLevel, PkgQual, Located ModuleName)],           -- ^ Non-source imports of the module from the module *text*-        ms_ghc_prim_import :: !Bool,-          -- ^ Whether the special module GHC.Prim was imported explicitly         ms_parsed_mod   :: Maybe HsParsedModule,           -- ^ The parsed, nonrenamed source, if we have it.  This is also           -- used to support "inline module syntax" in Backpack files.@@ -105,34 +106,36 @@ ms_mod_name = moduleName . ms_mod  -- | Textual imports, plus plugin imports but not SOURCE imports.-ms_imps :: ModSummary -> [(PkgQual, Located ModuleName)]+ms_imps :: ModSummary -> [(ImportLevel, PkgQual, Located ModuleName)] ms_imps ms = ms_textual_imps ms ++ ms_plugin_imps ms  -- | Plugin imports-ms_plugin_imps :: ModSummary -> [(PkgQual, Located ModuleName)]-ms_plugin_imps ms = map ((NoPkgQual,) . noLoc) (pluginModNames (ms_hspp_opts ms))+ms_plugin_imps :: ModSummary -> [(ImportLevel, PkgQual, Located ModuleName)]+ms_plugin_imps ms = map ((SpliceLevel, NoPkgQual,) . noLoc) (pluginModNames (ms_hspp_opts ms))  -- | All of the (possibly) home module imports from the given list that is to -- say, each of these module names could be a home import if an appropriately -- named file existed.  (This is in contrast to package qualified imports, which -- are guaranteed not to be home imports.)-home_imps :: [(PkgQual, Located ModuleName)] -> [(PkgQual, Located ModuleName)]-home_imps imps = filter (maybe_home . fst) imps+home_imps :: [(ImportLevel, PkgQual, Located ModuleName)] -> [(ImportLevel, PkgQual, Located ModuleName)]+home_imps imps = filter (maybe_home . pq) imps   where maybe_home NoPkgQual    = True         maybe_home (ThisPkg _)  = True         maybe_home (OtherPkg _) = False +        pq (_, p, _) = p+ -- | Like 'ms_home_imps', but for SOURCE imports. ms_home_srcimps :: ModSummary -> ([Located ModuleName]) -- [] here because source imports can only refer to the current package.-ms_home_srcimps = map snd . home_imps . ms_srcimps+ms_home_srcimps = ms_srcimps  -- | All of the (possibly) home module imports from a -- 'ModSummary'; that is to say, each of these module names -- could be a home import if an appropriately named file -- existed.  (This is in contrast to package qualified -- imports, which are guaranteed not to be home imports.)-ms_home_imps :: ModSummary -> ([(PkgQual, Located ModuleName)])+ms_home_imps :: ModSummary -> ([(ImportLevel, PkgQual, Located ModuleName)]) ms_home_imps = home_imps . ms_imps  -- The ModLocation contains both the original source filename and the@@ -146,14 +149,14 @@ -- the ms_hs_hash and imports can, of course, change  msHsFilePath, msDynHiFilePath, msHiFilePath, msObjFilePath, msDynObjFilePath :: ModSummary -> FilePath-msHsFilePath  ms = expectJust "msHsFilePath" (ml_hs_file  (ms_location ms))+msHsFilePath  ms = expectJust (ml_hs_file  (ms_location ms)) msHiFilePath  ms = ml_hi_file  (ms_location ms) msDynHiFilePath ms = ml_dyn_hi_file (ms_location ms) msObjFilePath ms = ml_obj_file (ms_location ms) msDynObjFilePath ms = ml_dyn_obj_file (ms_location ms)  msHsFileOsPath, msDynHiFileOsPath, msHiFileOsPath, msObjFileOsPath, msDynObjFileOsPath :: ModSummary -> OsPath-msHsFileOsPath  ms = expectJust "msHsFilePath" (ml_hs_file_ospath  (ms_location ms))+msHsFileOsPath  ms = expectJust (ml_hs_file_ospath  (ms_location ms)) msHiFileOsPath  ms = ml_hi_file_ospath  (ms_location ms) msDynHiFileOsPath ms = ml_dyn_hi_file_ospath (ms_location ms) msObjFileOsPath ms = ml_obj_file_ospath (ms_location ms)@@ -163,19 +166,24 @@ isBootSummary :: ModSummary -> IsBootInterface isBootSummary ms = if ms_hsc_src ms == HsBootFile then IsBoot else NotBoot +isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool+isTemplateHaskellOrQQNonBoot ms =+  (xopt LangExt.TemplateHaskell (ms_hspp_opts ms)+    || xopt LangExt.QuasiQuotes (ms_hspp_opts ms)) &&+  (isBootSummary ms == NotBoot)+ ms_mnwib :: ModSummary -> ModuleNameWithIsBoot ms_mnwib ms = GWIB (ms_mod_name ms) (isBootSummary ms)  -- | Returns the dependencies of the ModSummary s.-msDeps :: ModSummary -> ([(PkgQual, GenWithIsBoot (Located ModuleName))])-msDeps s =-           [ (NoPkgQual, d)+msDeps :: ModSummary -> ([(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))])+msDeps s = [ (NormalLevel, NoPkgQual, d) -- Source imports are always NormalLevel            | m <- ms_home_srcimps s            , d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot }                   ]            ]-        ++ [ (pkg, (GWIB { gwib_mod = m, gwib_isBoot = NotBoot }))-           | (pkg, m) <- ms_imps s+        ++ [ (stage, pkg, (GWIB { gwib_mod = m, gwib_isBoot = NotBoot }))+           | (stage, pkg, m) <- ms_imps s            ]  instance Outputable ModSummary where@@ -205,5 +213,4 @@         = f == f'  && ms_unitid summary == unitid     _ `matches` _         = False- 
+ compiler/GHC/Unit/Module/Stage.hs view
@@ -0,0 +1,85 @@+module GHC.Unit.Module.Stage ( ModuleStage(..)+                             , allStages+                             , nowAndFutureStages+                             , onlyFutureStages+                             , minStage+                             , maxStage+                             , zeroStage+                             , decModuleStage+                             , incModuleStage+                             ) where++import GHC.Prelude+import GHC.Utils.Outputable++{- Note [Stage vs Level]+~~~~~~~~~~~~~~~~~~~~~~~~++Modules are compiled at a specific stage. Levels within a module are interpreted+as offsets to the specific stage at which the module is being compiled.++* A **level** is a typechecking concept. The type checker performs level checking+  to ensure that the evaluation can proceed in a well-staged manner.+* A **stage** is an operational construct. The execution of the program happens+  in stages.++GHC at the moment knows about two stages, a module is either compiled for+compile time (*C*) or runtime (*R*), with *C* before *R*. Then:++* The main module is compiled for `R`.++* A normal import does not shift the stage at which the dependent module is required.++* If a module `M` splice imports module `A`, then compiling `M` at stage+  *R* requires compiling module `A` at stage *C*.++* If a module `N` quote imports module `B`, then compiling `N` at stage+  *C* requires compiling module `B` at stage *R*.++The compiler can then choose appropiately how modules needed at `C` are compiled+and how modules needed at `R` are compiled.++For example:++* In `-fno-code` mode, `C` modules may be compiled in dynamic way, but `R` modules+  are not compiled at all.+* When using a profiled GHC. `C` modules must be compiled in profiled way but `R` modules+  will be compiled in static way.++Further structure as needed by cross-compilation settings may require more stages.++-}++-- The order of these constructors is important for definitions such as+-- 'futureStages'.+data ModuleStage = CompileStage | RunStage deriving (Eq, Ord, Enum, Bounded)++allStages :: [ModuleStage]+allStages = [minBound .. maxBound]++nowAndFutureStages :: ModuleStage -> [ModuleStage]+nowAndFutureStages cur_st = [cur_st .. ]++onlyFutureStages :: ModuleStage -> [ModuleStage]+onlyFutureStages cur_st | cur_st == maxBound = []+onlyFutureStages cur_st = [succ cur_st .. ]++minStage :: ModuleStage+minStage = minBound++maxStage :: ModuleStage+maxStage = maxBound++instance Outputable ModuleStage where+  ppr CompileStage = text "compile"+  ppr RunStage = text "run"++zeroStage :: ModuleStage+zeroStage = RunStage++decModuleStage, incModuleStage :: ModuleStage -> ModuleStage+incModuleStage RunStage = RunStage+incModuleStage CompileStage = RunStage++decModuleStage RunStage = CompileStage+decModuleStage CompileStage = RunStage
compiler/GHC/Unit/Module/Status.hs view
@@ -41,6 +41,9 @@           -- changed.         } +instance Outputable HscRecompStatus where+  ppr HscUpToDate{} = text "HscUpToDate"+  ppr HscRecompNeeded{} = text "HscRecompNeeded"  instance Outputable HscBackendAction where   ppr (HscUpdate mi) = text "Update:" <+> (ppr (mi_module mi))
compiler/GHC/Unit/State.hs view
@@ -66,6 +66,7 @@         pprUnitInfoForUser,         pprModuleMap,         pprWithUnitState,+        pprRawUnitIds,          -- * Utils         unwireUnit)@@ -364,9 +365,13 @@         autoLink          | not (gopt Opt_AutoLinkPackages dflags) = []-         -- By default we add ghc-internal & rts to the preload units (when they are+         -- By default we add base, ghc-internal and rts to the preload units (when they are          -- found in the unit database) except when we are building them-         | otherwise = filter (hu_id /=) [ghcInternalUnitId, rtsUnitId]+         --+         -- Since "base" is not wired in, then the unit-id is discovered+         -- from the settings file by default, but can be overriden by power-users+         -- by specifying `-base-unit-id` flag.+         | otherwise = filter (hu_id /=) [baseUnitId dflags, ghcInternalUnitId, rtsUnitId]         -- if the home unit is indefinite, it means we are type-checking it only        -- (not producing any code). Hence we can use virtual units instantiated@@ -1885,8 +1890,7 @@   = case lookupModuleWithSuggestions pkgs m NoPkgQual of       LookupFound a b -> [(a,fst b)]       LookupMultiple rs -> map f rs-        where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs-                                                         (moduleUnit m)))+        where f (m,_) = (m, expectJust (lookupUnit pkgs (moduleUnit m)))       _ -> []  -- | The result of performing a lookup@@ -2266,3 +2270,7 @@ pprWithUnitState state = updSDocContext (\ctx -> ctx    { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs)    })++-- | Print raw unit-ids, without removing the hash+pprRawUnitIds :: SDoc -> SDoc+pprRawUnitIds = updSDocContext (\ctx -> ctx { sdocUnitIdForUser = ftext })
compiler/GHC/Unit/Types.hs view
@@ -1,5 +1,3 @@-{-# OPTIONS_GHC -Wno-orphans #-} -- instance Binary IsBootInterface- {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveTraversable #-}@@ -60,21 +58,21 @@    , Definite (..)       -- * Wired-in units-   , primUnitId-   , bignumUnitId    , ghcInternalUnitId    , rtsUnitId    , mainUnitId    , thisGhcUnitId    , interactiveUnitId+   , interactiveGhciUnitId+   , interactiveSessionUnitId -   , primUnit-   , bignumUnit    , ghcInternalUnit    , rtsUnit    , mainUnit    , thisGhcUnit    , interactiveUnit+   , interactiveGhciUnit+   , interactiveSessionUnit     , isInteractiveModule    , wiredInUnitIds@@ -84,8 +82,6 @@    , GenWithIsBoot (..)    , ModuleNameWithIsBoot    , ModuleWithIsBoot-   , InstalledModuleWithIsBoot-   , notBoot    ) where @@ -110,7 +106,7 @@ import qualified Data.ByteString.Char8 as BS.Char8  import Language.Haskell.Syntax.Module.Name-import {-# SOURCE #-} Language.Haskell.Syntax.ImpExp (IsBootInterface(..))+import Language.Haskell.Syntax.ImpExp (IsBootInterface(..))  --------------------------------------------------------------------- -- MODULES@@ -123,12 +119,6 @@    }    deriving (Eq,Ord,Data,Functor) -instance Data ModuleName where-  -- don't traverse?-  toConstr _   = abstractConstr "ModuleName"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "ModuleName"- -- | A Module is a pair of a 'Unit' and a 'ModuleName'. type Module = GenModule Unit @@ -523,6 +513,9 @@   }   deriving (Data) +instance NFData UnitId where+  rnf (UnitId fs) = rnf fs `seq` ()+ instance Binary UnitId where   put_ bh (UnitId fs) = put_ bh fs   get bh = do fs <- get bh; return (UnitId fs)@@ -598,25 +591,25 @@  -} -bignumUnitId, primUnitId, ghcInternalUnitId, rtsUnitId,-  mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId+ghcInternalUnitId, rtsUnitId,+  mainUnitId, thisGhcUnitId, interactiveUnitId, interactiveGhciUnitId, interactiveSessionUnitId :: UnitId -bignumUnit, primUnit, ghcInternalUnit, rtsUnit,-  mainUnit, thisGhcUnit, interactiveUnit :: Unit+ghcInternalUnit, rtsUnit,+  mainUnit, thisGhcUnit, interactiveUnit, interactiveGhciUnit, interactiveSessionUnit :: Unit -primUnitId        = UnitId (fsLit "ghc-prim")-bignumUnitId      = UnitId (fsLit "ghc-bignum") ghcInternalUnitId = UnitId (fsLit "ghc-internal") rtsUnitId         = UnitId (fsLit "rts") thisGhcUnitId     = UnitId (fsLit cProjectUnitId) -- See Note [GHC's Unit Id] interactiveUnitId = UnitId (fsLit "interactive")+interactiveGhciUnitId = UnitId (fsLit "interactive-ghci")+interactiveSessionUnitId = UnitId (fsLit "interactive-session") -primUnit          = RealUnit (Definite primUnitId)-bignumUnit        = RealUnit (Definite bignumUnitId) ghcInternalUnit   = RealUnit (Definite ghcInternalUnitId) rtsUnit           = RealUnit (Definite rtsUnitId) thisGhcUnit       = RealUnit (Definite thisGhcUnitId) interactiveUnit   = RealUnit (Definite interactiveUnitId)+interactiveGhciUnit = RealUnit (Definite interactiveGhciUnitId)+interactiveSessionUnit = RealUnit (Definite interactiveSessionUnitId)  -- | This is the package Id for the current program.  It is the default -- package Id if you don't specify a package name.  We don't add this prefix@@ -629,9 +622,7 @@  wiredInUnitIds :: [UnitId] wiredInUnitIds =-   [ primUnitId-   , bignumUnitId-   , ghcInternalUnitId+   [ ghcInternalUnitId    , rtsUnitId    ]    -- NB: ghc is no longer part of the wired-in units since its unit-id, given@@ -693,17 +684,6 @@ -- modules in opposition to boot interfaces. Instead, one should use -- 'DriverPhases.HscSource'. See Note [HscSource types]. -instance Binary IsBootInterface where-  put_ bh ib = put_ bh $-    case ib of-      NotBoot -> False-      IsBoot -> True-  get bh = do-    b <- get bh-    return $ case b of-      False -> NotBoot-      True -> IsBoot- -- | This data type just pairs a value 'mod' with an IsBootInterface flag. In -- practice, 'mod' is usually a @Module@ or @ModuleName@'. data GenWithIsBoot mod = GWIB@@ -716,12 +696,13 @@   -- IsBootInterface: this is assumed to perform filtering of non-boot modules,   -- e.g. in GHC.Driver.Env.hptModulesBelow +instance NFData mod => NFData (GenWithIsBoot mod) where+  rnf (GWIB mod isBoot) = rnf mod `seq` rnf isBoot `seq` ()+ type ModuleNameWithIsBoot = GenWithIsBoot ModuleName  type ModuleWithIsBoot = GenWithIsBoot Module -type InstalledModuleWithIsBoot = GenWithIsBoot InstalledModule- instance Binary a => Binary (GenWithIsBoot a) where   put_ bh (GWIB { gwib_mod, gwib_isBoot }) = do     put_ bh gwib_mod@@ -735,6 +716,3 @@   ppr (GWIB  { gwib_mod, gwib_isBoot }) = hsep $ ppr gwib_mod : case gwib_isBoot of     IsBoot -> [ text "{-# SOURCE #-}" ]     NotBoot -> []--notBoot :: mod -> GenWithIsBoot mod-notBoot gwib_mod = GWIB {gwib_mod, gwib_isBoot = NotBoot}
compiler/GHC/Utils/Binary.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE StandaloneDeriving #-}  {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} -- We always optimise this, otherwise performance of a non-optimised@@ -75,6 +77,9 @@    lazyGetMaybe,    lazyPutMaybe, +   -- * EnumBinary+   EnumBinary(..),+    -- * User data    ReaderUserData, getReaderUserData, setReaderUserData, noReaderUserData,    WriterUserData, getWriterUserData, setWriterUserData, noWriterUserData,@@ -107,11 +112,15 @@    simpleBindingNameReader,    FullBinData(..), freezeBinHandle, thawBinHandle, putFullBinData,    BinArray,++   -- * FingerprintWithValue+   FingerprintWithValue(..)   ) where  import GHC.Prelude  import Language.Haskell.Syntax.Module.Name (ModuleName(..))+import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..))  import {-# SOURCE #-} GHC.Types.Name (Name) import GHC.Data.FastString@@ -135,6 +144,7 @@ import Data.Coerce import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Unsafe   as BS+import qualified Data.ByteString.Short.Internal as SBS import Data.IORef import Data.Char                ( ord, chr ) import Data.List.NonEmpty       ( NonEmpty(..))@@ -154,18 +164,12 @@ import GHC.Real                 ( Ratio(..) ) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap-#if MIN_VERSION_base(4,15,0) import GHC.ForeignPtr           ( unsafeWithForeignPtr )-#endif  import Unsafe.Coerce (unsafeCoerce)  type BinArray = ForeignPtr Word8 -#if !MIN_VERSION_base(4,15,0)-unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b-unsafeWithForeignPtr = withForeignPtr-#endif  --------------------------------------------------------------- -- BinData@@ -946,8 +950,8 @@ -- | This instance doesn't rely on the determinism of the keys' 'Ord' instance, -- so it works e.g. for 'Name's too. instance (Binary a, Ord a) => Binary (Set a) where-  put_ bh s = put_ bh (Set.toList s)-  get bh = Set.fromList <$> get bh+  put_ bh s = put_ bh (Set.toAscList s)+  get bh = Set.fromAscList <$> get bh  instance Binary a => Binary (NonEmpty a) where     put_ bh = put_ bh . NonEmpty.toList@@ -1066,6 +1070,22 @@             0 -> return NotJoinPoint             _ -> do { ar <- get bh; return (JoinPoint ar) } +newtype EnumBinary a = EnumBinary { unEnumBinary :: a }+instance Enum a => Binary (EnumBinary a) where+  put_ bh (EnumBinary x) = put_ bh (fromEnum x)+  get bh = do x <- get bh+              return $ EnumBinary (toEnum x)+++instance Binary IsBootInterface where+  put_ bh ib = put_ bh (case ib of+                          IsBoot -> True+                          NotBoot -> False)+  get bh = do x <- get bh+              return $ case x of+                        True -> IsBoot+                        False -> NotBoot+ {- Finally - a reasonable portable Integer instance. @@ -1777,7 +1797,7 @@ ---------------------------------------------------------  putFS :: WriteBinHandle -> FastString -> IO ()-putFS bh fs = putBS bh $ bytesFS fs+putFS bh fs = putSBS bh $ fastStringToShortByteString fs  getFS :: ReadBinHandle -> IO FastString getFS bh = do@@ -1797,6 +1817,18 @@   BS.create l $ \dest -> do     getPrim bh l (\src -> copyBytes dest src l) +putSBS :: WriteBinHandle -> SBS.ShortByteString -> IO ()+putSBS bh sbs = do+  let l = SBS.length sbs+  put_ bh l+  putPrim bh l (\p -> SBS.copyToPtr sbs 0 p l)+++getSBS :: ReadBinHandle -> IO SBS.ShortByteString+getSBS bh = do+  l <- get bh :: IO Int+  getPrim bh l (\src -> SBS.createFromPtr src l)+ putBS :: WriteBinHandle -> ByteString -> IO () putBS bh bs =   BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do@@ -1809,6 +1841,10 @@   BS.create l $ \dest -> do     getPrim bh l (\src -> copyBytes dest src l) +instance Binary SBS.ShortByteString where+  put_ bh f = putSBS bh f+  get bh = getSBS bh+ instance Binary ByteString where   put_ bh f = putBS bh f   get bh = getBS bh@@ -2092,5 +2128,38 @@ --------------------------------------------------------------------------------  instance (Binary v) => Binary (IntMap v) where-  put_ bh m = put_ bh (IntMap.toList m)-  get bh = IntMap.fromList <$> get bh+  put_ bh m = put_ bh (IntMap.toAscList m)+  get bh = IntMap.fromAscList <$> get bh+++{- Note [FingerprintWithValue]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+FingerprintWithValue is a wrapper which allows us to store a fingerprint and+optionally the value which was used to create the fingerprint.++This is useful for storing information in interface files, where we want to+store the fingerprint of the interface file, but also the value which was used+to create the fingerprint (e.g. the DynFlags).++The wrapper is useful to ensure that the fingerprint can be read quickly without+having to deserialise the value itself.+-}++-- | A wrapper which allows us to store a fingerprint and optionally the value which+-- was used to create the fingerprint.+data FingerprintWithValue a = FingerprintWithValue !Fingerprint (Maybe a)+  deriving Functor++instance Binary a => Binary (FingerprintWithValue a) where+  put_ bh (FingerprintWithValue fp val) = do+    put_ bh fp+    lazyPutMaybe bh val++  get bh = do+    fp <- get bh+    val <- lazyGetMaybe bh+    return $ FingerprintWithValue fp val++instance NFData a => NFData (FingerprintWithValue a) where+  rnf (FingerprintWithValue fp mflags)+    = rnf fp `seq` rnf mflags `seq` ()
compiler/GHC/Utils/GlobalVars.hs view
@@ -57,13 +57,6 @@   -#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)--GLOBAL_VAR(v_unsafeHasPprDebug,      False, Bool)-GLOBAL_VAR(v_unsafeHasNoDebugOutput, False, Bool)-GLOBAL_VAR(v_unsafeHasNoStateHack,   False, Bool)--#else SHARED_GLOBAL_VAR( v_unsafeHasPprDebug                  , getOrSetLibHSghcGlobalHasPprDebug                  , "getOrSetLibHSghcGlobalHasPprDebug"@@ -79,7 +72,6 @@                  , "getOrSetLibHSghcGlobalHasNoStateHack"                  , False                  , Bool )-#endif  unsafeHasPprDebug :: Bool unsafeHasPprDebug = unsafePerformIO $ readIORef v_unsafeHasPprDebug
compiler/GHC/Utils/Logger.hs view
@@ -54,6 +54,7 @@     -- * Logging     , putLogMsg     , defaultLogAction+    , defaultLogActionWithHandles     , defaultLogJsonAction     , defaultLogActionHPrintDoc     , defaultLogActionHPutStrDoc@@ -372,13 +373,14 @@     printErrs  = defaultLogActionHPrintDoc  logflags False stderr     putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout     msg = renderJSON jsdoc+ -- See Note [JSON Error Messages] -- this is to be removed-jsonLogAction :: LogAction-jsonLogAction _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message-jsonLogAction logflags msg_class srcSpan msg+jsonLogActionWithHandle :: Handle {-^ Standard out -} -> LogAction+jsonLogActionWithHandle _ _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message+jsonLogActionWithHandle out logflags msg_class srcSpan msg   =-    defaultLogActionHPutStrDoc logflags True stdout+    defaultLogActionHPutStrDoc logflags True out       (withPprStyle PprCode (doc $$ text ""))     where       str = renderWithContext (log_default_user_context logflags) msg@@ -398,9 +400,18 @@                    where file = unpackFS $ srcSpanFile rss                  UnhelpfulSpan _ -> JSNull +-- | The default 'LogAction' prints to 'stdout' and 'stderr'.+--+-- To replicate the default log action behaviour with different @out@ and @err@+-- handles, see 'defaultLogActionWithHandles'. defaultLogAction :: LogAction-defaultLogAction logflags msg_class srcSpan msg-  | log_dopt Opt_D_dump_json logflags = jsonLogAction logflags msg_class srcSpan msg+defaultLogAction = defaultLogActionWithHandles stdout stderr++-- | The default 'LogAction' parametrized over the standard output and standard error handles.+-- Allows clients to replicate the log message formatting of GHC with custom handles.+defaultLogActionWithHandles :: Handle {-^ Handle for standard output -} -> Handle {-^ Handle for standard errors -} -> LogAction+defaultLogActionWithHandles out err logflags msg_class srcSpan msg+  | log_dopt Opt_D_dump_json logflags = jsonLogActionWithHandle out logflags msg_class srcSpan msg   | otherwise = case msg_class of       MCOutput                     -> printOut msg       MCDump                       -> printOut (msg $$ blankLine)@@ -410,9 +421,9 @@       MCDiagnostic SevIgnore _ _   -> pure () -- suppress the message       MCDiagnostic _sev _rea _code -> printDiagnostics     where-      printOut   = defaultLogActionHPrintDoc  logflags False stdout-      printErrs  = defaultLogActionHPrintDoc  logflags False stderr-      putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout+      printOut   = defaultLogActionHPrintDoc  logflags False out+      printErrs  = defaultLogActionHPrintDoc  logflags False err+      putStrSDoc = defaultLogActionHPutStrDoc logflags False out       -- Pretty print the warning flag, if any (#10752)       message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg 
compiler/GHC/Utils/Misc.hs view
@@ -2,6 +2,8 @@  {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | Highly random utility functions --@@ -23,7 +25,8 @@          dropWhileEndLE, spanEnd, last2, lastMaybe, onJust, -        List.foldl1', foldl2, count, countWhile, all2, any2,+        foldl2, count, countWhile, all2, any2, all2Prefix, all3Prefix,+        foldr1WithDefault, foldl1WithDefault',          lengthExceeds, lengthIs, lengthIsNot,         lengthAtLeast, lengthAtMost, lengthLessThan,@@ -126,8 +129,9 @@ import qualified Data.List as List import Data.List.NonEmpty  ( NonEmpty(..), last, nonEmpty ) -import GHC.Exts+import GHC.Exts hiding (toList) import GHC.Stack (HasCallStack)+import GHC.Data.List  import Control.Monad    ( guard ) import Control.Monad.IO.Class ( MonadIO, liftIO )@@ -138,6 +142,7 @@ import Data.Bifunctor   ( first, second ) import Data.Char        ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper                         , isHexDigit, digitToInt )+import Data.Foldable    ( Foldable (toList) ) import Data.Int import Data.Ratio       ( (%) ) import Data.Ord         ( comparing )@@ -237,34 +242,34 @@ DEBUGging on; hey, why not? -} -zipEqual        :: HasDebugCallStack => String -> [a] -> [b] -> [(a,b)]-zipWithEqual    :: HasDebugCallStack => String -> (a->b->c) -> [a]->[b]->[c]-zipWith3Equal   :: HasDebugCallStack => String -> (a->b->c->d) -> [a]->[b]->[c]->[d]-zipWith4Equal   :: HasDebugCallStack => String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]+zipEqual        :: HasDebugCallStack => [a] -> [b] -> [(a,b)]+zipWithEqual    :: HasDebugCallStack => (a->b->c) -> [a]->[b]->[c]+zipWith3Equal   :: HasDebugCallStack => (a->b->c->d) -> [a]->[b]->[c]->[d]+zipWith4Equal   :: HasDebugCallStack => (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]  #if !defined(DEBUG)-zipEqual      _ = zip-zipWithEqual  _ = zipWith-zipWith3Equal _ = zipWith3-zipWith4Equal _ = List.zipWith4+zipEqual      = zip+zipWithEqual  = zipWith+zipWith3Equal = zipWith3+zipWith4Equal = List.zipWith4 #else-zipEqual _   []     []     = []-zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs-zipEqual msg _      _      = panic ("zipEqual: unequal lists: "++msg)+zipEqual []     []     = []+zipEqual (a:as) (b:bs) = (a,b) : zipEqual as bs+zipEqual _      _      = panic "zipEqual: unequal lists" -zipWithEqual msg z (a:as) (b:bs)=  z a b : zipWithEqual msg z as bs-zipWithEqual _   _ [] []        =  []-zipWithEqual msg _ _ _          =  panic ("zipWithEqual: unequal lists: "++msg)+zipWithEqual z (a:as) (b:bs)=  z a b : zipWithEqual z as bs+zipWithEqual _ [] []        =  []+zipWithEqual _ _ _          =  panic "zipWithEqual: unequal lists" -zipWith3Equal msg z (a:as) (b:bs) (c:cs)-                                =  z a b c : zipWith3Equal msg z as bs cs-zipWith3Equal _   _ [] []  []   =  []-zipWith3Equal msg _ _  _   _    =  panic ("zipWith3Equal: unequal lists: "++msg)+zipWith3Equal z (a:as) (b:bs) (c:cs)+                                =  z a b c : zipWith3Equal z as bs cs+zipWith3Equal _ [] []  []   =  []+zipWith3Equal _ _  _   _    =  panic "zipWith3Equal: unequal lists" -zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)-                                =  z a b c d : zipWith4Equal msg z as bs cs ds-zipWith4Equal _   _ [] [] [] [] =  []-zipWith4Equal msg _ _  _  _  _  =  panic ("zipWith4Equal: unequal lists: "++msg)+zipWith4Equal z (a:as) (b:bs) (c:cs) (d:ds)+                                =  z a b c d : zipWith4Equal z as bs cs ds+zipWith4Equal _ [] [] [] [] =  []+zipWith4Equal _ _  _  _  _  =  panic "zipWith4Equal: unequal lists" #endif  -- | 'filterByList' takes a list of Bools and a list of some elements and@@ -323,31 +328,6 @@ mapFst = fmap . first mapSnd = fmap . second -mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])--mapAndUnzip _ [] = ([], [])-mapAndUnzip f (x:xs)-  = let (r1,  r2)  = f x-        (rs1, rs2) = mapAndUnzip f xs-    in-    (r1:rs1, r2:rs2)--mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])-mapAndUnzip3 _ [] = ([], [], [])-mapAndUnzip3 f (x:xs)-  = let (r1,  r2,  r3)  = f x-        (rs1, rs2, rs3) = mapAndUnzip3 f xs-    in-    (r1:rs1, r2:rs2, r3:rs3)--mapAndUnzip4 :: (a -> (b, c, d, e)) -> [a] -> ([b], [c], [d], [e])-mapAndUnzip4 _ [] = ([], [], [], [])-mapAndUnzip4 f (x:xs)-  = let (r1,  r2,  r3, r4)  = f x-        (rs1, rs2, rs3, rs4) = mapAndUnzip4 f xs-    in-    (r1:rs1, r2:rs2, r3:rs3, r4:rs4)- zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d]) zipWithAndUnzip f (a:as) (b:bs)   = let (r1,  r2)  = f a b@@ -488,14 +468,15 @@ -- | Extract the single element of a list and panic with the given message if -- there are more elements or the list was empty. -- Like 'expectJust', but for lists.-expectOnly :: HasDebugCallStack => String -> [a] -> a+expectOnly :: HasCallStack => [a] -> a+-- always enable the call stack to get the location even on non-debug builds {-# INLINE expectOnly #-} #if defined(DEBUG)-expectOnly _   [a]   = a+expectOnly [a]   = a #else-expectOnly _   (a:_) = a+expectOnly (a:_) = a #endif-expectOnly msg _     = panic ("expectOnly: " ++ msg)+expectOnly _     = panic "expectOnly"  -- | Compute all the ways of removing a single element from a list. --@@ -511,13 +492,14 @@ changeLast (x:xs) x' = x : changeLast xs x'  -- | Like @expectJust msg . nonEmpty@; a better alternative to 'NE.fromList'.-expectNonEmpty :: HasDebugCallStack => String -> [a] -> NonEmpty a+expectNonEmpty :: HasCallStack => [a] -> NonEmpty a+-- always enable the call stack to get the location even on non-debug builds {-# INLINE expectNonEmpty #-}-expectNonEmpty _   (x:xs) = x:|xs-expectNonEmpty msg []     = expectNonEmptyPanic msg+expectNonEmpty (x:xs) = x:|xs+expectNonEmpty []     = expectNonEmptyPanic -expectNonEmptyPanic :: String -> a-expectNonEmptyPanic msg = panic ("expectNonEmpty: " ++ msg)+expectNonEmptyPanic :: HasCallStack => a+expectNonEmptyPanic = panic "expectNonEmpty" {-# NOINLINE expectNonEmptyPanic #-}  whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m ()@@ -658,6 +640,36 @@ any2 p (x:xs) (y:ys) = p x y || any2 p xs ys any2 _ _      _      = False +all2Prefix :: forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool+-- ^ `all2Prefix p xs ys` is a fused version of `and $ zipWith2 p xs ys`.+-- (It generates good code nonetheless.)+-- So if one list is shorter than the other, `p` is assumed to be `True` for the+-- suffix.+all2Prefix p = foldr k z+  where+    k :: a -> ([b] -> Bool) -> [b] -> Bool+    k x go ys' = case ys' of+      (y:ys'') -> p x y && go ys''+      _ -> True+    z :: [b] -> Bool+    z _ = True+{-# INLINE all2Prefix #-}++all3Prefix :: forall a b c. (a -> b -> c -> Bool) -> [a] -> [b] -> [c] -> Bool+-- ^ `all3Prefix p xs ys zs` is a fused version of `and $ zipWith3 p xs ys zs`.+-- (It generates good code nonetheless.)+-- So if one list is shorter than the others, `p` is assumed to be `True` for+-- the suffix.+all3Prefix p = foldr k z+  where+    k :: a -> ([b] -> [c] -> Bool) -> [b] -> [c] -> Bool+    k x go ys' zs' = case (ys',zs') of+      (y:ys'',z:zs'') -> p x y z && go ys'' zs''+      _ -> False+    z :: [b] -> [c] -> Bool+    z _ _ = True+{-# INLINE all3Prefix #-}+ -- Count the number of times a predicate is true  count :: (a -> Bool) -> [a] -> Int@@ -1049,7 +1061,7 @@      readFix r = do         (ds,s)  <- lexDecDigits r         (ds',t) <- lexDotDigits s-        return (read (ds++ds'), length ds', t)+        return (read (toList ds++ds'), length ds', t)       readExp (e:s) | e `elem` "eE" = readExp' s      readExp s                     = return (0,s)@@ -1069,8 +1081,8 @@      lexDotDigits ('.':s) = return (span' isDigit s)      lexDotDigits s       = return ("",s) -     nonnull p s = do (cs@(_:_),t) <- return (span' p s)-                      return (cs,t)+     nonnull p s = do (c:cs,t) <- return (span' p s)+                      return (c:|cs,t)       span' _ xs@[]         =  (xs, xs)      span' p xs@(x:xs')@@ -1438,3 +1450,15 @@     g x rest       | Just y <- f x = y : rest       | otherwise     = rest++foldr1WithDefault :: Foldable f => a -> (a -> a -> a) -> f a -> a+foldr1WithDefault defaultA f xs = case nonEmpty (toList xs) of+    Nothing -> defaultA+    Just (xs1 :: NonEmpty a) -> foldr1 f xs1+{-# SPECIALIZE foldr1WithDefault :: a -> (a -> a -> a) -> [a] -> a #-}++foldl1WithDefault' :: Foldable f => a -> (a -> a -> a) -> f a -> a+foldl1WithDefault' defaultA f xs = case nonEmpty (toList xs) of+    Nothing -> defaultA+    Just (xs1 :: NonEmpty a) -> foldl1' f xs1+{-# SPECIALIZE foldl1WithDefault' :: a -> (a -> a -> a) -> [a] -> a #-}
compiler/GHC/Utils/Outputable.hs view
@@ -33,7 +33,7 @@         docToSDoc,         interppSP, interpp'SP, interpp'SP',         pprQuotedList, pprWithCommas, pprWithSemis,-        unquotedListWith,+        unquotedListWith, pprUnquotedSet,         quotedListWithOr, quotedListWithNor, quotedListWithAnd,         pprWithBars,         spaceIfSingleQuote,@@ -51,7 +51,7 @@         cat, fcat,         hang, hangNotEmpty, punctuate, punctuateFinal,         ppWhen, ppUnless, ppWhenOption, ppUnlessOption,-        speakNth, speakN, speakNOf, plural, singular,+        speakNth, speakN, speakNOf, plural, singular, pluralSet,         isOrAre, doOrDoes, itsOrTheir, thisOrThese, hasOrHave,         itOrThey,         unicodeSyntax,@@ -213,7 +213,7 @@  -- | Given a `Name`'s `Module` and `OccName`, decide whether and how to qualify -- it.-type QueryQualifyName = Module -> OccName -> QualifyName+type QueryQualifyName = Module -> Maybe ModuleName -> OccName -> QualifyName  -- | For a given module, we need to know whether to print it with -- a package name to disambiguate it.@@ -268,14 +268,14 @@   ppr NameNotInScope2 = text "NameNotInScope2"  reallyAlwaysQualifyNames :: QueryQualifyName-reallyAlwaysQualifyNames _ _ = NameNotInScope2+reallyAlwaysQualifyNames _ _ _ = NameNotInScope2  -- | NB: This won't ever show package IDs alwaysQualifyNames :: QueryQualifyName-alwaysQualifyNames m _ = NameQual (moduleName m)+alwaysQualifyNames m _ _ = NameQual (moduleName m)  neverQualifyNames :: QueryQualifyName-neverQualifyNames _ _ = NameUnqual+neverQualifyNames _ _ _ = NameUnqual  alwaysQualifyModules :: QueryQualifyModule alwaysQualifyModules _ = True@@ -567,9 +567,9 @@   = SDoc $ \ctx -> runSDoc doc (upd ctx)  qualName :: PprStyle -> QueryQualifyName-qualName (PprUser q _ _) mod occ = queryQualifyName q mod occ-qualName (PprDump q)     mod occ = queryQualifyName q mod occ-qualName _other          mod _   = NameQual (moduleName mod)+qualName (PprUser q _ _) mod user_qual occ = queryQualifyName q mod user_qual occ+qualName (PprDump q)     mod user_qual occ = queryQualifyName q mod user_qual occ+qualName _other          mod _ _           = NameQual (moduleName mod)  qualModule :: PprStyle -> QueryQualifyModule qualModule (PprUser q _ _)  m = queryQualifyModule q m@@ -1080,6 +1080,7 @@ instance Outputable ModuleName where   ppr = pprModuleName + pprModuleName :: IsLine doc => ModuleName -> doc pprModuleName (ModuleName nm) =     docWithStyle (ztext (zEncodeFS nm)) (\_ -> ftext nm)@@ -1436,6 +1437,15 @@ pprQuotedList :: Outputable a => [a] -> SDoc pprQuotedList = quotedList . map ppr ++pprUnquotedSet :: Outputable a => Set.Set a -> SDoc+pprUnquotedSet set =+  case Set.toList set of+    [] -> braces empty+    [x] -> ppr x+    xs  -> braces (fsep (punctuate comma (map ppr xs)))++ quotedList :: [SDoc] -> SDoc quotedList xs = fsep (punctuate comma (map quotes xs)) @@ -1539,6 +1549,10 @@ plural :: [a] -> SDoc plural [_] = empty  -- a bit frightening, but there you are plural _   = char 's'++-- | Like 'plural', but for sets.+pluralSet :: Set.Set a -> SDoc+pluralSet set = plural (Set.toList set)  -- | Determines the singular verb suffix appropriate for the length of a list: --
compiler/GHC/Utils/Panic.hs view
@@ -27,6 +27,7 @@    , panicDoc    , sorryDoc    , pgmErrorDoc+      -- ** Assertions    , assertPprPanic    , assertPpr@@ -176,7 +177,7 @@   PprProgramError str sdoc -> PlainProgramError $       concat [str, "\n\n", renderWithContext ctx sdoc] -throwGhcException :: GhcException -> a+throwGhcException :: HasCallStack => GhcException -> a throwGhcException = Exception.throw  throwGhcExceptionIO :: GhcException -> IO a@@ -187,11 +188,11 @@  -- | Throw an exception saying "bug in GHC" with a callstack pprPanic :: HasCallStack => String -> SDoc -> a-pprPanic s doc = panicDoc s (doc $$ callStackDoc)+pprPanic s doc = withFrozenCallStack $ panicDoc s (doc $$ callStackDoc)  -- | Throw an exception saying "bug in GHC"-panicDoc :: String -> SDoc -> a-panicDoc x doc = throwGhcException (PprPanic x doc)+panicDoc :: HasCallStack => String -> SDoc -> a+panicDoc x doc = withFrozenCallStack $ throwGhcException (PprPanic x doc)  -- | Throw an exception saying "this isn't finished yet" sorryDoc :: String -> SDoc -> a
compiler/GHC/Utils/Panic/Plain.hs view
@@ -116,9 +116,17 @@   Exception.throw (Exception.AssertionFailed            ("ASSERT failed! file " ++ file ++ ", line " ++ show line)) -+-- | Throw a failed assertion exception taking the location information+-- from 'HasCallStack' evidence. assertPanic' :: HasCallStack => a-assertPanic' = Exception.throw (Exception.AssertionFailed "ASSERT failed!")+assertPanic' =+    Exception.throw+      $ Exception.AssertionFailed+      $ "ASSERT failed!\n" ++ withFrozenCallStack doc+  where+    -- TODO: Drop CallStack when exception backtrace functionality+    -- can be assumed of bootstrap compiler.+    doc = unlines $ fmap ("  "++) $ lines (prettyCallStack callStack)  assert :: HasCallStack => Bool -> a -> a {-# INLINE assert #-}
compiler/Language/Haskell/Syntax/Basic.hs view
@@ -2,11 +2,11 @@ {-# LANGUAGE GeneralisedNewtypeDeriving #-} module Language.Haskell.Syntax.Basic where -import Data.Data+import Data.Data (Data) import Data.Eq import Data.Ord import Data.Bool-import Data.Int (Int)+import Prelude  import GHC.Data.FastString (FastString) import Control.DeepSeq@@ -81,24 +81,6 @@ ************************************************************************ -} --- | Haskell Bang------ Bangs on data constructor arguments written by the user.------ @(HsBang SrcUnpack SrcLazy)@ and--- @(HsBang SrcUnpack NoSrcStrict)@ (without StrictData) makes no sense, we--- emit a warning (in checkValidDataCon) and treat it like--- @(HsBang NoSrcUnpack SrcLazy)@------ 'GHC.Core.DataCon.HsSrcBang' is a wrapper around this, associating it with--- a 'GHC.Types.SourceText.SourceText' as written by the user.--- In the AST, the @SourceText@ is hidden inside the extension point--- 'Language.Haskell.Syntax.Extension.XBangTy'.-data HsBang =-  HsBang SrcUnpackedness-         SrcStrictness-  deriving Data- -- | Source Strictness -- -- What strictness annotation the user wrote@@ -134,5 +116,13 @@    | InfixN    deriving (Eq, Data) +instance NFData FixityDirection where+  rnf InfixL = ()+  rnf InfixR = ()+  rnf InfixN = ()+ data Fixity = Fixity Int FixityDirection   deriving (Eq, Data)++instance NFData Fixity where+  rnf (Fixity i d) = rnf i `seq` rnf d `seq` ()
compiler/Language/Haskell/Syntax/Binds.hs view
@@ -26,19 +26,15 @@   ( LHsExpr   , MatchGroup   , GRHSs )-import {-# SOURCE #-} Language.Haskell.Syntax.Pat-  ( LPat )-+import {-# SOURCE #-} Language.Haskell.Syntax.Pat( LPat )+import Language.Haskell.Syntax.BooleanFormula (LBooleanFormula) import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type+import Language.Haskell.Syntax.Basic ( Fixity ) -import GHC.Types.Fixity (Fixity) import GHC.Types.Basic (InlinePragma)--import GHC.Data.BooleanFormula (LBooleanFormula) import GHC.Types.SourceText (StringLiteral) -import Data.Void import Data.Bool import Data.Maybe @@ -255,20 +251,6 @@      }    | XPatSynBind !(XXPatSynBind idL idR) --- | Multiplicity annotations, on binders, are always resolved (to a unification--- variable if there is no annotation) during type-checking. The resolved--- multiplicity is stored in the extension fields.-data HsMultAnn pass-  = HsNoMultAnn !(XNoMultAnn pass)-  | HsPct1Ann   !(XPct1Ann pass)-  | HsMultAnn   !(XMultAnn pass) (LHsType (NoGhcTc pass))-  | XMultAnn    !(XXMultAnn pass)--type family XNoMultAnn p-type family XPct1Ann   p-type family XMultAnn   p-type family XXMultAnn  p- {- ************************************************************************ *                                                                      *@@ -359,9 +341,11 @@                 (LIdP pass)        -- Function name                 InlinePragma       -- Never defaultInlinePragma -        -- | A specialisation pragma+        -- | An old-form specialisation pragma         --         -- > {-# SPECIALISE f :: Int -> Int #-}+        --+        -- NB: this constructor is deprecated and will be removed in GHC 9.18 (#25540)   | SpecSig     (XSpecSig pass)                 (LIdP pass)        -- Specialise a function or datatype  ...                 [LHsSigType pass]  -- ... to these types@@ -369,6 +353,17 @@                                    -- If it's just defaultInlinePragma, then we said                                    --    SPECIALISE, not SPECIALISE_INLINE +        -- | A new-form specialisation pragma (see GHC Proposal #493)+        --   e.g.  {-# SPECIALISE f @Int 1 :: Int -> Int #-}+        --   See Note [Overview of SPECIALISE pragmas]+  | SpecSigE    (XSpecSigE pass)+                (RuleBndrs pass)+                (LHsExpr pass)     -- Expression to specialise+                InlinePragma+                -- The expression should be of form+                --     f a1 ... an [ :: sig ]+                -- with an optional type signature+         -- | A specialisation pragma for instance declarations only         --         -- > {-# SPECIALISE instance Eq [Int] #-}@@ -380,7 +375,7 @@         -- | A minimal complete definition pragma         --         -- > {-# MINIMAL a | (b, c | (d | e)) #-}-  | MinimalSig (XMinimalSig pass) (LBooleanFormula (LIdP pass))+  | MinimalSig (XMinimalSig pass) (LBooleanFormula pass)          -- | A "set cost centre" pragma for declarations         --@@ -423,8 +418,9 @@ isTypeLSig _                    = False  isSpecLSig :: forall p. UnXRec p => LSig p -> Bool-isSpecLSig (unXRec @p -> SpecSig {}) = True-isSpecLSig _                 = False+isSpecLSig (unXRec @p -> SpecSig {})  = True+isSpecLSig (unXRec @p -> SpecSigE {}) = True+isSpecLSig _                          = False  isSpecInstLSig :: forall p. UnXRec p => LSig p -> Bool isSpecInstLSig (unXRec @p -> SpecInstSig {}) = True@@ -433,6 +429,7 @@ isPragLSig :: forall p. UnXRec p => LSig p -> Bool -- Identifies pragmas isPragLSig (unXRec @p -> SpecSig {})   = True+isPragLSig (unXRec @p -> SpecSigE {})  = True isPragLSig (unXRec @p -> InlineSig {}) = True isPragLSig (unXRec @p -> SCCFunSig {}) = True isPragLSig (unXRec @p -> CompleteMatchSig {}) = True@@ -455,6 +452,40 @@ isCompleteMatchSig (unXRec @p -> CompleteMatchSig {} ) = True isCompleteMatchSig _                            = False +{- *********************************************************************+*                                                                      *+                   Rule binders+*                                                                      *+********************************************************************* -}++data RuleBndrs pass = RuleBndrs+       { rb_ext  :: XCRuleBndrs pass+           --   After typechecking rb_ext contains /all/ the quantified variables+           --   both term variables and type varibles+       , rb_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)]+           -- ^ User-written forall'd type vars; preserved for pretty-printing+       , rb_tmvs :: [LRuleBndr (NoGhcTc pass)]+           -- ^ User-written forall'd term vars; preserved for pretty-printing+       }+  | XRuleBndrs !(XXRuleBndrs pass)++-- | Located Rule Binder+type LRuleBndr pass = XRec pass (RuleBndr pass)++-- | Rule Binder+data RuleBndr pass+  = RuleBndr    (XCRuleBndr pass)   (LIdP pass)+  | RuleBndrSig (XRuleBndrSig pass) (LIdP pass) (HsPatSigType pass)+  | XRuleBndr !(XXRuleBndr pass)+        -- ^+        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',+        --     'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnClose'++        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation++collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass]+collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs]+ {- ************************************************************************ *                                                                      *@@ -464,7 +495,7 @@ -}  -- | Haskell Pattern Synonym Details-type HsPatSynDetails pass = HsConDetails Void (LIdP pass) [RecordPatSynField pass]+type HsPatSynDetails pass = HsConDetails (LIdP pass) [RecordPatSynField pass]  -- See Note [Record PatSyn Fields] -- | Record Pattern Synonym Field
+ compiler/Language/Haskell/Syntax/BooleanFormula.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE QuantifiedConstraints #-}++module Language.Haskell.Syntax.BooleanFormula(+  BooleanFormula(..), LBooleanFormula,+  mkVar, mkFalse, mkTrue, mkBool, mkAnd, mkOr+  ) where++import Prelude hiding ( init, last )+import Data.List ( nub )+import Language.Haskell.Syntax.Extension (XRec, UnXRec (..), LIdP)+++-- types+type LBooleanFormula p = XRec p (BooleanFormula p)+data BooleanFormula p = Var (LIdP p) | And [LBooleanFormula p] | Or [LBooleanFormula p]+                      | Parens (LBooleanFormula p)++-- instances+deriving instance (Eq (LIdP p), Eq (LBooleanFormula p)) => Eq (BooleanFormula p)++-- smart constructors+-- see note [Simplification of BooleanFormulas]+mkVar :: LIdP p -> BooleanFormula p+mkVar = Var++mkFalse, mkTrue :: BooleanFormula p+mkFalse = Or []+mkTrue = And []++-- Convert a Bool to a BooleanFormula+mkBool :: Bool -> BooleanFormula p+mkBool False = mkFalse+mkBool True  = mkTrue++-- Make a conjunction, and try to simplify+mkAnd :: forall p. (UnXRec p, Eq (LIdP p), Eq (LBooleanFormula p)) => [LBooleanFormula p] -> BooleanFormula p+mkAnd = maybe mkFalse (mkAnd' . nub . concat) . mapM fromAnd+  where+  -- See Note [Simplification of BooleanFormulas]+  fromAnd :: LBooleanFormula p -> Maybe [LBooleanFormula p]+  fromAnd bf = case unXRec @p bf of+    (And xs) -> Just xs+     -- assume that xs are already simplified+     -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs+    (Or [])  -> Nothing+     -- in case of False we bail out, And [..,mkFalse,..] == mkFalse+    _        -> Just [bf]+  mkAnd' [x] = unXRec @p x+  mkAnd' xs = And xs++mkOr :: forall p. (UnXRec p, Eq (LIdP p), Eq (LBooleanFormula p)) => [LBooleanFormula p] -> BooleanFormula p+mkOr = maybe mkTrue (mkOr' . nub . concat) . mapM fromOr+  where+  -- See Note [Simplification of BooleanFormulas]+  fromOr bf = case unXRec @p bf of+    (Or xs)  -> Just xs+    (And []) -> Nothing+    _        -> Just [bf]+  mkOr' [x] = unXRec @p x+  mkOr' xs = Or xs
compiler/Language/Haskell/Syntax/Decls.hs view
@@ -36,12 +36,9 @@   -- ** Class or type declarations   TyClDecl(..), LTyClDecl,   TyClGroup(..),-  tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,-  tyClGroupKindSigs,   isClassDecl, isDataDecl, isSynDecl,   isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,   isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,-  tyClDeclTyVars,   FamilyDecl(..), LFamilyDecl,    -- ** Instance declarations@@ -86,7 +83,7 @@   FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn,    -- * Grouping-  HsGroup(..), hsGroupInstDecls,+  HsGroup(..)     ) where  -- friends:@@ -97,13 +94,12 @@ import Language.Haskell.Syntax.Binds import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type-import Language.Haskell.Syntax.Basic (Role)+import Language.Haskell.Syntax.Basic (Role, LexicalFixity) import Language.Haskell.Syntax.Specificity (Specificity)  import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation-                       ,TyConFlavour(..), TypeOrData(..))+                       ,TyConFlavour(..), TypeOrData(..), NewOrData(..)) import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec)-import GHC.Types.Fixity (LexicalFixity)  import GHC.Unit.Module.Warnings (WarningTxt) @@ -112,15 +108,12 @@ import Control.Monad import Control.Exception (assert) import Data.Data        hiding (TyCon, Fixity, Infix)-import Data.Void import Data.Maybe import Data.String-import Data.Function import Data.Eq import Data.Int import Data.Bool import Prelude (Show)-import qualified Data.List import Data.Foldable import Data.Traversable import Data.List.NonEmpty (NonEmpty (..))@@ -235,9 +228,6 @@   | XHsGroup !(XXHsGroup p)  -hsGroupInstDecls :: HsGroup id -> [LInstDecl id]-hsGroupInstDecls = (=<<) group_instds . hs_tyclds- -- | Located Splice Declaration type LSpliceDecl pass = XRec pass (SpliceDecl pass) @@ -532,11 +522,6 @@  -- Dealing with names -tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass-tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs-tyClDeclTyVars d = tcdTyVars d-- {- Note [CUSKs: complete user-supplied kind signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We kind-check declarations differently if they have a complete, user-supplied@@ -636,25 +621,26 @@  {- Note [TyClGroups and dependency analysis] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A TyClGroup represents a strongly connected components of type/class/instance-decls, together with the role annotations for the type/class declarations.+A TyClGroup represents a strongly connected component of type/class/instance+decls, together with the role annotations and standalone kind signatures for the+type/class declarations.  The hs_tyclds :: [TyClGroup] field of a HsGroup is a dependency-order sequence of strongly-connected components.  Invariants- * The type and class declarations, group_tyclds, may depend on each-   other, or earlier TyClGroups, but not on later ones+ * The type and class declarations, group_tyclds, may lexically depend+   on each other, or earlier TyClGroups, but not on later ones   * The role annotations, group_roles, are role-annotations for some or    all of the types and classes in group_tyclds (only).   * The instance declarations, group_instds, may (and usually will)-   depend on group_tyclds, or on earlier TyClGroups, but not on later-   ones.+   lexically depend on group_tyclds, or on earlier TyClGroups, but+   not on later ones. -See Note [Dependency analysis of type, class, and instance decls]-in GHC.Rename.Module for more info.+See Note [Dependency analysis of type and class decls] in GHC.Rename.Module+for more info. -}  -- | Type or Class Group@@ -667,19 +653,6 @@   | XTyClGroup !(XXTyClGroup pass)  -tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass]-tyClGroupTyClDecls = Data.List.concatMap group_tyclds--tyClGroupInstDecls :: [TyClGroup pass] -> [LInstDecl pass]-tyClGroupInstDecls = Data.List.concatMap group_instds--tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass]-tyClGroupRoleDecls = Data.List.concatMap group_roles--tyClGroupKindSigs :: [TyClGroup pass] -> [LStandaloneKindSig pass]-tyClGroupKindSigs = Data.List.concatMap group_kisigs-- {- ********************************************************************* *                                                                      *                Data and type family declarations@@ -807,7 +780,7 @@   -> TyConFlavour tc familyInfoTyConFlavour mb_parent_tycon info =   case info of-    DataFamily         -> OpenFamilyFlavour IAmData mb_parent_tycon+    DataFamily         -> OpenFamilyFlavour (IAmData DataType) mb_parent_tycon     OpenTypeFamily     -> OpenFamilyFlavour IAmType mb_parent_tycon     ClosedTypeFamily _ -> assert (isNothing mb_parent_tycon)                           -- See Note [Closed type family mb_parent_tycon]@@ -942,12 +915,6 @@ for CUSKs, so this would be a separate feature. -} --- | When we only care whether a data-type declaration is `data` or `newtype`, but not what constructors it has-data NewOrData-  = NewType                     -- ^ @newtype Blah ...@-  | DataType                    -- ^ @data Blah ...@-  deriving ( Eq, Data )                -- Needed because Demand derives Eq- -- | Whether a data-type declaration is @data@ or @newtype@, and its constructors. data DataDefnCons a   = NewTypeCon          -- @newtype N x = MkN blah@@@ -962,8 +929,8 @@  dataDefnConsNewOrData :: DataDefnCons a -> NewOrData dataDefnConsNewOrData = \ case-    NewTypeCon _ -> NewType-    DataTypeCons _ _ -> DataType+    NewTypeCon   {} -> NewType+    DataTypeCons {} -> DataType  -- | Are the constructors within a @type data@ declaration? -- See Note [Type data declarations] in GHC.Rename.Module.@@ -1002,10 +969,13 @@       , con_names   :: NonEmpty (LIdP pass)       -- The following fields describe the type after the '::'       -- See Note [GADT abstract syntax]-      , con_bndrs   :: XRec pass (HsOuterSigTyVarBndrs pass)-        -- ^ The outermost type variable binders, be they explicit or-        --   implicit.  The 'XRec' is used to anchor exact print-        --   annotations, AnnForall and AnnDot.+      , con_outer_bndrs :: XRec pass (HsOuterSigTyVarBndrs pass)+        -- ^ The outermost type variable binders, be they explicit or implicit;+        --   cf. HsSigType that also stores the outermost sig_bndrs separately+        --   from the forall telescopes in sig_body.+        --   See Note [Representing type signatures] in Language.Haskell.Syntax.Type+      , con_inner_bndrs :: [HsForAllTelescope pass]+        -- ^ The forall telescopes other than the outermost invisible forall.       , con_mb_cxt  :: Maybe (LHsContext pass)   -- ^ User-written context (if any)       , con_g_args  :: HsConDeclGADTDetails pass -- ^ Arguments; never infix       , con_res_ty  :: LHsType pass              -- ^ Result type@@ -1149,7 +1119,7 @@  -- | The arguments in a Haskell98-style data constructor. type HsConDeclH98Details pass-   = HsConDetails Void (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass])+   = HsConDetails (HsConDeclField pass) (XRec pass [LHsConDeclRecField pass]) -- The Void argument to HsConDetails here is a reflection of the fact that -- type applications are not allowed in data constructor declarations. @@ -1160,8 +1130,8 @@ -- derived Show instances—see Note [Infix GADT constructors] in -- GHC.Tc.TyCl—but that is an orthogonal concern.) data HsConDeclGADTDetails pass-   = PrefixConGADT !(XPrefixConGADT pass) [HsScaled pass (LBangType pass)]-   | RecConGADT !(XRecConGADT pass) (XRec pass [LConDeclField pass])+   = PrefixConGADT !(XPrefixConGADT pass) [HsConDeclField pass]+   | RecConGADT !(XRecConGADT pass) (XRec pass [LHsConDeclRecField pass])    | XConDeclGADTDetails !(XXConDeclGADTDetails pass)  type family XPrefixConGADT       p@@ -1511,28 +1481,12 @@            -- ^ After renamer, free-vars from the LHS and RHS        , rd_name :: XRec pass RuleName            -- ^ Note [Pragma source text] in "GHC.Types.SourceText"-       , rd_act  :: Activation-       , rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)]-           -- ^ Forall'd type vars-       , rd_tmvs :: [LRuleBndr pass]-           -- ^ Forall'd term vars, before typechecking; after typechecking-           --    this includes all forall'd vars-       , rd_lhs  :: XRec pass (HsExpr pass)-       , rd_rhs  :: XRec pass (HsExpr pass)+       , rd_act   :: Activation+       , rd_bndrs :: RuleBndrs pass+       , rd_lhs   :: XRec pass (HsExpr pass)+       , rd_rhs   :: XRec pass (HsExpr pass)        }   | XRuleDecl !(XXRuleDecl pass)---- | Located Rule Binder-type LRuleBndr pass = XRec pass (RuleBndr pass)---- | Rule Binder-data RuleBndr pass-  = RuleBndr (XCRuleBndr pass)  (LIdP pass)-  | RuleBndrSig (XRuleBndrSig pass) (LIdP pass) (HsPatSigType pass)-  | XRuleBndr !(XXRuleBndr pass)--collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass]-collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs]  {- ************************************************************************
compiler/Language/Haskell/Syntax/Expr.hs view
@@ -41,7 +41,6 @@ import Data.Eq import Data.Maybe import Data.List.NonEmpty ( NonEmpty )-import GHC.Types.Name.Reader  {- Note [RecordDotSyntax field updates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -130,7 +129,7 @@ type LFieldLabelStrings p = XRec p (FieldLabelStrings p)  newtype FieldLabelStrings p =-  FieldLabelStrings [XRec p (DotFieldOcc p)]+  FieldLabelStrings (NonEmpty (XRec p (DotFieldOcc p)))  -- Field projection updates (e.g. @foo.bar.baz = 1@). See Note -- [RecordDotSyntax field updates].@@ -292,7 +291,7 @@     ...     | HsForAll (XForAll p) (HsForAllTelescope p) (LHsExpr p)     | HsQual (XQual p) (XRec p [LHsExpr p]) (LHsExpr p)-    | HsFunArr (XFunArr p) (HsArrowOf (LHsExpr p) p) (LHsExpr p) (LHsExpr p)+    | HsFunArr (XFunArr p) (HsMultAnnOf (LHsExpr p) p) (LHsExpr p) (LHsExpr p)    -- GHC/Parser.y   infixexp2 :: { ECP }@@ -332,21 +331,8 @@ -- | A Haskell expression. data HsExpr p   = HsVar     (XVar p)-              (LIdP p) -- ^ Variable-                       -- See Note [Located RdrNames]--  | HsUnboundVar (XUnboundVar p)-                 RdrName     -- ^ Unbound variable; also used for "holes"-                             --   (_ or _x).-                             -- Turned from HsVar to HsUnboundVar by the-                             --   renamer, when it finds an out-of-scope-                             --   variable or hole.-                             -- The (XUnboundVar p) field becomes an HoleExprRef-                             --   after typechecking; this is where the-                             --   erroring expression will be written after-                             --   solving. See Note [Holes] in GHC.Tc.Types.Constraint.--+              (LIdOccP p) -- ^ Variable+                          -- See Note [Located RdrNames]    | HsOverLabel (XOverLabel p) FastString      -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)@@ -380,7 +366,7 @@   -- NB Bracketed ops such as (+) come out as Vars.    -- NB Sadly, we need an expr for the operator in an OpApp/Section since-  -- the renamer may turn a HsVar into HsRecSel or HsUnboundVar+  -- the renamer may turn a HsVar into HsRecSel or HsHole.    | OpApp       (XOpApp p)                 (LHsExpr p)       -- left operand@@ -429,7 +415,7 @@                 (LHsExpr p)    --  else part    -- | Multi-way if-  | HsMultiIf   (XMultiIf p) [LGRHS p (LHsExpr p)]+  | HsMultiIf   (XMultiIf p) (NonEmpty (LGRHS p (LHsExpr p)))    -- | let(rec)   | HsLet       (XLet p)@@ -503,7 +489,7 @@    | HsTypedBracket   (XTypedBracket p)   (LHsExpr p)   | HsUntypedBracket (XUntypedBracket p) (HsQuote p)-  | HsTypedSplice    (XTypedSplice p)   (LHsExpr p) -- `$$z` or `$$(f 4)`+  | HsTypedSplice    (XTypedSplice p)   (HsTypedSplice p) -- `$$z` or `$$(f 4)`   | HsUntypedSplice  (XUntypedSplice p) (HsUntypedSplice p)    -----------------------------------------------------------@@ -529,6 +515,10 @@   | HsEmbTy   (XEmbTy p)               (LHsWcType (NoGhcTc p)) +   -- | Holes in expressions, i.e. '_'.+   -- See Note [Holes in expressions] in GHC.Tc.Types.Constraint.+  | HsHole (XHole p)+   -- | Forall-types @forall tvs. t@ and @forall tvs -> t@.   -- Used with @RequiredTypeArguments@, e.g. @fn (forall a. Proxy a)@.   -- See Note [Types in terms]@@ -542,7 +532,7 @@   -- | Function types @a -> b@.   -- Used with @RequiredTypeArguments@, e.g. @fn (Int -> Bool)@.   -- See Note [Types in terms]-  | HsFunArr (XFunArr p) (HsArrowOf (LHsExpr p) p) (LHsExpr p) (LHsExpr p)+  | HsFunArr (XFunArr p) (HsMultAnnOf (LHsExpr p) p) (LHsExpr p) (LHsExpr p)    | XExpr       !(XXExpr p)   -- Note [Trees That Grow] in Language.Haskell.Syntax.Extension for the@@ -871,10 +861,13 @@  data MatchGroup p body   = MG { mg_ext     :: XMG p body -- Post-typechecker, types of args and result, and origin-       , mg_alts    :: XRec p [LMatch p body] } -- The alternatives+       , mg_alts    :: XRec p [LMatch p body]+         -- The alternatives, see Note [Empty mg_alts] for what it means if 'mg_alts' is empty.+       }      -- The type is the type of the entire group      --      t1 -> ... -> tn -> tr      -- where there are n patterns+   | XMatchGroup !(XXMatchGroup p body)  -- | Located Match@@ -920,21 +913,31 @@     (&&&  ) [] [] =  []     xs    &&&   [] =  xs     (  &&&  ) [] ys =  ys--}  -isInfixMatch :: Match id body -> Bool-isInfixMatch match = case m_ctxt match of-  FunRhs {mc_fixity = Infix} -> True-  _                          -> False+Note [Empty mg_alts]+~~~~~~~~~~~~~~~~~~~~~~+A `MatchGroup` for a function definition must have at least one alt, as it is not possible to+define a function by zero clauses — the compiler would consider this a missing definition,+rather than one with no clauses. +However, a `MatchGroup` for a `case` or `\ case` expression may be empty, as such an expression+may have zero branches. (Note: A `\ cases` expression may not have zero branches; see GHC+proposal 302).++Ergo, if we have no alts, it must be either a `case` or a `\ case` expression; such expressions+have match arity 1.++-}++ -- | Guarded Right-Hand Sides -- -- GRHSs are used both for pattern bindings and for Matches data GRHSs p body   = GRHSs {       grhssExt :: XCGRHSs p body,-      grhssGRHSs :: [LGRHS p body],     -- ^ Guarded RHSs+      grhssGRHSs :: NonEmpty (LGRHS p body),     -- ^ Guarded RHSs       grhssLocalBinds :: HsLocalBinds p -- ^ The where clause     }   | XGRHSs !(XXGRHSs p body)@@ -1030,7 +1033,7 @@   -- ParStmts only occur in a list/monad comprehension   | ParStmt  (XParStmt idL idR body)    -- Post typecheck,                                         -- S in (>>=) :: Q -> (R -> S) -> T-             [ParStmtBlock idL idR]+             (NonEmpty (ParStmtBlock idL idR))              (HsExpr idR)               -- Polymorphic `mzip` for monad comprehensions              (SyntaxExpr idR)           -- The `>>=` operator                                         -- See notes [Monad Comprehensions]@@ -1316,11 +1319,15 @@     | HsQuasiQuote            -- See Note [Quasi-quote overview]         (XQuasiQuote id)-        (IdP id)             -- The quoter (the bit between `[` and `|`)+        (LIdP id)             -- The quoter (the bit between `[` and `|`)         (XRec id FastString) -- The enclosed string     | XUntypedSplice !(XXUntypedSplice id) -- Extension point; see Note [Trees That Grow]                                           -- in Language.Haskell.Syntax.Extension++data HsTypedSplice id+  = HsTypedSpliceExpr (XTypedSpliceExpr id) (LHsExpr id)+  | XTypedSplice !(XXTypedSplice id)  -- | Haskell (Untyped) Quote = Expr + Pat + Type + Var data HsQuote p
compiler/Language/Haskell/Syntax/Extension.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes     #-} -- for unXRec, etc.-{-# LANGUAGE CPP                     #-} {-# LANGUAGE ConstraintKinds         #-} {-# LANGUAGE DataKinds               #-} {-# LANGUAGE DeriveDataTypeable      #-}@@ -21,9 +20,7 @@ -- This module captures the type families to precisely identify the extension -- points for GHC.Hs syntax -#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) import Data.Type.Equality (type (~))-#endif  import Data.Data hiding ( Fixity ) import Data.Kind (Type)@@ -171,6 +168,42 @@  type LIdP p = XRec p (IdP p) +-- | Like 'IdP', except it keeps track of the user-written module qualification,+-- if any.+--+-- See Note [IdOcc].+type family IdOccP p+type LIdOccP p = XRec p (IdOccP p)++{- Note [IdOcc]+~~~~~~~~~~~~~~~+When possible, in error messages we would like to report identifiers with the+qualification that the user has written (provided this does not cause any+ambiguity). To do this, we record the user-written qualification in the+AST in the GhcRn stage. This is achieved with the 'WithUserRdr' data type.+Thus:++  - instead of using 'IdP', we use 'IdOccP', which wraps an 'IdP' in+    'WithUserRdr' at GhcRn pass, in:+      - 'HsVar'+      - 'HsTyVar' (which is used for 'TyCon's, not just type variables)+      - 'HsOpTy'+  - we also use 'ConLikeP' which wraps a 'Name' in 'WithUserRdr' at 'GhcRn'+    pass, in:+      - 'RecordCon'+      - 'ConPat'++This user-written module qualification is then consulted when pretty-printing+expressions, e.g. we have:++  - ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v++and 'pprPrefixOcc' uses the 'OutputableBndr' instance for 'WithUserRdr'.+This happens in 'GHC.Types.Name.Ppr.mkQualName'.++Test case: T25877.+-}+ -- ===================================================================== -- Type families for the HsBinds extension points @@ -211,6 +244,7 @@ type family XFixSig           x type family XInlineSig        x type family XSpecSig          x+type family XSpecSigE         x type family XSpecInstSig      x type family XMinimalSig       x type family XSCCFunSig        x@@ -367,6 +401,11 @@ type family XXRuleDecl       x  -- -------------------------------------+-- RuleBndrs type families+type family XCRuleBndrs     x+type family XXRuleBndrs     x++-- ------------------------------------- -- RuleBndr type families type family XCRuleBndr      x type family XRuleBndrSig    x@@ -448,6 +487,7 @@ type family XBinTick        x type family XPragE          x type family XEmbTy          x+type family XHole           x type family XForAll         x type family XQual           x type family XFunArr         x@@ -476,9 +516,13 @@ -- ------------------------------------- -- HsUntypedSplice type families type family XUntypedSpliceExpr x+type family XTypedSpliceExpr x type family XQuasiQuote        x type family XXUntypedSplice    x +-- HsTypedSplice type families+type family XXTypedSplice      x+ -- ------------------------------------- -- HsQuoteBracket type families type family XExpBr  x@@ -566,8 +610,6 @@ type family XHsWord16Prim x type family XHsWord32Prim x type family XHsWord64Prim x-type family XHsInteger x-type family XHsRat x type family XHsFloatPrim x type family XHsDoublePrim x type family XXLit x@@ -656,8 +698,6 @@ type family XKindSig         x type family XSpliceTy        x type family XDocTy           x-type family XBangTy          x-type family XRecTy           x type family XExplicitListTy  x type family XExplicitTupleTy x type family XTyLit           x@@ -683,6 +723,11 @@ type family XXTyVarBndr  x  -- ---------------------------------------------------------------------+-- HsConDeclRecField type families+type family XConDeclRecField  x+type family XXConDeclRecField x++-- --------------------------------------------------------------------- -- ConDeclField type families type family XConDeclField  x type family XXConDeclField x@@ -719,6 +764,7 @@ type family XIEDefault p type family XIEPattern p type family XIEType p+type family XIEData p type family XXIEWrappedName p  
compiler/Language/Haskell/Syntax/ImpExp.hs view
@@ -1,13 +1,12 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveDataTypeable #-}-module Language.Haskell.Syntax.ImpExp where+module Language.Haskell.Syntax.ImpExp ( module Language.Haskell.Syntax.ImpExp, IsBootInterface(..) ) where  import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Module.Name+import Language.Haskell.Syntax.ImpExp.IsBoot ( IsBootInterface(..) )  import Data.Eq (Eq)-import Data.Ord (Ord)-import Text.Show (Show) import Data.Data (Data) import Data.Bool (Bool) import Data.Maybe (Maybe)@@ -15,8 +14,7 @@ import Data.Int (Int)  import Control.DeepSeq--import GHC.Hs.Doc -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST+import {-# SOURCE #-} GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST  {- ************************************************************************@@ -38,15 +36,13 @@   | NotQualified  -- ^ Not qualified.   deriving (Eq, Data) --- | Indicates whether a module name is referring to a boot interface (hs-boot--- file) or regular module (hs file). We need to treat boot modules specially--- when building compilation graphs, since they break cycles. Regular source--- files and signature files are treated equivalently.-data IsBootInterface = NotBoot | IsBoot-    deriving (Eq, Ord, Show, Data)+data ImportDeclLevelStyle+  = LevelStylePre ImportDeclLevel -- ^ 'splice' or 'quote' appears in prepositive position.+  | LevelStylePost ImportDeclLevel -- ^ 'splice' or 'quote' appears in postpositive position.+  | NotLevelled -- ^ Not levelled.+  deriving (Eq, Data) -instance NFData IsBootInterface where-  rnf = rwhnf+data ImportDeclLevel = ImportDeclQuote | ImportDeclSplice deriving (Eq, Data)  -- | Import Declaration --@@ -57,6 +53,7 @@       ideclName       :: XRec pass ModuleName, -- ^ Module name.       ideclPkgQual    :: ImportDeclPkgQual pass,  -- ^ Package qualifier.       ideclSource     :: IsBootInterface,      -- ^ IsBoot \<=> {-\# SOURCE \#-} import+      ideclLevelSpec  :: ImportDeclLevelStyle,       ideclSafe       :: Bool,          -- ^ True => safe import       ideclQualified  :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified.       ideclAs         :: Maybe (XRec pass ModuleName),  -- ^ as Module@@ -177,11 +174,8 @@   = IEName    (XIEName p)    (LIdP p)  -- ^ unadorned name, e.g @myFun@   | IEDefault (XIEDefault p) (LIdP p)  -- ^ @default X ()@, see Note [Named default declarations] in GHC.Tc.Gen.Default   | IEPattern (XIEPattern p) (LIdP p)  -- ^ @pattern X@-                                       ---                                       -- exactprint: the location of @pattern@ keyword is captured via 'GHC.Parser.Annotation.EpaLocation'   | IEType    (XIEType p)    (LIdP p)  -- ^ @type (:+:)@-                                       ---                                       -- exactprint: the location of @type@ keyword is captured via 'GHC.Parser.Annotation.EpaLocation'+  | IEData    (XIEData p)    (LIdP p)  -- ^ @data (:+:)@   | XIEWrappedName !(XXIEWrappedName p)  -- | Located name with possible adornment
− compiler/Language/Haskell/Syntax/ImpExp.hs-boot 
@@ -1,16 +0,0 @@-module Language.Haskell.Syntax.ImpExp where--import Data.Eq-import Data.Ord-import Text.Show-import Data.Data---- This boot file should be short lived: As soon as the dependency on--- `GHC.Hs.Doc` is gone we'll no longer have cycles and can get rid this file.--data IsBootInterface = NotBoot | IsBoot--instance Eq IsBootInterface-instance Ord IsBootInterface-instance Show IsBootInterface-instance Data IsBootInterface
+ compiler/Language/Haskell/Syntax/ImpExp/IsBoot.hs view
@@ -0,0 +1,15 @@+module Language.Haskell.Syntax.ImpExp.IsBoot ( IsBootInterface(..) ) where++import Prelude (Eq, Ord, Show)+import Data.Data (Data)+import Control.DeepSeq (NFData(..), rwhnf)++-- | Indicates whether a module name is referring to a boot interface (hs-boot+-- file) or regular module (hs file). We need to treat boot modules specially+-- when building compilation graphs, since they break cycles. Regular source+-- files and signature files are treated equivalently.+data IsBootInterface = NotBoot | IsBoot+    deriving (Eq, Ord, Show, Data)++instance NFData IsBootInterface where+  rnf = rwhnf
compiler/Language/Haskell/Syntax/Lit.hs view
@@ -21,7 +21,6 @@ import Language.Haskell.Syntax.Extension  import GHC.Types.SourceText (IntegralLit, FractionalLit, SourceText)-import GHC.Core.Type (Type)  import GHC.Data.FastString (FastString, lexicalCompareFS) @@ -80,22 +79,13 @@       -- ^ literal @Word32#@   | HsWord64Prim (XHsWord64Prim x) {- SourceText -} Integer       -- ^ literal @Word64#@-  | HsInteger (XHsInteger x) {- SourceText -} Integer Type-      -- ^ Genuinely an integer; arises only-      -- from TRANSLATION (overloaded-      -- literals are done with HsOverLit)-  | HsRat (XHsRat x)  FractionalLit Type-      -- ^ Genuinely a rational; arises only from-      -- TRANSLATION (overloaded literals are-      -- done with HsOverLit)   | HsFloatPrim (XHsFloatPrim x)   FractionalLit       -- ^ Unboxed Float   | HsDoublePrim (XHsDoublePrim x) FractionalLit       -- ^ Unboxed Double-   | XLit !(XXLit x) -instance Eq (HsLit x) where+instance (Eq (XXLit x)) => Eq (HsLit x) where   (HsChar _ x1)       == (HsChar _ x2)       = x1==x2   (HsCharPrim _ x1)   == (HsCharPrim _ x2)   = x1==x2   (HsString _ x1)     == (HsString _ x2)     = x1==x2@@ -105,10 +95,9 @@   (HsWordPrim _ x1)   == (HsWordPrim _ x2)   = x1==x2   (HsInt64Prim _ x1)  == (HsInt64Prim _ x2)  = x1==x2   (HsWord64Prim _ x1) == (HsWord64Prim _ x2) = x1==x2-  (HsInteger _ x1 _)  == (HsInteger _ x2 _)  = x1==x2-  (HsRat _ x1 _)      == (HsRat _ x2 _)      = x1==x2   (HsFloatPrim _ x1)  == (HsFloatPrim _ x2)  = x1==x2   (HsDoublePrim _ x1) == (HsDoublePrim _ x2) = x1==x2+  (XLit x1)           == (XLit x2)           = x1==x2   _                   == _                   = False  -- | Haskell Overloaded Literal
compiler/Language/Haskell/Syntax/Module/Name.hs view
@@ -3,6 +3,7 @@ import Prelude  import Data.Char (isAlphaNum)+import Data.Data import Control.DeepSeq import qualified Text.ParserCombinators.ReadP as Parse import System.FilePath@@ -11,6 +12,14 @@  -- | A ModuleName is essentially a simple string, e.g. @Data.List@. newtype ModuleName = ModuleName FastString deriving (Show, Eq)++instance Data ModuleName where+  -- don't traverse?+  toConstr x   = constr+    where+      constr = mkConstr (dataTypeOf x) "{abstract:ModuleName}" [] Prefix+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "ModuleName"  instance Ord ModuleName where   nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2
compiler/Language/Haskell/Syntax/Pat.hs view
@@ -20,16 +20,16 @@ -- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* module Language.Haskell.Syntax.Pat (         Pat(..), LPat,-        ConLikeP, isInvisArgPat,-        isVisArgPat,+        ConLikeP,+        isInvisArgPat, isInvisArgLPat,+        isVisArgPat, isVisArgLPat, -        HsConPatDetails, hsConPatArgs, hsConPatTyArgs,-        HsConPatTyArg(..), XConPatTyArg,+        HsConPatDetails, hsConPatArgs,+        takeHsConPatTyArgs, dropHsConPatTyArgs,         HsRecFields(..), XHsRecFields, HsFieldBind(..), LHsFieldBind,         HsRecField, LHsRecField,         HsRecUpdField, LHsRecUpdField,-        RecFieldsDotDot(..),-        hsRecFields, hsRecFieldSel, hsRecFieldsArgs,+        RecFieldsDotDot(..)     ) where  import {-# SOURCE #-} Language.Haskell.Syntax.Expr (SyntaxExpr, LHsExpr, HsUntypedSplice)@@ -204,32 +204,36 @@  -- --------------------------------------------------------------------- --- | Type argument in a data constructor pattern,---   e.g. the @\@a@ in @f (Just \@a x) = ...@.-data HsConPatTyArg p = HsConPatTyArg !(XConPatTyArg p) (HsTyPat p)--type family XConPatTyArg p- isInvisArgPat :: Pat p -> Bool isInvisArgPat InvisPat{} = True isInvisArgPat _   = False +isInvisArgLPat :: forall p. (UnXRec p) => LPat p -> Bool+isInvisArgLPat = isInvisArgPat . unXRec @p+ isVisArgPat :: Pat p -> Bool isVisArgPat = not . isInvisArgPat +isVisArgLPat :: forall p. (UnXRec p) => LPat p -> Bool+isVisArgLPat = isVisArgPat . unXRec @p+ -- | Haskell Constructor Pattern Details-type HsConPatDetails p = HsConDetails (HsConPatTyArg (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p))+type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p))  hsConPatArgs :: forall p . (UnXRec p) => HsConPatDetails p -> [LPat p]-hsConPatArgs (PrefixCon _ ps) = ps+hsConPatArgs (PrefixCon ps)   = ps hsConPatArgs (RecCon fs)      = Data.List.map (hfbRHS . unXRec @p) (rec_flds fs) hsConPatArgs (InfixCon p1 p2) = [p1,p2] -hsConPatTyArgs :: forall p. HsConPatDetails p -> [HsConPatTyArg (NoGhcTc p)]-hsConPatTyArgs (PrefixCon tyargs _) = tyargs-hsConPatTyArgs (RecCon _)           = []-hsConPatTyArgs (InfixCon _ _)       = []+takeHsConPatTyArgs :: forall p. (UnXRec p) => [LPat p] -> [HsTyPat (NoGhcTc p)]+takeHsConPatTyArgs (p : ps)+  | InvisPat _ tp <- unXRec @p p+  = tp : takeHsConPatTyArgs ps+takeHsConPatTyArgs _ = [] +dropHsConPatTyArgs :: forall p. (UnXRec p) => [LPat p] -> [LPat p]+dropHsConPatTyArgs = Data.List.dropWhile (isInvisArgPat . unXRec @p)+ -- | Haskell Record Fields -- -- HsRecFields is used only for patterns and expressions (not data type@@ -340,12 +344,3 @@ --     hfbLHS = Unambiguous "x" $sel:x:MkS  :: AmbiguousFieldOcc Id -- -- See also Note [Disambiguating record updates] in GHC.Rename.Pat.--hsRecFields :: forall p arg.UnXRec p => HsRecFields p arg -> [IdP p]-hsRecFields rbinds = Data.List.map (hsRecFieldSel . unXRec @p) (rec_flds rbinds)--hsRecFieldsArgs :: forall p arg. UnXRec p => HsRecFields p arg -> [arg]-hsRecFieldsArgs rbinds = Data.List.map (hfbRHS . unXRec @p) (rec_flds rbinds)--hsRecFieldSel :: forall p arg. UnXRec p => HsRecField p arg -> IdP p-hsRecFieldSel = unXRec @p . foLabel . unXRec @p . hfbLHS
compiler/Language/Haskell/Syntax/Type.hs view
@@ -20,9 +20,8 @@  -- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* module Language.Haskell.Syntax.Type (-        HsScaled(..),-        hsMult, hsScaledThing,-        HsArrow, HsArrowOf(..), XUnrestrictedArrow, XLinearArrow, XExplicitMult, XXArrow,+        HsMultAnn, HsMultAnnOf(..),+        XUnannotated, XLinearAnn, XExplicitMult, XXMultAnnOf,          HsType(..), LHsType, HsKind, LHsKind,         HsBndrVis(..), XBndrRequired, XBndrInvisible, XXBndrVis,@@ -46,40 +45,39 @@          LHsTypeArg, -        LBangType, BangType,-        HsBang(..),         PromotionFlag(..), isPromoted, -        ConDeclField(..), LConDeclField,+        HsConDeclRecField(..), LHsConDeclRecField, -        HsConDetails(..), noTypeArgs,+        HsConDetails(..),+        HsConDeclField(..),          FieldOcc(..), LFieldOcc,          mapHsOuterImplicit,         hsQTvExplicit,-        isHsKindedTyVar,-        hsPatSigType,+        isHsKindedTyVar     ) where  import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsUntypedSplice ) -import Language.Haskell.Syntax.Basic ( HsBang(..) )+import Language.Haskell.Syntax.Basic ( SrcStrictness, SrcUnpackedness ) import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Specificity   import GHC.Hs.Doc (LHsDoc) import GHC.Data.FastString (FastString)+import GHC.Utils.Panic( panic )  import Data.Data hiding ( Fixity, Prefix, Infix )-import Data.Void import Data.Maybe import Data.Eq import Data.Bool import Data.Char import Prelude (Integer) import Data.Ord (Ord)+import Control.DeepSeq  {- ************************************************************************@@ -99,24 +97,9 @@ isPromoted IsPromoted  = True isPromoted NotPromoted = False -{--************************************************************************-*                                                                      *-\subsection{Bang annotations}-*                                                                      *-************************************************************************--}---- | Located Bang Type-type LBangType pass = XRec pass (BangType pass)---- | Bang Type------ In the parser, strictness and packedness annotations bind more tightly--- than docstrings. This means that when consuming a 'BangType' (and looking--- for 'HsBangTy') we must be ready to peer behind a potential layer of--- 'HsDocTy'. See #15206 for motivation and 'getBangType' for an example.-type BangType pass  = HsType pass       -- Bangs are in the HsType data type+instance NFData PromotionFlag where+  rnf NotPromoted = ()+  rnf IsPromoted  = ()  {- ************************************************************************@@ -344,7 +327,8 @@   | XLHsQTyVars !(XXLHsQTyVars pass)  hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr (HsBndrVis pass) pass]-hsQTvExplicit = hsq_explicit+hsQTvExplicit (HsQTvs { hsq_explicit = explicit_tvs }) = explicit_tvs+hsQTvExplicit (XLHsQTyVars {})                         = panic "hsQTvExplicit"  ------------------------------------------------ --            HsOuterTyVarBndrs@@ -460,9 +444,6 @@           }   | XHsSigType !(XXHsSigType pass) -hsPatSigType :: HsPatSigType pass -> LHsType pass-hsPatSigType = hsps_body- {- Note [forall-or-nothing rule] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -790,7 +771,7 @@ 4. In constructor patterns, as long as the conditions outlined in    Note [Type patterns: binders and unifiers] are satisfied -      fn (MkT @a @b x y) = ...  -- type arguments (HsConPatTyArg)+      fn (MkT @a @b x y) = ...  -- invisible type arguments (InvisPat)                                 -- in constructor patterns (ConPat)     Here, the `a` and `b` are type variable binders iff@@ -844,7 +825,7 @@   | HsTyVar  (XTyVar pass)               PromotionFlag    -- Whether explicitly promoted,                                -- for the pretty printer-             (LIdP pass)+             (LIdOccP pass)                   -- Type variable, type constructor, or data constructor                   -- see Note [Promotions (HsTyVar)]                   -- See Note [Located RdrNames] in GHC.Hs.Expr@@ -858,7 +839,7 @@                         (LHsKind pass)    | HsFunTy             (XFunTy pass)-                        (HsArrow pass)+                        (HsMultAnn pass) -- multiplicty annotations, includes the arrow                         (LHsType pass)   -- function type                         (LHsType pass) @@ -875,7 +856,7 @@   | HsOpTy              (XOpTy pass)                         PromotionFlag    -- Whether explicitly promoted,                                          -- for the pretty printer-                        (LHsType pass) (LIdP pass) (LHsType pass)+                        (LHsType pass) (LIdOccP pass) (LHsType pass)    | HsParTy             (XParTy pass)                         (LHsType pass)   -- See Note [Parens in HsSyn] in GHC.Hs.Expr@@ -906,12 +887,6 @@   | HsDocTy             (XDocTy pass)                         (LHsType pass) (LHsDoc pass) -- A documented type -  | HsBangTy    (XBangTy pass)          -- Contains the SourceText in GHC passes.-                HsBang (LHsType pass)   -- Bang-style type annotations--  | HsRecTy     (XRecTy pass)-                [LConDeclField pass]    -- Only in data type declarations-   | HsExplicitListTy       -- A promoted explicit list         (XExplicitListTy pass)         PromotionFlag      -- whether explicitly promoted, for pretty printer@@ -939,38 +914,31 @@   | HsCharTy (XCharTy pass) Char   | XTyLit   !(XXTyLit pass) -type HsArrow pass = HsArrowOf (LHsType pass) pass+type HsMultAnn pass = HsMultAnnOf (LHsType (NoGhcTc pass)) pass --- | Denotes the type of arrows in the surface language-data HsArrowOf mult pass-  = HsUnrestrictedArrow !(XUnrestrictedArrow mult pass)-    -- ^ a -> b or a → b+-- | Denotes multiplicity annotations in the surface language.+-- The `mult` type argument is usually `LHsType (NoGhcTc pass)`, but when the annotation+-- is part of a type used in a term, it is `LHsExpr pass`. See Note [Types in terms].+data HsMultAnnOf mult pass+  = HsUnannotated !(XUnannotated mult pass)+    -- ^ a -> b or a → b or { nm :: a } -  | HsLinearArrow !(XLinearArrow mult pass)-    -- ^ a %1 -> b or a %1 → b, or a ⊸ b+  | HsLinearAnn !(XLinearAnn mult pass)+    -- ^ a %1 -> b or a %1 → b, or a ⊸ b, or { nm %1 :: a }    | HsExplicitMult !(XExplicitMult mult pass) !mult-    -- ^ a %m -> b or a %m → b (very much including `a %Many -> b`!+    -- ^ a %m -> b or a %m → b or { nm %m :: a }+    -- (very much including `a %Many -> b`!     -- This is how the programmer wrote it). It is stored as an     -- `HsType` so as to preserve the syntax as written in the     -- program. -  | XArrow !(XXArrow mult pass)--type family XUnrestrictedArrow mult p-type family XLinearArrow       mult p-type family XExplicitMult      mult p-type family XXArrow            mult p---- | This is used in the syntax. In constructor declaration. It must keep the--- arrow representation.-data HsScaled pass a = HsScaled (HsArrow pass) a--hsMult :: HsScaled pass a -> HsArrow pass-hsMult (HsScaled m _) = m+  | XMultAnnOf !(XXMultAnnOf mult pass) -hsScaledThing :: HsScaled pass a -> a-hsScaledThing (HsScaled _ t) = t+type family XUnannotated  mult p+type family XLinearAnn    mult p+type family XExplicitMult mult p+type family XXMultAnnOf   mult p  {- Note [Unit tuples]@@ -1067,17 +1035,16 @@                  | HsBoxedOrConstraintTuple                  deriving Data --- | Located Constructor Declaration Field-type LConDeclField pass = XRec pass (ConDeclField pass)+-- | Located Constructor Declaration Record Field+type LHsConDeclRecField pass = XRec pass (HsConDeclRecField pass) --- | Constructor Declaration Field-data ConDeclField pass  -- Record fields have Haddock docs on them-  = ConDeclField { cd_fld_ext  :: XConDeclField pass,-                   cd_fld_names :: [LFieldOcc pass],-                                   -- ^ See Note [ConDeclField pass]-                   cd_fld_type :: LBangType pass,-                   cd_fld_doc  :: Maybe (LHsDoc pass)}-  | XConDeclField !(XXConDeclField pass)+-- | Constructor Declaration Record Field+data HsConDeclRecField pass+  = HsConDeclRecField { cdrf_ext  :: XConDeclRecField pass,+                        cdrf_names :: [LFieldOcc pass],+                                        -- ^ See Note [FieldOcc pass]+                        cdrf_spec :: HsConDeclField pass }+  | XConDeclRecField !(XXConDeclRecField pass)  -- | Describes the arguments to a data constructor. This is a common -- representation for several constructor-related concepts, including:@@ -1095,35 +1062,56 @@ -- a separate data type entirely (see 'HsConDeclGADTDetails' in -- "GHC.Hs.Decls"). This is because GADT constructors cannot be declared with -- infix syntax, unlike the concepts above (#18844).-data HsConDetails tyarg arg rec-  = PrefixCon [tyarg] [arg]     -- C @t1 @t2 p1 p2 p3+data HsConDetails arg rec+  = PrefixCon [arg]             -- C @t1 @t2 p1 p2 p3   | RecCon    rec               -- C { x = p1, y = p2 }   | InfixCon  arg arg           -- p1 `C` p2   deriving Data --- | An empty list that can be used to indicate that there are no--- type arguments allowed in cases where HsConDetails is applied to Void.-noTypeArgs :: [Void]-noTypeArgs = []+-- | Constructor declaration field specification, see Note [HsConDeclField on pass]+data HsConDeclField pass+  = CDF { cdf_ext          :: XConDeclField pass+          -- ^ Extension point -{--Note [ConDeclField pass]-~~~~~~~~~~~~~~~~~~~~~~~~~+        , cdf_unpack       :: SrcUnpackedness+          -- ^ UNPACK pragma if any+          -- E.g. data T = MkT {-# UNPACK #-} Int+          --   or data T where MtT :: {-# UNPACK #-} Int -> T -A ConDeclField contains a list of field occurrences: these always-include the field label as the user wrote it.  After the renamer, it-will additionally contain the identity of the selector function in the-second component.+        , cdf_bang         :: SrcStrictness+          -- ^ User-specified strictness, if any+          -- E.g. data T a = MkT !a+          --   or data T a where MtT :: !a -> T a -Due to DuplicateRecordFields, the OccName of the selector function-may have been mangled, which is why we keep the original field label-separately.  For example, when DuplicateRecordFields is enabled+        , cdf_multiplicity :: HsMultAnn pass+          -- ^ User-specified multiplicity, if any+          -- E.g. data T a = MkT { t %Many :: a }+          --   or data T a where MtT :: a %1 -> T a -    data T = MkT { x :: Int }+        , cdf_type         :: LHsType pass+          -- ^ The type of the field -gives+        , cdf_doc          :: Maybe (LHsDoc pass)+          -- ^ Documentation for the field+          -- F.e. this very piece of documentation+        } -    ConDeclField { cd_fld_names = [L _ (FieldOcc "x" $sel:x:MkT)], ... }.+{- Note [HsConDeclField on pass]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+`HsConDeclField` is used to specify the type of a data single constructor argument for all of:+* Haskell-98 style declarations (with prefix, infix or record syntax)+  e.g.  data T1 a = MkT (Maybe a) !Int+* GADT-style declarations with arrow syntax+  e.g.  data T2 a where MkT :: Maybe a -> !Int -> T2 a+* GADT-style declarations with record syntax+  e.g.  data T3 a where MkT :: { x :: Maybe a, y :: !Int } -> T3 a++Each argument type is decorated with any user-defined+  a) UNPACK pragma `cdf_unpack`+  b) strictness annotation `cdf_bang`+  c) multiplicity annotation `cdf_multiplicity`+     In the case of Haskell-98 style declarations, this only applies to record syntax.+  d) documentation `cdf_doc` -}  -----------------------@@ -1271,13 +1259,13 @@ -- | Field Occurrence -- -- Represents an *occurrence* of a field. This may or may not be a--- binding occurrence (e.g. this type is used in 'ConDeclField' and+-- binding occurrence (e.g. this type is used in 'HsConDeclRecField' and -- 'RecordPatSynField' which bind their fields, but also in -- 'HsRecField' for record construction and patterns, which do not). -- -- We store both the 'RdrName' the user originally wrote, and after -- the renamer we use the extension field to store the selector--- function.+-- function. See note [FieldOcc pass] -- -- There is a wrinkle in that update field occurances are sometimes -- ambiguous during the rename stage. See note@@ -1294,6 +1282,23 @@   , Eq (XCFieldOcc pass)   , Eq (XXFieldOcc pass)   ) => Eq (FieldOcc pass)++{- Note [FieldOcc pass]+~~~~~~~~~~~~~~~~~~~~~~~~~+The foLabel field of FieldOcc GhcRn contains the field name as the user wrote it.+After the renamer, a FieldOcc GhcTc has+- foExt field: A RdrName containing the original field label written by the user+- foLabel field: An Id for the field selector, whose OccName may have been mangled+  to give it a globally unique identity.++For example, when DuplicateRecordFields is enabled++    data T = MkT { x :: Int }++gives++    FieldOcc "x" $sel:x:MkT.+-}  {- ************************************************************************
compiler/Language/Haskell/Syntax/Type.hs-boot view
@@ -4,6 +4,8 @@ import Data.Eq import Data.Ord +import Control.DeepSeq+ {- ************************************************************************ *                                                                      *@@ -19,5 +21,6 @@  instance Eq PromotionFlag instance Ord PromotionFlag+instance NFData PromotionFlag  isPromoted :: PromotionFlag -> Bool
compiler/MachRegs.h view
@@ -222,7 +222,7 @@ /* define NO_ARG_REGS if we have no argument registers at all (we can  * optimise certain code paths using this predicate).  */-#if MAX_REAL_VANILLA_REG < 2+#if MAX_REAL_VANILLA_REG < 2 && MAX_REAL_XMM_REG == 0 #define NO_ARG_REGS #else #undef NO_ARG_REGS
compiler/cbits/genSym.c view
@@ -24,6 +24,3 @@ #if !defined(HAVE_UNIQUE64) HsWord64 ghc_unique_counter64 = 0; #endif-#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)-HsInt ghc_unique_inc     = 1;-#endif
compiler/ghc.cabal view
@@ -3,7 +3,7 @@ -- ./configure.  Make sure you are editing ghc.cabal.in, not ghc.cabal.  Name: ghc-Version: 9.12.3+Version: 9.14.1 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team@@ -50,7 +50,7 @@   custom-setup-    setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.10, directory, process, filepath, containers+    setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.14, directory, process, filepath, containers  Flag internal-interpreter     Description: Build with internal interpreter support.@@ -114,14 +114,14 @@         extra-libraries: zstd       CPP-Options: -DHAVE_LIBZSTD -    Build-Depends: base       >= 4.11 && < 4.22,+    Build-Depends: base       >= 4.11 && < 4.23,                    deepseq    >= 1.4 && < 1.6,                    directory  >= 1   && < 1.4,                    process    >= 1   && < 1.7,                    bytestring >= 0.11 && < 0.13,                    binary     == 0.8.*,-                   time       >= 1.4 && < 1.15,-                   containers >= 0.6.2.1 && < 0.8,+                   time       >= 1.4 && < 1.16,+                   containers >= 0.6.2.1 && < 0.9,                    array      >= 0.1 && < 0.6,                    filepath   >= 1.5 && < 1.6,                    os-string  >= 2.0.1 && < 2.1,@@ -130,16 +130,18 @@                    exceptions == 0.10.*,                    semaphore-compat,                    stm,-                   ghc-boot   == 9.12.3,-                   ghc-heap   == 9.12.3,-                   ghci == 9.12.3+                   rts,+                   ghc-boot   == 9.14.1,+                   ghc-heap   >=9.10.1 && <=9.14.1,+                   ghci == 9.14.1      if flag(bootstrap)       Build-Depends:-        ghc-boot-th-next     == 9.12.3+        ghc-boot-th-next     == 9.14.1     else       Build-Depends:-        ghc-boot-th          == 9.12.3+        ghc-boot-th          == 9.14.1,+        ghc-internal         == 9.1401.0,      if os(windows)         Build-Depends: Win32  >= 2.3 && < 2.15@@ -222,6 +224,7 @@         GHC.Builtin.Uniques         GHC.Builtin.Utils         GHC.ByteCode.Asm+        GHC.ByteCode.Breakpoints         GHC.ByteCode.InfoTable         GHC.ByteCode.Instr         GHC.ByteCode.Linker@@ -282,6 +285,13 @@         GHC.CmmToAsm.Dwarf.Types         GHC.CmmToAsm.Format         GHC.CmmToAsm.Instr+        GHC.CmmToAsm.LA64+        GHC.CmmToAsm.LA64.CodeGen+        GHC.CmmToAsm.LA64.Cond+        GHC.CmmToAsm.LA64.Instr+        GHC.CmmToAsm.LA64.Ppr+        GHC.CmmToAsm.LA64.RegInfo+        GHC.CmmToAsm.LA64.Regs         GHC.CmmToAsm.Monad         GHC.CmmToAsm.PIC         GHC.CmmToAsm.PPC@@ -306,6 +316,7 @@         GHC.CmmToAsm.Reg.Linear.Base         GHC.CmmToAsm.Reg.Linear.FreeRegs         GHC.CmmToAsm.Reg.Linear.JoinToTargets+        GHC.CmmToAsm.Reg.Linear.LA64         GHC.CmmToAsm.Reg.Linear.PPC         GHC.CmmToAsm.Reg.Linear.RV64         GHC.CmmToAsm.Reg.Linear.StackMap@@ -413,6 +424,7 @@         GHC.CoreToIface         GHC.CoreToStg         GHC.CoreToStg.Prep+        GHC.CoreToStg.AddImplicitBinds         GHC.Core.TyCo.FVs         GHC.Core.TyCo.Compare         GHC.Core.TyCon@@ -444,13 +456,17 @@         GHC.Data.Graph.Color         GHC.Data.Graph.Collapse         GHC.Data.Graph.Directed+        GHC.Data.Graph.Directed.Internal+        GHC.Data.Graph.Directed.Reachability         GHC.Data.Graph.Inductive.Graph         GHC.Data.Graph.Inductive.PatriciaTree         GHC.Data.Graph.Ops         GHC.Data.Graph.Ppr         GHC.Data.Graph.UnVar         GHC.Data.IOEnv+        GHC.Data.List         GHC.Data.List.Infinite+        GHC.Data.List.NonEmpty         GHC.Data.List.SetOps         GHC.Data.Maybe         GHC.Data.OrdList@@ -506,6 +522,8 @@         GHC.Driver.Config.Tidy         GHC.Driver.Config.StgToJS         GHC.Driver.DynFlags+        GHC.Driver.IncludeSpecs+        GHC.Driver.Downsweep         GHC.Driver.Env         GHC.Driver.Env.KnotVars         GHC.Driver.Env.Types@@ -519,6 +537,8 @@         GHC.Driver.MakeSem         GHC.Driver.Main         GHC.Driver.Make+        GHC.Driver.Messager+        GHC.Driver.MakeAction         GHC.Driver.MakeFile         GHC.Driver.Monad         GHC.Driver.Phases@@ -531,6 +551,8 @@         GHC.Driver.Plugins.External         GHC.Driver.Ppr         GHC.Driver.Session+        GHC.Driver.Session.Inspect+        GHC.Driver.Session.Units         GHC.Hs         GHC.Hs.Basic         GHC.Hs.Binds@@ -601,8 +623,10 @@         GHC.Iface.Recomp         GHC.Iface.Recomp.Binary         GHC.Iface.Recomp.Flags+        GHC.Iface.Recomp.Types         GHC.Iface.Rename         GHC.Iface.Syntax+        GHC.Iface.Flags         GHC.Iface.Tidy         GHC.Iface.Tidy.StaticPtrTable         GHC.Iface.Warnings@@ -655,7 +679,7 @@         GHC.Platform.ARM         GHC.Platform.AArch64         GHC.Platform.Constants-        GHC.Platform.LoongArch64+        GHC.Platform.LA64         GHC.Platform.NoRegs         GHC.Platform.PPC         GHC.Platform.Profile@@ -688,14 +712,17 @@         GHC.Rename.Utils         GHC.Runtime.Context         GHC.Runtime.Debugger+        GHC.Runtime.Debugger.Breakpoints         GHC.Runtime.Eval         GHC.Runtime.Eval.Types+        GHC.Runtime.Eval.Utils         GHC.Runtime.Heap.Inspect         GHC.Runtime.Heap.Layout         GHC.Runtime.Interpreter         GHC.Runtime.Interpreter.JS         GHC.Runtime.Interpreter.Process         GHC.Runtime.Interpreter.Types+        GHC.Runtime.Interpreter.Types.SymbolCache         GHC.Runtime.Interpreter.Wasm         GHC.Runtime.Loader         GHC.Runtime.Utils@@ -706,6 +733,10 @@         GHC.Stg.BcPrep         GHC.Stg.CSE         GHC.Stg.Debug+        GHC.Stg.EnforceEpt+        GHC.Stg.EnforceEpt.Rewrite+        GHC.Stg.EnforceEpt.TagSig+        GHC.Stg.EnforceEpt.Types         GHC.Stg.FVs         GHC.Stg.Lift         GHC.Stg.Lift.Analysis@@ -713,10 +744,6 @@         GHC.Stg.Lift.Monad         GHC.Stg.Lift.Types         GHC.Stg.Lint-        GHC.Stg.InferTags-        GHC.Stg.InferTags.Rewrite-        GHC.Stg.InferTags.TagSig-        GHC.Stg.InferTags.Types         GHC.Stg.Make         GHC.Stg.Pipeline         GHC.Stg.Stats@@ -768,7 +795,9 @@         GHC.StgToJS.Regs         GHC.StgToJS.Rts.Types         GHC.StgToJS.Rts.Rts-        GHC.StgToJS.Sinker+        GHC.StgToJS.Sinker.Collect+        GHC.StgToJS.Sinker.StringsUnfloat+        GHC.StgToJS.Sinker.Sinker         GHC.StgToJS.Stack         GHC.StgToJS.StaticPtr         GHC.StgToJS.Symbols@@ -813,7 +842,6 @@         GHC.Tc.Gen.HsType         GHC.Tc.Gen.Match         GHC.Tc.Gen.Pat-        GHC.Tc.Gen.Rule         GHC.Tc.Gen.Sig         GHC.Tc.Gen.Splice         GHC.Tc.Instance.Class@@ -823,6 +851,7 @@         GHC.Tc.Module         GHC.Tc.Plugin         GHC.Tc.Solver+        GHC.Tc.Solver.Default         GHC.Tc.Solver.Rewrite         GHC.Tc.Solver.InertSet         GHC.Tc.Solver.Solve@@ -840,7 +869,6 @@         GHC.Tc.Types         GHC.Tc.Types.Constraint         GHC.Tc.Types.Evidence-        GHC.Tc.Types.EvTerm         GHC.Tc.Types.Origin         GHC.Tc.Types.Rank         GHC.Tc.Types.CtLoc@@ -866,7 +894,6 @@         GHC.Types.Annotations         GHC.Types.Avail         GHC.Types.Basic-        GHC.Types.Breakpoint         GHC.Types.CompleteMatch         GHC.Types.CostCentre         GHC.Types.CostCentre.State@@ -886,6 +913,7 @@         GHC.Types.HpcInfo         GHC.Types.Id         GHC.Types.IPE+        GHC.Types.ThLevelIndex         GHC.Types.Id.Info         GHC.Types.Id.Make         GHC.Types.Literal@@ -931,12 +959,16 @@         GHC.Unit.Finder         GHC.Unit.Finder.Types         GHC.Unit.Home+        GHC.Unit.Home.Graph         GHC.Unit.Home.ModInfo+        GHC.Unit.Home.PackageTable         GHC.Unit.Info         GHC.Unit.Module         GHC.Unit.Module.Deps         GHC.Unit.Module.Env         GHC.Unit.Module.Graph+        GHC.Unit.Module.ModNodeKey+        GHC.Unit.Module.Stage         GHC.Unit.Module.Imported         GHC.Unit.Module.Location         GHC.Unit.Module.ModDetails@@ -992,10 +1024,12 @@         Language.Haskell.Syntax         Language.Haskell.Syntax.Basic         Language.Haskell.Syntax.Binds+        Language.Haskell.Syntax.BooleanFormula         Language.Haskell.Syntax.Decls         Language.Haskell.Syntax.Expr         Language.Haskell.Syntax.Extension         Language.Haskell.Syntax.ImpExp+        Language.Haskell.Syntax.ImpExp.IsBoot         Language.Haskell.Syntax.Lit         Language.Haskell.Syntax.Module.Name         Language.Haskell.Syntax.Pat
ghc-lib-parser.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: ghc-lib-parser-version: 9.12.3.20251228+version: 9.14.1.20251220 license: BSD-3-Clause license-file: LICENSE category: Development@@ -47,6 +47,8 @@     ghc-lib/stage0/compiler/build/primop-is-cheap.hs-incl     ghc-lib/stage0/compiler/build/primop-deprecations.hs-incl     ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs+    ghc-lib/stage0/libraries/ghc-internal/build/GHC/Internal/Prim.hs+    ghc-lib/stage0/libraries/ghc-internal/build/GHC/Internal/PrimopWrappers.hs     ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs     ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs     ghc-lib/stage0/libraries/ghc-boot/build/GHC/Platform/Host.hs@@ -90,28 +92,22 @@     if impl(ghc >= 8.8.1)         ghc-options: -fno-safe-haskell     if flag(threaded-rts)-        if impl(ghc < 9.12.3)-            ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS-        else-            ghc-options: -fobject-code -optc-DTHREADED_RTS+        ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS         cc-options: -DTHREADED_RTS         cpp-options: -DTHREADED_RTS   -DBOOTSTRAP_TH     else-        if impl(ghc < 9.12.3)-           ghc-options: -fobject-code -package=ghc-boot-th-        else-           ghc-options: -fobject-code+        ghc-options: -fobject-code -package=ghc-boot-th         cpp-options:   -DBOOTSTRAP_TH     if !os(windows)         build-depends: unix     else         build-depends: Win32     build-depends:-        base >= 4.19 && < 4.22,+        base >= 4.20 && < 4.23,         ghc-prim > 0.2 && < 0.14,-        containers >= 0.6.2.1 && < 0.8,+        containers >= 0.6.2.1 && < 0.9,         bytestring >= 0.11.4 && < 0.13,-        time >= 1.4 && < 1.15,+        time >= 1.4 && < 1.16,         filepath >= 1.5 && < 1.6,         hpc >= 0.6 && < 0.8,         os-string >= 2.0.1 && < 2.1,@@ -165,15 +161,16 @@         NoImplicitPrelude     if impl(ghc >= 9.2.2)       cmm-sources:-            libraries/ghc-heap/cbits/HeapPrim.cmm+            libraries/ghc-internal/cbits/HeapPrim.cmm     else       c-sources:-            libraries/ghc-heap/cbits/HeapPrim.cmm+            libraries/ghc-internal/cbits/HeapPrim.cmm     c-sources:         compiler/cbits/genSym.c         compiler/cbits/cutils.c         compiler/cbits/keepCAFsForGHCi.c     hs-source-dirs:+        ghc-lib/stage0/libraries/ghc-internal/build         ghc-lib/stage0/libraries/ghc-boot/build         ghc-lib/stage0/compiler/build         libraries/ghc-internal/src@@ -195,12 +192,15 @@         GHC.Boot.TH.PprLib         GHC.Boot.TH.Syntax         GHC.Builtin.Names+        GHC.Builtin.Names.TH         GHC.Builtin.PrimOps         GHC.Builtin.PrimOps.Ids         GHC.Builtin.Types         GHC.Builtin.Types.Literals         GHC.Builtin.Types.Prim         GHC.Builtin.Uniques+        GHC.Builtin.Utils+        GHC.ByteCode.Breakpoints         GHC.ByteCode.Types         GHC.Cmm         GHC.Cmm.BlockId@@ -288,9 +288,13 @@         GHC.Data.FiniteMap         GHC.Data.FlatBag         GHC.Data.Graph.Directed+        GHC.Data.Graph.Directed.Internal+        GHC.Data.Graph.Directed.Reachability         GHC.Data.Graph.UnVar         GHC.Data.IOEnv+        GHC.Data.List         GHC.Data.List.Infinite+        GHC.Data.List.NonEmpty         GHC.Data.List.SetOps         GHC.Data.Maybe         GHC.Data.OrdList@@ -329,6 +333,7 @@         GHC.Driver.Errors.Types         GHC.Driver.Flags         GHC.Driver.Hooks+        GHC.Driver.IncludeSpecs         GHC.Driver.LlvmConfigCache         GHC.Driver.Monad         GHC.Driver.Phases@@ -371,19 +376,29 @@         GHC.Hs.Specificity         GHC.Hs.Type         GHC.Hs.Utils+        GHC.HsToCore.Breakpoints         GHC.HsToCore.Errors.Ppr         GHC.HsToCore.Errors.Types         GHC.HsToCore.Pmc.Ppr         GHC.HsToCore.Pmc.Solver.Types         GHC.HsToCore.Pmc.Types+        GHC.HsToCore.Ticks         GHC.Iface.Decl         GHC.Iface.Errors.Ppr         GHC.Iface.Errors.Types         GHC.Iface.Ext.Fields+        GHC.Iface.Flags         GHC.Iface.Recomp.Binary+        GHC.Iface.Recomp.Types         GHC.Iface.Syntax         GHC.Iface.Type         GHC.Internal.ForeignSrcLang+        GHC.Internal.Heap.Closures+        GHC.Internal.Heap.Constants+        GHC.Internal.Heap.InfoTable+        GHC.Internal.Heap.InfoTable.Types+        GHC.Internal.Heap.InfoTableProf+        GHC.Internal.Heap.ProfInfo.Types         GHC.Internal.LanguageExtensions         GHC.Internal.Lexeme         GHC.Internal.TH.Syntax@@ -420,7 +435,7 @@         GHC.Platform.ARM         GHC.Platform.ArchOS         GHC.Platform.Constants-        GHC.Platform.LoongArch64+        GHC.Platform.LA64         GHC.Platform.NoRegs         GHC.Platform.PPC         GHC.Platform.Profile@@ -442,12 +457,13 @@         GHC.Runtime.Eval.Types         GHC.Runtime.Heap.Layout         GHC.Runtime.Interpreter.Types+        GHC.Runtime.Interpreter.Types.SymbolCache         GHC.Serialized         GHC.Settings         GHC.Settings.Config         GHC.Settings.Constants         GHC.Settings.Utils-        GHC.Stg.InferTags.TagSig+        GHC.Stg.EnforceEpt.TagSig         GHC.Stg.Lift.Types         GHC.Stg.Syntax         GHC.StgToCmm.CgUtils@@ -482,7 +498,6 @@         GHC.Types.Annotations         GHC.Types.Avail         GHC.Types.Basic-        GHC.Types.Breakpoint         GHC.Types.CompleteMatch         GHC.Types.CostCentre         GHC.Types.CostCentre.State@@ -524,6 +539,7 @@         GHC.Types.SptEntry         GHC.Types.SrcLoc         GHC.Types.Target+        GHC.Types.ThLevelIndex         GHC.Types.Tickish         GHC.Types.TyThing         GHC.Types.TyThing.Ppr@@ -547,7 +563,9 @@         GHC.Unit.External         GHC.Unit.Finder.Types         GHC.Unit.Home+        GHC.Unit.Home.Graph         GHC.Unit.Home.ModInfo+        GHC.Unit.Home.PackageTable         GHC.Unit.Info         GHC.Unit.Module         GHC.Unit.Module.Deps@@ -558,7 +576,9 @@         GHC.Unit.Module.ModDetails         GHC.Unit.Module.ModGuts         GHC.Unit.Module.ModIface+        GHC.Unit.Module.ModNodeKey         GHC.Unit.Module.ModSummary+        GHC.Unit.Module.Stage         GHC.Unit.Module.Status         GHC.Unit.Module.Warnings         GHC.Unit.Module.WholeCoreBindings@@ -605,10 +625,12 @@         Language.Haskell.Syntax         Language.Haskell.Syntax.Basic         Language.Haskell.Syntax.Binds+        Language.Haskell.Syntax.BooleanFormula         Language.Haskell.Syntax.Decls         Language.Haskell.Syntax.Expr         Language.Haskell.Syntax.Extension         Language.Haskell.Syntax.ImpExp+        Language.Haskell.Syntax.ImpExp.IsBoot         Language.Haskell.Syntax.Lit         Language.Haskell.Syntax.Module.Name         Language.Haskell.Syntax.Pat
ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs view
@@ -84,6 +84,7 @@       pc_OFFSET_StgEntCounter_entry_count :: {-# UNPACK #-} !Int,       pc_SIZEOF_StgUpdateFrame_NoHdr :: {-# UNPACK #-} !Int,       pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr :: {-# UNPACK #-} !Int,+      pc_SIZEOF_StgAnnFrame_NoHdr :: {-# UNPACK #-} !Int,       pc_SIZEOF_StgMutArrPtrs_NoHdr :: {-# UNPACK #-} !Int,       pc_OFFSET_StgMutArrPtrs_ptrs :: {-# UNPACK #-} !Int,       pc_OFFSET_StgMutArrPtrs_size :: {-# UNPACK #-} !Int,@@ -168,7 +169,7 @@      ,v80,v81,v82,v83,v84,v85,v86,v87,v88,v89,v90,v91,v92,v93,v94,v95      ,v96,v97,v98,v99,v100,v101,v102,v103,v104,v105,v106,v107,v108,v109,v110,v111      ,v112,v113,v114,v115,v116,v117,v118,v119,v120,v121,v122,v123,v124,v125,v126,v127-     ,v128,v129,v130+     ,v128,v129,v130,v131      ] -> PlatformConstants             { pc_CONTROL_GROUP_CONST_291 = fromIntegral v0             , pc_STD_HDR_SIZE = fromIntegral v1@@ -250,57 +251,58 @@             , pc_OFFSET_StgEntCounter_entry_count = fromIntegral v77             , pc_SIZEOF_StgUpdateFrame_NoHdr = fromIntegral v78             , pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr = fromIntegral v79-            , pc_SIZEOF_StgMutArrPtrs_NoHdr = fromIntegral v80-            , pc_OFFSET_StgMutArrPtrs_ptrs = fromIntegral v81-            , pc_OFFSET_StgMutArrPtrs_size = fromIntegral v82-            , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = fromIntegral v83-            , pc_OFFSET_StgSmallMutArrPtrs_ptrs = fromIntegral v84-            , pc_SIZEOF_StgArrBytes_NoHdr = fromIntegral v85-            , pc_OFFSET_StgArrBytes_bytes = fromIntegral v86-            , pc_OFFSET_StgTSO_alloc_limit = fromIntegral v87-            , pc_OFFSET_StgTSO_cccs = fromIntegral v88-            , pc_OFFSET_StgTSO_stackobj = fromIntegral v89-            , pc_OFFSET_StgStack_sp = fromIntegral v90-            , pc_OFFSET_StgStack_stack = fromIntegral v91-            , pc_OFFSET_StgUpdateFrame_updatee = fromIntegral v92-            , pc_OFFSET_StgOrigThunkInfoFrame_info_ptr = fromIntegral v93-            , pc_OFFSET_StgFunInfoExtraFwd_arity = fromIntegral v94-            , pc_REP_StgFunInfoExtraFwd_arity = fromIntegral v95-            , pc_SIZEOF_StgFunInfoExtraRev = fromIntegral v96-            , pc_OFFSET_StgFunInfoExtraRev_arity = fromIntegral v97-            , pc_REP_StgFunInfoExtraRev_arity = fromIntegral v98-            , pc_MAX_SPEC_SELECTEE_SIZE = fromIntegral v99-            , pc_MAX_SPEC_AP_SIZE = fromIntegral v100-            , pc_MIN_PAYLOAD_SIZE = fromIntegral v101-            , pc_MIN_INTLIKE = fromIntegral v102-            , pc_MAX_INTLIKE = fromIntegral v103-            , pc_MIN_CHARLIKE = fromIntegral v104-            , pc_MAX_CHARLIKE = fromIntegral v105-            , pc_MUT_ARR_PTRS_CARD_BITS = fromIntegral v106-            , pc_MAX_Vanilla_REG = fromIntegral v107-            , pc_MAX_Float_REG = fromIntegral v108-            , pc_MAX_Double_REG = fromIntegral v109-            , pc_MAX_Long_REG = fromIntegral v110-            , pc_MAX_XMM_REG = fromIntegral v111-            , pc_MAX_Real_Vanilla_REG = fromIntegral v112-            , pc_MAX_Real_Float_REG = fromIntegral v113-            , pc_MAX_Real_Double_REG = fromIntegral v114-            , pc_MAX_Real_XMM_REG = fromIntegral v115-            , pc_MAX_Real_Long_REG = fromIntegral v116-            , pc_RESERVED_C_STACK_BYTES = fromIntegral v117-            , pc_RESERVED_STACK_WORDS = fromIntegral v118-            , pc_AP_STACK_SPLIM = fromIntegral v119-            , pc_WORD_SIZE = fromIntegral v120-            , pc_CINT_SIZE = fromIntegral v121-            , pc_CLONG_SIZE = fromIntegral v122-            , pc_CLONG_LONG_SIZE = fromIntegral v123-            , pc_BITMAP_BITS_SHIFT = fromIntegral v124-            , pc_TAG_BITS = fromIntegral v125-            , pc_LDV_SHIFT = fromIntegral v126-            , pc_ILDV_CREATE_MASK = v127-            , pc_ILDV_STATE_CREATE = v128-            , pc_ILDV_STATE_USE = v129-            , pc_USE_INLINE_SRT_FIELD = 0 < v130+            , pc_SIZEOF_StgAnnFrame_NoHdr = fromIntegral v80+            , pc_SIZEOF_StgMutArrPtrs_NoHdr = fromIntegral v81+            , pc_OFFSET_StgMutArrPtrs_ptrs = fromIntegral v82+            , pc_OFFSET_StgMutArrPtrs_size = fromIntegral v83+            , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = fromIntegral v84+            , pc_OFFSET_StgSmallMutArrPtrs_ptrs = fromIntegral v85+            , pc_SIZEOF_StgArrBytes_NoHdr = fromIntegral v86+            , pc_OFFSET_StgArrBytes_bytes = fromIntegral v87+            , pc_OFFSET_StgTSO_alloc_limit = fromIntegral v88+            , pc_OFFSET_StgTSO_cccs = fromIntegral v89+            , pc_OFFSET_StgTSO_stackobj = fromIntegral v90+            , pc_OFFSET_StgStack_sp = fromIntegral v91+            , pc_OFFSET_StgStack_stack = fromIntegral v92+            , pc_OFFSET_StgUpdateFrame_updatee = fromIntegral v93+            , pc_OFFSET_StgOrigThunkInfoFrame_info_ptr = fromIntegral v94+            , pc_OFFSET_StgFunInfoExtraFwd_arity = fromIntegral v95+            , pc_REP_StgFunInfoExtraFwd_arity = fromIntegral v96+            , pc_SIZEOF_StgFunInfoExtraRev = fromIntegral v97+            , pc_OFFSET_StgFunInfoExtraRev_arity = fromIntegral v98+            , pc_REP_StgFunInfoExtraRev_arity = fromIntegral v99+            , pc_MAX_SPEC_SELECTEE_SIZE = fromIntegral v100+            , pc_MAX_SPEC_AP_SIZE = fromIntegral v101+            , pc_MIN_PAYLOAD_SIZE = fromIntegral v102+            , pc_MIN_INTLIKE = fromIntegral v103+            , pc_MAX_INTLIKE = fromIntegral v104+            , pc_MIN_CHARLIKE = fromIntegral v105+            , pc_MAX_CHARLIKE = fromIntegral v106+            , pc_MUT_ARR_PTRS_CARD_BITS = fromIntegral v107+            , pc_MAX_Vanilla_REG = fromIntegral v108+            , pc_MAX_Float_REG = fromIntegral v109+            , pc_MAX_Double_REG = fromIntegral v110+            , pc_MAX_Long_REG = fromIntegral v111+            , pc_MAX_XMM_REG = fromIntegral v112+            , pc_MAX_Real_Vanilla_REG = fromIntegral v113+            , pc_MAX_Real_Float_REG = fromIntegral v114+            , pc_MAX_Real_Double_REG = fromIntegral v115+            , pc_MAX_Real_XMM_REG = fromIntegral v116+            , pc_MAX_Real_Long_REG = fromIntegral v117+            , pc_RESERVED_C_STACK_BYTES = fromIntegral v118+            , pc_RESERVED_STACK_WORDS = fromIntegral v119+            , pc_AP_STACK_SPLIM = fromIntegral v120+            , pc_WORD_SIZE = fromIntegral v121+            , pc_CINT_SIZE = fromIntegral v122+            , pc_CLONG_SIZE = fromIntegral v123+            , pc_CLONG_LONG_SIZE = fromIntegral v124+            , pc_BITMAP_BITS_SHIFT = fromIntegral v125+            , pc_TAG_BITS = fromIntegral v126+            , pc_LDV_SHIFT = fromIntegral v127+            , pc_ILDV_CREATE_MASK = v128+            , pc_ILDV_STATE_CREATE = v129+            , pc_ILDV_STATE_USE = v130+            , pc_USE_INLINE_SRT_FIELD = 0 < v131             }     _ -> error "Invalid platform constants" 
ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs view
@@ -6,6 +6,7 @@   , cBooterVersion   , cStage   , cProjectUnitId+  , cGhcInternalUnitId   ) where  import GHC.Prelude.Basic@@ -22,10 +23,13 @@ cProjectName          = "The Glorious Glasgow Haskell Compilation System"  cBooterVersion        :: String-cBooterVersion        = "9.10.1"+cBooterVersion        = "9.12.1"  cStage                :: String cStage                = show (1 :: Int)  cProjectUnitId :: String-cProjectUnitId = "ghc-9.12.3-inplace"+cProjectUnitId = "ghc-9.14.1-inplace"++cGhcInternalUnitId :: String+cGhcInternalUnitId = "ghc-internal-9.1401.0-inplace"
ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl view
@@ -656,9 +656,6 @@    | ReadMVarOp    | TryReadMVarOp    | IsEmptyMVarOp-   | NewIOPortOp-   | ReadIOPortOp-   | WriteIOPortOp    | DelayOp    | WaitReadOp    | WaitWriteOp@@ -714,11 +711,13 @@    | GetCCSOfOp    | GetCurrentCCSOp    | ClearCCSOp+   | AnnotateStackOp    | WhereFromOp    | TraceEventOp    | TraceEventBinaryOp    | TraceMarkerOp    | SetThreadAllocationCounter+   | SetOtherThreadAllocationCounter    | VecBroadcastOp PrimOpVecCat Length Width    | VecPackOp PrimOpVecCat Length Width    | VecUnpackOp PrimOpVecCat Length Width
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -59,12 +59,16 @@   , (fsLit "bitReverse32#","Reverse the order of the bits in a 32-bit word.")   , (fsLit "bitReverse64#","Reverse the order of the bits in a 64-bit word.")   , (fsLit "bitReverse#","Reverse the order of the bits in a word.")+  , (fsLit "minDouble#","Return the minimum of the arguments.\n   When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@)\n   or one of the arguments is not-a-number (NaN),\n   it is unspecified which one is returned.")+  , (fsLit "maxDouble#","Return the maximum of the arguments.\n   When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@)\n   or one of the arguments is not-a-number (NaN),\n   it is unspecified which one is returned.")   , (fsLit "double2Int#","Truncates a 'Double#' value to the nearest 'Int#'.\n    Results are undefined if the truncation if truncation yields\n    a value outside the range of 'Int#'.")   , (fsLit "**##","Exponentiation.")   , (fsLit "decodeDouble_2Int#","Convert to integer.\n    First component of the result is -1 or 1, indicating the sign of the\n    mantissa. The next two are the high and low 32 bits of the mantissa\n    respectively, and the last is the exponent.")   , (fsLit "decodeDouble_Int64#","Decode 'Double#' into mantissa and base-2 exponent.")   , (fsLit "castDoubleToWord64#","Bitcast a 'Double#' into a 'Word64#'")   , (fsLit "castWord64ToDouble#","Bitcast a 'Word64#' into a 'Double#'")+  , (fsLit "minFloat#","Return the minimum of the arguments.\n   When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@)\n   or one of the arguments is not-a-number (NaN),\n   it is unspecified which one is returned.")+  , (fsLit "maxFloat#","Return the maximum of the arguments.\n   When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@)\n   or one of the arguments is not-a-number (NaN),\n   it is unspecified which one is returned.")   , (fsLit "float2Int#","Truncates a 'Float#' value to the nearest 'Int#'.\n    Results are undefined if the truncation if truncation yields\n    a value outside the range of 'Int#'.")   , (fsLit "decodeFloat_Int#","Convert to integers.\n    First 'Int#' in result is the mantissa; second is the exponent.")   , (fsLit "castFloatToWord32#","Bitcast a 'Float#' into a 'Word32#'")@@ -382,10 +386,6 @@   , (fsLit "readMVar#","If 'MVar#' is empty, block until it becomes full.\n   Then read its contents without modifying the MVar, without possibility\n   of intervention from other threads.")   , (fsLit "tryReadMVar#","If 'MVar#' is empty, immediately return with integer 0 and value undefined.\n   Otherwise, return with integer 1 and contents of 'MVar#'.")   , (fsLit "isEmptyMVar#","Return 1 if 'MVar#' is empty; 0 otherwise.")-  , (fsLit "IOPort#"," A shared I/O port is almost the same as an 'MVar#'.\n        The main difference is that IOPort has no deadlock detection or\n        deadlock breaking code that forcibly releases the lock. ")-  , (fsLit "newIOPort#","Create new 'IOPort#'; initially empty.")-  , (fsLit "readIOPort#","If 'IOPort#' is empty, block until it becomes full.\n   Then remove and return its contents, and set it empty.\n   Throws an 'IOPortException' if another thread is already\n   waiting to read this 'IOPort#'.")-  , (fsLit "writeIOPort#","If 'IOPort#' is full, immediately return with integer 0,\n    throwing an 'IOPortException'.\n    Otherwise, store value arg as 'IOPort#''s new contents,\n    and return with integer 1. ")   , (fsLit "delay#","Sleep specified number of microseconds.")   , (fsLit "waitRead#","Block until input is available on specified file descriptor.")   , (fsLit "waitWrite#","Block until output is possible on specified file descriptor.")@@ -425,6 +425,7 @@   , (fsLit "closureSize#"," @'closureSize#' closure@ returns the size of the given closure in\n     machine words. ")   , (fsLit "getCurrentCCS#"," Returns the current 'CostCentreStack' (value is @NULL@ if\n     not profiling).  Takes a dummy argument which can be used to\n     avoid the call to 'getCurrentCCS#' being floated out by the\n     simplifier, which would result in an uninformative stack\n     (\"CAF\"). ")   , (fsLit "clearCCS#"," Run the supplied IO action with an empty CCS.  For example, this\n     is used by the interpreter to run an interpreted computation\n     without the call stack showing that it was invoked from GHC. ")+  , (fsLit "annotateStack#"," Pushes an annotation frame to the stack which can be reported by backtraces. ")   , (fsLit "whereFrom#"," Fills the given buffer with the @InfoProvEnt@ for the info table of the\n     given object. Returns @1#@ on success and @0#@ otherwise.")   , (fsLit "FUN","The builtin function type, written in infix form as @a % m -> b@.\n   Values of this type are functions taking inputs of type @a@ and\n   producing outputs of type @b@. The multiplicity of the input is\n   @m@.\n\n   Note that @'FUN' m a b@ permits representation polymorphism in both\n   @a@ and @b@, so that types like @'Int#' -> 'Int#'@ can still be\n   well-kinded.\n  ")   , (fsLit "realWorld#"," The token used in the implementation of the IO monad as a state monad.\n     It does not pass any information at runtime.\n     See also 'GHC.Magic.runRW#'. ")@@ -436,6 +437,7 @@   , (fsLit "traceBinaryEvent#"," Emits an event via the RTS tracing framework.  The contents\n     of the event is the binary object passed as the first argument with\n     the given length passed as the second argument. The event will be\n     emitted to the @.eventlog@ file. ")   , (fsLit "traceMarker#"," Emits a marker event via the RTS tracing framework.  The contents\n     of the event is the zero-terminated byte string passed as the first\n     argument.  The event will be emitted either to the @.eventlog@ file,\n     or to stderr, depending on the runtime RTS flags. ")   , (fsLit "setThreadAllocationCounter#"," Sets the allocation counter for the current thread to the given value. ")+  , (fsLit "setOtherThreadAllocationCounter#"," Sets the allocation counter for the another thread to the given value.\n     This doesn't take allocations into the current nursery chunk into account.\n     Therefore it is only accurate if the other thread is not currently running. ")   , (fsLit "StackSnapshot#"," Haskell representation of a @StgStack*@ that was created (cloned)\n     with a function in \"GHC.Stack.CloneStack\". Please check the\n     documentation in that module for more detailed explanations. ")   , (fsLit "coerce"," The function 'coerce' allows you to safely convert between values of\n     types that have the same representation with no run-time overhead. In the\n     simplest case you can use it instead of a newtype constructor, to go from\n     the newtype's concrete type to the abstract type. But it also works in\n     more complicated settings, e.g. converting a list of newtypes to a list of\n     concrete types.\n\n     When used in conversions involving a newtype wrapper,\n     make sure the newtype constructor is in scope.\n\n     This function is representation-polymorphic, but the\n     'RuntimeRep' type argument is marked as 'Inferred', meaning\n     that it is not available for visible type application. This means\n     the typechecker will accept @'coerce' \\@'Int' \\@Age 42@.\n\n     === __Examples__\n\n     >>> newtype TTL = TTL Int deriving (Eq, Ord, Show)\n     >>> newtype Age = Age Int deriving (Eq, Ord, Show)\n     >>> coerce (Age 42) :: TTL\n     TTL 42\n     >>> coerce (+ (1 :: Int)) (Age 42) :: TTL\n     TTL 43\n     >>> coerce (map (+ (1 :: Int))) [Age 42, Age 24] :: [TTL]\n     [TTL 43,TTL 25]\n\n   ")   , (fsLit "broadcastInt8X16#"," Broadcast a scalar to all elements of a vector. ")@@ -498,66 +500,66 @@   , (fsLit "packDoubleX4#"," Pack the elements of an unboxed tuple into a vector. ")   , (fsLit "packFloatX16#"," Pack the elements of an unboxed tuple into a vector. ")   , (fsLit "packDoubleX8#"," Pack the elements of an unboxed tuple into a vector. ")-  , (fsLit "unpackInt8X16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt16X8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt32X4#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt64X2#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt8X32#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt16X16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt32X8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt64X4#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt8X64#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt16X32#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt32X16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt64X8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord8X16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord16X8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord32X4#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord64X2#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord8X32#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord16X16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord32X8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord64X4#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord8X64#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord16X32#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord32X16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord64X8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackFloatX4#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackDoubleX2#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackFloatX8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackDoubleX4#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackFloatX16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackDoubleX8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "insertInt8X16#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt16X8#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt32X4#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt64X2#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt8X32#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt16X16#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt32X8#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt64X4#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt8X64#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt16X32#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt32X16#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt64X8#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord8X16#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord16X8#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord32X4#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord64X2#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord8X32#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord16X16#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord32X8#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord64X4#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord8X64#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord16X32#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord32X16#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord64X8#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertFloatX4#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertDoubleX2#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertFloatX8#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertDoubleX4#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertFloatX16#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertDoubleX8#"," Insert a scalar at the given position in a vector. ")+  , (fsLit "unpackInt8X16#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt16X8#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt32X4#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt64X2#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt8X32#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt16X16#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt32X8#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt64X4#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt8X64#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt16X32#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt32X16#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt64X8#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord8X16#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord16X8#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord32X4#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord64X2#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord8X32#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord16X16#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord32X8#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord64X4#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord8X64#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord16X32#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord32X16#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord64X8#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackFloatX4#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackDoubleX2#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackFloatX8#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackDoubleX4#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackFloatX16#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackDoubleX8#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "insertInt8X16#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt16X8#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt32X4#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt64X2#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt8X32#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt16X16#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt32X8#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt64X4#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt8X64#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt16X32#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt32X16#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt64X8#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord8X16#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord16X8#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord32X4#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord64X2#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord8X32#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord16X16#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord32X8#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord64X4#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord8X64#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord16X32#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord32X16#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord64X8#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertFloatX4#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertDoubleX2#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertFloatX8#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertDoubleX4#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertFloatX16#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertDoubleX8#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")   , (fsLit "plusInt8X16#"," Add two vectors element-wise. ")   , (fsLit "plusInt16X8#"," Add two vectors element-wise. ")   , (fsLit "plusInt32X4#"," Add two vectors element-wise. ")@@ -654,54 +656,54 @@   , (fsLit "divideDoubleX4#"," Divide two vectors element-wise. ")   , (fsLit "divideFloatX16#"," Divide two vectors element-wise. ")   , (fsLit "divideDoubleX8#"," Divide two vectors element-wise. ")-  , (fsLit "quotInt8X16#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt16X8#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt32X4#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt64X2#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt8X32#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt16X16#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt32X8#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt64X4#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt8X64#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt16X32#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt32X16#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt64X8#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord8X16#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord16X8#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord32X4#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord64X2#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord8X32#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord16X16#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord32X8#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord64X4#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord8X64#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord16X32#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord32X16#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord64X8#"," Rounds towards zero element-wise. ")-  , (fsLit "remInt8X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt16X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt32X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt64X2#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt8X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt16X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt32X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt64X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt8X64#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt16X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt32X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt64X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord8X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord16X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord32X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord64X2#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord8X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord16X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord32X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord64X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord8X64#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord16X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord32X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord64X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , (fsLit "quotInt8X16#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt16X8#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt32X4#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt64X2#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt8X32#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt16X16#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt32X8#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt64X4#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt8X64#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt16X32#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt32X16#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt64X8#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord8X16#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord16X8#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord32X4#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord64X2#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord8X32#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord16X16#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord32X8#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord64X4#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord8X64#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord16X32#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord32X16#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord64X8#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt8X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt16X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt32X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt64X2#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt8X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt16X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt32X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt64X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt8X64#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt16X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt32X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt64X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord8X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord16X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord32X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord64X2#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord8X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord16X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord32X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord64X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord8X64#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord16X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord32X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord64X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")   , (fsLit "negateInt8X16#"," Negate element-wise. ")   , (fsLit "negateInt16X8#"," Negate element-wise. ")   , (fsLit "negateInt32X4#"," Negate element-wise. ")@@ -720,186 +722,186 @@   , (fsLit "negateDoubleX4#"," Negate element-wise. ")   , (fsLit "negateFloatX16#"," Negate element-wise. ")   , (fsLit "negateDoubleX8#"," Negate element-wise. ")-  , (fsLit "indexInt8X16Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt16X8Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt32X4Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt64X2Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt8X32Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt16X16Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt32X8Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt64X4Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt8X64Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt16X32Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt32X16Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt64X8Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord8X16Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord16X8Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord32X4Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord64X2Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord8X32Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord16X16Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord32X8Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord64X4Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord8X64Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord16X32Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord32X16Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord64X8Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexFloatX4Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexDoubleX2Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexFloatX8Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexDoubleX4Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexFloatX16Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexDoubleX8Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "readInt8X16Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt16X8Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt32X4Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt64X2Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt8X32Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt16X16Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt32X8Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt64X4Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt8X64Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt16X32Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt32X16Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt64X8Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord8X16Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord16X8Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord32X4Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord64X2Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord8X32Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord16X16Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord32X8Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord64X4Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord8X64Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord16X32Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord32X16Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord64X8Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readFloatX4Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readDoubleX2Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readFloatX8Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readDoubleX4Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readFloatX16Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readDoubleX8Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "writeInt8X16Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt16X8Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt32X4Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt64X2Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt8X32Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt16X16Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt32X8Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt64X4Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt8X64Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt16X32Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt32X16Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt64X8Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord8X16Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord16X8Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord32X4Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord64X2Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord8X32Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord16X16Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord32X8Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord64X4Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord8X64Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord16X32Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord32X16Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord64X8Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeFloatX4Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeDoubleX2Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeFloatX8Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeDoubleX4Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeFloatX16Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeDoubleX8Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "indexInt8X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt16X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt32X4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt64X2OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt8X32OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt16X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt32X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt64X4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt8X64OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt16X32OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt32X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt64X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord8X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord16X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord32X4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord64X2OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord8X32OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord16X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord32X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord64X4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord8X64OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord16X32OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord32X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord64X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexFloatX4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexDoubleX2OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexFloatX8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexDoubleX4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexFloatX16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexDoubleX8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt8X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt16X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt32X4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt64X2OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt8X32OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt16X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt32X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt64X4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt8X64OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt16X32OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt32X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt64X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord8X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord16X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord32X4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord64X2OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord8X32OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord16X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord32X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord64X4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord8X64OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord16X32OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord32X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord64X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readFloatX4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readDoubleX2OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readFloatX8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readDoubleX4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readFloatX16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readDoubleX8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "writeInt8X16OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt16X8OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt32X4OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt64X2OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt8X32OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt16X16OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt32X8OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt64X4OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt8X64OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt16X32OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt32X16OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt64X8OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord8X16OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord16X8OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord32X4OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord64X2OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord8X32OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord16X16OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord32X8OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord64X4OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord8X64OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord16X32OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord32X16OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord64X8OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeFloatX4OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeDoubleX2OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeFloatX8OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeDoubleX4OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeFloatX16OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeDoubleX8OffAddr#"," Write vector; offset in bytes. ")+  , (fsLit "indexInt8X16Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt16X8Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt32X4Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt64X2Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt8X32Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt16X16Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt32X8Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt64X4Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt8X64Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt16X32Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt32X16Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt64X8Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord8X16Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord16X8Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord32X4Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord64X2Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord8X32Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord16X16Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord32X8Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord64X4Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord8X64Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord16X32Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord32X16Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord64X8Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexFloatX4Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexDoubleX2Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexFloatX8Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexDoubleX4Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexFloatX16Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexDoubleX8Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt8X16Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt16X8Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt32X4Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt64X2Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt8X32Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt16X16Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt32X8Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt64X4Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt8X64Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt16X32Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt32X16Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt64X8Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord8X16Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord16X8Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord32X4Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord64X2Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord8X32Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord16X16Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord32X8Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord64X4Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord8X64Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord16X32Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord32X16Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord64X8Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readFloatX4Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readDoubleX2Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readFloatX8Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readDoubleX4Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readFloatX16Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readDoubleX8Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt8X16Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt16X8Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt32X4Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt64X2Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt8X32Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt16X16Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt32X8Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt64X4Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt8X64Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt16X32Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt32X16Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt64X8Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord8X16Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord16X8Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord32X4Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord64X2Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord8X32Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord16X16Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord32X8Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord64X4Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord8X64Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord16X32Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord32X16Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord64X8Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeFloatX4Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeDoubleX2Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeFloatX8Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeDoubleX4Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeFloatX16Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeDoubleX8Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt8X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt16X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt32X4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt64X2OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt8X32OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt16X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt32X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt64X4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt8X64OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt16X32OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt32X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt64X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord8X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord16X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord32X4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord64X2OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord8X32OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord16X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord32X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord64X4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord8X64OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord16X32OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord32X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord64X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexFloatX4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexDoubleX2OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexFloatX8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexDoubleX4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexFloatX16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexDoubleX8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt8X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt16X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt32X4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt64X2OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt8X32OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt16X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt32X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt64X4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt8X64OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt16X32OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt32X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt64X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord8X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord16X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord32X4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord64X2OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord8X32OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord16X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord32X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord64X4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord8X64OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord16X32OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord32X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord64X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readFloatX4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readDoubleX2OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readFloatX8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readDoubleX4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readFloatX16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readDoubleX8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt8X16OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt16X8OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt32X4OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt64X2OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt8X32OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt16X16OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt32X8OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt64X4OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt8X64OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt16X32OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt32X16OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt64X8OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord8X16OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord16X8OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord32X4OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord64X2OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord8X32OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord16X16OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord32X8OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord64X4OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord8X64OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord16X32OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord32X16OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord64X8OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeFloatX4OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeDoubleX2OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeFloatX8OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeDoubleX4OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeFloatX16OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeDoubleX8OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")   , (fsLit "indexInt8ArrayAsInt8X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")   , (fsLit "indexInt16ArrayAsInt16X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")   , (fsLit "indexInt32ArrayAsInt32X4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")@@ -1104,36 +1106,36 @@   , (fsLit "fnmsubDoubleX4#","Fused negate-multiply-subtract operation @-x*y-z@. See \"GHC.Prim#fma\".")   , (fsLit "fnmsubFloatX16#","Fused negate-multiply-subtract operation @-x*y-z@. See \"GHC.Prim#fma\".")   , (fsLit "fnmsubDoubleX8#","Fused negate-multiply-subtract operation @-x*y-z@. See \"GHC.Prim#fma\".")-  , (fsLit "shuffleInt8X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt16X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt32X4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt64X2#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt8X32#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt16X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt32X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt64X4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt8X64#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt16X32#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt32X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt64X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord8X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord16X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord32X4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord64X2#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord8X32#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord16X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord32X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord64X4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord8X64#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord16X32#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord32X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord64X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleFloatX4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleDoubleX2#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleFloatX8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleDoubleX4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleFloatX16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleDoubleX8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")+  , (fsLit "shuffleInt8X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt16X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt32X4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt64X2#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt8X32#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt16X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt32X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt64X4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt8X64#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt16X32#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt32X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt64X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord8X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord16X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord32X4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord64X2#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord8X32#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord16X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord32X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord64X4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord8X64#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord16X32#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord32X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord64X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleFloatX4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleDoubleX2#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleFloatX8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleDoubleX4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleFloatX16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleDoubleX8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")   , (fsLit "minInt8X16#","Component-wise minimum of two vectors.")   , (fsLit "minInt16X8#","Component-wise minimum of two vectors.")   , (fsLit "minInt32X4#","Component-wise minimum of two vectors.")
ghc-lib/stage0/compiler/build/primop-effects.hs-incl view
@@ -327,9 +327,6 @@ primOpEffect ReadMVarOp = ReadWriteEffect primOpEffect TryReadMVarOp = ReadWriteEffect primOpEffect IsEmptyMVarOp = ReadWriteEffect-primOpEffect NewIOPortOp = ReadWriteEffect-primOpEffect ReadIOPortOp = ReadWriteEffect-primOpEffect WriteIOPortOp = ReadWriteEffect primOpEffect DelayOp = ReadWriteEffect primOpEffect WaitReadOp = ReadWriteEffect primOpEffect WaitWriteOp = ReadWriteEffect@@ -374,6 +371,7 @@ primOpEffect TraceEventBinaryOp = ReadWriteEffect primOpEffect TraceMarkerOp = ReadWriteEffect primOpEffect SetThreadAllocationCounter = ReadWriteEffect+primOpEffect SetOtherThreadAllocationCounter = ReadWriteEffect primOpEffect (VecInsertOp _ _ _) = CanFail primOpEffect (VecDivOp _ _ _) = CanFail primOpEffect (VecQuotOp _ _ _) = CanFail
ghc-lib/stage0/compiler/build/primop-list.hs-incl view
@@ -655,9 +655,6 @@    , ReadMVarOp    , TryReadMVarOp    , IsEmptyMVarOp-   , NewIOPortOp-   , ReadIOPortOp-   , WriteIOPortOp    , DelayOp    , WaitReadOp    , WaitWriteOp@@ -713,11 +710,13 @@    , GetCCSOfOp    , GetCurrentCCSOp    , ClearCCSOp+   , AnnotateStackOp    , WhereFromOp    , TraceEventOp    , TraceEventBinaryOp    , TraceMarkerOp    , SetThreadAllocationCounter+   , SetOtherThreadAllocationCounter    , (VecBroadcastOp IntVec 16 W8)    , (VecBroadcastOp IntVec 8 W16)    , (VecBroadcastOp IntVec 4 W32)
ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl view
@@ -62,9 +62,6 @@ primOpOutOfLine ReadMVarOp = True primOpOutOfLine TryReadMVarOp = True primOpOutOfLine IsEmptyMVarOp = True-primOpOutOfLine NewIOPortOp = True-primOpOutOfLine ReadIOPortOp = True-primOpOutOfLine WriteIOPortOp = True primOpOutOfLine DelayOp = True primOpOutOfLine WaitReadOp = True primOpOutOfLine WaitWriteOp = True@@ -106,9 +103,11 @@ primOpOutOfLine ClosureSizeOp = True primOpOutOfLine GetApStackValOp = True primOpOutOfLine ClearCCSOp = True+primOpOutOfLine AnnotateStackOp = True primOpOutOfLine WhereFromOp = True primOpOutOfLine TraceEventOp = True primOpOutOfLine TraceEventBinaryOp = True primOpOutOfLine TraceMarkerOp = True primOpOutOfLine SetThreadAllocationCounter = True+primOpOutOfLine SetOtherThreadAllocationCounter = True primOpOutOfLine _thisOp = False
ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view
@@ -655,9 +655,6 @@ primOpInfo ReadMVarOp = mkGenPrimOp (fsLit "readMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy])) primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy])) primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo NewIOPortOp = mkGenPrimOp (fsLit "newIOPort#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkIOPortPrimTy deltaTy levPolyAlphaTy]))-primOpInfo ReadIOPortOp = mkGenPrimOp (fsLit "readIOPort#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkIOPortPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy]))-primOpInfo WriteIOPortOp = mkGenPrimOp (fsLit "writeIOPort#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkIOPortPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo DelayOp = mkGenPrimOp (fsLit "delay#")  [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WaitReadOp = mkGenPrimOp (fsLit "waitRead#")  [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WaitWriteOp = mkGenPrimOp (fsLit "waitWrite#")  [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)@@ -713,11 +710,13 @@ primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#")  [deltaTyVarSpec, alphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo AnnotateStackOp = mkGenPrimOp (fsLit "annotateStack#")  [runtimeRep1TyVarInf, betaTyVarSpec, deltaTyVarSpec, openAlphaTyVarSpec] [betaTy, (mkVisFunTyMany (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, openAlphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, openAlphaTy])) primOpInfo WhereFromOp = mkGenPrimOp (fsLit "whereFrom#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#")  [deltaTyVarSpec] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#")  [deltaTyVarSpec] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo SetThreadAllocationCounter = mkGenPrimOp (fsLit "setThreadAllocationCounter#")  [] [int64PrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo SetOtherThreadAllocationCounter = mkGenPrimOp (fsLit "setOtherThreadAllocationCounter#")  [] [int64PrimTy, threadIdPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#")  [] [int8PrimTy] (int8X16PrimTy) primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#")  [] [int16PrimTy] (int16X8PrimTy) primOpInfo (VecBroadcastOp IntVec 4 W32) = mkGenPrimOp (fsLit "broadcastInt32X4#")  [] [int32PrimTy] (int32X4PrimTy)
ghc-lib/stage0/compiler/build/primop-tag.hs-incl view
@@ -1,1495 +1,1494 @@ maxPrimOpTag :: Int-maxPrimOpTag = 1491-primOpTag :: PrimOp -> Int-primOpTag CharGtOp = 0-primOpTag CharGeOp = 1-primOpTag CharEqOp = 2-primOpTag CharNeOp = 3-primOpTag CharLtOp = 4-primOpTag CharLeOp = 5-primOpTag OrdOp = 6-primOpTag Int8ToIntOp = 7-primOpTag IntToInt8Op = 8-primOpTag Int8NegOp = 9-primOpTag Int8AddOp = 10-primOpTag Int8SubOp = 11-primOpTag Int8MulOp = 12-primOpTag Int8QuotOp = 13-primOpTag Int8RemOp = 14-primOpTag Int8QuotRemOp = 15-primOpTag Int8SllOp = 16-primOpTag Int8SraOp = 17-primOpTag Int8SrlOp = 18-primOpTag Int8ToWord8Op = 19-primOpTag Int8EqOp = 20-primOpTag Int8GeOp = 21-primOpTag Int8GtOp = 22-primOpTag Int8LeOp = 23-primOpTag Int8LtOp = 24-primOpTag Int8NeOp = 25-primOpTag Word8ToWordOp = 26-primOpTag WordToWord8Op = 27-primOpTag Word8AddOp = 28-primOpTag Word8SubOp = 29-primOpTag Word8MulOp = 30-primOpTag Word8QuotOp = 31-primOpTag Word8RemOp = 32-primOpTag Word8QuotRemOp = 33-primOpTag Word8AndOp = 34-primOpTag Word8OrOp = 35-primOpTag Word8XorOp = 36-primOpTag Word8NotOp = 37-primOpTag Word8SllOp = 38-primOpTag Word8SrlOp = 39-primOpTag Word8ToInt8Op = 40-primOpTag Word8EqOp = 41-primOpTag Word8GeOp = 42-primOpTag Word8GtOp = 43-primOpTag Word8LeOp = 44-primOpTag Word8LtOp = 45-primOpTag Word8NeOp = 46-primOpTag Int16ToIntOp = 47-primOpTag IntToInt16Op = 48-primOpTag Int16NegOp = 49-primOpTag Int16AddOp = 50-primOpTag Int16SubOp = 51-primOpTag Int16MulOp = 52-primOpTag Int16QuotOp = 53-primOpTag Int16RemOp = 54-primOpTag Int16QuotRemOp = 55-primOpTag Int16SllOp = 56-primOpTag Int16SraOp = 57-primOpTag Int16SrlOp = 58-primOpTag Int16ToWord16Op = 59-primOpTag Int16EqOp = 60-primOpTag Int16GeOp = 61-primOpTag Int16GtOp = 62-primOpTag Int16LeOp = 63-primOpTag Int16LtOp = 64-primOpTag Int16NeOp = 65-primOpTag Word16ToWordOp = 66-primOpTag WordToWord16Op = 67-primOpTag Word16AddOp = 68-primOpTag Word16SubOp = 69-primOpTag Word16MulOp = 70-primOpTag Word16QuotOp = 71-primOpTag Word16RemOp = 72-primOpTag Word16QuotRemOp = 73-primOpTag Word16AndOp = 74-primOpTag Word16OrOp = 75-primOpTag Word16XorOp = 76-primOpTag Word16NotOp = 77-primOpTag Word16SllOp = 78-primOpTag Word16SrlOp = 79-primOpTag Word16ToInt16Op = 80-primOpTag Word16EqOp = 81-primOpTag Word16GeOp = 82-primOpTag Word16GtOp = 83-primOpTag Word16LeOp = 84-primOpTag Word16LtOp = 85-primOpTag Word16NeOp = 86-primOpTag Int32ToIntOp = 87-primOpTag IntToInt32Op = 88-primOpTag Int32NegOp = 89-primOpTag Int32AddOp = 90-primOpTag Int32SubOp = 91-primOpTag Int32MulOp = 92-primOpTag Int32QuotOp = 93-primOpTag Int32RemOp = 94-primOpTag Int32QuotRemOp = 95-primOpTag Int32SllOp = 96-primOpTag Int32SraOp = 97-primOpTag Int32SrlOp = 98-primOpTag Int32ToWord32Op = 99-primOpTag Int32EqOp = 100-primOpTag Int32GeOp = 101-primOpTag Int32GtOp = 102-primOpTag Int32LeOp = 103-primOpTag Int32LtOp = 104-primOpTag Int32NeOp = 105-primOpTag Word32ToWordOp = 106-primOpTag WordToWord32Op = 107-primOpTag Word32AddOp = 108-primOpTag Word32SubOp = 109-primOpTag Word32MulOp = 110-primOpTag Word32QuotOp = 111-primOpTag Word32RemOp = 112-primOpTag Word32QuotRemOp = 113-primOpTag Word32AndOp = 114-primOpTag Word32OrOp = 115-primOpTag Word32XorOp = 116-primOpTag Word32NotOp = 117-primOpTag Word32SllOp = 118-primOpTag Word32SrlOp = 119-primOpTag Word32ToInt32Op = 120-primOpTag Word32EqOp = 121-primOpTag Word32GeOp = 122-primOpTag Word32GtOp = 123-primOpTag Word32LeOp = 124-primOpTag Word32LtOp = 125-primOpTag Word32NeOp = 126-primOpTag Int64ToIntOp = 127-primOpTag IntToInt64Op = 128-primOpTag Int64NegOp = 129-primOpTag Int64AddOp = 130-primOpTag Int64SubOp = 131-primOpTag Int64MulOp = 132-primOpTag Int64QuotOp = 133-primOpTag Int64RemOp = 134-primOpTag Int64SllOp = 135-primOpTag Int64SraOp = 136-primOpTag Int64SrlOp = 137-primOpTag Int64ToWord64Op = 138-primOpTag Int64EqOp = 139-primOpTag Int64GeOp = 140-primOpTag Int64GtOp = 141-primOpTag Int64LeOp = 142-primOpTag Int64LtOp = 143-primOpTag Int64NeOp = 144-primOpTag Word64ToWordOp = 145-primOpTag WordToWord64Op = 146-primOpTag Word64AddOp = 147-primOpTag Word64SubOp = 148-primOpTag Word64MulOp = 149-primOpTag Word64QuotOp = 150-primOpTag Word64RemOp = 151-primOpTag Word64AndOp = 152-primOpTag Word64OrOp = 153-primOpTag Word64XorOp = 154-primOpTag Word64NotOp = 155-primOpTag Word64SllOp = 156-primOpTag Word64SrlOp = 157-primOpTag Word64ToInt64Op = 158-primOpTag Word64EqOp = 159-primOpTag Word64GeOp = 160-primOpTag Word64GtOp = 161-primOpTag Word64LeOp = 162-primOpTag Word64LtOp = 163-primOpTag Word64NeOp = 164-primOpTag IntAddOp = 165-primOpTag IntSubOp = 166-primOpTag IntMulOp = 167-primOpTag IntMul2Op = 168-primOpTag IntMulMayOfloOp = 169-primOpTag IntQuotOp = 170-primOpTag IntRemOp = 171-primOpTag IntQuotRemOp = 172-primOpTag IntAndOp = 173-primOpTag IntOrOp = 174-primOpTag IntXorOp = 175-primOpTag IntNotOp = 176-primOpTag IntNegOp = 177-primOpTag IntAddCOp = 178-primOpTag IntSubCOp = 179-primOpTag IntGtOp = 180-primOpTag IntGeOp = 181-primOpTag IntEqOp = 182-primOpTag IntNeOp = 183-primOpTag IntLtOp = 184-primOpTag IntLeOp = 185-primOpTag ChrOp = 186-primOpTag IntToWordOp = 187-primOpTag IntToFloatOp = 188-primOpTag IntToDoubleOp = 189-primOpTag WordToFloatOp = 190-primOpTag WordToDoubleOp = 191-primOpTag IntSllOp = 192-primOpTag IntSraOp = 193-primOpTag IntSrlOp = 194-primOpTag WordAddOp = 195-primOpTag WordAddCOp = 196-primOpTag WordSubCOp = 197-primOpTag WordAdd2Op = 198-primOpTag WordSubOp = 199-primOpTag WordMulOp = 200-primOpTag WordMul2Op = 201-primOpTag WordQuotOp = 202-primOpTag WordRemOp = 203-primOpTag WordQuotRemOp = 204-primOpTag WordQuotRem2Op = 205-primOpTag WordAndOp = 206-primOpTag WordOrOp = 207-primOpTag WordXorOp = 208-primOpTag WordNotOp = 209-primOpTag WordSllOp = 210-primOpTag WordSrlOp = 211-primOpTag WordToIntOp = 212-primOpTag WordGtOp = 213-primOpTag WordGeOp = 214-primOpTag WordEqOp = 215-primOpTag WordNeOp = 216-primOpTag WordLtOp = 217-primOpTag WordLeOp = 218-primOpTag PopCnt8Op = 219-primOpTag PopCnt16Op = 220-primOpTag PopCnt32Op = 221-primOpTag PopCnt64Op = 222-primOpTag PopCntOp = 223-primOpTag Pdep8Op = 224-primOpTag Pdep16Op = 225-primOpTag Pdep32Op = 226-primOpTag Pdep64Op = 227-primOpTag PdepOp = 228-primOpTag Pext8Op = 229-primOpTag Pext16Op = 230-primOpTag Pext32Op = 231-primOpTag Pext64Op = 232-primOpTag PextOp = 233-primOpTag Clz8Op = 234-primOpTag Clz16Op = 235-primOpTag Clz32Op = 236-primOpTag Clz64Op = 237-primOpTag ClzOp = 238-primOpTag Ctz8Op = 239-primOpTag Ctz16Op = 240-primOpTag Ctz32Op = 241-primOpTag Ctz64Op = 242-primOpTag CtzOp = 243-primOpTag BSwap16Op = 244-primOpTag BSwap32Op = 245-primOpTag BSwap64Op = 246-primOpTag BSwapOp = 247-primOpTag BRev8Op = 248-primOpTag BRev16Op = 249-primOpTag BRev32Op = 250-primOpTag BRev64Op = 251-primOpTag BRevOp = 252-primOpTag Narrow8IntOp = 253-primOpTag Narrow16IntOp = 254-primOpTag Narrow32IntOp = 255-primOpTag Narrow8WordOp = 256-primOpTag Narrow16WordOp = 257-primOpTag Narrow32WordOp = 258-primOpTag DoubleGtOp = 259-primOpTag DoubleGeOp = 260-primOpTag DoubleEqOp = 261-primOpTag DoubleNeOp = 262-primOpTag DoubleLtOp = 263-primOpTag DoubleLeOp = 264-primOpTag DoubleMinOp = 265-primOpTag DoubleMaxOp = 266-primOpTag DoubleAddOp = 267-primOpTag DoubleSubOp = 268-primOpTag DoubleMulOp = 269-primOpTag DoubleDivOp = 270-primOpTag DoubleNegOp = 271-primOpTag DoubleFabsOp = 272-primOpTag DoubleToIntOp = 273-primOpTag DoubleToFloatOp = 274-primOpTag DoubleExpOp = 275-primOpTag DoubleExpM1Op = 276-primOpTag DoubleLogOp = 277-primOpTag DoubleLog1POp = 278-primOpTag DoubleSqrtOp = 279-primOpTag DoubleSinOp = 280-primOpTag DoubleCosOp = 281-primOpTag DoubleTanOp = 282-primOpTag DoubleAsinOp = 283-primOpTag DoubleAcosOp = 284-primOpTag DoubleAtanOp = 285-primOpTag DoubleSinhOp = 286-primOpTag DoubleCoshOp = 287-primOpTag DoubleTanhOp = 288-primOpTag DoubleAsinhOp = 289-primOpTag DoubleAcoshOp = 290-primOpTag DoubleAtanhOp = 291-primOpTag DoublePowerOp = 292-primOpTag DoubleDecode_2IntOp = 293-primOpTag DoubleDecode_Int64Op = 294-primOpTag CastDoubleToWord64Op = 295-primOpTag CastWord64ToDoubleOp = 296-primOpTag FloatGtOp = 297-primOpTag FloatGeOp = 298-primOpTag FloatEqOp = 299-primOpTag FloatNeOp = 300-primOpTag FloatLtOp = 301-primOpTag FloatLeOp = 302-primOpTag FloatMinOp = 303-primOpTag FloatMaxOp = 304-primOpTag FloatAddOp = 305-primOpTag FloatSubOp = 306-primOpTag FloatMulOp = 307-primOpTag FloatDivOp = 308-primOpTag FloatNegOp = 309-primOpTag FloatFabsOp = 310-primOpTag FloatToIntOp = 311-primOpTag FloatExpOp = 312-primOpTag FloatExpM1Op = 313-primOpTag FloatLogOp = 314-primOpTag FloatLog1POp = 315-primOpTag FloatSqrtOp = 316-primOpTag FloatSinOp = 317-primOpTag FloatCosOp = 318-primOpTag FloatTanOp = 319-primOpTag FloatAsinOp = 320-primOpTag FloatAcosOp = 321-primOpTag FloatAtanOp = 322-primOpTag FloatSinhOp = 323-primOpTag FloatCoshOp = 324-primOpTag FloatTanhOp = 325-primOpTag FloatAsinhOp = 326-primOpTag FloatAcoshOp = 327-primOpTag FloatAtanhOp = 328-primOpTag FloatPowerOp = 329-primOpTag FloatToDoubleOp = 330-primOpTag FloatDecode_IntOp = 331-primOpTag CastFloatToWord32Op = 332-primOpTag CastWord32ToFloatOp = 333-primOpTag FloatFMAdd = 334-primOpTag FloatFMSub = 335-primOpTag FloatFNMAdd = 336-primOpTag FloatFNMSub = 337-primOpTag DoubleFMAdd = 338-primOpTag DoubleFMSub = 339-primOpTag DoubleFNMAdd = 340-primOpTag DoubleFNMSub = 341-primOpTag NewArrayOp = 342-primOpTag ReadArrayOp = 343-primOpTag WriteArrayOp = 344-primOpTag SizeofArrayOp = 345-primOpTag SizeofMutableArrayOp = 346-primOpTag IndexArrayOp = 347-primOpTag UnsafeFreezeArrayOp = 348-primOpTag UnsafeThawArrayOp = 349-primOpTag CopyArrayOp = 350-primOpTag CopyMutableArrayOp = 351-primOpTag CloneArrayOp = 352-primOpTag CloneMutableArrayOp = 353-primOpTag FreezeArrayOp = 354-primOpTag ThawArrayOp = 355-primOpTag CasArrayOp = 356-primOpTag NewSmallArrayOp = 357-primOpTag ShrinkSmallMutableArrayOp_Char = 358-primOpTag ReadSmallArrayOp = 359-primOpTag WriteSmallArrayOp = 360-primOpTag SizeofSmallArrayOp = 361-primOpTag SizeofSmallMutableArrayOp = 362-primOpTag GetSizeofSmallMutableArrayOp = 363-primOpTag IndexSmallArrayOp = 364-primOpTag UnsafeFreezeSmallArrayOp = 365-primOpTag UnsafeThawSmallArrayOp = 366-primOpTag CopySmallArrayOp = 367-primOpTag CopySmallMutableArrayOp = 368-primOpTag CloneSmallArrayOp = 369-primOpTag CloneSmallMutableArrayOp = 370-primOpTag FreezeSmallArrayOp = 371-primOpTag ThawSmallArrayOp = 372-primOpTag CasSmallArrayOp = 373-primOpTag NewByteArrayOp_Char = 374-primOpTag NewPinnedByteArrayOp_Char = 375-primOpTag NewAlignedPinnedByteArrayOp_Char = 376-primOpTag MutableByteArrayIsPinnedOp = 377-primOpTag ByteArrayIsPinnedOp = 378-primOpTag ByteArrayIsWeaklyPinnedOp = 379-primOpTag MutableByteArrayIsWeaklyPinnedOp = 380-primOpTag ByteArrayContents_Char = 381-primOpTag MutableByteArrayContents_Char = 382-primOpTag ShrinkMutableByteArrayOp_Char = 383-primOpTag ResizeMutableByteArrayOp_Char = 384-primOpTag UnsafeFreezeByteArrayOp = 385-primOpTag UnsafeThawByteArrayOp = 386-primOpTag SizeofByteArrayOp = 387-primOpTag SizeofMutableByteArrayOp = 388-primOpTag GetSizeofMutableByteArrayOp = 389-primOpTag IndexByteArrayOp_Char = 390-primOpTag IndexByteArrayOp_WideChar = 391-primOpTag IndexByteArrayOp_Int = 392-primOpTag IndexByteArrayOp_Word = 393-primOpTag IndexByteArrayOp_Addr = 394-primOpTag IndexByteArrayOp_Float = 395-primOpTag IndexByteArrayOp_Double = 396-primOpTag IndexByteArrayOp_StablePtr = 397-primOpTag IndexByteArrayOp_Int8 = 398-primOpTag IndexByteArrayOp_Word8 = 399-primOpTag IndexByteArrayOp_Int16 = 400-primOpTag IndexByteArrayOp_Word16 = 401-primOpTag IndexByteArrayOp_Int32 = 402-primOpTag IndexByteArrayOp_Word32 = 403-primOpTag IndexByteArrayOp_Int64 = 404-primOpTag IndexByteArrayOp_Word64 = 405-primOpTag IndexByteArrayOp_Word8AsChar = 406-primOpTag IndexByteArrayOp_Word8AsWideChar = 407-primOpTag IndexByteArrayOp_Word8AsInt = 408-primOpTag IndexByteArrayOp_Word8AsWord = 409-primOpTag IndexByteArrayOp_Word8AsAddr = 410-primOpTag IndexByteArrayOp_Word8AsFloat = 411-primOpTag IndexByteArrayOp_Word8AsDouble = 412-primOpTag IndexByteArrayOp_Word8AsStablePtr = 413-primOpTag IndexByteArrayOp_Word8AsInt16 = 414-primOpTag IndexByteArrayOp_Word8AsWord16 = 415-primOpTag IndexByteArrayOp_Word8AsInt32 = 416-primOpTag IndexByteArrayOp_Word8AsWord32 = 417-primOpTag IndexByteArrayOp_Word8AsInt64 = 418-primOpTag IndexByteArrayOp_Word8AsWord64 = 419-primOpTag ReadByteArrayOp_Char = 420-primOpTag ReadByteArrayOp_WideChar = 421-primOpTag ReadByteArrayOp_Int = 422-primOpTag ReadByteArrayOp_Word = 423-primOpTag ReadByteArrayOp_Addr = 424-primOpTag ReadByteArrayOp_Float = 425-primOpTag ReadByteArrayOp_Double = 426-primOpTag ReadByteArrayOp_StablePtr = 427-primOpTag ReadByteArrayOp_Int8 = 428-primOpTag ReadByteArrayOp_Word8 = 429-primOpTag ReadByteArrayOp_Int16 = 430-primOpTag ReadByteArrayOp_Word16 = 431-primOpTag ReadByteArrayOp_Int32 = 432-primOpTag ReadByteArrayOp_Word32 = 433-primOpTag ReadByteArrayOp_Int64 = 434-primOpTag ReadByteArrayOp_Word64 = 435-primOpTag ReadByteArrayOp_Word8AsChar = 436-primOpTag ReadByteArrayOp_Word8AsWideChar = 437-primOpTag ReadByteArrayOp_Word8AsInt = 438-primOpTag ReadByteArrayOp_Word8AsWord = 439-primOpTag ReadByteArrayOp_Word8AsAddr = 440-primOpTag ReadByteArrayOp_Word8AsFloat = 441-primOpTag ReadByteArrayOp_Word8AsDouble = 442-primOpTag ReadByteArrayOp_Word8AsStablePtr = 443-primOpTag ReadByteArrayOp_Word8AsInt16 = 444-primOpTag ReadByteArrayOp_Word8AsWord16 = 445-primOpTag ReadByteArrayOp_Word8AsInt32 = 446-primOpTag ReadByteArrayOp_Word8AsWord32 = 447-primOpTag ReadByteArrayOp_Word8AsInt64 = 448-primOpTag ReadByteArrayOp_Word8AsWord64 = 449-primOpTag WriteByteArrayOp_Char = 450-primOpTag WriteByteArrayOp_WideChar = 451-primOpTag WriteByteArrayOp_Int = 452-primOpTag WriteByteArrayOp_Word = 453-primOpTag WriteByteArrayOp_Addr = 454-primOpTag WriteByteArrayOp_Float = 455-primOpTag WriteByteArrayOp_Double = 456-primOpTag WriteByteArrayOp_StablePtr = 457-primOpTag WriteByteArrayOp_Int8 = 458-primOpTag WriteByteArrayOp_Word8 = 459-primOpTag WriteByteArrayOp_Int16 = 460-primOpTag WriteByteArrayOp_Word16 = 461-primOpTag WriteByteArrayOp_Int32 = 462-primOpTag WriteByteArrayOp_Word32 = 463-primOpTag WriteByteArrayOp_Int64 = 464-primOpTag WriteByteArrayOp_Word64 = 465-primOpTag WriteByteArrayOp_Word8AsChar = 466-primOpTag WriteByteArrayOp_Word8AsWideChar = 467-primOpTag WriteByteArrayOp_Word8AsInt = 468-primOpTag WriteByteArrayOp_Word8AsWord = 469-primOpTag WriteByteArrayOp_Word8AsAddr = 470-primOpTag WriteByteArrayOp_Word8AsFloat = 471-primOpTag WriteByteArrayOp_Word8AsDouble = 472-primOpTag WriteByteArrayOp_Word8AsStablePtr = 473-primOpTag WriteByteArrayOp_Word8AsInt16 = 474-primOpTag WriteByteArrayOp_Word8AsWord16 = 475-primOpTag WriteByteArrayOp_Word8AsInt32 = 476-primOpTag WriteByteArrayOp_Word8AsWord32 = 477-primOpTag WriteByteArrayOp_Word8AsInt64 = 478-primOpTag WriteByteArrayOp_Word8AsWord64 = 479-primOpTag CompareByteArraysOp = 480-primOpTag CopyByteArrayOp = 481-primOpTag CopyMutableByteArrayOp = 482-primOpTag CopyMutableByteArrayNonOverlappingOp = 483-primOpTag CopyByteArrayToAddrOp = 484-primOpTag CopyMutableByteArrayToAddrOp = 485-primOpTag CopyAddrToByteArrayOp = 486-primOpTag CopyAddrToAddrOp = 487-primOpTag CopyAddrToAddrNonOverlappingOp = 488-primOpTag SetByteArrayOp = 489-primOpTag SetAddrRangeOp = 490-primOpTag AtomicReadByteArrayOp_Int = 491-primOpTag AtomicWriteByteArrayOp_Int = 492-primOpTag CasByteArrayOp_Int = 493-primOpTag CasByteArrayOp_Int8 = 494-primOpTag CasByteArrayOp_Int16 = 495-primOpTag CasByteArrayOp_Int32 = 496-primOpTag CasByteArrayOp_Int64 = 497-primOpTag FetchAddByteArrayOp_Int = 498-primOpTag FetchSubByteArrayOp_Int = 499-primOpTag FetchAndByteArrayOp_Int = 500-primOpTag FetchNandByteArrayOp_Int = 501-primOpTag FetchOrByteArrayOp_Int = 502-primOpTag FetchXorByteArrayOp_Int = 503-primOpTag AddrAddOp = 504-primOpTag AddrSubOp = 505-primOpTag AddrRemOp = 506-primOpTag AddrToIntOp = 507-primOpTag IntToAddrOp = 508-primOpTag AddrGtOp = 509-primOpTag AddrGeOp = 510-primOpTag AddrEqOp = 511-primOpTag AddrNeOp = 512-primOpTag AddrLtOp = 513-primOpTag AddrLeOp = 514-primOpTag IndexOffAddrOp_Char = 515-primOpTag IndexOffAddrOp_WideChar = 516-primOpTag IndexOffAddrOp_Int = 517-primOpTag IndexOffAddrOp_Word = 518-primOpTag IndexOffAddrOp_Addr = 519-primOpTag IndexOffAddrOp_Float = 520-primOpTag IndexOffAddrOp_Double = 521-primOpTag IndexOffAddrOp_StablePtr = 522-primOpTag IndexOffAddrOp_Int8 = 523-primOpTag IndexOffAddrOp_Word8 = 524-primOpTag IndexOffAddrOp_Int16 = 525-primOpTag IndexOffAddrOp_Word16 = 526-primOpTag IndexOffAddrOp_Int32 = 527-primOpTag IndexOffAddrOp_Word32 = 528-primOpTag IndexOffAddrOp_Int64 = 529-primOpTag IndexOffAddrOp_Word64 = 530-primOpTag IndexOffAddrOp_Word8AsChar = 531-primOpTag IndexOffAddrOp_Word8AsWideChar = 532-primOpTag IndexOffAddrOp_Word8AsInt = 533-primOpTag IndexOffAddrOp_Word8AsWord = 534-primOpTag IndexOffAddrOp_Word8AsAddr = 535-primOpTag IndexOffAddrOp_Word8AsFloat = 536-primOpTag IndexOffAddrOp_Word8AsDouble = 537-primOpTag IndexOffAddrOp_Word8AsStablePtr = 538-primOpTag IndexOffAddrOp_Word8AsInt16 = 539-primOpTag IndexOffAddrOp_Word8AsWord16 = 540-primOpTag IndexOffAddrOp_Word8AsInt32 = 541-primOpTag IndexOffAddrOp_Word8AsWord32 = 542-primOpTag IndexOffAddrOp_Word8AsInt64 = 543-primOpTag IndexOffAddrOp_Word8AsWord64 = 544-primOpTag ReadOffAddrOp_Char = 545-primOpTag ReadOffAddrOp_WideChar = 546-primOpTag ReadOffAddrOp_Int = 547-primOpTag ReadOffAddrOp_Word = 548-primOpTag ReadOffAddrOp_Addr = 549-primOpTag ReadOffAddrOp_Float = 550-primOpTag ReadOffAddrOp_Double = 551-primOpTag ReadOffAddrOp_StablePtr = 552-primOpTag ReadOffAddrOp_Int8 = 553-primOpTag ReadOffAddrOp_Word8 = 554-primOpTag ReadOffAddrOp_Int16 = 555-primOpTag ReadOffAddrOp_Word16 = 556-primOpTag ReadOffAddrOp_Int32 = 557-primOpTag ReadOffAddrOp_Word32 = 558-primOpTag ReadOffAddrOp_Int64 = 559-primOpTag ReadOffAddrOp_Word64 = 560-primOpTag ReadOffAddrOp_Word8AsChar = 561-primOpTag ReadOffAddrOp_Word8AsWideChar = 562-primOpTag ReadOffAddrOp_Word8AsInt = 563-primOpTag ReadOffAddrOp_Word8AsWord = 564-primOpTag ReadOffAddrOp_Word8AsAddr = 565-primOpTag ReadOffAddrOp_Word8AsFloat = 566-primOpTag ReadOffAddrOp_Word8AsDouble = 567-primOpTag ReadOffAddrOp_Word8AsStablePtr = 568-primOpTag ReadOffAddrOp_Word8AsInt16 = 569-primOpTag ReadOffAddrOp_Word8AsWord16 = 570-primOpTag ReadOffAddrOp_Word8AsInt32 = 571-primOpTag ReadOffAddrOp_Word8AsWord32 = 572-primOpTag ReadOffAddrOp_Word8AsInt64 = 573-primOpTag ReadOffAddrOp_Word8AsWord64 = 574-primOpTag WriteOffAddrOp_Char = 575-primOpTag WriteOffAddrOp_WideChar = 576-primOpTag WriteOffAddrOp_Int = 577-primOpTag WriteOffAddrOp_Word = 578-primOpTag WriteOffAddrOp_Addr = 579-primOpTag WriteOffAddrOp_Float = 580-primOpTag WriteOffAddrOp_Double = 581-primOpTag WriteOffAddrOp_StablePtr = 582-primOpTag WriteOffAddrOp_Int8 = 583-primOpTag WriteOffAddrOp_Word8 = 584-primOpTag WriteOffAddrOp_Int16 = 585-primOpTag WriteOffAddrOp_Word16 = 586-primOpTag WriteOffAddrOp_Int32 = 587-primOpTag WriteOffAddrOp_Word32 = 588-primOpTag WriteOffAddrOp_Int64 = 589-primOpTag WriteOffAddrOp_Word64 = 590-primOpTag WriteOffAddrOp_Word8AsChar = 591-primOpTag WriteOffAddrOp_Word8AsWideChar = 592-primOpTag WriteOffAddrOp_Word8AsInt = 593-primOpTag WriteOffAddrOp_Word8AsWord = 594-primOpTag WriteOffAddrOp_Word8AsAddr = 595-primOpTag WriteOffAddrOp_Word8AsFloat = 596-primOpTag WriteOffAddrOp_Word8AsDouble = 597-primOpTag WriteOffAddrOp_Word8AsStablePtr = 598-primOpTag WriteOffAddrOp_Word8AsInt16 = 599-primOpTag WriteOffAddrOp_Word8AsWord16 = 600-primOpTag WriteOffAddrOp_Word8AsInt32 = 601-primOpTag WriteOffAddrOp_Word8AsWord32 = 602-primOpTag WriteOffAddrOp_Word8AsInt64 = 603-primOpTag WriteOffAddrOp_Word8AsWord64 = 604-primOpTag InterlockedExchange_Addr = 605-primOpTag InterlockedExchange_Word = 606-primOpTag CasAddrOp_Addr = 607-primOpTag CasAddrOp_Word = 608-primOpTag CasAddrOp_Word8 = 609-primOpTag CasAddrOp_Word16 = 610-primOpTag CasAddrOp_Word32 = 611-primOpTag CasAddrOp_Word64 = 612-primOpTag FetchAddAddrOp_Word = 613-primOpTag FetchSubAddrOp_Word = 614-primOpTag FetchAndAddrOp_Word = 615-primOpTag FetchNandAddrOp_Word = 616-primOpTag FetchOrAddrOp_Word = 617-primOpTag FetchXorAddrOp_Word = 618-primOpTag AtomicReadAddrOp_Word = 619-primOpTag AtomicWriteAddrOp_Word = 620-primOpTag NewMutVarOp = 621-primOpTag ReadMutVarOp = 622-primOpTag WriteMutVarOp = 623-primOpTag AtomicSwapMutVarOp = 624-primOpTag AtomicModifyMutVar2Op = 625-primOpTag AtomicModifyMutVar_Op = 626-primOpTag CasMutVarOp = 627-primOpTag CatchOp = 628-primOpTag RaiseOp = 629-primOpTag RaiseUnderflowOp = 630-primOpTag RaiseOverflowOp = 631-primOpTag RaiseDivZeroOp = 632-primOpTag RaiseIOOp = 633-primOpTag MaskAsyncExceptionsOp = 634-primOpTag MaskUninterruptibleOp = 635-primOpTag UnmaskAsyncExceptionsOp = 636-primOpTag MaskStatus = 637-primOpTag NewPromptTagOp = 638-primOpTag PromptOp = 639-primOpTag Control0Op = 640-primOpTag AtomicallyOp = 641-primOpTag RetryOp = 642-primOpTag CatchRetryOp = 643-primOpTag CatchSTMOp = 644-primOpTag NewTVarOp = 645-primOpTag ReadTVarOp = 646-primOpTag ReadTVarIOOp = 647-primOpTag WriteTVarOp = 648-primOpTag NewMVarOp = 649-primOpTag TakeMVarOp = 650-primOpTag TryTakeMVarOp = 651-primOpTag PutMVarOp = 652-primOpTag TryPutMVarOp = 653-primOpTag ReadMVarOp = 654-primOpTag TryReadMVarOp = 655-primOpTag IsEmptyMVarOp = 656-primOpTag NewIOPortOp = 657-primOpTag ReadIOPortOp = 658-primOpTag WriteIOPortOp = 659-primOpTag DelayOp = 660-primOpTag WaitReadOp = 661-primOpTag WaitWriteOp = 662-primOpTag ForkOp = 663-primOpTag ForkOnOp = 664-primOpTag KillThreadOp = 665-primOpTag YieldOp = 666-primOpTag MyThreadIdOp = 667-primOpTag LabelThreadOp = 668-primOpTag IsCurrentThreadBoundOp = 669-primOpTag NoDuplicateOp = 670-primOpTag GetThreadLabelOp = 671-primOpTag ThreadStatusOp = 672-primOpTag ListThreadsOp = 673-primOpTag MkWeakOp = 674-primOpTag MkWeakNoFinalizerOp = 675-primOpTag AddCFinalizerToWeakOp = 676-primOpTag DeRefWeakOp = 677-primOpTag FinalizeWeakOp = 678-primOpTag TouchOp = 679-primOpTag MakeStablePtrOp = 680-primOpTag DeRefStablePtrOp = 681-primOpTag EqStablePtrOp = 682-primOpTag MakeStableNameOp = 683-primOpTag StableNameToIntOp = 684-primOpTag CompactNewOp = 685-primOpTag CompactResizeOp = 686-primOpTag CompactContainsOp = 687-primOpTag CompactContainsAnyOp = 688-primOpTag CompactGetFirstBlockOp = 689-primOpTag CompactGetNextBlockOp = 690-primOpTag CompactAllocateBlockOp = 691-primOpTag CompactFixupPointersOp = 692-primOpTag CompactAdd = 693-primOpTag CompactAddWithSharing = 694-primOpTag CompactSize = 695-primOpTag ReallyUnsafePtrEqualityOp = 696-primOpTag ParOp = 697-primOpTag SparkOp = 698-primOpTag GetSparkOp = 699-primOpTag NumSparks = 700-primOpTag KeepAliveOp = 701-primOpTag DataToTagSmallOp = 702-primOpTag DataToTagLargeOp = 703-primOpTag TagToEnumOp = 704-primOpTag AddrToAnyOp = 705-primOpTag AnyToAddrOp = 706-primOpTag MkApUpd0_Op = 707-primOpTag NewBCOOp = 708-primOpTag UnpackClosureOp = 709-primOpTag ClosureSizeOp = 710-primOpTag GetApStackValOp = 711-primOpTag GetCCSOfOp = 712-primOpTag GetCurrentCCSOp = 713-primOpTag ClearCCSOp = 714-primOpTag WhereFromOp = 715-primOpTag TraceEventOp = 716-primOpTag TraceEventBinaryOp = 717-primOpTag TraceMarkerOp = 718-primOpTag SetThreadAllocationCounter = 719-primOpTag (VecBroadcastOp IntVec 16 W8) = 720-primOpTag (VecBroadcastOp IntVec 8 W16) = 721-primOpTag (VecBroadcastOp IntVec 4 W32) = 722-primOpTag (VecBroadcastOp IntVec 2 W64) = 723-primOpTag (VecBroadcastOp IntVec 32 W8) = 724-primOpTag (VecBroadcastOp IntVec 16 W16) = 725-primOpTag (VecBroadcastOp IntVec 8 W32) = 726-primOpTag (VecBroadcastOp IntVec 4 W64) = 727-primOpTag (VecBroadcastOp IntVec 64 W8) = 728-primOpTag (VecBroadcastOp IntVec 32 W16) = 729-primOpTag (VecBroadcastOp IntVec 16 W32) = 730-primOpTag (VecBroadcastOp IntVec 8 W64) = 731-primOpTag (VecBroadcastOp WordVec 16 W8) = 732-primOpTag (VecBroadcastOp WordVec 8 W16) = 733-primOpTag (VecBroadcastOp WordVec 4 W32) = 734-primOpTag (VecBroadcastOp WordVec 2 W64) = 735-primOpTag (VecBroadcastOp WordVec 32 W8) = 736-primOpTag (VecBroadcastOp WordVec 16 W16) = 737-primOpTag (VecBroadcastOp WordVec 8 W32) = 738-primOpTag (VecBroadcastOp WordVec 4 W64) = 739-primOpTag (VecBroadcastOp WordVec 64 W8) = 740-primOpTag (VecBroadcastOp WordVec 32 W16) = 741-primOpTag (VecBroadcastOp WordVec 16 W32) = 742-primOpTag (VecBroadcastOp WordVec 8 W64) = 743-primOpTag (VecBroadcastOp FloatVec 4 W32) = 744-primOpTag (VecBroadcastOp FloatVec 2 W64) = 745-primOpTag (VecBroadcastOp FloatVec 8 W32) = 746-primOpTag (VecBroadcastOp FloatVec 4 W64) = 747-primOpTag (VecBroadcastOp FloatVec 16 W32) = 748-primOpTag (VecBroadcastOp FloatVec 8 W64) = 749-primOpTag (VecPackOp IntVec 16 W8) = 750-primOpTag (VecPackOp IntVec 8 W16) = 751-primOpTag (VecPackOp IntVec 4 W32) = 752-primOpTag (VecPackOp IntVec 2 W64) = 753-primOpTag (VecPackOp IntVec 32 W8) = 754-primOpTag (VecPackOp IntVec 16 W16) = 755-primOpTag (VecPackOp IntVec 8 W32) = 756-primOpTag (VecPackOp IntVec 4 W64) = 757-primOpTag (VecPackOp IntVec 64 W8) = 758-primOpTag (VecPackOp IntVec 32 W16) = 759-primOpTag (VecPackOp IntVec 16 W32) = 760-primOpTag (VecPackOp IntVec 8 W64) = 761-primOpTag (VecPackOp WordVec 16 W8) = 762-primOpTag (VecPackOp WordVec 8 W16) = 763-primOpTag (VecPackOp WordVec 4 W32) = 764-primOpTag (VecPackOp WordVec 2 W64) = 765-primOpTag (VecPackOp WordVec 32 W8) = 766-primOpTag (VecPackOp WordVec 16 W16) = 767-primOpTag (VecPackOp WordVec 8 W32) = 768-primOpTag (VecPackOp WordVec 4 W64) = 769-primOpTag (VecPackOp WordVec 64 W8) = 770-primOpTag (VecPackOp WordVec 32 W16) = 771-primOpTag (VecPackOp WordVec 16 W32) = 772-primOpTag (VecPackOp WordVec 8 W64) = 773-primOpTag (VecPackOp FloatVec 4 W32) = 774-primOpTag (VecPackOp FloatVec 2 W64) = 775-primOpTag (VecPackOp FloatVec 8 W32) = 776-primOpTag (VecPackOp FloatVec 4 W64) = 777-primOpTag (VecPackOp FloatVec 16 W32) = 778-primOpTag (VecPackOp FloatVec 8 W64) = 779-primOpTag (VecUnpackOp IntVec 16 W8) = 780-primOpTag (VecUnpackOp IntVec 8 W16) = 781-primOpTag (VecUnpackOp IntVec 4 W32) = 782-primOpTag (VecUnpackOp IntVec 2 W64) = 783-primOpTag (VecUnpackOp IntVec 32 W8) = 784-primOpTag (VecUnpackOp IntVec 16 W16) = 785-primOpTag (VecUnpackOp IntVec 8 W32) = 786-primOpTag (VecUnpackOp IntVec 4 W64) = 787-primOpTag (VecUnpackOp IntVec 64 W8) = 788-primOpTag (VecUnpackOp IntVec 32 W16) = 789-primOpTag (VecUnpackOp IntVec 16 W32) = 790-primOpTag (VecUnpackOp IntVec 8 W64) = 791-primOpTag (VecUnpackOp WordVec 16 W8) = 792-primOpTag (VecUnpackOp WordVec 8 W16) = 793-primOpTag (VecUnpackOp WordVec 4 W32) = 794-primOpTag (VecUnpackOp WordVec 2 W64) = 795-primOpTag (VecUnpackOp WordVec 32 W8) = 796-primOpTag (VecUnpackOp WordVec 16 W16) = 797-primOpTag (VecUnpackOp WordVec 8 W32) = 798-primOpTag (VecUnpackOp WordVec 4 W64) = 799-primOpTag (VecUnpackOp WordVec 64 W8) = 800-primOpTag (VecUnpackOp WordVec 32 W16) = 801-primOpTag (VecUnpackOp WordVec 16 W32) = 802-primOpTag (VecUnpackOp WordVec 8 W64) = 803-primOpTag (VecUnpackOp FloatVec 4 W32) = 804-primOpTag (VecUnpackOp FloatVec 2 W64) = 805-primOpTag (VecUnpackOp FloatVec 8 W32) = 806-primOpTag (VecUnpackOp FloatVec 4 W64) = 807-primOpTag (VecUnpackOp FloatVec 16 W32) = 808-primOpTag (VecUnpackOp FloatVec 8 W64) = 809-primOpTag (VecInsertOp IntVec 16 W8) = 810-primOpTag (VecInsertOp IntVec 8 W16) = 811-primOpTag (VecInsertOp IntVec 4 W32) = 812-primOpTag (VecInsertOp IntVec 2 W64) = 813-primOpTag (VecInsertOp IntVec 32 W8) = 814-primOpTag (VecInsertOp IntVec 16 W16) = 815-primOpTag (VecInsertOp IntVec 8 W32) = 816-primOpTag (VecInsertOp IntVec 4 W64) = 817-primOpTag (VecInsertOp IntVec 64 W8) = 818-primOpTag (VecInsertOp IntVec 32 W16) = 819-primOpTag (VecInsertOp IntVec 16 W32) = 820-primOpTag (VecInsertOp IntVec 8 W64) = 821-primOpTag (VecInsertOp WordVec 16 W8) = 822-primOpTag (VecInsertOp WordVec 8 W16) = 823-primOpTag (VecInsertOp WordVec 4 W32) = 824-primOpTag (VecInsertOp WordVec 2 W64) = 825-primOpTag (VecInsertOp WordVec 32 W8) = 826-primOpTag (VecInsertOp WordVec 16 W16) = 827-primOpTag (VecInsertOp WordVec 8 W32) = 828-primOpTag (VecInsertOp WordVec 4 W64) = 829-primOpTag (VecInsertOp WordVec 64 W8) = 830-primOpTag (VecInsertOp WordVec 32 W16) = 831-primOpTag (VecInsertOp WordVec 16 W32) = 832-primOpTag (VecInsertOp WordVec 8 W64) = 833-primOpTag (VecInsertOp FloatVec 4 W32) = 834-primOpTag (VecInsertOp FloatVec 2 W64) = 835-primOpTag (VecInsertOp FloatVec 8 W32) = 836-primOpTag (VecInsertOp FloatVec 4 W64) = 837-primOpTag (VecInsertOp FloatVec 16 W32) = 838-primOpTag (VecInsertOp FloatVec 8 W64) = 839-primOpTag (VecAddOp IntVec 16 W8) = 840-primOpTag (VecAddOp IntVec 8 W16) = 841-primOpTag (VecAddOp IntVec 4 W32) = 842-primOpTag (VecAddOp IntVec 2 W64) = 843-primOpTag (VecAddOp IntVec 32 W8) = 844-primOpTag (VecAddOp IntVec 16 W16) = 845-primOpTag (VecAddOp IntVec 8 W32) = 846-primOpTag (VecAddOp IntVec 4 W64) = 847-primOpTag (VecAddOp IntVec 64 W8) = 848-primOpTag (VecAddOp IntVec 32 W16) = 849-primOpTag (VecAddOp IntVec 16 W32) = 850-primOpTag (VecAddOp IntVec 8 W64) = 851-primOpTag (VecAddOp WordVec 16 W8) = 852-primOpTag (VecAddOp WordVec 8 W16) = 853-primOpTag (VecAddOp WordVec 4 W32) = 854-primOpTag (VecAddOp WordVec 2 W64) = 855-primOpTag (VecAddOp WordVec 32 W8) = 856-primOpTag (VecAddOp WordVec 16 W16) = 857-primOpTag (VecAddOp WordVec 8 W32) = 858-primOpTag (VecAddOp WordVec 4 W64) = 859-primOpTag (VecAddOp WordVec 64 W8) = 860-primOpTag (VecAddOp WordVec 32 W16) = 861-primOpTag (VecAddOp WordVec 16 W32) = 862-primOpTag (VecAddOp WordVec 8 W64) = 863-primOpTag (VecAddOp FloatVec 4 W32) = 864-primOpTag (VecAddOp FloatVec 2 W64) = 865-primOpTag (VecAddOp FloatVec 8 W32) = 866-primOpTag (VecAddOp FloatVec 4 W64) = 867-primOpTag (VecAddOp FloatVec 16 W32) = 868-primOpTag (VecAddOp FloatVec 8 W64) = 869-primOpTag (VecSubOp IntVec 16 W8) = 870-primOpTag (VecSubOp IntVec 8 W16) = 871-primOpTag (VecSubOp IntVec 4 W32) = 872-primOpTag (VecSubOp IntVec 2 W64) = 873-primOpTag (VecSubOp IntVec 32 W8) = 874-primOpTag (VecSubOp IntVec 16 W16) = 875-primOpTag (VecSubOp IntVec 8 W32) = 876-primOpTag (VecSubOp IntVec 4 W64) = 877-primOpTag (VecSubOp IntVec 64 W8) = 878-primOpTag (VecSubOp IntVec 32 W16) = 879-primOpTag (VecSubOp IntVec 16 W32) = 880-primOpTag (VecSubOp IntVec 8 W64) = 881-primOpTag (VecSubOp WordVec 16 W8) = 882-primOpTag (VecSubOp WordVec 8 W16) = 883-primOpTag (VecSubOp WordVec 4 W32) = 884-primOpTag (VecSubOp WordVec 2 W64) = 885-primOpTag (VecSubOp WordVec 32 W8) = 886-primOpTag (VecSubOp WordVec 16 W16) = 887-primOpTag (VecSubOp WordVec 8 W32) = 888-primOpTag (VecSubOp WordVec 4 W64) = 889-primOpTag (VecSubOp WordVec 64 W8) = 890-primOpTag (VecSubOp WordVec 32 W16) = 891-primOpTag (VecSubOp WordVec 16 W32) = 892-primOpTag (VecSubOp WordVec 8 W64) = 893-primOpTag (VecSubOp FloatVec 4 W32) = 894-primOpTag (VecSubOp FloatVec 2 W64) = 895-primOpTag (VecSubOp FloatVec 8 W32) = 896-primOpTag (VecSubOp FloatVec 4 W64) = 897-primOpTag (VecSubOp FloatVec 16 W32) = 898-primOpTag (VecSubOp FloatVec 8 W64) = 899-primOpTag (VecMulOp IntVec 16 W8) = 900-primOpTag (VecMulOp IntVec 8 W16) = 901-primOpTag (VecMulOp IntVec 4 W32) = 902-primOpTag (VecMulOp IntVec 2 W64) = 903-primOpTag (VecMulOp IntVec 32 W8) = 904-primOpTag (VecMulOp IntVec 16 W16) = 905-primOpTag (VecMulOp IntVec 8 W32) = 906-primOpTag (VecMulOp IntVec 4 W64) = 907-primOpTag (VecMulOp IntVec 64 W8) = 908-primOpTag (VecMulOp IntVec 32 W16) = 909-primOpTag (VecMulOp IntVec 16 W32) = 910-primOpTag (VecMulOp IntVec 8 W64) = 911-primOpTag (VecMulOp WordVec 16 W8) = 912-primOpTag (VecMulOp WordVec 8 W16) = 913-primOpTag (VecMulOp WordVec 4 W32) = 914-primOpTag (VecMulOp WordVec 2 W64) = 915-primOpTag (VecMulOp WordVec 32 W8) = 916-primOpTag (VecMulOp WordVec 16 W16) = 917-primOpTag (VecMulOp WordVec 8 W32) = 918-primOpTag (VecMulOp WordVec 4 W64) = 919-primOpTag (VecMulOp WordVec 64 W8) = 920-primOpTag (VecMulOp WordVec 32 W16) = 921-primOpTag (VecMulOp WordVec 16 W32) = 922-primOpTag (VecMulOp WordVec 8 W64) = 923-primOpTag (VecMulOp FloatVec 4 W32) = 924-primOpTag (VecMulOp FloatVec 2 W64) = 925-primOpTag (VecMulOp FloatVec 8 W32) = 926-primOpTag (VecMulOp FloatVec 4 W64) = 927-primOpTag (VecMulOp FloatVec 16 W32) = 928-primOpTag (VecMulOp FloatVec 8 W64) = 929-primOpTag (VecDivOp FloatVec 4 W32) = 930-primOpTag (VecDivOp FloatVec 2 W64) = 931-primOpTag (VecDivOp FloatVec 8 W32) = 932-primOpTag (VecDivOp FloatVec 4 W64) = 933-primOpTag (VecDivOp FloatVec 16 W32) = 934-primOpTag (VecDivOp FloatVec 8 W64) = 935-primOpTag (VecQuotOp IntVec 16 W8) = 936-primOpTag (VecQuotOp IntVec 8 W16) = 937-primOpTag (VecQuotOp IntVec 4 W32) = 938-primOpTag (VecQuotOp IntVec 2 W64) = 939-primOpTag (VecQuotOp IntVec 32 W8) = 940-primOpTag (VecQuotOp IntVec 16 W16) = 941-primOpTag (VecQuotOp IntVec 8 W32) = 942-primOpTag (VecQuotOp IntVec 4 W64) = 943-primOpTag (VecQuotOp IntVec 64 W8) = 944-primOpTag (VecQuotOp IntVec 32 W16) = 945-primOpTag (VecQuotOp IntVec 16 W32) = 946-primOpTag (VecQuotOp IntVec 8 W64) = 947-primOpTag (VecQuotOp WordVec 16 W8) = 948-primOpTag (VecQuotOp WordVec 8 W16) = 949-primOpTag (VecQuotOp WordVec 4 W32) = 950-primOpTag (VecQuotOp WordVec 2 W64) = 951-primOpTag (VecQuotOp WordVec 32 W8) = 952-primOpTag (VecQuotOp WordVec 16 W16) = 953-primOpTag (VecQuotOp WordVec 8 W32) = 954-primOpTag (VecQuotOp WordVec 4 W64) = 955-primOpTag (VecQuotOp WordVec 64 W8) = 956-primOpTag (VecQuotOp WordVec 32 W16) = 957-primOpTag (VecQuotOp WordVec 16 W32) = 958-primOpTag (VecQuotOp WordVec 8 W64) = 959-primOpTag (VecRemOp IntVec 16 W8) = 960-primOpTag (VecRemOp IntVec 8 W16) = 961-primOpTag (VecRemOp IntVec 4 W32) = 962-primOpTag (VecRemOp IntVec 2 W64) = 963-primOpTag (VecRemOp IntVec 32 W8) = 964-primOpTag (VecRemOp IntVec 16 W16) = 965-primOpTag (VecRemOp IntVec 8 W32) = 966-primOpTag (VecRemOp IntVec 4 W64) = 967-primOpTag (VecRemOp IntVec 64 W8) = 968-primOpTag (VecRemOp IntVec 32 W16) = 969-primOpTag (VecRemOp IntVec 16 W32) = 970-primOpTag (VecRemOp IntVec 8 W64) = 971-primOpTag (VecRemOp WordVec 16 W8) = 972-primOpTag (VecRemOp WordVec 8 W16) = 973-primOpTag (VecRemOp WordVec 4 W32) = 974-primOpTag (VecRemOp WordVec 2 W64) = 975-primOpTag (VecRemOp WordVec 32 W8) = 976-primOpTag (VecRemOp WordVec 16 W16) = 977-primOpTag (VecRemOp WordVec 8 W32) = 978-primOpTag (VecRemOp WordVec 4 W64) = 979-primOpTag (VecRemOp WordVec 64 W8) = 980-primOpTag (VecRemOp WordVec 32 W16) = 981-primOpTag (VecRemOp WordVec 16 W32) = 982-primOpTag (VecRemOp WordVec 8 W64) = 983-primOpTag (VecNegOp IntVec 16 W8) = 984-primOpTag (VecNegOp IntVec 8 W16) = 985-primOpTag (VecNegOp IntVec 4 W32) = 986-primOpTag (VecNegOp IntVec 2 W64) = 987-primOpTag (VecNegOp IntVec 32 W8) = 988-primOpTag (VecNegOp IntVec 16 W16) = 989-primOpTag (VecNegOp IntVec 8 W32) = 990-primOpTag (VecNegOp IntVec 4 W64) = 991-primOpTag (VecNegOp IntVec 64 W8) = 992-primOpTag (VecNegOp IntVec 32 W16) = 993-primOpTag (VecNegOp IntVec 16 W32) = 994-primOpTag (VecNegOp IntVec 8 W64) = 995-primOpTag (VecNegOp FloatVec 4 W32) = 996-primOpTag (VecNegOp FloatVec 2 W64) = 997-primOpTag (VecNegOp FloatVec 8 W32) = 998-primOpTag (VecNegOp FloatVec 4 W64) = 999-primOpTag (VecNegOp FloatVec 16 W32) = 1000-primOpTag (VecNegOp FloatVec 8 W64) = 1001-primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 1002-primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 1003-primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 1004-primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 1005-primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 1006-primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 1007-primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 1008-primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 1009-primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 1010-primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 1011-primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 1012-primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 1013-primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 1014-primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 1015-primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 1016-primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 1017-primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 1018-primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 1019-primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 1020-primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 1021-primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 1022-primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 1023-primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 1024-primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 1025-primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 1026-primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 1027-primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 1028-primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 1029-primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 1030-primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 1031-primOpTag (VecReadByteArrayOp IntVec 16 W8) = 1032-primOpTag (VecReadByteArrayOp IntVec 8 W16) = 1033-primOpTag (VecReadByteArrayOp IntVec 4 W32) = 1034-primOpTag (VecReadByteArrayOp IntVec 2 W64) = 1035-primOpTag (VecReadByteArrayOp IntVec 32 W8) = 1036-primOpTag (VecReadByteArrayOp IntVec 16 W16) = 1037-primOpTag (VecReadByteArrayOp IntVec 8 W32) = 1038-primOpTag (VecReadByteArrayOp IntVec 4 W64) = 1039-primOpTag (VecReadByteArrayOp IntVec 64 W8) = 1040-primOpTag (VecReadByteArrayOp IntVec 32 W16) = 1041-primOpTag (VecReadByteArrayOp IntVec 16 W32) = 1042-primOpTag (VecReadByteArrayOp IntVec 8 W64) = 1043-primOpTag (VecReadByteArrayOp WordVec 16 W8) = 1044-primOpTag (VecReadByteArrayOp WordVec 8 W16) = 1045-primOpTag (VecReadByteArrayOp WordVec 4 W32) = 1046-primOpTag (VecReadByteArrayOp WordVec 2 W64) = 1047-primOpTag (VecReadByteArrayOp WordVec 32 W8) = 1048-primOpTag (VecReadByteArrayOp WordVec 16 W16) = 1049-primOpTag (VecReadByteArrayOp WordVec 8 W32) = 1050-primOpTag (VecReadByteArrayOp WordVec 4 W64) = 1051-primOpTag (VecReadByteArrayOp WordVec 64 W8) = 1052-primOpTag (VecReadByteArrayOp WordVec 32 W16) = 1053-primOpTag (VecReadByteArrayOp WordVec 16 W32) = 1054-primOpTag (VecReadByteArrayOp WordVec 8 W64) = 1055-primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 1056-primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 1057-primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 1058-primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 1059-primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 1060-primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 1061-primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 1062-primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 1063-primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 1064-primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 1065-primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 1066-primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 1067-primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 1068-primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 1069-primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 1070-primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 1071-primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 1072-primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 1073-primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 1074-primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 1075-primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 1076-primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 1077-primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 1078-primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 1079-primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 1080-primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 1081-primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 1082-primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 1083-primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 1084-primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 1085-primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 1086-primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 1087-primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 1088-primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 1089-primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 1090-primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 1091-primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 1092-primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 1093-primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1094-primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1095-primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1096-primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1097-primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1098-primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1099-primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1100-primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1101-primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1102-primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1103-primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1104-primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1105-primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1106-primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1107-primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1108-primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1109-primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1110-primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1111-primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1112-primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1113-primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1114-primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1115-primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1116-primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1117-primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1118-primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1119-primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1120-primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1121-primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1122-primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1123-primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1124-primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1125-primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1126-primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1127-primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1128-primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1129-primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1130-primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1131-primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1132-primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1133-primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1134-primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1135-primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1136-primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1137-primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1138-primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1139-primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1140-primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1141-primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1142-primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1143-primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1144-primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1145-primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1146-primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1147-primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1148-primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1149-primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1150-primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1151-primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1152-primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1153-primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1154-primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1155-primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1156-primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1157-primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1158-primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1159-primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1160-primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1161-primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1162-primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1163-primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1164-primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1165-primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1166-primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1167-primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1168-primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1169-primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1170-primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1171-primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1172-primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1173-primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1174-primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1175-primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1176-primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1177-primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1178-primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1179-primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1180-primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1181-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1182-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1183-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1184-primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1185-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1186-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1187-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1188-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1189-primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1190-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1191-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1192-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1193-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1194-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1195-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1196-primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1197-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1198-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1199-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1200-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1201-primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1202-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1203-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1204-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1205-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1206-primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1207-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1208-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1209-primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1210-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1211-primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1212-primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1213-primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1214-primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1215-primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1216-primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1217-primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1218-primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1219-primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1220-primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1221-primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1222-primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1223-primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1224-primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1225-primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1226-primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1227-primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1228-primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1229-primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1230-primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1231-primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1232-primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1233-primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1234-primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1235-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1236-primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1237-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1238-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1239-primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1240-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1241-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1242-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1243-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1244-primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1245-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1246-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1247-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1248-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1249-primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1250-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1251-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1252-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1253-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1254-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1255-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1256-primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1257-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1258-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1259-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1260-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1261-primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1262-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1263-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1264-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1265-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1266-primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1267-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1268-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1269-primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1270-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1271-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1272-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1273-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1274-primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1275-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1276-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1277-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1278-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1279-primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1280-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1281-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1282-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1283-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1284-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1285-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1286-primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1287-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1288-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1289-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1290-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1291-primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1292-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1293-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1294-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1295-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1296-primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1297-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1298-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1299-primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1300-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1301-primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1302-primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1303-primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1304-primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1305-primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1306-primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1307-primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1308-primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1309-primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1310-primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1311-primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1312-primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1313-primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1314-primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1315-primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1316-primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1317-primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1318-primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1319-primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1320-primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1321-primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1322-primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1323-primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1324-primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1325-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1326-primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1327-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1328-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1329-primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1330-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1331-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1332-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1333-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1334-primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1335-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1336-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1337-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1338-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1339-primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1340-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1341-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1342-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1343-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1344-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1345-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1346-primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1347-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1348-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1349-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1350-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1351-primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1352-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1353-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1354-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1355-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1356-primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1357-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1358-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1359-primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1360-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1361-primOpTag (VecFMAdd FloatVec 4 W32) = 1362-primOpTag (VecFMAdd FloatVec 2 W64) = 1363-primOpTag (VecFMAdd FloatVec 8 W32) = 1364-primOpTag (VecFMAdd FloatVec 4 W64) = 1365-primOpTag (VecFMAdd FloatVec 16 W32) = 1366-primOpTag (VecFMAdd FloatVec 8 W64) = 1367-primOpTag (VecFMSub FloatVec 4 W32) = 1368-primOpTag (VecFMSub FloatVec 2 W64) = 1369-primOpTag (VecFMSub FloatVec 8 W32) = 1370-primOpTag (VecFMSub FloatVec 4 W64) = 1371-primOpTag (VecFMSub FloatVec 16 W32) = 1372-primOpTag (VecFMSub FloatVec 8 W64) = 1373-primOpTag (VecFNMAdd FloatVec 4 W32) = 1374-primOpTag (VecFNMAdd FloatVec 2 W64) = 1375-primOpTag (VecFNMAdd FloatVec 8 W32) = 1376-primOpTag (VecFNMAdd FloatVec 4 W64) = 1377-primOpTag (VecFNMAdd FloatVec 16 W32) = 1378-primOpTag (VecFNMAdd FloatVec 8 W64) = 1379-primOpTag (VecFNMSub FloatVec 4 W32) = 1380-primOpTag (VecFNMSub FloatVec 2 W64) = 1381-primOpTag (VecFNMSub FloatVec 8 W32) = 1382-primOpTag (VecFNMSub FloatVec 4 W64) = 1383-primOpTag (VecFNMSub FloatVec 16 W32) = 1384-primOpTag (VecFNMSub FloatVec 8 W64) = 1385-primOpTag (VecShuffleOp IntVec 16 W8) = 1386-primOpTag (VecShuffleOp IntVec 8 W16) = 1387-primOpTag (VecShuffleOp IntVec 4 W32) = 1388-primOpTag (VecShuffleOp IntVec 2 W64) = 1389-primOpTag (VecShuffleOp IntVec 32 W8) = 1390-primOpTag (VecShuffleOp IntVec 16 W16) = 1391-primOpTag (VecShuffleOp IntVec 8 W32) = 1392-primOpTag (VecShuffleOp IntVec 4 W64) = 1393-primOpTag (VecShuffleOp IntVec 64 W8) = 1394-primOpTag (VecShuffleOp IntVec 32 W16) = 1395-primOpTag (VecShuffleOp IntVec 16 W32) = 1396-primOpTag (VecShuffleOp IntVec 8 W64) = 1397-primOpTag (VecShuffleOp WordVec 16 W8) = 1398-primOpTag (VecShuffleOp WordVec 8 W16) = 1399-primOpTag (VecShuffleOp WordVec 4 W32) = 1400-primOpTag (VecShuffleOp WordVec 2 W64) = 1401-primOpTag (VecShuffleOp WordVec 32 W8) = 1402-primOpTag (VecShuffleOp WordVec 16 W16) = 1403-primOpTag (VecShuffleOp WordVec 8 W32) = 1404-primOpTag (VecShuffleOp WordVec 4 W64) = 1405-primOpTag (VecShuffleOp WordVec 64 W8) = 1406-primOpTag (VecShuffleOp WordVec 32 W16) = 1407-primOpTag (VecShuffleOp WordVec 16 W32) = 1408-primOpTag (VecShuffleOp WordVec 8 W64) = 1409-primOpTag (VecShuffleOp FloatVec 4 W32) = 1410-primOpTag (VecShuffleOp FloatVec 2 W64) = 1411-primOpTag (VecShuffleOp FloatVec 8 W32) = 1412-primOpTag (VecShuffleOp FloatVec 4 W64) = 1413-primOpTag (VecShuffleOp FloatVec 16 W32) = 1414-primOpTag (VecShuffleOp FloatVec 8 W64) = 1415-primOpTag (VecMinOp IntVec 16 W8) = 1416-primOpTag (VecMinOp IntVec 8 W16) = 1417-primOpTag (VecMinOp IntVec 4 W32) = 1418-primOpTag (VecMinOp IntVec 2 W64) = 1419-primOpTag (VecMinOp IntVec 32 W8) = 1420-primOpTag (VecMinOp IntVec 16 W16) = 1421-primOpTag (VecMinOp IntVec 8 W32) = 1422-primOpTag (VecMinOp IntVec 4 W64) = 1423-primOpTag (VecMinOp IntVec 64 W8) = 1424-primOpTag (VecMinOp IntVec 32 W16) = 1425-primOpTag (VecMinOp IntVec 16 W32) = 1426-primOpTag (VecMinOp IntVec 8 W64) = 1427-primOpTag (VecMinOp WordVec 16 W8) = 1428-primOpTag (VecMinOp WordVec 8 W16) = 1429-primOpTag (VecMinOp WordVec 4 W32) = 1430-primOpTag (VecMinOp WordVec 2 W64) = 1431-primOpTag (VecMinOp WordVec 32 W8) = 1432-primOpTag (VecMinOp WordVec 16 W16) = 1433-primOpTag (VecMinOp WordVec 8 W32) = 1434-primOpTag (VecMinOp WordVec 4 W64) = 1435-primOpTag (VecMinOp WordVec 64 W8) = 1436-primOpTag (VecMinOp WordVec 32 W16) = 1437-primOpTag (VecMinOp WordVec 16 W32) = 1438-primOpTag (VecMinOp WordVec 8 W64) = 1439-primOpTag (VecMinOp FloatVec 4 W32) = 1440-primOpTag (VecMinOp FloatVec 2 W64) = 1441-primOpTag (VecMinOp FloatVec 8 W32) = 1442-primOpTag (VecMinOp FloatVec 4 W64) = 1443-primOpTag (VecMinOp FloatVec 16 W32) = 1444-primOpTag (VecMinOp FloatVec 8 W64) = 1445-primOpTag (VecMaxOp IntVec 16 W8) = 1446-primOpTag (VecMaxOp IntVec 8 W16) = 1447-primOpTag (VecMaxOp IntVec 4 W32) = 1448-primOpTag (VecMaxOp IntVec 2 W64) = 1449-primOpTag (VecMaxOp IntVec 32 W8) = 1450-primOpTag (VecMaxOp IntVec 16 W16) = 1451-primOpTag (VecMaxOp IntVec 8 W32) = 1452-primOpTag (VecMaxOp IntVec 4 W64) = 1453-primOpTag (VecMaxOp IntVec 64 W8) = 1454-primOpTag (VecMaxOp IntVec 32 W16) = 1455-primOpTag (VecMaxOp IntVec 16 W32) = 1456-primOpTag (VecMaxOp IntVec 8 W64) = 1457-primOpTag (VecMaxOp WordVec 16 W8) = 1458-primOpTag (VecMaxOp WordVec 8 W16) = 1459-primOpTag (VecMaxOp WordVec 4 W32) = 1460-primOpTag (VecMaxOp WordVec 2 W64) = 1461-primOpTag (VecMaxOp WordVec 32 W8) = 1462-primOpTag (VecMaxOp WordVec 16 W16) = 1463-primOpTag (VecMaxOp WordVec 8 W32) = 1464-primOpTag (VecMaxOp WordVec 4 W64) = 1465-primOpTag (VecMaxOp WordVec 64 W8) = 1466-primOpTag (VecMaxOp WordVec 32 W16) = 1467-primOpTag (VecMaxOp WordVec 16 W32) = 1468-primOpTag (VecMaxOp WordVec 8 W64) = 1469-primOpTag (VecMaxOp FloatVec 4 W32) = 1470-primOpTag (VecMaxOp FloatVec 2 W64) = 1471-primOpTag (VecMaxOp FloatVec 8 W32) = 1472-primOpTag (VecMaxOp FloatVec 4 W64) = 1473-primOpTag (VecMaxOp FloatVec 16 W32) = 1474-primOpTag (VecMaxOp FloatVec 8 W64) = 1475-primOpTag PrefetchByteArrayOp3 = 1476-primOpTag PrefetchMutableByteArrayOp3 = 1477-primOpTag PrefetchAddrOp3 = 1478-primOpTag PrefetchValueOp3 = 1479-primOpTag PrefetchByteArrayOp2 = 1480-primOpTag PrefetchMutableByteArrayOp2 = 1481-primOpTag PrefetchAddrOp2 = 1482-primOpTag PrefetchValueOp2 = 1483-primOpTag PrefetchByteArrayOp1 = 1484-primOpTag PrefetchMutableByteArrayOp1 = 1485-primOpTag PrefetchAddrOp1 = 1486-primOpTag PrefetchValueOp1 = 1487-primOpTag PrefetchByteArrayOp0 = 1488-primOpTag PrefetchMutableByteArrayOp0 = 1489-primOpTag PrefetchAddrOp0 = 1490-primOpTag PrefetchValueOp0 = 1491+maxPrimOpTag = 1490+primOpTag :: PrimOp -> Int+primOpTag CharGtOp = 0+primOpTag CharGeOp = 1+primOpTag CharEqOp = 2+primOpTag CharNeOp = 3+primOpTag CharLtOp = 4+primOpTag CharLeOp = 5+primOpTag OrdOp = 6+primOpTag Int8ToIntOp = 7+primOpTag IntToInt8Op = 8+primOpTag Int8NegOp = 9+primOpTag Int8AddOp = 10+primOpTag Int8SubOp = 11+primOpTag Int8MulOp = 12+primOpTag Int8QuotOp = 13+primOpTag Int8RemOp = 14+primOpTag Int8QuotRemOp = 15+primOpTag Int8SllOp = 16+primOpTag Int8SraOp = 17+primOpTag Int8SrlOp = 18+primOpTag Int8ToWord8Op = 19+primOpTag Int8EqOp = 20+primOpTag Int8GeOp = 21+primOpTag Int8GtOp = 22+primOpTag Int8LeOp = 23+primOpTag Int8LtOp = 24+primOpTag Int8NeOp = 25+primOpTag Word8ToWordOp = 26+primOpTag WordToWord8Op = 27+primOpTag Word8AddOp = 28+primOpTag Word8SubOp = 29+primOpTag Word8MulOp = 30+primOpTag Word8QuotOp = 31+primOpTag Word8RemOp = 32+primOpTag Word8QuotRemOp = 33+primOpTag Word8AndOp = 34+primOpTag Word8OrOp = 35+primOpTag Word8XorOp = 36+primOpTag Word8NotOp = 37+primOpTag Word8SllOp = 38+primOpTag Word8SrlOp = 39+primOpTag Word8ToInt8Op = 40+primOpTag Word8EqOp = 41+primOpTag Word8GeOp = 42+primOpTag Word8GtOp = 43+primOpTag Word8LeOp = 44+primOpTag Word8LtOp = 45+primOpTag Word8NeOp = 46+primOpTag Int16ToIntOp = 47+primOpTag IntToInt16Op = 48+primOpTag Int16NegOp = 49+primOpTag Int16AddOp = 50+primOpTag Int16SubOp = 51+primOpTag Int16MulOp = 52+primOpTag Int16QuotOp = 53+primOpTag Int16RemOp = 54+primOpTag Int16QuotRemOp = 55+primOpTag Int16SllOp = 56+primOpTag Int16SraOp = 57+primOpTag Int16SrlOp = 58+primOpTag Int16ToWord16Op = 59+primOpTag Int16EqOp = 60+primOpTag Int16GeOp = 61+primOpTag Int16GtOp = 62+primOpTag Int16LeOp = 63+primOpTag Int16LtOp = 64+primOpTag Int16NeOp = 65+primOpTag Word16ToWordOp = 66+primOpTag WordToWord16Op = 67+primOpTag Word16AddOp = 68+primOpTag Word16SubOp = 69+primOpTag Word16MulOp = 70+primOpTag Word16QuotOp = 71+primOpTag Word16RemOp = 72+primOpTag Word16QuotRemOp = 73+primOpTag Word16AndOp = 74+primOpTag Word16OrOp = 75+primOpTag Word16XorOp = 76+primOpTag Word16NotOp = 77+primOpTag Word16SllOp = 78+primOpTag Word16SrlOp = 79+primOpTag Word16ToInt16Op = 80+primOpTag Word16EqOp = 81+primOpTag Word16GeOp = 82+primOpTag Word16GtOp = 83+primOpTag Word16LeOp = 84+primOpTag Word16LtOp = 85+primOpTag Word16NeOp = 86+primOpTag Int32ToIntOp = 87+primOpTag IntToInt32Op = 88+primOpTag Int32NegOp = 89+primOpTag Int32AddOp = 90+primOpTag Int32SubOp = 91+primOpTag Int32MulOp = 92+primOpTag Int32QuotOp = 93+primOpTag Int32RemOp = 94+primOpTag Int32QuotRemOp = 95+primOpTag Int32SllOp = 96+primOpTag Int32SraOp = 97+primOpTag Int32SrlOp = 98+primOpTag Int32ToWord32Op = 99+primOpTag Int32EqOp = 100+primOpTag Int32GeOp = 101+primOpTag Int32GtOp = 102+primOpTag Int32LeOp = 103+primOpTag Int32LtOp = 104+primOpTag Int32NeOp = 105+primOpTag Word32ToWordOp = 106+primOpTag WordToWord32Op = 107+primOpTag Word32AddOp = 108+primOpTag Word32SubOp = 109+primOpTag Word32MulOp = 110+primOpTag Word32QuotOp = 111+primOpTag Word32RemOp = 112+primOpTag Word32QuotRemOp = 113+primOpTag Word32AndOp = 114+primOpTag Word32OrOp = 115+primOpTag Word32XorOp = 116+primOpTag Word32NotOp = 117+primOpTag Word32SllOp = 118+primOpTag Word32SrlOp = 119+primOpTag Word32ToInt32Op = 120+primOpTag Word32EqOp = 121+primOpTag Word32GeOp = 122+primOpTag Word32GtOp = 123+primOpTag Word32LeOp = 124+primOpTag Word32LtOp = 125+primOpTag Word32NeOp = 126+primOpTag Int64ToIntOp = 127+primOpTag IntToInt64Op = 128+primOpTag Int64NegOp = 129+primOpTag Int64AddOp = 130+primOpTag Int64SubOp = 131+primOpTag Int64MulOp = 132+primOpTag Int64QuotOp = 133+primOpTag Int64RemOp = 134+primOpTag Int64SllOp = 135+primOpTag Int64SraOp = 136+primOpTag Int64SrlOp = 137+primOpTag Int64ToWord64Op = 138+primOpTag Int64EqOp = 139+primOpTag Int64GeOp = 140+primOpTag Int64GtOp = 141+primOpTag Int64LeOp = 142+primOpTag Int64LtOp = 143+primOpTag Int64NeOp = 144+primOpTag Word64ToWordOp = 145+primOpTag WordToWord64Op = 146+primOpTag Word64AddOp = 147+primOpTag Word64SubOp = 148+primOpTag Word64MulOp = 149+primOpTag Word64QuotOp = 150+primOpTag Word64RemOp = 151+primOpTag Word64AndOp = 152+primOpTag Word64OrOp = 153+primOpTag Word64XorOp = 154+primOpTag Word64NotOp = 155+primOpTag Word64SllOp = 156+primOpTag Word64SrlOp = 157+primOpTag Word64ToInt64Op = 158+primOpTag Word64EqOp = 159+primOpTag Word64GeOp = 160+primOpTag Word64GtOp = 161+primOpTag Word64LeOp = 162+primOpTag Word64LtOp = 163+primOpTag Word64NeOp = 164+primOpTag IntAddOp = 165+primOpTag IntSubOp = 166+primOpTag IntMulOp = 167+primOpTag IntMul2Op = 168+primOpTag IntMulMayOfloOp = 169+primOpTag IntQuotOp = 170+primOpTag IntRemOp = 171+primOpTag IntQuotRemOp = 172+primOpTag IntAndOp = 173+primOpTag IntOrOp = 174+primOpTag IntXorOp = 175+primOpTag IntNotOp = 176+primOpTag IntNegOp = 177+primOpTag IntAddCOp = 178+primOpTag IntSubCOp = 179+primOpTag IntGtOp = 180+primOpTag IntGeOp = 181+primOpTag IntEqOp = 182+primOpTag IntNeOp = 183+primOpTag IntLtOp = 184+primOpTag IntLeOp = 185+primOpTag ChrOp = 186+primOpTag IntToWordOp = 187+primOpTag IntToFloatOp = 188+primOpTag IntToDoubleOp = 189+primOpTag WordToFloatOp = 190+primOpTag WordToDoubleOp = 191+primOpTag IntSllOp = 192+primOpTag IntSraOp = 193+primOpTag IntSrlOp = 194+primOpTag WordAddOp = 195+primOpTag WordAddCOp = 196+primOpTag WordSubCOp = 197+primOpTag WordAdd2Op = 198+primOpTag WordSubOp = 199+primOpTag WordMulOp = 200+primOpTag WordMul2Op = 201+primOpTag WordQuotOp = 202+primOpTag WordRemOp = 203+primOpTag WordQuotRemOp = 204+primOpTag WordQuotRem2Op = 205+primOpTag WordAndOp = 206+primOpTag WordOrOp = 207+primOpTag WordXorOp = 208+primOpTag WordNotOp = 209+primOpTag WordSllOp = 210+primOpTag WordSrlOp = 211+primOpTag WordToIntOp = 212+primOpTag WordGtOp = 213+primOpTag WordGeOp = 214+primOpTag WordEqOp = 215+primOpTag WordNeOp = 216+primOpTag WordLtOp = 217+primOpTag WordLeOp = 218+primOpTag PopCnt8Op = 219+primOpTag PopCnt16Op = 220+primOpTag PopCnt32Op = 221+primOpTag PopCnt64Op = 222+primOpTag PopCntOp = 223+primOpTag Pdep8Op = 224+primOpTag Pdep16Op = 225+primOpTag Pdep32Op = 226+primOpTag Pdep64Op = 227+primOpTag PdepOp = 228+primOpTag Pext8Op = 229+primOpTag Pext16Op = 230+primOpTag Pext32Op = 231+primOpTag Pext64Op = 232+primOpTag PextOp = 233+primOpTag Clz8Op = 234+primOpTag Clz16Op = 235+primOpTag Clz32Op = 236+primOpTag Clz64Op = 237+primOpTag ClzOp = 238+primOpTag Ctz8Op = 239+primOpTag Ctz16Op = 240+primOpTag Ctz32Op = 241+primOpTag Ctz64Op = 242+primOpTag CtzOp = 243+primOpTag BSwap16Op = 244+primOpTag BSwap32Op = 245+primOpTag BSwap64Op = 246+primOpTag BSwapOp = 247+primOpTag BRev8Op = 248+primOpTag BRev16Op = 249+primOpTag BRev32Op = 250+primOpTag BRev64Op = 251+primOpTag BRevOp = 252+primOpTag Narrow8IntOp = 253+primOpTag Narrow16IntOp = 254+primOpTag Narrow32IntOp = 255+primOpTag Narrow8WordOp = 256+primOpTag Narrow16WordOp = 257+primOpTag Narrow32WordOp = 258+primOpTag DoubleGtOp = 259+primOpTag DoubleGeOp = 260+primOpTag DoubleEqOp = 261+primOpTag DoubleNeOp = 262+primOpTag DoubleLtOp = 263+primOpTag DoubleLeOp = 264+primOpTag DoubleMinOp = 265+primOpTag DoubleMaxOp = 266+primOpTag DoubleAddOp = 267+primOpTag DoubleSubOp = 268+primOpTag DoubleMulOp = 269+primOpTag DoubleDivOp = 270+primOpTag DoubleNegOp = 271+primOpTag DoubleFabsOp = 272+primOpTag DoubleToIntOp = 273+primOpTag DoubleToFloatOp = 274+primOpTag DoubleExpOp = 275+primOpTag DoubleExpM1Op = 276+primOpTag DoubleLogOp = 277+primOpTag DoubleLog1POp = 278+primOpTag DoubleSqrtOp = 279+primOpTag DoubleSinOp = 280+primOpTag DoubleCosOp = 281+primOpTag DoubleTanOp = 282+primOpTag DoubleAsinOp = 283+primOpTag DoubleAcosOp = 284+primOpTag DoubleAtanOp = 285+primOpTag DoubleSinhOp = 286+primOpTag DoubleCoshOp = 287+primOpTag DoubleTanhOp = 288+primOpTag DoubleAsinhOp = 289+primOpTag DoubleAcoshOp = 290+primOpTag DoubleAtanhOp = 291+primOpTag DoublePowerOp = 292+primOpTag DoubleDecode_2IntOp = 293+primOpTag DoubleDecode_Int64Op = 294+primOpTag CastDoubleToWord64Op = 295+primOpTag CastWord64ToDoubleOp = 296+primOpTag FloatGtOp = 297+primOpTag FloatGeOp = 298+primOpTag FloatEqOp = 299+primOpTag FloatNeOp = 300+primOpTag FloatLtOp = 301+primOpTag FloatLeOp = 302+primOpTag FloatMinOp = 303+primOpTag FloatMaxOp = 304+primOpTag FloatAddOp = 305+primOpTag FloatSubOp = 306+primOpTag FloatMulOp = 307+primOpTag FloatDivOp = 308+primOpTag FloatNegOp = 309+primOpTag FloatFabsOp = 310+primOpTag FloatToIntOp = 311+primOpTag FloatExpOp = 312+primOpTag FloatExpM1Op = 313+primOpTag FloatLogOp = 314+primOpTag FloatLog1POp = 315+primOpTag FloatSqrtOp = 316+primOpTag FloatSinOp = 317+primOpTag FloatCosOp = 318+primOpTag FloatTanOp = 319+primOpTag FloatAsinOp = 320+primOpTag FloatAcosOp = 321+primOpTag FloatAtanOp = 322+primOpTag FloatSinhOp = 323+primOpTag FloatCoshOp = 324+primOpTag FloatTanhOp = 325+primOpTag FloatAsinhOp = 326+primOpTag FloatAcoshOp = 327+primOpTag FloatAtanhOp = 328+primOpTag FloatPowerOp = 329+primOpTag FloatToDoubleOp = 330+primOpTag FloatDecode_IntOp = 331+primOpTag CastFloatToWord32Op = 332+primOpTag CastWord32ToFloatOp = 333+primOpTag FloatFMAdd = 334+primOpTag FloatFMSub = 335+primOpTag FloatFNMAdd = 336+primOpTag FloatFNMSub = 337+primOpTag DoubleFMAdd = 338+primOpTag DoubleFMSub = 339+primOpTag DoubleFNMAdd = 340+primOpTag DoubleFNMSub = 341+primOpTag NewArrayOp = 342+primOpTag ReadArrayOp = 343+primOpTag WriteArrayOp = 344+primOpTag SizeofArrayOp = 345+primOpTag SizeofMutableArrayOp = 346+primOpTag IndexArrayOp = 347+primOpTag UnsafeFreezeArrayOp = 348+primOpTag UnsafeThawArrayOp = 349+primOpTag CopyArrayOp = 350+primOpTag CopyMutableArrayOp = 351+primOpTag CloneArrayOp = 352+primOpTag CloneMutableArrayOp = 353+primOpTag FreezeArrayOp = 354+primOpTag ThawArrayOp = 355+primOpTag CasArrayOp = 356+primOpTag NewSmallArrayOp = 357+primOpTag ShrinkSmallMutableArrayOp_Char = 358+primOpTag ReadSmallArrayOp = 359+primOpTag WriteSmallArrayOp = 360+primOpTag SizeofSmallArrayOp = 361+primOpTag SizeofSmallMutableArrayOp = 362+primOpTag GetSizeofSmallMutableArrayOp = 363+primOpTag IndexSmallArrayOp = 364+primOpTag UnsafeFreezeSmallArrayOp = 365+primOpTag UnsafeThawSmallArrayOp = 366+primOpTag CopySmallArrayOp = 367+primOpTag CopySmallMutableArrayOp = 368+primOpTag CloneSmallArrayOp = 369+primOpTag CloneSmallMutableArrayOp = 370+primOpTag FreezeSmallArrayOp = 371+primOpTag ThawSmallArrayOp = 372+primOpTag CasSmallArrayOp = 373+primOpTag NewByteArrayOp_Char = 374+primOpTag NewPinnedByteArrayOp_Char = 375+primOpTag NewAlignedPinnedByteArrayOp_Char = 376+primOpTag MutableByteArrayIsPinnedOp = 377+primOpTag ByteArrayIsPinnedOp = 378+primOpTag ByteArrayIsWeaklyPinnedOp = 379+primOpTag MutableByteArrayIsWeaklyPinnedOp = 380+primOpTag ByteArrayContents_Char = 381+primOpTag MutableByteArrayContents_Char = 382+primOpTag ShrinkMutableByteArrayOp_Char = 383+primOpTag ResizeMutableByteArrayOp_Char = 384+primOpTag UnsafeFreezeByteArrayOp = 385+primOpTag UnsafeThawByteArrayOp = 386+primOpTag SizeofByteArrayOp = 387+primOpTag SizeofMutableByteArrayOp = 388+primOpTag GetSizeofMutableByteArrayOp = 389+primOpTag IndexByteArrayOp_Char = 390+primOpTag IndexByteArrayOp_WideChar = 391+primOpTag IndexByteArrayOp_Int = 392+primOpTag IndexByteArrayOp_Word = 393+primOpTag IndexByteArrayOp_Addr = 394+primOpTag IndexByteArrayOp_Float = 395+primOpTag IndexByteArrayOp_Double = 396+primOpTag IndexByteArrayOp_StablePtr = 397+primOpTag IndexByteArrayOp_Int8 = 398+primOpTag IndexByteArrayOp_Word8 = 399+primOpTag IndexByteArrayOp_Int16 = 400+primOpTag IndexByteArrayOp_Word16 = 401+primOpTag IndexByteArrayOp_Int32 = 402+primOpTag IndexByteArrayOp_Word32 = 403+primOpTag IndexByteArrayOp_Int64 = 404+primOpTag IndexByteArrayOp_Word64 = 405+primOpTag IndexByteArrayOp_Word8AsChar = 406+primOpTag IndexByteArrayOp_Word8AsWideChar = 407+primOpTag IndexByteArrayOp_Word8AsInt = 408+primOpTag IndexByteArrayOp_Word8AsWord = 409+primOpTag IndexByteArrayOp_Word8AsAddr = 410+primOpTag IndexByteArrayOp_Word8AsFloat = 411+primOpTag IndexByteArrayOp_Word8AsDouble = 412+primOpTag IndexByteArrayOp_Word8AsStablePtr = 413+primOpTag IndexByteArrayOp_Word8AsInt16 = 414+primOpTag IndexByteArrayOp_Word8AsWord16 = 415+primOpTag IndexByteArrayOp_Word8AsInt32 = 416+primOpTag IndexByteArrayOp_Word8AsWord32 = 417+primOpTag IndexByteArrayOp_Word8AsInt64 = 418+primOpTag IndexByteArrayOp_Word8AsWord64 = 419+primOpTag ReadByteArrayOp_Char = 420+primOpTag ReadByteArrayOp_WideChar = 421+primOpTag ReadByteArrayOp_Int = 422+primOpTag ReadByteArrayOp_Word = 423+primOpTag ReadByteArrayOp_Addr = 424+primOpTag ReadByteArrayOp_Float = 425+primOpTag ReadByteArrayOp_Double = 426+primOpTag ReadByteArrayOp_StablePtr = 427+primOpTag ReadByteArrayOp_Int8 = 428+primOpTag ReadByteArrayOp_Word8 = 429+primOpTag ReadByteArrayOp_Int16 = 430+primOpTag ReadByteArrayOp_Word16 = 431+primOpTag ReadByteArrayOp_Int32 = 432+primOpTag ReadByteArrayOp_Word32 = 433+primOpTag ReadByteArrayOp_Int64 = 434+primOpTag ReadByteArrayOp_Word64 = 435+primOpTag ReadByteArrayOp_Word8AsChar = 436+primOpTag ReadByteArrayOp_Word8AsWideChar = 437+primOpTag ReadByteArrayOp_Word8AsInt = 438+primOpTag ReadByteArrayOp_Word8AsWord = 439+primOpTag ReadByteArrayOp_Word8AsAddr = 440+primOpTag ReadByteArrayOp_Word8AsFloat = 441+primOpTag ReadByteArrayOp_Word8AsDouble = 442+primOpTag ReadByteArrayOp_Word8AsStablePtr = 443+primOpTag ReadByteArrayOp_Word8AsInt16 = 444+primOpTag ReadByteArrayOp_Word8AsWord16 = 445+primOpTag ReadByteArrayOp_Word8AsInt32 = 446+primOpTag ReadByteArrayOp_Word8AsWord32 = 447+primOpTag ReadByteArrayOp_Word8AsInt64 = 448+primOpTag ReadByteArrayOp_Word8AsWord64 = 449+primOpTag WriteByteArrayOp_Char = 450+primOpTag WriteByteArrayOp_WideChar = 451+primOpTag WriteByteArrayOp_Int = 452+primOpTag WriteByteArrayOp_Word = 453+primOpTag WriteByteArrayOp_Addr = 454+primOpTag WriteByteArrayOp_Float = 455+primOpTag WriteByteArrayOp_Double = 456+primOpTag WriteByteArrayOp_StablePtr = 457+primOpTag WriteByteArrayOp_Int8 = 458+primOpTag WriteByteArrayOp_Word8 = 459+primOpTag WriteByteArrayOp_Int16 = 460+primOpTag WriteByteArrayOp_Word16 = 461+primOpTag WriteByteArrayOp_Int32 = 462+primOpTag WriteByteArrayOp_Word32 = 463+primOpTag WriteByteArrayOp_Int64 = 464+primOpTag WriteByteArrayOp_Word64 = 465+primOpTag WriteByteArrayOp_Word8AsChar = 466+primOpTag WriteByteArrayOp_Word8AsWideChar = 467+primOpTag WriteByteArrayOp_Word8AsInt = 468+primOpTag WriteByteArrayOp_Word8AsWord = 469+primOpTag WriteByteArrayOp_Word8AsAddr = 470+primOpTag WriteByteArrayOp_Word8AsFloat = 471+primOpTag WriteByteArrayOp_Word8AsDouble = 472+primOpTag WriteByteArrayOp_Word8AsStablePtr = 473+primOpTag WriteByteArrayOp_Word8AsInt16 = 474+primOpTag WriteByteArrayOp_Word8AsWord16 = 475+primOpTag WriteByteArrayOp_Word8AsInt32 = 476+primOpTag WriteByteArrayOp_Word8AsWord32 = 477+primOpTag WriteByteArrayOp_Word8AsInt64 = 478+primOpTag WriteByteArrayOp_Word8AsWord64 = 479+primOpTag CompareByteArraysOp = 480+primOpTag CopyByteArrayOp = 481+primOpTag CopyMutableByteArrayOp = 482+primOpTag CopyMutableByteArrayNonOverlappingOp = 483+primOpTag CopyByteArrayToAddrOp = 484+primOpTag CopyMutableByteArrayToAddrOp = 485+primOpTag CopyAddrToByteArrayOp = 486+primOpTag CopyAddrToAddrOp = 487+primOpTag CopyAddrToAddrNonOverlappingOp = 488+primOpTag SetByteArrayOp = 489+primOpTag SetAddrRangeOp = 490+primOpTag AtomicReadByteArrayOp_Int = 491+primOpTag AtomicWriteByteArrayOp_Int = 492+primOpTag CasByteArrayOp_Int = 493+primOpTag CasByteArrayOp_Int8 = 494+primOpTag CasByteArrayOp_Int16 = 495+primOpTag CasByteArrayOp_Int32 = 496+primOpTag CasByteArrayOp_Int64 = 497+primOpTag FetchAddByteArrayOp_Int = 498+primOpTag FetchSubByteArrayOp_Int = 499+primOpTag FetchAndByteArrayOp_Int = 500+primOpTag FetchNandByteArrayOp_Int = 501+primOpTag FetchOrByteArrayOp_Int = 502+primOpTag FetchXorByteArrayOp_Int = 503+primOpTag AddrAddOp = 504+primOpTag AddrSubOp = 505+primOpTag AddrRemOp = 506+primOpTag AddrToIntOp = 507+primOpTag IntToAddrOp = 508+primOpTag AddrGtOp = 509+primOpTag AddrGeOp = 510+primOpTag AddrEqOp = 511+primOpTag AddrNeOp = 512+primOpTag AddrLtOp = 513+primOpTag AddrLeOp = 514+primOpTag IndexOffAddrOp_Char = 515+primOpTag IndexOffAddrOp_WideChar = 516+primOpTag IndexOffAddrOp_Int = 517+primOpTag IndexOffAddrOp_Word = 518+primOpTag IndexOffAddrOp_Addr = 519+primOpTag IndexOffAddrOp_Float = 520+primOpTag IndexOffAddrOp_Double = 521+primOpTag IndexOffAddrOp_StablePtr = 522+primOpTag IndexOffAddrOp_Int8 = 523+primOpTag IndexOffAddrOp_Word8 = 524+primOpTag IndexOffAddrOp_Int16 = 525+primOpTag IndexOffAddrOp_Word16 = 526+primOpTag IndexOffAddrOp_Int32 = 527+primOpTag IndexOffAddrOp_Word32 = 528+primOpTag IndexOffAddrOp_Int64 = 529+primOpTag IndexOffAddrOp_Word64 = 530+primOpTag IndexOffAddrOp_Word8AsChar = 531+primOpTag IndexOffAddrOp_Word8AsWideChar = 532+primOpTag IndexOffAddrOp_Word8AsInt = 533+primOpTag IndexOffAddrOp_Word8AsWord = 534+primOpTag IndexOffAddrOp_Word8AsAddr = 535+primOpTag IndexOffAddrOp_Word8AsFloat = 536+primOpTag IndexOffAddrOp_Word8AsDouble = 537+primOpTag IndexOffAddrOp_Word8AsStablePtr = 538+primOpTag IndexOffAddrOp_Word8AsInt16 = 539+primOpTag IndexOffAddrOp_Word8AsWord16 = 540+primOpTag IndexOffAddrOp_Word8AsInt32 = 541+primOpTag IndexOffAddrOp_Word8AsWord32 = 542+primOpTag IndexOffAddrOp_Word8AsInt64 = 543+primOpTag IndexOffAddrOp_Word8AsWord64 = 544+primOpTag ReadOffAddrOp_Char = 545+primOpTag ReadOffAddrOp_WideChar = 546+primOpTag ReadOffAddrOp_Int = 547+primOpTag ReadOffAddrOp_Word = 548+primOpTag ReadOffAddrOp_Addr = 549+primOpTag ReadOffAddrOp_Float = 550+primOpTag ReadOffAddrOp_Double = 551+primOpTag ReadOffAddrOp_StablePtr = 552+primOpTag ReadOffAddrOp_Int8 = 553+primOpTag ReadOffAddrOp_Word8 = 554+primOpTag ReadOffAddrOp_Int16 = 555+primOpTag ReadOffAddrOp_Word16 = 556+primOpTag ReadOffAddrOp_Int32 = 557+primOpTag ReadOffAddrOp_Word32 = 558+primOpTag ReadOffAddrOp_Int64 = 559+primOpTag ReadOffAddrOp_Word64 = 560+primOpTag ReadOffAddrOp_Word8AsChar = 561+primOpTag ReadOffAddrOp_Word8AsWideChar = 562+primOpTag ReadOffAddrOp_Word8AsInt = 563+primOpTag ReadOffAddrOp_Word8AsWord = 564+primOpTag ReadOffAddrOp_Word8AsAddr = 565+primOpTag ReadOffAddrOp_Word8AsFloat = 566+primOpTag ReadOffAddrOp_Word8AsDouble = 567+primOpTag ReadOffAddrOp_Word8AsStablePtr = 568+primOpTag ReadOffAddrOp_Word8AsInt16 = 569+primOpTag ReadOffAddrOp_Word8AsWord16 = 570+primOpTag ReadOffAddrOp_Word8AsInt32 = 571+primOpTag ReadOffAddrOp_Word8AsWord32 = 572+primOpTag ReadOffAddrOp_Word8AsInt64 = 573+primOpTag ReadOffAddrOp_Word8AsWord64 = 574+primOpTag WriteOffAddrOp_Char = 575+primOpTag WriteOffAddrOp_WideChar = 576+primOpTag WriteOffAddrOp_Int = 577+primOpTag WriteOffAddrOp_Word = 578+primOpTag WriteOffAddrOp_Addr = 579+primOpTag WriteOffAddrOp_Float = 580+primOpTag WriteOffAddrOp_Double = 581+primOpTag WriteOffAddrOp_StablePtr = 582+primOpTag WriteOffAddrOp_Int8 = 583+primOpTag WriteOffAddrOp_Word8 = 584+primOpTag WriteOffAddrOp_Int16 = 585+primOpTag WriteOffAddrOp_Word16 = 586+primOpTag WriteOffAddrOp_Int32 = 587+primOpTag WriteOffAddrOp_Word32 = 588+primOpTag WriteOffAddrOp_Int64 = 589+primOpTag WriteOffAddrOp_Word64 = 590+primOpTag WriteOffAddrOp_Word8AsChar = 591+primOpTag WriteOffAddrOp_Word8AsWideChar = 592+primOpTag WriteOffAddrOp_Word8AsInt = 593+primOpTag WriteOffAddrOp_Word8AsWord = 594+primOpTag WriteOffAddrOp_Word8AsAddr = 595+primOpTag WriteOffAddrOp_Word8AsFloat = 596+primOpTag WriteOffAddrOp_Word8AsDouble = 597+primOpTag WriteOffAddrOp_Word8AsStablePtr = 598+primOpTag WriteOffAddrOp_Word8AsInt16 = 599+primOpTag WriteOffAddrOp_Word8AsWord16 = 600+primOpTag WriteOffAddrOp_Word8AsInt32 = 601+primOpTag WriteOffAddrOp_Word8AsWord32 = 602+primOpTag WriteOffAddrOp_Word8AsInt64 = 603+primOpTag WriteOffAddrOp_Word8AsWord64 = 604+primOpTag InterlockedExchange_Addr = 605+primOpTag InterlockedExchange_Word = 606+primOpTag CasAddrOp_Addr = 607+primOpTag CasAddrOp_Word = 608+primOpTag CasAddrOp_Word8 = 609+primOpTag CasAddrOp_Word16 = 610+primOpTag CasAddrOp_Word32 = 611+primOpTag CasAddrOp_Word64 = 612+primOpTag FetchAddAddrOp_Word = 613+primOpTag FetchSubAddrOp_Word = 614+primOpTag FetchAndAddrOp_Word = 615+primOpTag FetchNandAddrOp_Word = 616+primOpTag FetchOrAddrOp_Word = 617+primOpTag FetchXorAddrOp_Word = 618+primOpTag AtomicReadAddrOp_Word = 619+primOpTag AtomicWriteAddrOp_Word = 620+primOpTag NewMutVarOp = 621+primOpTag ReadMutVarOp = 622+primOpTag WriteMutVarOp = 623+primOpTag AtomicSwapMutVarOp = 624+primOpTag AtomicModifyMutVar2Op = 625+primOpTag AtomicModifyMutVar_Op = 626+primOpTag CasMutVarOp = 627+primOpTag CatchOp = 628+primOpTag RaiseOp = 629+primOpTag RaiseUnderflowOp = 630+primOpTag RaiseOverflowOp = 631+primOpTag RaiseDivZeroOp = 632+primOpTag RaiseIOOp = 633+primOpTag MaskAsyncExceptionsOp = 634+primOpTag MaskUninterruptibleOp = 635+primOpTag UnmaskAsyncExceptionsOp = 636+primOpTag MaskStatus = 637+primOpTag NewPromptTagOp = 638+primOpTag PromptOp = 639+primOpTag Control0Op = 640+primOpTag AtomicallyOp = 641+primOpTag RetryOp = 642+primOpTag CatchRetryOp = 643+primOpTag CatchSTMOp = 644+primOpTag NewTVarOp = 645+primOpTag ReadTVarOp = 646+primOpTag ReadTVarIOOp = 647+primOpTag WriteTVarOp = 648+primOpTag NewMVarOp = 649+primOpTag TakeMVarOp = 650+primOpTag TryTakeMVarOp = 651+primOpTag PutMVarOp = 652+primOpTag TryPutMVarOp = 653+primOpTag ReadMVarOp = 654+primOpTag TryReadMVarOp = 655+primOpTag IsEmptyMVarOp = 656+primOpTag DelayOp = 657+primOpTag WaitReadOp = 658+primOpTag WaitWriteOp = 659+primOpTag ForkOp = 660+primOpTag ForkOnOp = 661+primOpTag KillThreadOp = 662+primOpTag YieldOp = 663+primOpTag MyThreadIdOp = 664+primOpTag LabelThreadOp = 665+primOpTag IsCurrentThreadBoundOp = 666+primOpTag NoDuplicateOp = 667+primOpTag GetThreadLabelOp = 668+primOpTag ThreadStatusOp = 669+primOpTag ListThreadsOp = 670+primOpTag MkWeakOp = 671+primOpTag MkWeakNoFinalizerOp = 672+primOpTag AddCFinalizerToWeakOp = 673+primOpTag DeRefWeakOp = 674+primOpTag FinalizeWeakOp = 675+primOpTag TouchOp = 676+primOpTag MakeStablePtrOp = 677+primOpTag DeRefStablePtrOp = 678+primOpTag EqStablePtrOp = 679+primOpTag MakeStableNameOp = 680+primOpTag StableNameToIntOp = 681+primOpTag CompactNewOp = 682+primOpTag CompactResizeOp = 683+primOpTag CompactContainsOp = 684+primOpTag CompactContainsAnyOp = 685+primOpTag CompactGetFirstBlockOp = 686+primOpTag CompactGetNextBlockOp = 687+primOpTag CompactAllocateBlockOp = 688+primOpTag CompactFixupPointersOp = 689+primOpTag CompactAdd = 690+primOpTag CompactAddWithSharing = 691+primOpTag CompactSize = 692+primOpTag ReallyUnsafePtrEqualityOp = 693+primOpTag ParOp = 694+primOpTag SparkOp = 695+primOpTag GetSparkOp = 696+primOpTag NumSparks = 697+primOpTag KeepAliveOp = 698+primOpTag DataToTagSmallOp = 699+primOpTag DataToTagLargeOp = 700+primOpTag TagToEnumOp = 701+primOpTag AddrToAnyOp = 702+primOpTag AnyToAddrOp = 703+primOpTag MkApUpd0_Op = 704+primOpTag NewBCOOp = 705+primOpTag UnpackClosureOp = 706+primOpTag ClosureSizeOp = 707+primOpTag GetApStackValOp = 708+primOpTag GetCCSOfOp = 709+primOpTag GetCurrentCCSOp = 710+primOpTag ClearCCSOp = 711+primOpTag AnnotateStackOp = 712+primOpTag WhereFromOp = 713+primOpTag TraceEventOp = 714+primOpTag TraceEventBinaryOp = 715+primOpTag TraceMarkerOp = 716+primOpTag SetThreadAllocationCounter = 717+primOpTag SetOtherThreadAllocationCounter = 718+primOpTag (VecBroadcastOp IntVec 16 W8) = 719+primOpTag (VecBroadcastOp IntVec 8 W16) = 720+primOpTag (VecBroadcastOp IntVec 4 W32) = 721+primOpTag (VecBroadcastOp IntVec 2 W64) = 722+primOpTag (VecBroadcastOp IntVec 32 W8) = 723+primOpTag (VecBroadcastOp IntVec 16 W16) = 724+primOpTag (VecBroadcastOp IntVec 8 W32) = 725+primOpTag (VecBroadcastOp IntVec 4 W64) = 726+primOpTag (VecBroadcastOp IntVec 64 W8) = 727+primOpTag (VecBroadcastOp IntVec 32 W16) = 728+primOpTag (VecBroadcastOp IntVec 16 W32) = 729+primOpTag (VecBroadcastOp IntVec 8 W64) = 730+primOpTag (VecBroadcastOp WordVec 16 W8) = 731+primOpTag (VecBroadcastOp WordVec 8 W16) = 732+primOpTag (VecBroadcastOp WordVec 4 W32) = 733+primOpTag (VecBroadcastOp WordVec 2 W64) = 734+primOpTag (VecBroadcastOp WordVec 32 W8) = 735+primOpTag (VecBroadcastOp WordVec 16 W16) = 736+primOpTag (VecBroadcastOp WordVec 8 W32) = 737+primOpTag (VecBroadcastOp WordVec 4 W64) = 738+primOpTag (VecBroadcastOp WordVec 64 W8) = 739+primOpTag (VecBroadcastOp WordVec 32 W16) = 740+primOpTag (VecBroadcastOp WordVec 16 W32) = 741+primOpTag (VecBroadcastOp WordVec 8 W64) = 742+primOpTag (VecBroadcastOp FloatVec 4 W32) = 743+primOpTag (VecBroadcastOp FloatVec 2 W64) = 744+primOpTag (VecBroadcastOp FloatVec 8 W32) = 745+primOpTag (VecBroadcastOp FloatVec 4 W64) = 746+primOpTag (VecBroadcastOp FloatVec 16 W32) = 747+primOpTag (VecBroadcastOp FloatVec 8 W64) = 748+primOpTag (VecPackOp IntVec 16 W8) = 749+primOpTag (VecPackOp IntVec 8 W16) = 750+primOpTag (VecPackOp IntVec 4 W32) = 751+primOpTag (VecPackOp IntVec 2 W64) = 752+primOpTag (VecPackOp IntVec 32 W8) = 753+primOpTag (VecPackOp IntVec 16 W16) = 754+primOpTag (VecPackOp IntVec 8 W32) = 755+primOpTag (VecPackOp IntVec 4 W64) = 756+primOpTag (VecPackOp IntVec 64 W8) = 757+primOpTag (VecPackOp IntVec 32 W16) = 758+primOpTag (VecPackOp IntVec 16 W32) = 759+primOpTag (VecPackOp IntVec 8 W64) = 760+primOpTag (VecPackOp WordVec 16 W8) = 761+primOpTag (VecPackOp WordVec 8 W16) = 762+primOpTag (VecPackOp WordVec 4 W32) = 763+primOpTag (VecPackOp WordVec 2 W64) = 764+primOpTag (VecPackOp WordVec 32 W8) = 765+primOpTag (VecPackOp WordVec 16 W16) = 766+primOpTag (VecPackOp WordVec 8 W32) = 767+primOpTag (VecPackOp WordVec 4 W64) = 768+primOpTag (VecPackOp WordVec 64 W8) = 769+primOpTag (VecPackOp WordVec 32 W16) = 770+primOpTag (VecPackOp WordVec 16 W32) = 771+primOpTag (VecPackOp WordVec 8 W64) = 772+primOpTag (VecPackOp FloatVec 4 W32) = 773+primOpTag (VecPackOp FloatVec 2 W64) = 774+primOpTag (VecPackOp FloatVec 8 W32) = 775+primOpTag (VecPackOp FloatVec 4 W64) = 776+primOpTag (VecPackOp FloatVec 16 W32) = 777+primOpTag (VecPackOp FloatVec 8 W64) = 778+primOpTag (VecUnpackOp IntVec 16 W8) = 779+primOpTag (VecUnpackOp IntVec 8 W16) = 780+primOpTag (VecUnpackOp IntVec 4 W32) = 781+primOpTag (VecUnpackOp IntVec 2 W64) = 782+primOpTag (VecUnpackOp IntVec 32 W8) = 783+primOpTag (VecUnpackOp IntVec 16 W16) = 784+primOpTag (VecUnpackOp IntVec 8 W32) = 785+primOpTag (VecUnpackOp IntVec 4 W64) = 786+primOpTag (VecUnpackOp IntVec 64 W8) = 787+primOpTag (VecUnpackOp IntVec 32 W16) = 788+primOpTag (VecUnpackOp IntVec 16 W32) = 789+primOpTag (VecUnpackOp IntVec 8 W64) = 790+primOpTag (VecUnpackOp WordVec 16 W8) = 791+primOpTag (VecUnpackOp WordVec 8 W16) = 792+primOpTag (VecUnpackOp WordVec 4 W32) = 793+primOpTag (VecUnpackOp WordVec 2 W64) = 794+primOpTag (VecUnpackOp WordVec 32 W8) = 795+primOpTag (VecUnpackOp WordVec 16 W16) = 796+primOpTag (VecUnpackOp WordVec 8 W32) = 797+primOpTag (VecUnpackOp WordVec 4 W64) = 798+primOpTag (VecUnpackOp WordVec 64 W8) = 799+primOpTag (VecUnpackOp WordVec 32 W16) = 800+primOpTag (VecUnpackOp WordVec 16 W32) = 801+primOpTag (VecUnpackOp WordVec 8 W64) = 802+primOpTag (VecUnpackOp FloatVec 4 W32) = 803+primOpTag (VecUnpackOp FloatVec 2 W64) = 804+primOpTag (VecUnpackOp FloatVec 8 W32) = 805+primOpTag (VecUnpackOp FloatVec 4 W64) = 806+primOpTag (VecUnpackOp FloatVec 16 W32) = 807+primOpTag (VecUnpackOp FloatVec 8 W64) = 808+primOpTag (VecInsertOp IntVec 16 W8) = 809+primOpTag (VecInsertOp IntVec 8 W16) = 810+primOpTag (VecInsertOp IntVec 4 W32) = 811+primOpTag (VecInsertOp IntVec 2 W64) = 812+primOpTag (VecInsertOp IntVec 32 W8) = 813+primOpTag (VecInsertOp IntVec 16 W16) = 814+primOpTag (VecInsertOp IntVec 8 W32) = 815+primOpTag (VecInsertOp IntVec 4 W64) = 816+primOpTag (VecInsertOp IntVec 64 W8) = 817+primOpTag (VecInsertOp IntVec 32 W16) = 818+primOpTag (VecInsertOp IntVec 16 W32) = 819+primOpTag (VecInsertOp IntVec 8 W64) = 820+primOpTag (VecInsertOp WordVec 16 W8) = 821+primOpTag (VecInsertOp WordVec 8 W16) = 822+primOpTag (VecInsertOp WordVec 4 W32) = 823+primOpTag (VecInsertOp WordVec 2 W64) = 824+primOpTag (VecInsertOp WordVec 32 W8) = 825+primOpTag (VecInsertOp WordVec 16 W16) = 826+primOpTag (VecInsertOp WordVec 8 W32) = 827+primOpTag (VecInsertOp WordVec 4 W64) = 828+primOpTag (VecInsertOp WordVec 64 W8) = 829+primOpTag (VecInsertOp WordVec 32 W16) = 830+primOpTag (VecInsertOp WordVec 16 W32) = 831+primOpTag (VecInsertOp WordVec 8 W64) = 832+primOpTag (VecInsertOp FloatVec 4 W32) = 833+primOpTag (VecInsertOp FloatVec 2 W64) = 834+primOpTag (VecInsertOp FloatVec 8 W32) = 835+primOpTag (VecInsertOp FloatVec 4 W64) = 836+primOpTag (VecInsertOp FloatVec 16 W32) = 837+primOpTag (VecInsertOp FloatVec 8 W64) = 838+primOpTag (VecAddOp IntVec 16 W8) = 839+primOpTag (VecAddOp IntVec 8 W16) = 840+primOpTag (VecAddOp IntVec 4 W32) = 841+primOpTag (VecAddOp IntVec 2 W64) = 842+primOpTag (VecAddOp IntVec 32 W8) = 843+primOpTag (VecAddOp IntVec 16 W16) = 844+primOpTag (VecAddOp IntVec 8 W32) = 845+primOpTag (VecAddOp IntVec 4 W64) = 846+primOpTag (VecAddOp IntVec 64 W8) = 847+primOpTag (VecAddOp IntVec 32 W16) = 848+primOpTag (VecAddOp IntVec 16 W32) = 849+primOpTag (VecAddOp IntVec 8 W64) = 850+primOpTag (VecAddOp WordVec 16 W8) = 851+primOpTag (VecAddOp WordVec 8 W16) = 852+primOpTag (VecAddOp WordVec 4 W32) = 853+primOpTag (VecAddOp WordVec 2 W64) = 854+primOpTag (VecAddOp WordVec 32 W8) = 855+primOpTag (VecAddOp WordVec 16 W16) = 856+primOpTag (VecAddOp WordVec 8 W32) = 857+primOpTag (VecAddOp WordVec 4 W64) = 858+primOpTag (VecAddOp WordVec 64 W8) = 859+primOpTag (VecAddOp WordVec 32 W16) = 860+primOpTag (VecAddOp WordVec 16 W32) = 861+primOpTag (VecAddOp WordVec 8 W64) = 862+primOpTag (VecAddOp FloatVec 4 W32) = 863+primOpTag (VecAddOp FloatVec 2 W64) = 864+primOpTag (VecAddOp FloatVec 8 W32) = 865+primOpTag (VecAddOp FloatVec 4 W64) = 866+primOpTag (VecAddOp FloatVec 16 W32) = 867+primOpTag (VecAddOp FloatVec 8 W64) = 868+primOpTag (VecSubOp IntVec 16 W8) = 869+primOpTag (VecSubOp IntVec 8 W16) = 870+primOpTag (VecSubOp IntVec 4 W32) = 871+primOpTag (VecSubOp IntVec 2 W64) = 872+primOpTag (VecSubOp IntVec 32 W8) = 873+primOpTag (VecSubOp IntVec 16 W16) = 874+primOpTag (VecSubOp IntVec 8 W32) = 875+primOpTag (VecSubOp IntVec 4 W64) = 876+primOpTag (VecSubOp IntVec 64 W8) = 877+primOpTag (VecSubOp IntVec 32 W16) = 878+primOpTag (VecSubOp IntVec 16 W32) = 879+primOpTag (VecSubOp IntVec 8 W64) = 880+primOpTag (VecSubOp WordVec 16 W8) = 881+primOpTag (VecSubOp WordVec 8 W16) = 882+primOpTag (VecSubOp WordVec 4 W32) = 883+primOpTag (VecSubOp WordVec 2 W64) = 884+primOpTag (VecSubOp WordVec 32 W8) = 885+primOpTag (VecSubOp WordVec 16 W16) = 886+primOpTag (VecSubOp WordVec 8 W32) = 887+primOpTag (VecSubOp WordVec 4 W64) = 888+primOpTag (VecSubOp WordVec 64 W8) = 889+primOpTag (VecSubOp WordVec 32 W16) = 890+primOpTag (VecSubOp WordVec 16 W32) = 891+primOpTag (VecSubOp WordVec 8 W64) = 892+primOpTag (VecSubOp FloatVec 4 W32) = 893+primOpTag (VecSubOp FloatVec 2 W64) = 894+primOpTag (VecSubOp FloatVec 8 W32) = 895+primOpTag (VecSubOp FloatVec 4 W64) = 896+primOpTag (VecSubOp FloatVec 16 W32) = 897+primOpTag (VecSubOp FloatVec 8 W64) = 898+primOpTag (VecMulOp IntVec 16 W8) = 899+primOpTag (VecMulOp IntVec 8 W16) = 900+primOpTag (VecMulOp IntVec 4 W32) = 901+primOpTag (VecMulOp IntVec 2 W64) = 902+primOpTag (VecMulOp IntVec 32 W8) = 903+primOpTag (VecMulOp IntVec 16 W16) = 904+primOpTag (VecMulOp IntVec 8 W32) = 905+primOpTag (VecMulOp IntVec 4 W64) = 906+primOpTag (VecMulOp IntVec 64 W8) = 907+primOpTag (VecMulOp IntVec 32 W16) = 908+primOpTag (VecMulOp IntVec 16 W32) = 909+primOpTag (VecMulOp IntVec 8 W64) = 910+primOpTag (VecMulOp WordVec 16 W8) = 911+primOpTag (VecMulOp WordVec 8 W16) = 912+primOpTag (VecMulOp WordVec 4 W32) = 913+primOpTag (VecMulOp WordVec 2 W64) = 914+primOpTag (VecMulOp WordVec 32 W8) = 915+primOpTag (VecMulOp WordVec 16 W16) = 916+primOpTag (VecMulOp WordVec 8 W32) = 917+primOpTag (VecMulOp WordVec 4 W64) = 918+primOpTag (VecMulOp WordVec 64 W8) = 919+primOpTag (VecMulOp WordVec 32 W16) = 920+primOpTag (VecMulOp WordVec 16 W32) = 921+primOpTag (VecMulOp WordVec 8 W64) = 922+primOpTag (VecMulOp FloatVec 4 W32) = 923+primOpTag (VecMulOp FloatVec 2 W64) = 924+primOpTag (VecMulOp FloatVec 8 W32) = 925+primOpTag (VecMulOp FloatVec 4 W64) = 926+primOpTag (VecMulOp FloatVec 16 W32) = 927+primOpTag (VecMulOp FloatVec 8 W64) = 928+primOpTag (VecDivOp FloatVec 4 W32) = 929+primOpTag (VecDivOp FloatVec 2 W64) = 930+primOpTag (VecDivOp FloatVec 8 W32) = 931+primOpTag (VecDivOp FloatVec 4 W64) = 932+primOpTag (VecDivOp FloatVec 16 W32) = 933+primOpTag (VecDivOp FloatVec 8 W64) = 934+primOpTag (VecQuotOp IntVec 16 W8) = 935+primOpTag (VecQuotOp IntVec 8 W16) = 936+primOpTag (VecQuotOp IntVec 4 W32) = 937+primOpTag (VecQuotOp IntVec 2 W64) = 938+primOpTag (VecQuotOp IntVec 32 W8) = 939+primOpTag (VecQuotOp IntVec 16 W16) = 940+primOpTag (VecQuotOp IntVec 8 W32) = 941+primOpTag (VecQuotOp IntVec 4 W64) = 942+primOpTag (VecQuotOp IntVec 64 W8) = 943+primOpTag (VecQuotOp IntVec 32 W16) = 944+primOpTag (VecQuotOp IntVec 16 W32) = 945+primOpTag (VecQuotOp IntVec 8 W64) = 946+primOpTag (VecQuotOp WordVec 16 W8) = 947+primOpTag (VecQuotOp WordVec 8 W16) = 948+primOpTag (VecQuotOp WordVec 4 W32) = 949+primOpTag (VecQuotOp WordVec 2 W64) = 950+primOpTag (VecQuotOp WordVec 32 W8) = 951+primOpTag (VecQuotOp WordVec 16 W16) = 952+primOpTag (VecQuotOp WordVec 8 W32) = 953+primOpTag (VecQuotOp WordVec 4 W64) = 954+primOpTag (VecQuotOp WordVec 64 W8) = 955+primOpTag (VecQuotOp WordVec 32 W16) = 956+primOpTag (VecQuotOp WordVec 16 W32) = 957+primOpTag (VecQuotOp WordVec 8 W64) = 958+primOpTag (VecRemOp IntVec 16 W8) = 959+primOpTag (VecRemOp IntVec 8 W16) = 960+primOpTag (VecRemOp IntVec 4 W32) = 961+primOpTag (VecRemOp IntVec 2 W64) = 962+primOpTag (VecRemOp IntVec 32 W8) = 963+primOpTag (VecRemOp IntVec 16 W16) = 964+primOpTag (VecRemOp IntVec 8 W32) = 965+primOpTag (VecRemOp IntVec 4 W64) = 966+primOpTag (VecRemOp IntVec 64 W8) = 967+primOpTag (VecRemOp IntVec 32 W16) = 968+primOpTag (VecRemOp IntVec 16 W32) = 969+primOpTag (VecRemOp IntVec 8 W64) = 970+primOpTag (VecRemOp WordVec 16 W8) = 971+primOpTag (VecRemOp WordVec 8 W16) = 972+primOpTag (VecRemOp WordVec 4 W32) = 973+primOpTag (VecRemOp WordVec 2 W64) = 974+primOpTag (VecRemOp WordVec 32 W8) = 975+primOpTag (VecRemOp WordVec 16 W16) = 976+primOpTag (VecRemOp WordVec 8 W32) = 977+primOpTag (VecRemOp WordVec 4 W64) = 978+primOpTag (VecRemOp WordVec 64 W8) = 979+primOpTag (VecRemOp WordVec 32 W16) = 980+primOpTag (VecRemOp WordVec 16 W32) = 981+primOpTag (VecRemOp WordVec 8 W64) = 982+primOpTag (VecNegOp IntVec 16 W8) = 983+primOpTag (VecNegOp IntVec 8 W16) = 984+primOpTag (VecNegOp IntVec 4 W32) = 985+primOpTag (VecNegOp IntVec 2 W64) = 986+primOpTag (VecNegOp IntVec 32 W8) = 987+primOpTag (VecNegOp IntVec 16 W16) = 988+primOpTag (VecNegOp IntVec 8 W32) = 989+primOpTag (VecNegOp IntVec 4 W64) = 990+primOpTag (VecNegOp IntVec 64 W8) = 991+primOpTag (VecNegOp IntVec 32 W16) = 992+primOpTag (VecNegOp IntVec 16 W32) = 993+primOpTag (VecNegOp IntVec 8 W64) = 994+primOpTag (VecNegOp FloatVec 4 W32) = 995+primOpTag (VecNegOp FloatVec 2 W64) = 996+primOpTag (VecNegOp FloatVec 8 W32) = 997+primOpTag (VecNegOp FloatVec 4 W64) = 998+primOpTag (VecNegOp FloatVec 16 W32) = 999+primOpTag (VecNegOp FloatVec 8 W64) = 1000+primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 1001+primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 1002+primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 1003+primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 1004+primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 1005+primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 1006+primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 1007+primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 1008+primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 1009+primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 1010+primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 1011+primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 1012+primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 1013+primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 1014+primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 1015+primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 1016+primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 1017+primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 1018+primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 1019+primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 1020+primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 1021+primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 1022+primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 1023+primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 1024+primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 1025+primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 1026+primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 1027+primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 1028+primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 1029+primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 1030+primOpTag (VecReadByteArrayOp IntVec 16 W8) = 1031+primOpTag (VecReadByteArrayOp IntVec 8 W16) = 1032+primOpTag (VecReadByteArrayOp IntVec 4 W32) = 1033+primOpTag (VecReadByteArrayOp IntVec 2 W64) = 1034+primOpTag (VecReadByteArrayOp IntVec 32 W8) = 1035+primOpTag (VecReadByteArrayOp IntVec 16 W16) = 1036+primOpTag (VecReadByteArrayOp IntVec 8 W32) = 1037+primOpTag (VecReadByteArrayOp IntVec 4 W64) = 1038+primOpTag (VecReadByteArrayOp IntVec 64 W8) = 1039+primOpTag (VecReadByteArrayOp IntVec 32 W16) = 1040+primOpTag (VecReadByteArrayOp IntVec 16 W32) = 1041+primOpTag (VecReadByteArrayOp IntVec 8 W64) = 1042+primOpTag (VecReadByteArrayOp WordVec 16 W8) = 1043+primOpTag (VecReadByteArrayOp WordVec 8 W16) = 1044+primOpTag (VecReadByteArrayOp WordVec 4 W32) = 1045+primOpTag (VecReadByteArrayOp WordVec 2 W64) = 1046+primOpTag (VecReadByteArrayOp WordVec 32 W8) = 1047+primOpTag (VecReadByteArrayOp WordVec 16 W16) = 1048+primOpTag (VecReadByteArrayOp WordVec 8 W32) = 1049+primOpTag (VecReadByteArrayOp WordVec 4 W64) = 1050+primOpTag (VecReadByteArrayOp WordVec 64 W8) = 1051+primOpTag (VecReadByteArrayOp WordVec 32 W16) = 1052+primOpTag (VecReadByteArrayOp WordVec 16 W32) = 1053+primOpTag (VecReadByteArrayOp WordVec 8 W64) = 1054+primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 1055+primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 1056+primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 1057+primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 1058+primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 1059+primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 1060+primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 1061+primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 1062+primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 1063+primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 1064+primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 1065+primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 1066+primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 1067+primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 1068+primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 1069+primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 1070+primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 1071+primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 1072+primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 1073+primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 1074+primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 1075+primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 1076+primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 1077+primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 1078+primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 1079+primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 1080+primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 1081+primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 1082+primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 1083+primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 1084+primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 1085+primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 1086+primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 1087+primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 1088+primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 1089+primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 1090+primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 1091+primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 1092+primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1093+primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1094+primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1095+primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1096+primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1097+primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1098+primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1099+primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1100+primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1101+primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1102+primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1103+primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1104+primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1105+primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1106+primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1107+primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1108+primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1109+primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1110+primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1111+primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1112+primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1113+primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1114+primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1115+primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1116+primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1117+primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1118+primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1119+primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1120+primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1121+primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1122+primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1123+primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1124+primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1125+primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1126+primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1127+primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1128+primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1129+primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1130+primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1131+primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1132+primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1133+primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1134+primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1135+primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1136+primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1137+primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1138+primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1139+primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1140+primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1141+primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1142+primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1143+primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1144+primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1145+primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1146+primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1147+primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1148+primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1149+primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1150+primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1151+primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1152+primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1153+primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1154+primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1155+primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1156+primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1157+primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1158+primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1159+primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1160+primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1161+primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1162+primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1163+primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1164+primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1165+primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1166+primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1167+primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1168+primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1169+primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1170+primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1171+primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1172+primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1173+primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1174+primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1175+primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1176+primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1177+primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1178+primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1179+primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1180+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1181+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1182+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1183+primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1184+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1185+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1186+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1187+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1188+primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1189+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1190+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1191+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1192+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1193+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1194+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1195+primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1196+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1197+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1198+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1199+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1200+primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1201+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1202+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1203+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1204+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1205+primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1206+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1207+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1208+primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1209+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1210+primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1211+primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1212+primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1213+primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1214+primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1215+primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1216+primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1217+primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1218+primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1219+primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1220+primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1221+primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1222+primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1223+primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1224+primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1225+primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1226+primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1227+primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1228+primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1229+primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1230+primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1231+primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1232+primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1233+primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1234+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1235+primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1236+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1237+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1238+primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1239+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1240+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1241+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1242+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1243+primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1244+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1245+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1246+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1247+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1248+primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1249+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1250+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1251+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1252+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1253+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1254+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1255+primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1256+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1257+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1258+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1259+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1260+primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1261+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1262+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1263+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1264+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1265+primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1266+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1267+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1268+primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1269+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1270+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1271+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1272+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1273+primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1274+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1275+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1276+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1277+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1278+primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1279+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1280+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1281+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1282+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1283+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1284+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1285+primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1286+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1287+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1288+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1289+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1290+primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1291+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1292+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1293+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1294+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1295+primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1296+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1297+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1298+primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1299+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1300+primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1301+primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1302+primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1303+primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1304+primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1305+primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1306+primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1307+primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1308+primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1309+primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1310+primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1311+primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1312+primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1313+primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1314+primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1315+primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1316+primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1317+primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1318+primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1319+primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1320+primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1321+primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1322+primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1323+primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1324+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1325+primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1326+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1327+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1328+primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1329+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1330+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1331+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1332+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1333+primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1334+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1335+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1336+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1337+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1338+primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1339+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1340+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1341+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1342+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1343+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1344+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1345+primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1346+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1347+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1348+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1349+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1350+primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1351+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1352+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1353+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1354+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1355+primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1356+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1357+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1358+primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1359+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1360+primOpTag (VecFMAdd FloatVec 4 W32) = 1361+primOpTag (VecFMAdd FloatVec 2 W64) = 1362+primOpTag (VecFMAdd FloatVec 8 W32) = 1363+primOpTag (VecFMAdd FloatVec 4 W64) = 1364+primOpTag (VecFMAdd FloatVec 16 W32) = 1365+primOpTag (VecFMAdd FloatVec 8 W64) = 1366+primOpTag (VecFMSub FloatVec 4 W32) = 1367+primOpTag (VecFMSub FloatVec 2 W64) = 1368+primOpTag (VecFMSub FloatVec 8 W32) = 1369+primOpTag (VecFMSub FloatVec 4 W64) = 1370+primOpTag (VecFMSub FloatVec 16 W32) = 1371+primOpTag (VecFMSub FloatVec 8 W64) = 1372+primOpTag (VecFNMAdd FloatVec 4 W32) = 1373+primOpTag (VecFNMAdd FloatVec 2 W64) = 1374+primOpTag (VecFNMAdd FloatVec 8 W32) = 1375+primOpTag (VecFNMAdd FloatVec 4 W64) = 1376+primOpTag (VecFNMAdd FloatVec 16 W32) = 1377+primOpTag (VecFNMAdd FloatVec 8 W64) = 1378+primOpTag (VecFNMSub FloatVec 4 W32) = 1379+primOpTag (VecFNMSub FloatVec 2 W64) = 1380+primOpTag (VecFNMSub FloatVec 8 W32) = 1381+primOpTag (VecFNMSub FloatVec 4 W64) = 1382+primOpTag (VecFNMSub FloatVec 16 W32) = 1383+primOpTag (VecFNMSub FloatVec 8 W64) = 1384+primOpTag (VecShuffleOp IntVec 16 W8) = 1385+primOpTag (VecShuffleOp IntVec 8 W16) = 1386+primOpTag (VecShuffleOp IntVec 4 W32) = 1387+primOpTag (VecShuffleOp IntVec 2 W64) = 1388+primOpTag (VecShuffleOp IntVec 32 W8) = 1389+primOpTag (VecShuffleOp IntVec 16 W16) = 1390+primOpTag (VecShuffleOp IntVec 8 W32) = 1391+primOpTag (VecShuffleOp IntVec 4 W64) = 1392+primOpTag (VecShuffleOp IntVec 64 W8) = 1393+primOpTag (VecShuffleOp IntVec 32 W16) = 1394+primOpTag (VecShuffleOp IntVec 16 W32) = 1395+primOpTag (VecShuffleOp IntVec 8 W64) = 1396+primOpTag (VecShuffleOp WordVec 16 W8) = 1397+primOpTag (VecShuffleOp WordVec 8 W16) = 1398+primOpTag (VecShuffleOp WordVec 4 W32) = 1399+primOpTag (VecShuffleOp WordVec 2 W64) = 1400+primOpTag (VecShuffleOp WordVec 32 W8) = 1401+primOpTag (VecShuffleOp WordVec 16 W16) = 1402+primOpTag (VecShuffleOp WordVec 8 W32) = 1403+primOpTag (VecShuffleOp WordVec 4 W64) = 1404+primOpTag (VecShuffleOp WordVec 64 W8) = 1405+primOpTag (VecShuffleOp WordVec 32 W16) = 1406+primOpTag (VecShuffleOp WordVec 16 W32) = 1407+primOpTag (VecShuffleOp WordVec 8 W64) = 1408+primOpTag (VecShuffleOp FloatVec 4 W32) = 1409+primOpTag (VecShuffleOp FloatVec 2 W64) = 1410+primOpTag (VecShuffleOp FloatVec 8 W32) = 1411+primOpTag (VecShuffleOp FloatVec 4 W64) = 1412+primOpTag (VecShuffleOp FloatVec 16 W32) = 1413+primOpTag (VecShuffleOp FloatVec 8 W64) = 1414+primOpTag (VecMinOp IntVec 16 W8) = 1415+primOpTag (VecMinOp IntVec 8 W16) = 1416+primOpTag (VecMinOp IntVec 4 W32) = 1417+primOpTag (VecMinOp IntVec 2 W64) = 1418+primOpTag (VecMinOp IntVec 32 W8) = 1419+primOpTag (VecMinOp IntVec 16 W16) = 1420+primOpTag (VecMinOp IntVec 8 W32) = 1421+primOpTag (VecMinOp IntVec 4 W64) = 1422+primOpTag (VecMinOp IntVec 64 W8) = 1423+primOpTag (VecMinOp IntVec 32 W16) = 1424+primOpTag (VecMinOp IntVec 16 W32) = 1425+primOpTag (VecMinOp IntVec 8 W64) = 1426+primOpTag (VecMinOp WordVec 16 W8) = 1427+primOpTag (VecMinOp WordVec 8 W16) = 1428+primOpTag (VecMinOp WordVec 4 W32) = 1429+primOpTag (VecMinOp WordVec 2 W64) = 1430+primOpTag (VecMinOp WordVec 32 W8) = 1431+primOpTag (VecMinOp WordVec 16 W16) = 1432+primOpTag (VecMinOp WordVec 8 W32) = 1433+primOpTag (VecMinOp WordVec 4 W64) = 1434+primOpTag (VecMinOp WordVec 64 W8) = 1435+primOpTag (VecMinOp WordVec 32 W16) = 1436+primOpTag (VecMinOp WordVec 16 W32) = 1437+primOpTag (VecMinOp WordVec 8 W64) = 1438+primOpTag (VecMinOp FloatVec 4 W32) = 1439+primOpTag (VecMinOp FloatVec 2 W64) = 1440+primOpTag (VecMinOp FloatVec 8 W32) = 1441+primOpTag (VecMinOp FloatVec 4 W64) = 1442+primOpTag (VecMinOp FloatVec 16 W32) = 1443+primOpTag (VecMinOp FloatVec 8 W64) = 1444+primOpTag (VecMaxOp IntVec 16 W8) = 1445+primOpTag (VecMaxOp IntVec 8 W16) = 1446+primOpTag (VecMaxOp IntVec 4 W32) = 1447+primOpTag (VecMaxOp IntVec 2 W64) = 1448+primOpTag (VecMaxOp IntVec 32 W8) = 1449+primOpTag (VecMaxOp IntVec 16 W16) = 1450+primOpTag (VecMaxOp IntVec 8 W32) = 1451+primOpTag (VecMaxOp IntVec 4 W64) = 1452+primOpTag (VecMaxOp IntVec 64 W8) = 1453+primOpTag (VecMaxOp IntVec 32 W16) = 1454+primOpTag (VecMaxOp IntVec 16 W32) = 1455+primOpTag (VecMaxOp IntVec 8 W64) = 1456+primOpTag (VecMaxOp WordVec 16 W8) = 1457+primOpTag (VecMaxOp WordVec 8 W16) = 1458+primOpTag (VecMaxOp WordVec 4 W32) = 1459+primOpTag (VecMaxOp WordVec 2 W64) = 1460+primOpTag (VecMaxOp WordVec 32 W8) = 1461+primOpTag (VecMaxOp WordVec 16 W16) = 1462+primOpTag (VecMaxOp WordVec 8 W32) = 1463+primOpTag (VecMaxOp WordVec 4 W64) = 1464+primOpTag (VecMaxOp WordVec 64 W8) = 1465+primOpTag (VecMaxOp WordVec 32 W16) = 1466+primOpTag (VecMaxOp WordVec 16 W32) = 1467+primOpTag (VecMaxOp WordVec 8 W64) = 1468+primOpTag (VecMaxOp FloatVec 4 W32) = 1469+primOpTag (VecMaxOp FloatVec 2 W64) = 1470+primOpTag (VecMaxOp FloatVec 8 W32) = 1471+primOpTag (VecMaxOp FloatVec 4 W64) = 1472+primOpTag (VecMaxOp FloatVec 16 W32) = 1473+primOpTag (VecMaxOp FloatVec 8 W64) = 1474+primOpTag PrefetchByteArrayOp3 = 1475+primOpTag PrefetchMutableByteArrayOp3 = 1476+primOpTag PrefetchAddrOp3 = 1477+primOpTag PrefetchValueOp3 = 1478+primOpTag PrefetchByteArrayOp2 = 1479+primOpTag PrefetchMutableByteArrayOp2 = 1480+primOpTag PrefetchAddrOp2 = 1481+primOpTag PrefetchValueOp2 = 1482+primOpTag PrefetchByteArrayOp1 = 1483+primOpTag PrefetchMutableByteArrayOp1 = 1484+primOpTag PrefetchAddrOp1 = 1485+primOpTag PrefetchValueOp1 = 1486+primOpTag PrefetchByteArrayOp0 = 1487+primOpTag PrefetchMutableByteArrayOp0 = 1488+primOpTag PrefetchAddrOp0 = 1489+primOpTag PrefetchValueOp0 = 1490
ghc-lib/stage0/lib/llvm-targets view
@@ -1,4 +1,5 @@ [("x86_64-unknown-windows-gnu", ("e-m:w-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))+,("aarch64-unknown-windows-gnu", ("e-m:w-p:64:64-i32:32-i64:64-i128:128-n32:64-S128-Fn32", "generic", "+v8a +fp-armv8 +neon")) ,("arm-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align")) ,("arm-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align")) ,("arm-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))
ghc-lib/stage0/lib/settings view
@@ -44,9 +44,10 @@ ,("LLVM llc command", "llc") ,("LLVM opt command", "opt") ,("LLVM llvm-as command", "clang-19")+,("LLVM llvm-as flags", "") ,("Use inplace MinGW toolchain", "NO") ,("target RTS linker only supports shared libraries", "NO")-,("Use interpreter", "YES")+,("Use interpreter", "NO") ,("Support SMP", "YES") ,("RTS ways", "v thr thr_debug thr_debug_p thr_debug_p_dyn thr_debug_dyn thr_p thr_p_dyn thr_dyn debug debug_p debug_p_dyn debug_dyn p p_dyn dyn") ,("Tables next to code", "YES")@@ -54,4 +55,5 @@ ,("Use LibFFI", "NO") ,("RTS expects libdw", "NO") ,("Relative Global Package DB", "../../stage1/lib/package.conf.d")+,("base unit-id", "base-4.22.0.0-inplace") ]
ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs view
@@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?]  cProjectGitCommitId   :: String-cProjectGitCommitId   = "8b63dfe0a81d08fef5b4acba6e60d80067daa5d7"+cProjectGitCommitId   = "902339d332fb4ce2b3c87dcac1ee6495d41ad886"  cProjectVersion       :: String-cProjectVersion       = "9.12.3"+cProjectVersion       = "9.14.1"  cProjectVersionInt    :: String-cProjectVersionInt    = "912"+cProjectVersionInt    = "914"  cProjectPatchLevel    :: String-cProjectPatchLevel    = "3"+cProjectPatchLevel    = "1"  cProjectPatchLevel1   :: String-cProjectPatchLevel1   = "3"+cProjectPatchLevel1   = "1"  cProjectPatchLevel2   :: String cProjectPatchLevel2   = "0"
+ ghc-lib/stage0/libraries/ghc-internal/build/GHC/Internal/Prim.hs view
@@ -0,0 +1,9889 @@+{-+This is a generated file (generated by genprimopcode).+It is not code to actually be used. Its only purpose is to be+consumed by haddock.+-}++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Internal.Prim+-- +-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- GHC's primitive types and operations.+-- Use GHC.Exts from the base package instead of importing this+-- module directly.+--+-----------------------------------------------------------------------------+{-# LANGUAGE Unsafe #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE NegativeLiterals #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+{-# OPTIONS_HADDOCK print-explicit-runtime-reps #-}+module GHC.Internal.Prim (+        +{- * The word size story.-}+{-|Haskell98 specifies that signed integers (type 'Int')+         must contain at least 30 bits. GHC always implements+         'Int' using the primitive type 'Int#', whose size equals+         the @MachDeps.h@ constant @WORD\_SIZE\_IN\_BITS@.+         This is normally set based on the RTS @ghcautoconf.h@ parameter+         @SIZEOF\_HSWORD@, i.e., 32 bits on 32-bit machines, 64+         bits on 64-bit machines.++         GHC also implements a primitive unsigned integer type+         'Word#' which always has the same number of bits as 'Int#'.++         In addition, GHC supports families of explicit-sized integers+         and words at 8, 16, 32, and 64 bits, with the usual+         arithmetic operations, comparisons, and a range of+         conversions.++         Finally, there are strongly deprecated primops for coercing+         between 'Addr#', the primitive type of machine+         addresses, and 'Int#'.  These are pretty bogus anyway,+         but will work on existing 32-bit and 64-bit GHC targets; they+         are completely bogus when tag bits are used in 'Int#',+         so are not available in this case.-}+        +{- * Char#-}+{-|Operations on 31-bit characters.-}+        Char#,+        gtChar#,+        geChar#,+        eqChar#,+        neChar#,+        ltChar#,+        leChar#,+        ord#,+        +{- * Int8#-}+{-|Operations on 8-bit integers.-}+        Int8#,+        int8ToInt#,+        intToInt8#,+        negateInt8#,+        plusInt8#,+        subInt8#,+        timesInt8#,+        quotInt8#,+        remInt8#,+        quotRemInt8#,+        uncheckedShiftLInt8#,+        uncheckedShiftRAInt8#,+        uncheckedShiftRLInt8#,+        int8ToWord8#,+        eqInt8#,+        geInt8#,+        gtInt8#,+        leInt8#,+        ltInt8#,+        neInt8#,+        +{- * Word8#-}+{-|Operations on 8-bit unsigned words.-}+        Word8#,+        word8ToWord#,+        wordToWord8#,+        plusWord8#,+        subWord8#,+        timesWord8#,+        quotWord8#,+        remWord8#,+        quotRemWord8#,+        andWord8#,+        orWord8#,+        xorWord8#,+        notWord8#,+        uncheckedShiftLWord8#,+        uncheckedShiftRLWord8#,+        word8ToInt8#,+        eqWord8#,+        geWord8#,+        gtWord8#,+        leWord8#,+        ltWord8#,+        neWord8#,+        +{- * Int16#-}+{-|Operations on 16-bit integers.-}+        Int16#,+        int16ToInt#,+        intToInt16#,+        negateInt16#,+        plusInt16#,+        subInt16#,+        timesInt16#,+        quotInt16#,+        remInt16#,+        quotRemInt16#,+        uncheckedShiftLInt16#,+        uncheckedShiftRAInt16#,+        uncheckedShiftRLInt16#,+        int16ToWord16#,+        eqInt16#,+        geInt16#,+        gtInt16#,+        leInt16#,+        ltInt16#,+        neInt16#,+        +{- * Word16#-}+{-|Operations on 16-bit unsigned words.-}+        Word16#,+        word16ToWord#,+        wordToWord16#,+        plusWord16#,+        subWord16#,+        timesWord16#,+        quotWord16#,+        remWord16#,+        quotRemWord16#,+        andWord16#,+        orWord16#,+        xorWord16#,+        notWord16#,+        uncheckedShiftLWord16#,+        uncheckedShiftRLWord16#,+        word16ToInt16#,+        eqWord16#,+        geWord16#,+        gtWord16#,+        leWord16#,+        ltWord16#,+        neWord16#,+        +{- * Int32#-}+{-|Operations on 32-bit integers.-}+        Int32#,+        int32ToInt#,+        intToInt32#,+        negateInt32#,+        plusInt32#,+        subInt32#,+        timesInt32#,+        quotInt32#,+        remInt32#,+        quotRemInt32#,+        uncheckedShiftLInt32#,+        uncheckedShiftRAInt32#,+        uncheckedShiftRLInt32#,+        int32ToWord32#,+        eqInt32#,+        geInt32#,+        gtInt32#,+        leInt32#,+        ltInt32#,+        neInt32#,+        +{- * Word32#-}+{-|Operations on 32-bit unsigned words.-}+        Word32#,+        word32ToWord#,+        wordToWord32#,+        plusWord32#,+        subWord32#,+        timesWord32#,+        quotWord32#,+        remWord32#,+        quotRemWord32#,+        andWord32#,+        orWord32#,+        xorWord32#,+        notWord32#,+        uncheckedShiftLWord32#,+        uncheckedShiftRLWord32#,+        word32ToInt32#,+        eqWord32#,+        geWord32#,+        gtWord32#,+        leWord32#,+        ltWord32#,+        neWord32#,+        +{- * Int64#-}+{-|Operations on 64-bit signed words.-}+        Int64#,+        int64ToInt#,+        intToInt64#,+        negateInt64#,+        plusInt64#,+        subInt64#,+        timesInt64#,+        quotInt64#,+        remInt64#,+        uncheckedIShiftL64#,+        uncheckedIShiftRA64#,+        uncheckedIShiftRL64#,+        int64ToWord64#,+        eqInt64#,+        geInt64#,+        gtInt64#,+        leInt64#,+        ltInt64#,+        neInt64#,+        +{- * Word64#-}+{-|Operations on 64-bit unsigned words.-}+        Word64#,+        word64ToWord#,+        wordToWord64#,+        plusWord64#,+        subWord64#,+        timesWord64#,+        quotWord64#,+        remWord64#,+        and64#,+        or64#,+        xor64#,+        not64#,+        uncheckedShiftL64#,+        uncheckedShiftRL64#,+        word64ToInt64#,+        eqWord64#,+        geWord64#,+        gtWord64#,+        leWord64#,+        ltWord64#,+        neWord64#,+        +{- * Int#-}+{-|Operations on native-size integers (32+ bits).-}+        Int#,+        (+#),+        (-#),+        (*#),+        timesInt2#,+        mulIntMayOflo#,+        quotInt#,+        remInt#,+        quotRemInt#,+        andI#,+        orI#,+        xorI#,+        notI#,+        negateInt#,+        addIntC#,+        subIntC#,+        (>#),+        (>=#),+        (==#),+        (/=#),+        (<#),+        (<=#),+        chr#,+        int2Word#,+        int2Float#,+        int2Double#,+        word2Float#,+        word2Double#,+        uncheckedIShiftL#,+        uncheckedIShiftRA#,+        uncheckedIShiftRL#,+        +{- * Word#-}+{-|Operations on native-sized unsigned words (32+ bits).-}+        Word#,+        plusWord#,+        addWordC#,+        subWordC#,+        plusWord2#,+        minusWord#,+        timesWord#,+        timesWord2#,+        quotWord#,+        remWord#,+        quotRemWord#,+        quotRemWord2#,+        and#,+        or#,+        xor#,+        not#,+        uncheckedShiftL#,+        uncheckedShiftRL#,+        word2Int#,+        gtWord#,+        geWord#,+        eqWord#,+        neWord#,+        ltWord#,+        leWord#,+        popCnt8#,+        popCnt16#,+        popCnt32#,+        popCnt64#,+        popCnt#,+        pdep8#,+        pdep16#,+        pdep32#,+        pdep64#,+        pdep#,+        pext8#,+        pext16#,+        pext32#,+        pext64#,+        pext#,+        clz8#,+        clz16#,+        clz32#,+        clz64#,+        clz#,+        ctz8#,+        ctz16#,+        ctz32#,+        ctz64#,+        ctz#,+        byteSwap16#,+        byteSwap32#,+        byteSwap64#,+        byteSwap#,+        bitReverse8#,+        bitReverse16#,+        bitReverse32#,+        bitReverse64#,+        bitReverse#,+        +{- * Narrowings-}+{-|Explicit narrowing of native-sized ints or words.-}+        narrow8Int#,+        narrow16Int#,+        narrow32Int#,+        narrow8Word#,+        narrow16Word#,+        narrow32Word#,+        +{- * Double#-}+{-|Operations on double-precision (64 bit) floating-point numbers.-}+        Double#,+        (>##),+        (>=##),+        (==##),+        (/=##),+        (<##),+        (<=##),+        minDouble#,+        maxDouble#,+        (+##),+        (-##),+        (*##),+        (/##),+        negateDouble#,+        fabsDouble#,+        double2Int#,+        double2Float#,+        expDouble#,+        expm1Double#,+        logDouble#,+        log1pDouble#,+        sqrtDouble#,+        sinDouble#,+        cosDouble#,+        tanDouble#,+        asinDouble#,+        acosDouble#,+        atanDouble#,+        sinhDouble#,+        coshDouble#,+        tanhDouble#,+        asinhDouble#,+        acoshDouble#,+        atanhDouble#,+        (**##),+        decodeDouble_2Int#,+        decodeDouble_Int64#,+        castDoubleToWord64#,+        castWord64ToDouble#,+        +{- * Float#-}+{-|Operations on single-precision (32-bit) floating-point numbers.-}+        Float#,+        gtFloat#,+        geFloat#,+        eqFloat#,+        neFloat#,+        ltFloat#,+        leFloat#,+        minFloat#,+        maxFloat#,+        plusFloat#,+        minusFloat#,+        timesFloat#,+        divideFloat#,+        negateFloat#,+        fabsFloat#,+        float2Int#,+        expFloat#,+        expm1Float#,+        logFloat#,+        log1pFloat#,+        sqrtFloat#,+        sinFloat#,+        cosFloat#,+        tanFloat#,+        asinFloat#,+        acosFloat#,+        atanFloat#,+        sinhFloat#,+        coshFloat#,+        tanhFloat#,+        asinhFloat#,+        acoshFloat#,+        atanhFloat#,+        powerFloat#,+        float2Double#,+        decodeFloat_Int#,+        castFloatToWord32#,+        castWord32ToFloat#,+        +{- * Fused multiply-add operations-}+{-| #fma#++    The fused multiply-add primops 'fmaddFloat#' and 'fmaddDouble#'+    implement the operation++    \[+    \lambda\ x\ y\ z \rightarrow x * y + z+    \]++    with a single floating-point rounding operation at the end, as opposed to+    rounding twice (which can accumulate rounding errors).++    These primops can be compiled directly to a single machine instruction on+    architectures that support them. Currently, these are:++      1. x86 with CPUs that support the FMA3 extended instruction set (which+         includes most processors since 2013).+      2. PowerPC.+      3. AArch64.++    This requires users pass the '-mfma' flag to GHC. Otherwise, the primop+    is implemented by falling back to the C standard library, which might+    perform software emulation (this may yield results that are not IEEE+    compliant on some platforms).++    The additional operations 'fmsubFloat#'/'fmsubDouble#',+    'fnmaddFloat#'/'fnmaddDouble#' and 'fnmsubFloat#'/'fnmsubDouble#' provide+    variants on 'fmaddFloat#'/'fmaddDouble#' in which some signs are changed:++    \[+    \begin{aligned}+    \mathrm{fmadd}\ x\ y\ z &= \phantom{+} x * y + z \\[8pt]+    \mathrm{fmsub}\ x\ y\ z &= \phantom{+} x * y - z \\[8pt]+    \mathrm{fnmadd}\ x\ y\ z &= - x * y + z \\[8pt]+    \mathrm{fnmsub}\ x\ y\ z &= - x * y - z+    \end{aligned}+    \]++    -}+        fmaddFloat#,+        fmsubFloat#,+        fnmaddFloat#,+        fnmsubFloat#,+        fmaddDouble#,+        fmsubDouble#,+        fnmaddDouble#,+        fnmsubDouble#,+        +{- * Arrays-}+{-|Operations on 'Array#'.-}+        Array#,+        MutableArray#,+        newArray#,+        readArray#,+        writeArray#,+        sizeofArray#,+        sizeofMutableArray#,+        indexArray#,+        unsafeFreezeArray#,+        unsafeThawArray#,+        copyArray#,+        copyMutableArray#,+        cloneArray#,+        cloneMutableArray#,+        freezeArray#,+        thawArray#,+        casArray#,+        +{- * Small Arrays-}+{-|Operations on 'SmallArray#'. A 'SmallArray#' works+         just like an 'Array#', but with different space use and+         performance characteristics (that are often useful with small+         arrays). The 'SmallArray#' and 'SmallMutableArray#'+         lack a `card table'. The purpose of a card table is to avoid+         having to scan every element of the array on each GC by+         keeping track of which elements have changed since the last GC+         and only scanning those that have changed. So the consequence+         of there being no card table is that the representation is+         somewhat smaller and the writes are somewhat faster (because+         the card table does not need to be updated). The disadvantage+         of course is that for a 'SmallMutableArray#' the whole+         array has to be scanned on each GC. Thus it is best suited for+         use cases where the mutable array is not long lived, e.g.+         where a mutable array is initialised quickly and then frozen+         to become an immutable 'SmallArray#'.+        -}+        SmallArray#,+        SmallMutableArray#,+        newSmallArray#,+        shrinkSmallMutableArray#,+        readSmallArray#,+        writeSmallArray#,+        sizeofSmallArray#,+        sizeofSmallMutableArray#,+        getSizeofSmallMutableArray#,+        indexSmallArray#,+        unsafeFreezeSmallArray#,+        unsafeThawSmallArray#,+        copySmallArray#,+        copySmallMutableArray#,+        cloneSmallArray#,+        cloneSmallMutableArray#,+        freezeSmallArray#,+        thawSmallArray#,+        casSmallArray#,+        +{- * Byte Arrays-}+{-|A 'ByteArray#' is a region of+         raw memory in the garbage-collected heap, which is not+         scanned for pointers.+         There are three sets of operations for accessing byte array contents:+         index for reading from immutable byte arrays, and read/write+         for mutable byte arrays.  Each set contains operations for a+         range of useful primitive data types.  Each operation takes+         an offset measured in terms of the size of the primitive type+         being read or written.++         -}+        ByteArray#,+        MutableByteArray#,+        newByteArray#,+        newPinnedByteArray#,+        newAlignedPinnedByteArray#,+        isMutableByteArrayPinned#,+        isByteArrayPinned#,+        isByteArrayWeaklyPinned#,+        isMutableByteArrayWeaklyPinned#,+        byteArrayContents#,+        mutableByteArrayContents#,+        shrinkMutableByteArray#,+        resizeMutableByteArray#,+        unsafeFreezeByteArray#,+        unsafeThawByteArray#,+        sizeofByteArray#,+        sizeofMutableByteArray#,+        getSizeofMutableByteArray#,+        indexCharArray#,+        indexWideCharArray#,+        indexIntArray#,+        indexWordArray#,+        indexAddrArray#,+        indexFloatArray#,+        indexDoubleArray#,+        indexStablePtrArray#,+        indexInt8Array#,+        indexWord8Array#,+        indexInt16Array#,+        indexWord16Array#,+        indexInt32Array#,+        indexWord32Array#,+        indexInt64Array#,+        indexWord64Array#,+        indexWord8ArrayAsChar#,+        indexWord8ArrayAsWideChar#,+        indexWord8ArrayAsInt#,+        indexWord8ArrayAsWord#,+        indexWord8ArrayAsAddr#,+        indexWord8ArrayAsFloat#,+        indexWord8ArrayAsDouble#,+        indexWord8ArrayAsStablePtr#,+        indexWord8ArrayAsInt16#,+        indexWord8ArrayAsWord16#,+        indexWord8ArrayAsInt32#,+        indexWord8ArrayAsWord32#,+        indexWord8ArrayAsInt64#,+        indexWord8ArrayAsWord64#,+        readCharArray#,+        readWideCharArray#,+        readIntArray#,+        readWordArray#,+        readAddrArray#,+        readFloatArray#,+        readDoubleArray#,+        readStablePtrArray#,+        readInt8Array#,+        readWord8Array#,+        readInt16Array#,+        readWord16Array#,+        readInt32Array#,+        readWord32Array#,+        readInt64Array#,+        readWord64Array#,+        readWord8ArrayAsChar#,+        readWord8ArrayAsWideChar#,+        readWord8ArrayAsInt#,+        readWord8ArrayAsWord#,+        readWord8ArrayAsAddr#,+        readWord8ArrayAsFloat#,+        readWord8ArrayAsDouble#,+        readWord8ArrayAsStablePtr#,+        readWord8ArrayAsInt16#,+        readWord8ArrayAsWord16#,+        readWord8ArrayAsInt32#,+        readWord8ArrayAsWord32#,+        readWord8ArrayAsInt64#,+        readWord8ArrayAsWord64#,+        writeCharArray#,+        writeWideCharArray#,+        writeIntArray#,+        writeWordArray#,+        writeAddrArray#,+        writeFloatArray#,+        writeDoubleArray#,+        writeStablePtrArray#,+        writeInt8Array#,+        writeWord8Array#,+        writeInt16Array#,+        writeWord16Array#,+        writeInt32Array#,+        writeWord32Array#,+        writeInt64Array#,+        writeWord64Array#,+        writeWord8ArrayAsChar#,+        writeWord8ArrayAsWideChar#,+        writeWord8ArrayAsInt#,+        writeWord8ArrayAsWord#,+        writeWord8ArrayAsAddr#,+        writeWord8ArrayAsFloat#,+        writeWord8ArrayAsDouble#,+        writeWord8ArrayAsStablePtr#,+        writeWord8ArrayAsInt16#,+        writeWord8ArrayAsWord16#,+        writeWord8ArrayAsInt32#,+        writeWord8ArrayAsWord32#,+        writeWord8ArrayAsInt64#,+        writeWord8ArrayAsWord64#,+        compareByteArrays#,+        copyByteArray#,+        copyMutableByteArray#,+        copyMutableByteArrayNonOverlapping#,+        copyByteArrayToAddr#,+        copyMutableByteArrayToAddr#,+        copyAddrToByteArray#,+        copyAddrToAddr#,+        copyAddrToAddrNonOverlapping#,+        setByteArray#,+        setAddrRange#,+        atomicReadIntArray#,+        atomicWriteIntArray#,+        casIntArray#,+        casInt8Array#,+        casInt16Array#,+        casInt32Array#,+        casInt64Array#,+        fetchAddIntArray#,+        fetchSubIntArray#,+        fetchAndIntArray#,+        fetchNandIntArray#,+        fetchOrIntArray#,+        fetchXorIntArray#,+        +{- * Addr#-}+{-|-}+        Addr#,+        nullAddr#,+        plusAddr#,+        minusAddr#,+        remAddr#,+        addr2Int#,+        int2Addr#,+        gtAddr#,+        geAddr#,+        eqAddr#,+        neAddr#,+        ltAddr#,+        leAddr#,+        indexCharOffAddr#,+        indexWideCharOffAddr#,+        indexIntOffAddr#,+        indexWordOffAddr#,+        indexAddrOffAddr#,+        indexFloatOffAddr#,+        indexDoubleOffAddr#,+        indexStablePtrOffAddr#,+        indexInt8OffAddr#,+        indexWord8OffAddr#,+        indexInt16OffAddr#,+        indexWord16OffAddr#,+        indexInt32OffAddr#,+        indexWord32OffAddr#,+        indexInt64OffAddr#,+        indexWord64OffAddr#,+        indexWord8OffAddrAsChar#,+        indexWord8OffAddrAsWideChar#,+        indexWord8OffAddrAsInt#,+        indexWord8OffAddrAsWord#,+        indexWord8OffAddrAsAddr#,+        indexWord8OffAddrAsFloat#,+        indexWord8OffAddrAsDouble#,+        indexWord8OffAddrAsStablePtr#,+        indexWord8OffAddrAsInt16#,+        indexWord8OffAddrAsWord16#,+        indexWord8OffAddrAsInt32#,+        indexWord8OffAddrAsWord32#,+        indexWord8OffAddrAsInt64#,+        indexWord8OffAddrAsWord64#,+        readCharOffAddr#,+        readWideCharOffAddr#,+        readIntOffAddr#,+        readWordOffAddr#,+        readAddrOffAddr#,+        readFloatOffAddr#,+        readDoubleOffAddr#,+        readStablePtrOffAddr#,+        readInt8OffAddr#,+        readWord8OffAddr#,+        readInt16OffAddr#,+        readWord16OffAddr#,+        readInt32OffAddr#,+        readWord32OffAddr#,+        readInt64OffAddr#,+        readWord64OffAddr#,+        readWord8OffAddrAsChar#,+        readWord8OffAddrAsWideChar#,+        readWord8OffAddrAsInt#,+        readWord8OffAddrAsWord#,+        readWord8OffAddrAsAddr#,+        readWord8OffAddrAsFloat#,+        readWord8OffAddrAsDouble#,+        readWord8OffAddrAsStablePtr#,+        readWord8OffAddrAsInt16#,+        readWord8OffAddrAsWord16#,+        readWord8OffAddrAsInt32#,+        readWord8OffAddrAsWord32#,+        readWord8OffAddrAsInt64#,+        readWord8OffAddrAsWord64#,+        writeCharOffAddr#,+        writeWideCharOffAddr#,+        writeIntOffAddr#,+        writeWordOffAddr#,+        writeAddrOffAddr#,+        writeFloatOffAddr#,+        writeDoubleOffAddr#,+        writeStablePtrOffAddr#,+        writeInt8OffAddr#,+        writeWord8OffAddr#,+        writeInt16OffAddr#,+        writeWord16OffAddr#,+        writeInt32OffAddr#,+        writeWord32OffAddr#,+        writeInt64OffAddr#,+        writeWord64OffAddr#,+        writeWord8OffAddrAsChar#,+        writeWord8OffAddrAsWideChar#,+        writeWord8OffAddrAsInt#,+        writeWord8OffAddrAsWord#,+        writeWord8OffAddrAsAddr#,+        writeWord8OffAddrAsFloat#,+        writeWord8OffAddrAsDouble#,+        writeWord8OffAddrAsStablePtr#,+        writeWord8OffAddrAsInt16#,+        writeWord8OffAddrAsWord16#,+        writeWord8OffAddrAsInt32#,+        writeWord8OffAddrAsWord32#,+        writeWord8OffAddrAsInt64#,+        writeWord8OffAddrAsWord64#,+        atomicExchangeAddrAddr#,+        atomicExchangeWordAddr#,+        atomicCasAddrAddr#,+        atomicCasWordAddr#,+        atomicCasWord8Addr#,+        atomicCasWord16Addr#,+        atomicCasWord32Addr#,+        atomicCasWord64Addr#,+        fetchAddWordAddr#,+        fetchSubWordAddr#,+        fetchAndWordAddr#,+        fetchNandWordAddr#,+        fetchOrWordAddr#,+        fetchXorWordAddr#,+        atomicReadWordAddr#,+        atomicWriteWordAddr#,+        +{- * Mutable variables-}+{-|Operations on MutVar\#s.-}+        MutVar#,+        newMutVar#,+        readMutVar#,+        writeMutVar#,+        atomicSwapMutVar#,+        atomicModifyMutVar2#,+        atomicModifyMutVar_#,+        casMutVar#,+        +{- * Exceptions-}+{-|-}+        catch#,+        raise#,+        raiseUnderflow#,+        raiseOverflow#,+        raiseDivZero#,+        raiseIO#,+        maskAsyncExceptions#,+        maskUninterruptible#,+        unmaskAsyncExceptions#,+        getMaskingState#,+        +{- * Continuations-}+{-| #continuations#++    These operations provide access to first-class delimited continuations,+    which allow a computation to access and manipulate portions of its+    /current continuation/. Operationally, they are implemented by direct+    manipulation of the RTS call stack, which may provide significant+    performance gains relative to manual continuation-passing style (CPS) for+    some programs.++    Intuitively, the delimited control operators 'prompt#' and+    'control0#' can be understood by analogy to 'catch#' and 'raiseIO#',+    respectively:++      * Like 'catch#', 'prompt#' does not do anything on its own, it+        just /delimits/ a subcomputation (the source of the name "delimited+        continuations").++      * Like 'raiseIO#', 'control0#' aborts to the nearest enclosing+        'prompt#' before resuming execution.++    However, /unlike/ 'raiseIO#', 'control0#' does /not/ discard+    the aborted computation: instead, it /captures/ it in a form that allows+    it to be resumed later. In other words, 'control0#' does not+    irreversibly abort the local computation before returning to the enclosing+    'prompt#', it merely suspends it. All local context of the suspended+    computation is packaged up and returned as an ordinary function that can be+    invoked at a later point in time to /continue/ execution, which is why+    the suspended computation is known as a /first-class continuation/.++    In GHC, every continuation prompt is associated with exactly one+    'PromptTag#'. Prompt tags are unique, opaque values created by+    'newPromptTag#' that may only be compared for equality. Both 'prompt#'+    and 'control0#' accept a 'PromptTag#' argument, and 'control0#'+    captures the continuation up to the nearest enclosing use of 'prompt#'+    /with the same tag/. This allows a program to control exactly which+    prompt it will abort to by using different tags, similar to how a program+    can control which 'catch' it will abort to by throwing different types+    of exceptions. Additionally, 'PromptTag#' accepts a single type parameter,+    which is used to relate the expected result type at the point of the+    'prompt#' to the type of the continuation produced by 'control0#'.++    == The gory details++    The high-level explanation provided above should hopefully provide some+    intuition for what these operations do, but it is not very precise; this+    section provides a more thorough explanation.++    The 'prompt#' operation morally has the following type:++@+'prompt#' :: 'PromptTag#' a -> IO a -> IO a+@++    If a computation @/m/@ never calls 'control0#', then+    @'prompt#' /tag/ /m/@ is equivalent to just @/m/@, i.e. the 'prompt#' is+    a no-op. This implies the following law:++    \[+    \mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{pure}\ x) \equiv \mathtt{pure}\ x+    \]++    The 'control0#' operation morally has the following type:++@+'control0#' :: 'PromptTag#' a -> ((IO b -> IO a) -> IO a) -> IO b+@++    @'control0#' /tag/ /f/@ captures the current continuation up to the nearest+    enclosing @'prompt#' /tag/@ and resumes execution from the point of the call+    to 'prompt#', passing the captured continuation to @/f/@. To make that+    somewhat more precise, we can say 'control0#' obeys the following law:++    \[+    \mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{control0\#}\ tag\ f \mathbin{\mathtt{>>=}} k)+      \equiv f\ (\lambda\ m \rightarrow m \mathbin{\mathtt{>>=}} k)+    \]++    However, this law does not fully describe the behavior of 'control0#',+    as it does not account for situations where 'control0#' does not appear+    immediately inside 'prompt#'. Capturing the semantics more precisely+    requires some additional notational machinery; a common approach is to+    use [reduction semantics](https://en.wikipedia.org/wiki/Operational_semantics#Reduction_semantics).+    Assuming an appropriate definition of evaluation contexts \(E\), the+    semantics of 'prompt#' and 'control0#' can be given as follows:++    \[+    \begin{aligned}+    E[\mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{pure}\ v)]+      &\longrightarrow E[\mathtt{pure}\ v] \\[8pt]+    E_1[\mathtt{prompt\#}\ \mathit{tag}\ E_2[\mathtt{control0\#}\ tag\ f]]+      &\longrightarrow E_1[f\ (\lambda\ m \rightarrow E_2[m])] \\[-2pt]+      \mathrm{where}\;\: \mathtt{prompt\#}\ \mathit{tag} &\not\in E_2+    \end{aligned}+    \]++    A full treatment of the semantics and metatheory of delimited control is+    well outside the scope of this documentation, but a good, thorough+    overview (in Haskell) is provided in [A Monadic Framework for Delimited+    Continuations](https://legacy.cs.indiana.edu/~dyb/pubs/monadicDC.pdf) by+    Dybvig et al.++    == Safety and invariants++    Correct uses of 'control0#' must obey the following restrictions:++    1. The behavior of 'control0#' is only well-defined within a /strict+       'State#' thread/, such as those associated with @IO@ and strict @ST@+       computations.++    2. Furthermore, 'control0#' may only be called within the dynamic extent+       of a 'prompt#' with a matching tag somewhere in the /current/ strict+       'State#' thread. Effectively, this means that a matching prompt must+       exist somewhere, and the captured continuation must /not/ contain any+       uses of @unsafePerformIO@, @runST@, @unsafeInterleaveIO@, etc. For+       example, the following program is ill-defined:++        @+        'prompt#' /tag/ $+          evaluate (unsafePerformIO $ 'control0#' /tag/ /f/)+        @++        In this example, the use of 'prompt#' appears in a different 'State#'+        thread from the use of 'control0#', so there is no valid prompt in+        scope to capture up to.++    3. Finally, 'control0#' may not be used within 'State#' threads associated+       with an STM transaction (i.e. those introduced by 'atomically#').++    If the runtime is able to detect that any of these invariants have been+    violated in a way that would compromise internal invariants of the runtime,+    'control0#' will fail by raising an exception. However, such violations+    are only detected on a best-effort basis, as the bookkeeping necessary for+    detecting /all/ illegal uses of 'control0#' would have significant overhead.+    Therefore, although the operations are "safe" from the runtime's point of+    view (e.g. they will not compromise memory safety or clobber internal runtime+    state), it is still ultimately the programmer's responsibility to ensure+    these invariants hold to guarantee predictable program behavior.++    In a similar vein, since each captured continuation includes the full local+    context of the suspended computation, it can safely be resumed arbitrarily+    many times without violating any invariants of the runtime system. However,+    use of these operations in an arbitrary 'IO' computation may be unsafe for+    other reasons, as most 'IO' code is not written with reentrancy in mind. For+    example, a computation suspended in the middle of reading a file will likely+    finish reading it when it is resumed; further attempts to resume from the+    same place would then fail because the file handle was already closed.++    In other words, although the RTS ensures that a computation's control state+    and local variables are properly restored for each distinct resumption of+    a continuation, it makes no attempt to duplicate any local state the+    computation may have been using (and could not possibly do so in general).+    Furthermore, it provides no mechanism for an arbitrary computation to+    protect itself against unwanted reentrancy (i.e. there is no analogue to+    Scheme's @dynamic-wind@). For those reasons, manipulating the continuation+    is only safe if the caller can be certain that doing so will not violate any+    expectations or invariants of the enclosing computation. -}+        PromptTag#,+        newPromptTag#,+        prompt#,+        control0#,+        +{- * STM-accessible Mutable Variables-}+{-|-}+        TVar#,+        atomically#,+        retry#,+        catchRetry#,+        catchSTM#,+        newTVar#,+        readTVar#,+        readTVarIO#,+        writeTVar#,+        +{- * Synchronized Mutable Variables-}+{-|Operations on 'MVar#'s. -}+        MVar#,+        newMVar#,+        takeMVar#,+        tryTakeMVar#,+        putMVar#,+        tryPutMVar#,+        readMVar#,+        tryReadMVar#,+        isEmptyMVar#,+        +{- * Delay/wait operations-}+{-|-}+        delay#,+        waitRead#,+        waitWrite#,+        +{- * Concurrency primitives-}+{-|-}+        State#,+        RealWorld,+        ThreadId#,+        fork#,+        forkOn#,+        killThread#,+        yield#,+        myThreadId#,+        labelThread#,+        isCurrentThreadBound#,+        noDuplicate#,+        threadLabel#,+        threadStatus#,+        listThreads#,+        +{- * Weak pointers-}+{-|-}+        Weak#,+        mkWeak#,+        mkWeakNoFinalizer#,+        addCFinalizerToWeak#,+        deRefWeak#,+        finalizeWeak#,+        touch#,+        +{- * Stable pointers and names-}+{-|-}+        StablePtr#,+        StableName#,+        makeStablePtr#,+        deRefStablePtr#,+        eqStablePtr#,+        makeStableName#,+        stableNameToInt#,+        +{- * Compact normal form-}+{-|Primitives for working with compact regions. The @ghc-compact@+         library and the @compact@ library demonstrate how to use these+         primitives. The documentation below draws a distinction between+         a CNF and a compact block. A CNF contains one or more compact+         blocks. The source file @rts\/sm\/CNF.c@+         diagrams this relationship. When discussing a compact+         block, an additional distinction is drawn between capacity and+         utilized bytes. The capacity is the maximum number of bytes that+         the compact block can hold. The utilized bytes is the number of+         bytes that are actually used by the compact block.+        -}+        Compact#,+        compactNew#,+        compactResize#,+        compactContains#,+        compactContainsAny#,+        compactGetFirstBlock#,+        compactGetNextBlock#,+        compactAllocateBlock#,+        compactFixupPointers#,+        compactAdd#,+        compactAddWithSharing#,+        compactSize#,+        +{- * Unsafe pointer equality-}+{-|-}+        reallyUnsafePtrEquality#,+        +{- * Parallelism-}+{-|-}+        par#,+        spark#,+        getSpark#,+        numSparks#,+        +{- * Controlling object lifetime-}+{-|Ensuring that objects don't die a premature death.-}+        keepAlive#,+        +{- * Tag to enum stuff-}+{-|Convert back and forth between values of enumerated types+        and small integers.-}+        dataToTagSmall#,+        dataToTagLarge#,+        tagToEnum#,+        +{- * Bytecode operations-}+{-|Support for manipulating bytecode objects used by the interpreter and+        linker.++        Bytecode objects are heap objects which represent top-level bindings and+        contain a list of instructions and data needed by these instructions.-}+        BCO,+        addrToAny#,+        anyToAddr#,+        mkApUpd0#,+        newBCO#,+        unpackClosure#,+        closureSize#,+        getApStackVal#,+        +{- * Misc-}+{-|These aren't nearly as wired in as Etc...-}+        getCCSOf#,+        getCurrentCCS#,+        clearCCS#,+        +{- * Annotating call stacks-}+{-|-}+        annotateStack#,+        +{- * Info Table Origin-}+{-|-}+        whereFrom#,+        +{- * Etc-}+{-|Miscellaneous built-ins-}+        FUN,+        realWorld#,+        void#,+        Proxy#,+        proxy#,+        seq,+        traceEvent#,+        traceBinaryEvent#,+        traceMarker#,+        setThreadAllocationCounter#,+        setOtherThreadAllocationCounter#,+        StackSnapshot#,+        +{- * Safe coercions-}+{-|-}+        coerce,+        +{- * SIMD Vectors-}+{-|Operations on SIMD vectors.-}+        Int8X16#,+        Int16X8#,+        Int32X4#,+        Int64X2#,+        Int8X32#,+        Int16X16#,+        Int32X8#,+        Int64X4#,+        Int8X64#,+        Int16X32#,+        Int32X16#,+        Int64X8#,+        Word8X16#,+        Word16X8#,+        Word32X4#,+        Word64X2#,+        Word8X32#,+        Word16X16#,+        Word32X8#,+        Word64X4#,+        Word8X64#,+        Word16X32#,+        Word32X16#,+        Word64X8#,+        FloatX4#,+        DoubleX2#,+        FloatX8#,+        DoubleX4#,+        FloatX16#,+        DoubleX8#,+        broadcastInt8X16#,+        broadcastInt16X8#,+        broadcastInt32X4#,+        broadcastInt64X2#,+        broadcastInt8X32#,+        broadcastInt16X16#,+        broadcastInt32X8#,+        broadcastInt64X4#,+        broadcastInt8X64#,+        broadcastInt16X32#,+        broadcastInt32X16#,+        broadcastInt64X8#,+        broadcastWord8X16#,+        broadcastWord16X8#,+        broadcastWord32X4#,+        broadcastWord64X2#,+        broadcastWord8X32#,+        broadcastWord16X16#,+        broadcastWord32X8#,+        broadcastWord64X4#,+        broadcastWord8X64#,+        broadcastWord16X32#,+        broadcastWord32X16#,+        broadcastWord64X8#,+        broadcastFloatX4#,+        broadcastDoubleX2#,+        broadcastFloatX8#,+        broadcastDoubleX4#,+        broadcastFloatX16#,+        broadcastDoubleX8#,+        packInt8X16#,+        packInt16X8#,+        packInt32X4#,+        packInt64X2#,+        packInt8X32#,+        packInt16X16#,+        packInt32X8#,+        packInt64X4#,+        packInt8X64#,+        packInt16X32#,+        packInt32X16#,+        packInt64X8#,+        packWord8X16#,+        packWord16X8#,+        packWord32X4#,+        packWord64X2#,+        packWord8X32#,+        packWord16X16#,+        packWord32X8#,+        packWord64X4#,+        packWord8X64#,+        packWord16X32#,+        packWord32X16#,+        packWord64X8#,+        packFloatX4#,+        packDoubleX2#,+        packFloatX8#,+        packDoubleX4#,+        packFloatX16#,+        packDoubleX8#,+        unpackInt8X16#,+        unpackInt16X8#,+        unpackInt32X4#,+        unpackInt64X2#,+        unpackInt8X32#,+        unpackInt16X16#,+        unpackInt32X8#,+        unpackInt64X4#,+        unpackInt8X64#,+        unpackInt16X32#,+        unpackInt32X16#,+        unpackInt64X8#,+        unpackWord8X16#,+        unpackWord16X8#,+        unpackWord32X4#,+        unpackWord64X2#,+        unpackWord8X32#,+        unpackWord16X16#,+        unpackWord32X8#,+        unpackWord64X4#,+        unpackWord8X64#,+        unpackWord16X32#,+        unpackWord32X16#,+        unpackWord64X8#,+        unpackFloatX4#,+        unpackDoubleX2#,+        unpackFloatX8#,+        unpackDoubleX4#,+        unpackFloatX16#,+        unpackDoubleX8#,+        insertInt8X16#,+        insertInt16X8#,+        insertInt32X4#,+        insertInt64X2#,+        insertInt8X32#,+        insertInt16X16#,+        insertInt32X8#,+        insertInt64X4#,+        insertInt8X64#,+        insertInt16X32#,+        insertInt32X16#,+        insertInt64X8#,+        insertWord8X16#,+        insertWord16X8#,+        insertWord32X4#,+        insertWord64X2#,+        insertWord8X32#,+        insertWord16X16#,+        insertWord32X8#,+        insertWord64X4#,+        insertWord8X64#,+        insertWord16X32#,+        insertWord32X16#,+        insertWord64X8#,+        insertFloatX4#,+        insertDoubleX2#,+        insertFloatX8#,+        insertDoubleX4#,+        insertFloatX16#,+        insertDoubleX8#,+        plusInt8X16#,+        plusInt16X8#,+        plusInt32X4#,+        plusInt64X2#,+        plusInt8X32#,+        plusInt16X16#,+        plusInt32X8#,+        plusInt64X4#,+        plusInt8X64#,+        plusInt16X32#,+        plusInt32X16#,+        plusInt64X8#,+        plusWord8X16#,+        plusWord16X8#,+        plusWord32X4#,+        plusWord64X2#,+        plusWord8X32#,+        plusWord16X16#,+        plusWord32X8#,+        plusWord64X4#,+        plusWord8X64#,+        plusWord16X32#,+        plusWord32X16#,+        plusWord64X8#,+        plusFloatX4#,+        plusDoubleX2#,+        plusFloatX8#,+        plusDoubleX4#,+        plusFloatX16#,+        plusDoubleX8#,+        minusInt8X16#,+        minusInt16X8#,+        minusInt32X4#,+        minusInt64X2#,+        minusInt8X32#,+        minusInt16X16#,+        minusInt32X8#,+        minusInt64X4#,+        minusInt8X64#,+        minusInt16X32#,+        minusInt32X16#,+        minusInt64X8#,+        minusWord8X16#,+        minusWord16X8#,+        minusWord32X4#,+        minusWord64X2#,+        minusWord8X32#,+        minusWord16X16#,+        minusWord32X8#,+        minusWord64X4#,+        minusWord8X64#,+        minusWord16X32#,+        minusWord32X16#,+        minusWord64X8#,+        minusFloatX4#,+        minusDoubleX2#,+        minusFloatX8#,+        minusDoubleX4#,+        minusFloatX16#,+        minusDoubleX8#,+        timesInt8X16#,+        timesInt16X8#,+        timesInt32X4#,+        timesInt64X2#,+        timesInt8X32#,+        timesInt16X16#,+        timesInt32X8#,+        timesInt64X4#,+        timesInt8X64#,+        timesInt16X32#,+        timesInt32X16#,+        timesInt64X8#,+        timesWord8X16#,+        timesWord16X8#,+        timesWord32X4#,+        timesWord64X2#,+        timesWord8X32#,+        timesWord16X16#,+        timesWord32X8#,+        timesWord64X4#,+        timesWord8X64#,+        timesWord16X32#,+        timesWord32X16#,+        timesWord64X8#,+        timesFloatX4#,+        timesDoubleX2#,+        timesFloatX8#,+        timesDoubleX4#,+        timesFloatX16#,+        timesDoubleX8#,+        divideFloatX4#,+        divideDoubleX2#,+        divideFloatX8#,+        divideDoubleX4#,+        divideFloatX16#,+        divideDoubleX8#,+        quotInt8X16#,+        quotInt16X8#,+        quotInt32X4#,+        quotInt64X2#,+        quotInt8X32#,+        quotInt16X16#,+        quotInt32X8#,+        quotInt64X4#,+        quotInt8X64#,+        quotInt16X32#,+        quotInt32X16#,+        quotInt64X8#,+        quotWord8X16#,+        quotWord16X8#,+        quotWord32X4#,+        quotWord64X2#,+        quotWord8X32#,+        quotWord16X16#,+        quotWord32X8#,+        quotWord64X4#,+        quotWord8X64#,+        quotWord16X32#,+        quotWord32X16#,+        quotWord64X8#,+        remInt8X16#,+        remInt16X8#,+        remInt32X4#,+        remInt64X2#,+        remInt8X32#,+        remInt16X16#,+        remInt32X8#,+        remInt64X4#,+        remInt8X64#,+        remInt16X32#,+        remInt32X16#,+        remInt64X8#,+        remWord8X16#,+        remWord16X8#,+        remWord32X4#,+        remWord64X2#,+        remWord8X32#,+        remWord16X16#,+        remWord32X8#,+        remWord64X4#,+        remWord8X64#,+        remWord16X32#,+        remWord32X16#,+        remWord64X8#,+        negateInt8X16#,+        negateInt16X8#,+        negateInt32X4#,+        negateInt64X2#,+        negateInt8X32#,+        negateInt16X16#,+        negateInt32X8#,+        negateInt64X4#,+        negateInt8X64#,+        negateInt16X32#,+        negateInt32X16#,+        negateInt64X8#,+        negateFloatX4#,+        negateDoubleX2#,+        negateFloatX8#,+        negateDoubleX4#,+        negateFloatX16#,+        negateDoubleX8#,+        indexInt8X16Array#,+        indexInt16X8Array#,+        indexInt32X4Array#,+        indexInt64X2Array#,+        indexInt8X32Array#,+        indexInt16X16Array#,+        indexInt32X8Array#,+        indexInt64X4Array#,+        indexInt8X64Array#,+        indexInt16X32Array#,+        indexInt32X16Array#,+        indexInt64X8Array#,+        indexWord8X16Array#,+        indexWord16X8Array#,+        indexWord32X4Array#,+        indexWord64X2Array#,+        indexWord8X32Array#,+        indexWord16X16Array#,+        indexWord32X8Array#,+        indexWord64X4Array#,+        indexWord8X64Array#,+        indexWord16X32Array#,+        indexWord32X16Array#,+        indexWord64X8Array#,+        indexFloatX4Array#,+        indexDoubleX2Array#,+        indexFloatX8Array#,+        indexDoubleX4Array#,+        indexFloatX16Array#,+        indexDoubleX8Array#,+        readInt8X16Array#,+        readInt16X8Array#,+        readInt32X4Array#,+        readInt64X2Array#,+        readInt8X32Array#,+        readInt16X16Array#,+        readInt32X8Array#,+        readInt64X4Array#,+        readInt8X64Array#,+        readInt16X32Array#,+        readInt32X16Array#,+        readInt64X8Array#,+        readWord8X16Array#,+        readWord16X8Array#,+        readWord32X4Array#,+        readWord64X2Array#,+        readWord8X32Array#,+        readWord16X16Array#,+        readWord32X8Array#,+        readWord64X4Array#,+        readWord8X64Array#,+        readWord16X32Array#,+        readWord32X16Array#,+        readWord64X8Array#,+        readFloatX4Array#,+        readDoubleX2Array#,+        readFloatX8Array#,+        readDoubleX4Array#,+        readFloatX16Array#,+        readDoubleX8Array#,+        writeInt8X16Array#,+        writeInt16X8Array#,+        writeInt32X4Array#,+        writeInt64X2Array#,+        writeInt8X32Array#,+        writeInt16X16Array#,+        writeInt32X8Array#,+        writeInt64X4Array#,+        writeInt8X64Array#,+        writeInt16X32Array#,+        writeInt32X16Array#,+        writeInt64X8Array#,+        writeWord8X16Array#,+        writeWord16X8Array#,+        writeWord32X4Array#,+        writeWord64X2Array#,+        writeWord8X32Array#,+        writeWord16X16Array#,+        writeWord32X8Array#,+        writeWord64X4Array#,+        writeWord8X64Array#,+        writeWord16X32Array#,+        writeWord32X16Array#,+        writeWord64X8Array#,+        writeFloatX4Array#,+        writeDoubleX2Array#,+        writeFloatX8Array#,+        writeDoubleX4Array#,+        writeFloatX16Array#,+        writeDoubleX8Array#,+        indexInt8X16OffAddr#,+        indexInt16X8OffAddr#,+        indexInt32X4OffAddr#,+        indexInt64X2OffAddr#,+        indexInt8X32OffAddr#,+        indexInt16X16OffAddr#,+        indexInt32X8OffAddr#,+        indexInt64X4OffAddr#,+        indexInt8X64OffAddr#,+        indexInt16X32OffAddr#,+        indexInt32X16OffAddr#,+        indexInt64X8OffAddr#,+        indexWord8X16OffAddr#,+        indexWord16X8OffAddr#,+        indexWord32X4OffAddr#,+        indexWord64X2OffAddr#,+        indexWord8X32OffAddr#,+        indexWord16X16OffAddr#,+        indexWord32X8OffAddr#,+        indexWord64X4OffAddr#,+        indexWord8X64OffAddr#,+        indexWord16X32OffAddr#,+        indexWord32X16OffAddr#,+        indexWord64X8OffAddr#,+        indexFloatX4OffAddr#,+        indexDoubleX2OffAddr#,+        indexFloatX8OffAddr#,+        indexDoubleX4OffAddr#,+        indexFloatX16OffAddr#,+        indexDoubleX8OffAddr#,+        readInt8X16OffAddr#,+        readInt16X8OffAddr#,+        readInt32X4OffAddr#,+        readInt64X2OffAddr#,+        readInt8X32OffAddr#,+        readInt16X16OffAddr#,+        readInt32X8OffAddr#,+        readInt64X4OffAddr#,+        readInt8X64OffAddr#,+        readInt16X32OffAddr#,+        readInt32X16OffAddr#,+        readInt64X8OffAddr#,+        readWord8X16OffAddr#,+        readWord16X8OffAddr#,+        readWord32X4OffAddr#,+        readWord64X2OffAddr#,+        readWord8X32OffAddr#,+        readWord16X16OffAddr#,+        readWord32X8OffAddr#,+        readWord64X4OffAddr#,+        readWord8X64OffAddr#,+        readWord16X32OffAddr#,+        readWord32X16OffAddr#,+        readWord64X8OffAddr#,+        readFloatX4OffAddr#,+        readDoubleX2OffAddr#,+        readFloatX8OffAddr#,+        readDoubleX4OffAddr#,+        readFloatX16OffAddr#,+        readDoubleX8OffAddr#,+        writeInt8X16OffAddr#,+        writeInt16X8OffAddr#,+        writeInt32X4OffAddr#,+        writeInt64X2OffAddr#,+        writeInt8X32OffAddr#,+        writeInt16X16OffAddr#,+        writeInt32X8OffAddr#,+        writeInt64X4OffAddr#,+        writeInt8X64OffAddr#,+        writeInt16X32OffAddr#,+        writeInt32X16OffAddr#,+        writeInt64X8OffAddr#,+        writeWord8X16OffAddr#,+        writeWord16X8OffAddr#,+        writeWord32X4OffAddr#,+        writeWord64X2OffAddr#,+        writeWord8X32OffAddr#,+        writeWord16X16OffAddr#,+        writeWord32X8OffAddr#,+        writeWord64X4OffAddr#,+        writeWord8X64OffAddr#,+        writeWord16X32OffAddr#,+        writeWord32X16OffAddr#,+        writeWord64X8OffAddr#,+        writeFloatX4OffAddr#,+        writeDoubleX2OffAddr#,+        writeFloatX8OffAddr#,+        writeDoubleX4OffAddr#,+        writeFloatX16OffAddr#,+        writeDoubleX8OffAddr#,+        indexInt8ArrayAsInt8X16#,+        indexInt16ArrayAsInt16X8#,+        indexInt32ArrayAsInt32X4#,+        indexInt64ArrayAsInt64X2#,+        indexInt8ArrayAsInt8X32#,+        indexInt16ArrayAsInt16X16#,+        indexInt32ArrayAsInt32X8#,+        indexInt64ArrayAsInt64X4#,+        indexInt8ArrayAsInt8X64#,+        indexInt16ArrayAsInt16X32#,+        indexInt32ArrayAsInt32X16#,+        indexInt64ArrayAsInt64X8#,+        indexWord8ArrayAsWord8X16#,+        indexWord16ArrayAsWord16X8#,+        indexWord32ArrayAsWord32X4#,+        indexWord64ArrayAsWord64X2#,+        indexWord8ArrayAsWord8X32#,+        indexWord16ArrayAsWord16X16#,+        indexWord32ArrayAsWord32X8#,+        indexWord64ArrayAsWord64X4#,+        indexWord8ArrayAsWord8X64#,+        indexWord16ArrayAsWord16X32#,+        indexWord32ArrayAsWord32X16#,+        indexWord64ArrayAsWord64X8#,+        indexFloatArrayAsFloatX4#,+        indexDoubleArrayAsDoubleX2#,+        indexFloatArrayAsFloatX8#,+        indexDoubleArrayAsDoubleX4#,+        indexFloatArrayAsFloatX16#,+        indexDoubleArrayAsDoubleX8#,+        readInt8ArrayAsInt8X16#,+        readInt16ArrayAsInt16X8#,+        readInt32ArrayAsInt32X4#,+        readInt64ArrayAsInt64X2#,+        readInt8ArrayAsInt8X32#,+        readInt16ArrayAsInt16X16#,+        readInt32ArrayAsInt32X8#,+        readInt64ArrayAsInt64X4#,+        readInt8ArrayAsInt8X64#,+        readInt16ArrayAsInt16X32#,+        readInt32ArrayAsInt32X16#,+        readInt64ArrayAsInt64X8#,+        readWord8ArrayAsWord8X16#,+        readWord16ArrayAsWord16X8#,+        readWord32ArrayAsWord32X4#,+        readWord64ArrayAsWord64X2#,+        readWord8ArrayAsWord8X32#,+        readWord16ArrayAsWord16X16#,+        readWord32ArrayAsWord32X8#,+        readWord64ArrayAsWord64X4#,+        readWord8ArrayAsWord8X64#,+        readWord16ArrayAsWord16X32#,+        readWord32ArrayAsWord32X16#,+        readWord64ArrayAsWord64X8#,+        readFloatArrayAsFloatX4#,+        readDoubleArrayAsDoubleX2#,+        readFloatArrayAsFloatX8#,+        readDoubleArrayAsDoubleX4#,+        readFloatArrayAsFloatX16#,+        readDoubleArrayAsDoubleX8#,+        writeInt8ArrayAsInt8X16#,+        writeInt16ArrayAsInt16X8#,+        writeInt32ArrayAsInt32X4#,+        writeInt64ArrayAsInt64X2#,+        writeInt8ArrayAsInt8X32#,+        writeInt16ArrayAsInt16X16#,+        writeInt32ArrayAsInt32X8#,+        writeInt64ArrayAsInt64X4#,+        writeInt8ArrayAsInt8X64#,+        writeInt16ArrayAsInt16X32#,+        writeInt32ArrayAsInt32X16#,+        writeInt64ArrayAsInt64X8#,+        writeWord8ArrayAsWord8X16#,+        writeWord16ArrayAsWord16X8#,+        writeWord32ArrayAsWord32X4#,+        writeWord64ArrayAsWord64X2#,+        writeWord8ArrayAsWord8X32#,+        writeWord16ArrayAsWord16X16#,+        writeWord32ArrayAsWord32X8#,+        writeWord64ArrayAsWord64X4#,+        writeWord8ArrayAsWord8X64#,+        writeWord16ArrayAsWord16X32#,+        writeWord32ArrayAsWord32X16#,+        writeWord64ArrayAsWord64X8#,+        writeFloatArrayAsFloatX4#,+        writeDoubleArrayAsDoubleX2#,+        writeFloatArrayAsFloatX8#,+        writeDoubleArrayAsDoubleX4#,+        writeFloatArrayAsFloatX16#,+        writeDoubleArrayAsDoubleX8#,+        indexInt8OffAddrAsInt8X16#,+        indexInt16OffAddrAsInt16X8#,+        indexInt32OffAddrAsInt32X4#,+        indexInt64OffAddrAsInt64X2#,+        indexInt8OffAddrAsInt8X32#,+        indexInt16OffAddrAsInt16X16#,+        indexInt32OffAddrAsInt32X8#,+        indexInt64OffAddrAsInt64X4#,+        indexInt8OffAddrAsInt8X64#,+        indexInt16OffAddrAsInt16X32#,+        indexInt32OffAddrAsInt32X16#,+        indexInt64OffAddrAsInt64X8#,+        indexWord8OffAddrAsWord8X16#,+        indexWord16OffAddrAsWord16X8#,+        indexWord32OffAddrAsWord32X4#,+        indexWord64OffAddrAsWord64X2#,+        indexWord8OffAddrAsWord8X32#,+        indexWord16OffAddrAsWord16X16#,+        indexWord32OffAddrAsWord32X8#,+        indexWord64OffAddrAsWord64X4#,+        indexWord8OffAddrAsWord8X64#,+        indexWord16OffAddrAsWord16X32#,+        indexWord32OffAddrAsWord32X16#,+        indexWord64OffAddrAsWord64X8#,+        indexFloatOffAddrAsFloatX4#,+        indexDoubleOffAddrAsDoubleX2#,+        indexFloatOffAddrAsFloatX8#,+        indexDoubleOffAddrAsDoubleX4#,+        indexFloatOffAddrAsFloatX16#,+        indexDoubleOffAddrAsDoubleX8#,+        readInt8OffAddrAsInt8X16#,+        readInt16OffAddrAsInt16X8#,+        readInt32OffAddrAsInt32X4#,+        readInt64OffAddrAsInt64X2#,+        readInt8OffAddrAsInt8X32#,+        readInt16OffAddrAsInt16X16#,+        readInt32OffAddrAsInt32X8#,+        readInt64OffAddrAsInt64X4#,+        readInt8OffAddrAsInt8X64#,+        readInt16OffAddrAsInt16X32#,+        readInt32OffAddrAsInt32X16#,+        readInt64OffAddrAsInt64X8#,+        readWord8OffAddrAsWord8X16#,+        readWord16OffAddrAsWord16X8#,+        readWord32OffAddrAsWord32X4#,+        readWord64OffAddrAsWord64X2#,+        readWord8OffAddrAsWord8X32#,+        readWord16OffAddrAsWord16X16#,+        readWord32OffAddrAsWord32X8#,+        readWord64OffAddrAsWord64X4#,+        readWord8OffAddrAsWord8X64#,+        readWord16OffAddrAsWord16X32#,+        readWord32OffAddrAsWord32X16#,+        readWord64OffAddrAsWord64X8#,+        readFloatOffAddrAsFloatX4#,+        readDoubleOffAddrAsDoubleX2#,+        readFloatOffAddrAsFloatX8#,+        readDoubleOffAddrAsDoubleX4#,+        readFloatOffAddrAsFloatX16#,+        readDoubleOffAddrAsDoubleX8#,+        writeInt8OffAddrAsInt8X16#,+        writeInt16OffAddrAsInt16X8#,+        writeInt32OffAddrAsInt32X4#,+        writeInt64OffAddrAsInt64X2#,+        writeInt8OffAddrAsInt8X32#,+        writeInt16OffAddrAsInt16X16#,+        writeInt32OffAddrAsInt32X8#,+        writeInt64OffAddrAsInt64X4#,+        writeInt8OffAddrAsInt8X64#,+        writeInt16OffAddrAsInt16X32#,+        writeInt32OffAddrAsInt32X16#,+        writeInt64OffAddrAsInt64X8#,+        writeWord8OffAddrAsWord8X16#,+        writeWord16OffAddrAsWord16X8#,+        writeWord32OffAddrAsWord32X4#,+        writeWord64OffAddrAsWord64X2#,+        writeWord8OffAddrAsWord8X32#,+        writeWord16OffAddrAsWord16X16#,+        writeWord32OffAddrAsWord32X8#,+        writeWord64OffAddrAsWord64X4#,+        writeWord8OffAddrAsWord8X64#,+        writeWord16OffAddrAsWord16X32#,+        writeWord32OffAddrAsWord32X16#,+        writeWord64OffAddrAsWord64X8#,+        writeFloatOffAddrAsFloatX4#,+        writeDoubleOffAddrAsDoubleX2#,+        writeFloatOffAddrAsFloatX8#,+        writeDoubleOffAddrAsDoubleX4#,+        writeFloatOffAddrAsFloatX16#,+        writeDoubleOffAddrAsDoubleX8#,+        fmaddFloatX4#,+        fmaddDoubleX2#,+        fmaddFloatX8#,+        fmaddDoubleX4#,+        fmaddFloatX16#,+        fmaddDoubleX8#,+        fmsubFloatX4#,+        fmsubDoubleX2#,+        fmsubFloatX8#,+        fmsubDoubleX4#,+        fmsubFloatX16#,+        fmsubDoubleX8#,+        fnmaddFloatX4#,+        fnmaddDoubleX2#,+        fnmaddFloatX8#,+        fnmaddDoubleX4#,+        fnmaddFloatX16#,+        fnmaddDoubleX8#,+        fnmsubFloatX4#,+        fnmsubDoubleX2#,+        fnmsubFloatX8#,+        fnmsubDoubleX4#,+        fnmsubFloatX16#,+        fnmsubDoubleX8#,+        shuffleInt8X16#,+        shuffleInt16X8#,+        shuffleInt32X4#,+        shuffleInt64X2#,+        shuffleInt8X32#,+        shuffleInt16X16#,+        shuffleInt32X8#,+        shuffleInt64X4#,+        shuffleInt8X64#,+        shuffleInt16X32#,+        shuffleInt32X16#,+        shuffleInt64X8#,+        shuffleWord8X16#,+        shuffleWord16X8#,+        shuffleWord32X4#,+        shuffleWord64X2#,+        shuffleWord8X32#,+        shuffleWord16X16#,+        shuffleWord32X8#,+        shuffleWord64X4#,+        shuffleWord8X64#,+        shuffleWord16X32#,+        shuffleWord32X16#,+        shuffleWord64X8#,+        shuffleFloatX4#,+        shuffleDoubleX2#,+        shuffleFloatX8#,+        shuffleDoubleX4#,+        shuffleFloatX16#,+        shuffleDoubleX8#,+        minInt8X16#,+        minInt16X8#,+        minInt32X4#,+        minInt64X2#,+        minInt8X32#,+        minInt16X16#,+        minInt32X8#,+        minInt64X4#,+        minInt8X64#,+        minInt16X32#,+        minInt32X16#,+        minInt64X8#,+        minWord8X16#,+        minWord16X8#,+        minWord32X4#,+        minWord64X2#,+        minWord8X32#,+        minWord16X16#,+        minWord32X8#,+        minWord64X4#,+        minWord8X64#,+        minWord16X32#,+        minWord32X16#,+        minWord64X8#,+        minFloatX4#,+        minDoubleX2#,+        minFloatX8#,+        minDoubleX4#,+        minFloatX16#,+        minDoubleX8#,+        maxInt8X16#,+        maxInt16X8#,+        maxInt32X4#,+        maxInt64X2#,+        maxInt8X32#,+        maxInt16X16#,+        maxInt32X8#,+        maxInt64X4#,+        maxInt8X64#,+        maxInt16X32#,+        maxInt32X16#,+        maxInt64X8#,+        maxWord8X16#,+        maxWord16X8#,+        maxWord32X4#,+        maxWord64X2#,+        maxWord8X32#,+        maxWord16X16#,+        maxWord32X8#,+        maxWord64X4#,+        maxWord8X64#,+        maxWord16X32#,+        maxWord32X16#,+        maxWord64X8#,+        maxFloatX4#,+        maxDoubleX2#,+        maxFloatX8#,+        maxDoubleX4#,+        maxFloatX16#,+        maxDoubleX8#,+        +{- * Prefetch-}+{-|Prefetch operations: Note how every prefetch operation has a name+  with the pattern prefetch*N#, where N is either 0,1,2, or 3.++  This suffix number, N, is the "locality level" of the prefetch, following the+  convention in GCC and other compilers.+  Higher locality numbers correspond to the memory being loaded in more+  levels of the cpu cache, and being retained after initial use. The naming+  convention follows the naming convention of the prefetch intrinsic found+  in the GCC and Clang C compilers.++  On the LLVM backend, prefetch*N# uses the LLVM prefetch intrinsic+  with locality level N. The code generated by LLVM is target architecture+  dependent, but should agree with the GHC NCG on x86 systems.++  On the PPC native backend, prefetch*N is a No-Op.++  On the x86 NCG, N=0 will generate prefetchNTA,+  N=1 generates prefetcht2, N=2 generates prefetcht1, and+  N=3 generates prefetcht0.++  For streaming workloads, the prefetch*0 operations are recommended.+  For workloads which do many reads or writes to a memory location in a short period of time,+  prefetch*3 operations are recommended.++  For further reading about prefetch and associated systems performance optimization,+  the instruction set and optimization manuals by Intel and other CPU vendors are+  excellent starting place.+++  The "Intel 64 and IA-32 Architectures Optimization Reference Manual" is+  especially a helpful read, even if your software is meant for other CPU+  architectures or vendor hardware. The manual can be found at+  http://www.intel.com/content/www/us/en/architecture-and-technology/64-ia-32-architectures-optimization-manual.html .++  The @prefetch*@ family of operations has the order of operations+  determined by passing around the 'State#' token.++  To get a "pure" version of these operations, use 'inlinePerformIO' which is quite safe in this context.++  It is important to note that while the prefetch operations will never change the+  answer to a pure computation, They CAN change the memory locations resident+  in a CPU cache and that may change the performance and timing characteristics+  of an application. The prefetch operations are marked as ReadWriteEffect+  to reflect that these operations have side effects with respect to the runtime+  performance characteristics of the resulting code. Additionally, if the prefetchValue+  operations did not have this attribute, GHC does a float out transformation that+  results in a let-can-float invariant violation, at least with the current design.+  -}+        prefetchByteArray3#,+        prefetchMutableByteArray3#,+        prefetchAddr3#,+        prefetchValue3#,+        prefetchByteArray2#,+        prefetchMutableByteArray2#,+        prefetchAddr2#,+        prefetchValue2#,+        prefetchByteArray1#,+        prefetchMutableByteArray1#,+        prefetchAddr1#,+        prefetchValue1#,+        prefetchByteArray0#,+        prefetchMutableByteArray0#,+        prefetchAddr0#,+        prefetchValue0#,+        +{- * RuntimeRep polymorphism in continuation-style primops-}+{-|+  Several primops provided by GHC accept continuation arguments with highly polymorphic+  arguments. For instance, consider the type of `catch#`:++    catch# :: forall (r_rep :: RuntimeRep) (r :: TYPE r_rep) w.+              (State# RealWorld -> (# State# RealWorld, r #) )+           -> (w -> State# RealWorld -> (# State# RealWorld, r #) )+           -> State# RealWorld+           -> (# State# RealWorld, r #)++  This type suggests that we could instantiate `catch#` continuation argument+  (namely, the first argument) with something like,++    f :: State# RealWorld -> (# State# RealWorld, (# Int, String, Int8# #) #)++  However, sadly the type does not capture an important limitation of the+  primop. Specifically, due to the operational behavior of `catch#` the result+  type must be representable with a single machine word. In a future GHC+  release we may improve the precision of this type to capture this limitation.++  See #21868.+  -}+) where++{-+effect = NoEffect+can_fail_warning = WarnIfEffectIsCanFail+out_of_line = False+commutable = False+code_size = {  primOpCodeSizeDefault }+work_free = {  primOpCodeSize _thisOp == 0 }+cheap = {  primOpOkForSpeculation _thisOp }+strictness = {  \ arity -> mkClosedDmdSig (replicate arity topDmd) topDiv }+fixity = Nothing++deprecated_msg = { }+div_like = False+defined_bits = Nothing+-}+default ()++data Char#++gtChar# :: Char# -> Char# -> Int#+gtChar# = gtChar#++geChar# :: Char# -> Char# -> Int#+geChar# = geChar#++eqChar# :: Char# -> Char# -> Int#+eqChar# = eqChar#++neChar# :: Char# -> Char# -> Int#+neChar# = neChar#++ltChar# :: Char# -> Char# -> Int#+ltChar# = ltChar#++leChar# :: Char# -> Char# -> Int#+leChar# = leChar#++ord# :: Char# -> Int#+ord# = ord#++data Int8#++int8ToInt# :: Int8# -> Int#+int8ToInt# = int8ToInt#++intToInt8# :: Int# -> Int8#+intToInt8# = intToInt8#++negateInt8# :: Int8# -> Int8#+negateInt8# = negateInt8#++plusInt8# :: Int8# -> Int8# -> Int8#+plusInt8# = plusInt8#++subInt8# :: Int8# -> Int8# -> Int8#+subInt8# = subInt8#++timesInt8# :: Int8# -> Int8# -> Int8#+timesInt8# = timesInt8#++quotInt8# :: Int8# -> Int8# -> Int8#+quotInt8# = quotInt8#++remInt8# :: Int8# -> Int8# -> Int8#+remInt8# = remInt8#++quotRemInt8# :: Int8# -> Int8# -> (# Int8#,Int8# #)+quotRemInt8# = quotRemInt8#++uncheckedShiftLInt8# :: Int8# -> Int# -> Int8#+uncheckedShiftLInt8# = uncheckedShiftLInt8#++uncheckedShiftRAInt8# :: Int8# -> Int# -> Int8#+uncheckedShiftRAInt8# = uncheckedShiftRAInt8#++uncheckedShiftRLInt8# :: Int8# -> Int# -> Int8#+uncheckedShiftRLInt8# = uncheckedShiftRLInt8#++int8ToWord8# :: Int8# -> Word8#+int8ToWord8# = int8ToWord8#++eqInt8# :: Int8# -> Int8# -> Int#+eqInt8# = eqInt8#++geInt8# :: Int8# -> Int8# -> Int#+geInt8# = geInt8#++gtInt8# :: Int8# -> Int8# -> Int#+gtInt8# = gtInt8#++leInt8# :: Int8# -> Int8# -> Int#+leInt8# = leInt8#++ltInt8# :: Int8# -> Int8# -> Int#+ltInt8# = ltInt8#++neInt8# :: Int8# -> Int8# -> Int#+neInt8# = neInt8#++data Word8#++word8ToWord# :: Word8# -> Word#+word8ToWord# = word8ToWord#++wordToWord8# :: Word# -> Word8#+wordToWord8# = wordToWord8#++plusWord8# :: Word8# -> Word8# -> Word8#+plusWord8# = plusWord8#++subWord8# :: Word8# -> Word8# -> Word8#+subWord8# = subWord8#++timesWord8# :: Word8# -> Word8# -> Word8#+timesWord8# = timesWord8#++quotWord8# :: Word8# -> Word8# -> Word8#+quotWord8# = quotWord8#++remWord8# :: Word8# -> Word8# -> Word8#+remWord8# = remWord8#++quotRemWord8# :: Word8# -> Word8# -> (# Word8#,Word8# #)+quotRemWord8# = quotRemWord8#++andWord8# :: Word8# -> Word8# -> Word8#+andWord8# = andWord8#++orWord8# :: Word8# -> Word8# -> Word8#+orWord8# = orWord8#++xorWord8# :: Word8# -> Word8# -> Word8#+xorWord8# = xorWord8#++notWord8# :: Word8# -> Word8#+notWord8# = notWord8#++uncheckedShiftLWord8# :: Word8# -> Int# -> Word8#+uncheckedShiftLWord8# = uncheckedShiftLWord8#++uncheckedShiftRLWord8# :: Word8# -> Int# -> Word8#+uncheckedShiftRLWord8# = uncheckedShiftRLWord8#++word8ToInt8# :: Word8# -> Int8#+word8ToInt8# = word8ToInt8#++eqWord8# :: Word8# -> Word8# -> Int#+eqWord8# = eqWord8#++geWord8# :: Word8# -> Word8# -> Int#+geWord8# = geWord8#++gtWord8# :: Word8# -> Word8# -> Int#+gtWord8# = gtWord8#++leWord8# :: Word8# -> Word8# -> Int#+leWord8# = leWord8#++ltWord8# :: Word8# -> Word8# -> Int#+ltWord8# = ltWord8#++neWord8# :: Word8# -> Word8# -> Int#+neWord8# = neWord8#++data Int16#++int16ToInt# :: Int16# -> Int#+int16ToInt# = int16ToInt#++intToInt16# :: Int# -> Int16#+intToInt16# = intToInt16#++negateInt16# :: Int16# -> Int16#+negateInt16# = negateInt16#++plusInt16# :: Int16# -> Int16# -> Int16#+plusInt16# = plusInt16#++subInt16# :: Int16# -> Int16# -> Int16#+subInt16# = subInt16#++timesInt16# :: Int16# -> Int16# -> Int16#+timesInt16# = timesInt16#++quotInt16# :: Int16# -> Int16# -> Int16#+quotInt16# = quotInt16#++remInt16# :: Int16# -> Int16# -> Int16#+remInt16# = remInt16#++quotRemInt16# :: Int16# -> Int16# -> (# Int16#,Int16# #)+quotRemInt16# = quotRemInt16#++uncheckedShiftLInt16# :: Int16# -> Int# -> Int16#+uncheckedShiftLInt16# = uncheckedShiftLInt16#++uncheckedShiftRAInt16# :: Int16# -> Int# -> Int16#+uncheckedShiftRAInt16# = uncheckedShiftRAInt16#++uncheckedShiftRLInt16# :: Int16# -> Int# -> Int16#+uncheckedShiftRLInt16# = uncheckedShiftRLInt16#++int16ToWord16# :: Int16# -> Word16#+int16ToWord16# = int16ToWord16#++eqInt16# :: Int16# -> Int16# -> Int#+eqInt16# = eqInt16#++geInt16# :: Int16# -> Int16# -> Int#+geInt16# = geInt16#++gtInt16# :: Int16# -> Int16# -> Int#+gtInt16# = gtInt16#++leInt16# :: Int16# -> Int16# -> Int#+leInt16# = leInt16#++ltInt16# :: Int16# -> Int16# -> Int#+ltInt16# = ltInt16#++neInt16# :: Int16# -> Int16# -> Int#+neInt16# = neInt16#++data Word16#++word16ToWord# :: Word16# -> Word#+word16ToWord# = word16ToWord#++wordToWord16# :: Word# -> Word16#+wordToWord16# = wordToWord16#++plusWord16# :: Word16# -> Word16# -> Word16#+plusWord16# = plusWord16#++subWord16# :: Word16# -> Word16# -> Word16#+subWord16# = subWord16#++timesWord16# :: Word16# -> Word16# -> Word16#+timesWord16# = timesWord16#++quotWord16# :: Word16# -> Word16# -> Word16#+quotWord16# = quotWord16#++remWord16# :: Word16# -> Word16# -> Word16#+remWord16# = remWord16#++quotRemWord16# :: Word16# -> Word16# -> (# Word16#,Word16# #)+quotRemWord16# = quotRemWord16#++andWord16# :: Word16# -> Word16# -> Word16#+andWord16# = andWord16#++orWord16# :: Word16# -> Word16# -> Word16#+orWord16# = orWord16#++xorWord16# :: Word16# -> Word16# -> Word16#+xorWord16# = xorWord16#++notWord16# :: Word16# -> Word16#+notWord16# = notWord16#++uncheckedShiftLWord16# :: Word16# -> Int# -> Word16#+uncheckedShiftLWord16# = uncheckedShiftLWord16#++uncheckedShiftRLWord16# :: Word16# -> Int# -> Word16#+uncheckedShiftRLWord16# = uncheckedShiftRLWord16#++word16ToInt16# :: Word16# -> Int16#+word16ToInt16# = word16ToInt16#++eqWord16# :: Word16# -> Word16# -> Int#+eqWord16# = eqWord16#++geWord16# :: Word16# -> Word16# -> Int#+geWord16# = geWord16#++gtWord16# :: Word16# -> Word16# -> Int#+gtWord16# = gtWord16#++leWord16# :: Word16# -> Word16# -> Int#+leWord16# = leWord16#++ltWord16# :: Word16# -> Word16# -> Int#+ltWord16# = ltWord16#++neWord16# :: Word16# -> Word16# -> Int#+neWord16# = neWord16#++data Int32#++int32ToInt# :: Int32# -> Int#+int32ToInt# = int32ToInt#++intToInt32# :: Int# -> Int32#+intToInt32# = intToInt32#++negateInt32# :: Int32# -> Int32#+negateInt32# = negateInt32#++plusInt32# :: Int32# -> Int32# -> Int32#+plusInt32# = plusInt32#++subInt32# :: Int32# -> Int32# -> Int32#+subInt32# = subInt32#++timesInt32# :: Int32# -> Int32# -> Int32#+timesInt32# = timesInt32#++quotInt32# :: Int32# -> Int32# -> Int32#+quotInt32# = quotInt32#++remInt32# :: Int32# -> Int32# -> Int32#+remInt32# = remInt32#++quotRemInt32# :: Int32# -> Int32# -> (# Int32#,Int32# #)+quotRemInt32# = quotRemInt32#++uncheckedShiftLInt32# :: Int32# -> Int# -> Int32#+uncheckedShiftLInt32# = uncheckedShiftLInt32#++uncheckedShiftRAInt32# :: Int32# -> Int# -> Int32#+uncheckedShiftRAInt32# = uncheckedShiftRAInt32#++uncheckedShiftRLInt32# :: Int32# -> Int# -> Int32#+uncheckedShiftRLInt32# = uncheckedShiftRLInt32#++int32ToWord32# :: Int32# -> Word32#+int32ToWord32# = int32ToWord32#++eqInt32# :: Int32# -> Int32# -> Int#+eqInt32# = eqInt32#++geInt32# :: Int32# -> Int32# -> Int#+geInt32# = geInt32#++gtInt32# :: Int32# -> Int32# -> Int#+gtInt32# = gtInt32#++leInt32# :: Int32# -> Int32# -> Int#+leInt32# = leInt32#++ltInt32# :: Int32# -> Int32# -> Int#+ltInt32# = ltInt32#++neInt32# :: Int32# -> Int32# -> Int#+neInt32# = neInt32#++data Word32#++word32ToWord# :: Word32# -> Word#+word32ToWord# = word32ToWord#++wordToWord32# :: Word# -> Word32#+wordToWord32# = wordToWord32#++plusWord32# :: Word32# -> Word32# -> Word32#+plusWord32# = plusWord32#++subWord32# :: Word32# -> Word32# -> Word32#+subWord32# = subWord32#++timesWord32# :: Word32# -> Word32# -> Word32#+timesWord32# = timesWord32#++quotWord32# :: Word32# -> Word32# -> Word32#+quotWord32# = quotWord32#++remWord32# :: Word32# -> Word32# -> Word32#+remWord32# = remWord32#++quotRemWord32# :: Word32# -> Word32# -> (# Word32#,Word32# #)+quotRemWord32# = quotRemWord32#++andWord32# :: Word32# -> Word32# -> Word32#+andWord32# = andWord32#++orWord32# :: Word32# -> Word32# -> Word32#+orWord32# = orWord32#++xorWord32# :: Word32# -> Word32# -> Word32#+xorWord32# = xorWord32#++notWord32# :: Word32# -> Word32#+notWord32# = notWord32#++uncheckedShiftLWord32# :: Word32# -> Int# -> Word32#+uncheckedShiftLWord32# = uncheckedShiftLWord32#++uncheckedShiftRLWord32# :: Word32# -> Int# -> Word32#+uncheckedShiftRLWord32# = uncheckedShiftRLWord32#++word32ToInt32# :: Word32# -> Int32#+word32ToInt32# = word32ToInt32#++eqWord32# :: Word32# -> Word32# -> Int#+eqWord32# = eqWord32#++geWord32# :: Word32# -> Word32# -> Int#+geWord32# = geWord32#++gtWord32# :: Word32# -> Word32# -> Int#+gtWord32# = gtWord32#++leWord32# :: Word32# -> Word32# -> Int#+leWord32# = leWord32#++ltWord32# :: Word32# -> Word32# -> Int#+ltWord32# = ltWord32#++neWord32# :: Word32# -> Word32# -> Int#+neWord32# = neWord32#++data Int64#++int64ToInt# :: Int64# -> Int#+int64ToInt# = int64ToInt#++intToInt64# :: Int# -> Int64#+intToInt64# = intToInt64#++negateInt64# :: Int64# -> Int64#+negateInt64# = negateInt64#++plusInt64# :: Int64# -> Int64# -> Int64#+plusInt64# = plusInt64#++subInt64# :: Int64# -> Int64# -> Int64#+subInt64# = subInt64#++timesInt64# :: Int64# -> Int64# -> Int64#+timesInt64# = timesInt64#++quotInt64# :: Int64# -> Int64# -> Int64#+quotInt64# = quotInt64#++remInt64# :: Int64# -> Int64# -> Int64#+remInt64# = remInt64#++uncheckedIShiftL64# :: Int64# -> Int# -> Int64#+uncheckedIShiftL64# = uncheckedIShiftL64#++uncheckedIShiftRA64# :: Int64# -> Int# -> Int64#+uncheckedIShiftRA64# = uncheckedIShiftRA64#++uncheckedIShiftRL64# :: Int64# -> Int# -> Int64#+uncheckedIShiftRL64# = uncheckedIShiftRL64#++int64ToWord64# :: Int64# -> Word64#+int64ToWord64# = int64ToWord64#++eqInt64# :: Int64# -> Int64# -> Int#+eqInt64# = eqInt64#++geInt64# :: Int64# -> Int64# -> Int#+geInt64# = geInt64#++gtInt64# :: Int64# -> Int64# -> Int#+gtInt64# = gtInt64#++leInt64# :: Int64# -> Int64# -> Int#+leInt64# = leInt64#++ltInt64# :: Int64# -> Int64# -> Int#+ltInt64# = ltInt64#++neInt64# :: Int64# -> Int64# -> Int#+neInt64# = neInt64#++data Word64#++word64ToWord# :: Word64# -> Word#+word64ToWord# = word64ToWord#++wordToWord64# :: Word# -> Word64#+wordToWord64# = wordToWord64#++plusWord64# :: Word64# -> Word64# -> Word64#+plusWord64# = plusWord64#++subWord64# :: Word64# -> Word64# -> Word64#+subWord64# = subWord64#++timesWord64# :: Word64# -> Word64# -> Word64#+timesWord64# = timesWord64#++quotWord64# :: Word64# -> Word64# -> Word64#+quotWord64# = quotWord64#++remWord64# :: Word64# -> Word64# -> Word64#+remWord64# = remWord64#++and64# :: Word64# -> Word64# -> Word64#+and64# = and64#++or64# :: Word64# -> Word64# -> Word64#+or64# = or64#++xor64# :: Word64# -> Word64# -> Word64#+xor64# = xor64#++not64# :: Word64# -> Word64#+not64# = not64#++uncheckedShiftL64# :: Word64# -> Int# -> Word64#+uncheckedShiftL64# = uncheckedShiftL64#++uncheckedShiftRL64# :: Word64# -> Int# -> Word64#+uncheckedShiftRL64# = uncheckedShiftRL64#++word64ToInt64# :: Word64# -> Int64#+word64ToInt64# = word64ToInt64#++eqWord64# :: Word64# -> Word64# -> Int#+eqWord64# = eqWord64#++geWord64# :: Word64# -> Word64# -> Int#+geWord64# = geWord64#++gtWord64# :: Word64# -> Word64# -> Int#+gtWord64# = gtWord64#++leWord64# :: Word64# -> Word64# -> Int#+leWord64# = leWord64#++ltWord64# :: Word64# -> Word64# -> Int#+ltWord64# = ltWord64#++neWord64# :: Word64# -> Word64# -> Int#+neWord64# = neWord64#++data Int#++infixl 6 +#+(+#) :: Int# -> Int# -> Int#+(+#) = (+#)++infixl 6 -#+(-#) :: Int# -> Int# -> Int#+(-#) = (-#)++{-|Low word of signed integer multiply.-}+infixl 7 *#+(*#) :: Int# -> Int# -> Int#+(*#) = (*#)++{-|Return a triple (isHighNeeded,high,low) where high and low are respectively+   the high and low bits of the double-word result. isHighNeeded is a cheap way+   to test if the high word is a sign-extension of the low word (isHighNeeded =+   0#) or not (isHighNeeded = 1#).-}+timesInt2# :: Int# -> Int# -> (# Int#,Int#,Int# #)+timesInt2# = timesInt2#++{-|Return non-zero if there is any possibility that the upper word of a+    signed integer multiply might contain useful information.  Return+    zero only if you are completely sure that no overflow can occur.+    On a 32-bit platform, the recommended implementation is to do a+    32 x 32 -> 64 signed multiply, and subtract result[63:32] from+    (result[31] >>signed 31).  If this is zero, meaning that the+    upper word is merely a sign extension of the lower one, no+    overflow can occur.++    On a 64-bit platform it is not always possible to+    acquire the top 64 bits of the result.  Therefore, a recommended+    implementation is to take the absolute value of both operands, and+    return 0 iff bits[63:31] of them are zero, since that means that their+    magnitudes fit within 31 bits, so the magnitude of the product must fit+    into 62 bits.++    If in doubt, return non-zero, but do make an effort to create the+    correct answer for small args, since otherwise the performance of+    @(*) :: Integer -> Integer -> Integer@ will be poor.+   -}+mulIntMayOflo# :: Int# -> Int# -> Int#+mulIntMayOflo# = mulIntMayOflo#++{-|Rounds towards zero. The behavior is undefined if the second argument is+    zero.+   -}+quotInt# :: Int# -> Int# -> Int#+quotInt# = quotInt#++{-|Satisfies @('quotInt#' x y) '*#' y '+#' ('remInt#' x y) == x@. The+    behavior is undefined if the second argument is zero.+   -}+remInt# :: Int# -> Int# -> Int#+remInt# = remInt#++{-|Rounds towards zero.-}+quotRemInt# :: Int# -> Int# -> (# Int#,Int# #)+quotRemInt# = quotRemInt#++{-|Bitwise "and".-}+andI# :: Int# -> Int# -> Int#+andI# = andI#++{-|Bitwise "or".-}+orI# :: Int# -> Int# -> Int#+orI# = orI#++{-|Bitwise "xor".-}+xorI# :: Int# -> Int# -> Int#+xorI# = xorI#++{-|Bitwise "not", also known as the binary complement.-}+notI# :: Int# -> Int#+notI# = notI#++{-|Unary negation.+    Since the negative 'Int#' range extends one further than the+    positive range, 'negateInt#' of the most negative number is an+    identity operation. This way, 'negateInt#' is always its own inverse.-}+negateInt# :: Int# -> Int#+negateInt# = negateInt#++{-|Add signed integers reporting overflow.+          First member of result is the sum truncated to an 'Int#';+          second member is zero if the true sum fits in an 'Int#',+          nonzero if overflow occurred (the sum is either too large+          or too small to fit in an 'Int#').-}+addIntC# :: Int# -> Int# -> (# Int#,Int# #)+addIntC# = addIntC#++{-|Subtract signed integers reporting overflow.+          First member of result is the difference truncated to an 'Int#';+          second member is zero if the true difference fits in an 'Int#',+          nonzero if overflow occurred (the difference is either too large+          or too small to fit in an 'Int#').-}+subIntC# :: Int# -> Int# -> (# Int#,Int# #)+subIntC# = subIntC#++infix 4 >#+(>#) :: Int# -> Int# -> Int#+(>#) = (>#)++infix 4 >=#+(>=#) :: Int# -> Int# -> Int#+(>=#) = (>=#)++infix 4 ==#+(==#) :: Int# -> Int# -> Int#+(==#) = (==#)++infix 4 /=#+(/=#) :: Int# -> Int# -> Int#+(/=#) = (/=#)++infix 4 <#+(<#) :: Int# -> Int# -> Int#+(<#) = (<#)++infix 4 <=#+(<=#) :: Int# -> Int# -> Int#+(<=#) = (<=#)++chr# :: Int# -> Char#+chr# = chr#++int2Word# :: Int# -> Word#+int2Word# = int2Word#++{-|Convert an 'Int#' to the corresponding 'Float#' with the same+    integral value (up to truncation due to floating-point precision). e.g.+    @'int2Float#' 1# == 1.0#@-}+int2Float# :: Int# -> Float#+int2Float# = int2Float#++{-|Convert an 'Int#' to the corresponding 'Double#' with the same+    integral value (up to truncation due to floating-point precision). e.g.+    @'int2Double#' 1# == 1.0##@-}+int2Double# :: Int# -> Double#+int2Double# = int2Double#++{-|Convert an 'Word#' to the corresponding 'Float#' with the same+    integral value (up to truncation due to floating-point precision). e.g.+    @'word2Float#' 1## == 1.0#@-}+word2Float# :: Word# -> Float#+word2Float# = word2Float#++{-|Convert an 'Word#' to the corresponding 'Double#' with the same+    integral value (up to truncation due to floating-point precision). e.g.+    @'word2Double#' 1## == 1.0##@-}+word2Double# :: Word# -> Double#+word2Double# = word2Double#++{-|Shift left.  Result undefined if shift amount is not+          in the range 0 to word size - 1 inclusive.-}+uncheckedIShiftL# :: Int# -> Int# -> Int#+uncheckedIShiftL# = uncheckedIShiftL#++{-|Shift right arithmetic.  Result undefined if shift amount is not+          in the range 0 to word size - 1 inclusive.-}+uncheckedIShiftRA# :: Int# -> Int# -> Int#+uncheckedIShiftRA# = uncheckedIShiftRA#++{-|Shift right logical.  Result undefined if shift amount is not+          in the range 0 to word size - 1 inclusive.-}+uncheckedIShiftRL# :: Int# -> Int# -> Int#+uncheckedIShiftRL# = uncheckedIShiftRL#++data Word#++plusWord# :: Word# -> Word# -> Word#+plusWord# = plusWord#++{-|Add unsigned integers reporting overflow.+          The first element of the pair is the result.  The second element is+          the carry flag, which is nonzero on overflow. See also 'plusWord2#'.-}+addWordC# :: Word# -> Word# -> (# Word#,Int# #)+addWordC# = addWordC#++{-|Subtract unsigned integers reporting overflow.+          The first element of the pair is the result.  The second element is+          the carry flag, which is nonzero on overflow.-}+subWordC# :: Word# -> Word# -> (# Word#,Int# #)+subWordC# = subWordC#++{-|Add unsigned integers, with the high part (carry) in the first+          component of the returned pair and the low part in the second+          component of the pair. See also 'addWordC#'.-}+plusWord2# :: Word# -> Word# -> (# Word#,Word# #)+plusWord2# = plusWord2#++minusWord# :: Word# -> Word# -> Word#+minusWord# = minusWord#++timesWord# :: Word# -> Word# -> Word#+timesWord# = timesWord#++timesWord2# :: Word# -> Word# -> (# Word#,Word# #)+timesWord2# = timesWord2#++quotWord# :: Word# -> Word# -> Word#+quotWord# = quotWord#++remWord# :: Word# -> Word# -> Word#+remWord# = remWord#++quotRemWord# :: Word# -> Word# -> (# Word#,Word# #)+quotRemWord# = quotRemWord#++{-| Takes high word of dividend, then low word of dividend, then divisor.+           Requires that high word < divisor.-}+quotRemWord2# :: Word# -> Word# -> Word# -> (# Word#,Word# #)+quotRemWord2# = quotRemWord2#++and# :: Word# -> Word# -> Word#+and# = and#++or# :: Word# -> Word# -> Word#+or# = or#++xor# :: Word# -> Word# -> Word#+xor# = xor#++not# :: Word# -> Word#+not# = not#++{-|Shift left logical.   Result undefined if shift amount is not+          in the range 0 to word size - 1 inclusive.-}+uncheckedShiftL# :: Word# -> Int# -> Word#+uncheckedShiftL# = uncheckedShiftL#++{-|Shift right logical.   Result undefined if shift  amount is not+          in the range 0 to word size - 1 inclusive.-}+uncheckedShiftRL# :: Word# -> Int# -> Word#+uncheckedShiftRL# = uncheckedShiftRL#++word2Int# :: Word# -> Int#+word2Int# = word2Int#++gtWord# :: Word# -> Word# -> Int#+gtWord# = gtWord#++geWord# :: Word# -> Word# -> Int#+geWord# = geWord#++eqWord# :: Word# -> Word# -> Int#+eqWord# = eqWord#++neWord# :: Word# -> Word# -> Int#+neWord# = neWord#++ltWord# :: Word# -> Word# -> Int#+ltWord# = ltWord#++leWord# :: Word# -> Word# -> Int#+leWord# = leWord#++{-|Count the number of set bits in the lower 8 bits of a word.-}+popCnt8# :: Word# -> Word#+popCnt8# = popCnt8#++{-|Count the number of set bits in the lower 16 bits of a word.-}+popCnt16# :: Word# -> Word#+popCnt16# = popCnt16#++{-|Count the number of set bits in the lower 32 bits of a word.-}+popCnt32# :: Word# -> Word#+popCnt32# = popCnt32#++{-|Count the number of set bits in a 64-bit word.-}+popCnt64# :: Word64# -> Word#+popCnt64# = popCnt64#++{-|Count the number of set bits in a word.-}+popCnt# :: Word# -> Word#+popCnt# = popCnt#++{-|Deposit bits to lower 8 bits of a word at locations specified by a mask.++    @since 0.5.2.0-}+pdep8# :: Word# -> Word# -> Word#+pdep8# = pdep8#++{-|Deposit bits to lower 16 bits of a word at locations specified by a mask.++    @since 0.5.2.0-}+pdep16# :: Word# -> Word# -> Word#+pdep16# = pdep16#++{-|Deposit bits to lower 32 bits of a word at locations specified by a mask.++    @since 0.5.2.0-}+pdep32# :: Word# -> Word# -> Word#+pdep32# = pdep32#++{-|Deposit bits to a word at locations specified by a mask.++    @since 0.5.2.0-}+pdep64# :: Word64# -> Word64# -> Word64#+pdep64# = pdep64#++{-|Deposit bits to a word at locations specified by a mask, aka+    [parallel bit deposit](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract).++    Software emulation:++    > pdep :: Word -> Word -> Word+    > pdep src mask = go 0 src mask+    >   where+    >     go :: Word -> Word -> Word -> Word+    >     go result _ 0 = result+    >     go result src mask = go newResult newSrc newMask+    >       where+    >         maskCtz   = countTrailingZeros mask+    >         newResult = if testBit src 0 then setBit result maskCtz else result+    >         newSrc    = src `shiftR` 1+    >         newMask   = clearBit mask maskCtz++    @since 0.5.2.0-}+pdep# :: Word# -> Word# -> Word#+pdep# = pdep#++{-|Extract bits from lower 8 bits of a word at locations specified by a mask.++    @since 0.5.2.0-}+pext8# :: Word# -> Word# -> Word#+pext8# = pext8#++{-|Extract bits from lower 16 bits of a word at locations specified by a mask.++    @since 0.5.2.0-}+pext16# :: Word# -> Word# -> Word#+pext16# = pext16#++{-|Extract bits from lower 32 bits of a word at locations specified by a mask.++    @since 0.5.2.0-}+pext32# :: Word# -> Word# -> Word#+pext32# = pext32#++{-|Extract bits from a word at locations specified by a mask.++    @since 0.5.2.0-}+pext64# :: Word64# -> Word64# -> Word64#+pext64# = pext64#++{-|Extract bits from a word at locations specified by a mask, aka+    [parallel bit extract](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract).++    Software emulation:++    > pext :: Word -> Word -> Word+    > pext src mask = loop 0 0 0+    >   where+    >     loop i count result+    >       | i >= finiteBitSize (0 :: Word)+    >       = result+    >       | testBit mask i+    >       = loop (i + 1) (count + 1) (if testBit src i then setBit result count else result)+    >       | otherwise+    >       = loop (i + 1) count result++    @since 0.5.2.0-}+pext# :: Word# -> Word# -> Word#+pext# = pext#++{-|Count leading zeros in the lower 8 bits of a word.-}+clz8# :: Word# -> Word#+clz8# = clz8#++{-|Count leading zeros in the lower 16 bits of a word.-}+clz16# :: Word# -> Word#+clz16# = clz16#++{-|Count leading zeros in the lower 32 bits of a word.-}+clz32# :: Word# -> Word#+clz32# = clz32#++{-|Count leading zeros in a 64-bit word.-}+clz64# :: Word64# -> Word#+clz64# = clz64#++{-|Count leading zeros in a word.-}+clz# :: Word# -> Word#+clz# = clz#++{-|Count trailing zeros in the lower 8 bits of a word.-}+ctz8# :: Word# -> Word#+ctz8# = ctz8#++{-|Count trailing zeros in the lower 16 bits of a word.-}+ctz16# :: Word# -> Word#+ctz16# = ctz16#++{-|Count trailing zeros in the lower 32 bits of a word.-}+ctz32# :: Word# -> Word#+ctz32# = ctz32#++{-|Count trailing zeros in a 64-bit word.-}+ctz64# :: Word64# -> Word#+ctz64# = ctz64#++{-|Count trailing zeros in a word.-}+ctz# :: Word# -> Word#+ctz# = ctz#++{-|Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. -}+byteSwap16# :: Word# -> Word#+byteSwap16# = byteSwap16#++{-|Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. -}+byteSwap32# :: Word# -> Word#+byteSwap32# = byteSwap32#++{-|Swap bytes in a 64 bits of a word.-}+byteSwap64# :: Word64# -> Word64#+byteSwap64# = byteSwap64#++{-|Swap bytes in a word.-}+byteSwap# :: Word# -> Word#+byteSwap# = byteSwap#++{-|Reverse the order of the bits in a 8-bit word.-}+bitReverse8# :: Word# -> Word#+bitReverse8# = bitReverse8#++{-|Reverse the order of the bits in a 16-bit word.-}+bitReverse16# :: Word# -> Word#+bitReverse16# = bitReverse16#++{-|Reverse the order of the bits in a 32-bit word.-}+bitReverse32# :: Word# -> Word#+bitReverse32# = bitReverse32#++{-|Reverse the order of the bits in a 64-bit word.-}+bitReverse64# :: Word64# -> Word64#+bitReverse64# = bitReverse64#++{-|Reverse the order of the bits in a word.-}+bitReverse# :: Word# -> Word#+bitReverse# = bitReverse#++narrow8Int# :: Int# -> Int#+narrow8Int# = narrow8Int#++narrow16Int# :: Int# -> Int#+narrow16Int# = narrow16Int#++narrow32Int# :: Int# -> Int#+narrow32Int# = narrow32Int#++narrow8Word# :: Word# -> Word#+narrow8Word# = narrow8Word#++narrow16Word# :: Word# -> Word#+narrow16Word# = narrow16Word#++narrow32Word# :: Word# -> Word#+narrow32Word# = narrow32Word#++data Double#++infix 4 >##+(>##) :: Double# -> Double# -> Int#+(>##) = (>##)++infix 4 >=##+(>=##) :: Double# -> Double# -> Int#+(>=##) = (>=##)++infix 4 ==##+(==##) :: Double# -> Double# -> Int#+(==##) = (==##)++infix 4 /=##+(/=##) :: Double# -> Double# -> Int#+(/=##) = (/=##)++infix 4 <##+(<##) :: Double# -> Double# -> Int#+(<##) = (<##)++infix 4 <=##+(<=##) :: Double# -> Double# -> Int#+(<=##) = (<=##)++{-|Return the minimum of the arguments.+   When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@)+   or one of the arguments is not-a-number (NaN),+   it is unspecified which one is returned.-}+minDouble# :: Double# -> Double# -> Double#+minDouble# = minDouble#++{-|Return the maximum of the arguments.+   When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@)+   or one of the arguments is not-a-number (NaN),+   it is unspecified which one is returned.-}+maxDouble# :: Double# -> Double# -> Double#+maxDouble# = maxDouble#++infixl 6 +##+(+##) :: Double# -> Double# -> Double#+(+##) = (+##)++infixl 6 -##+(-##) :: Double# -> Double# -> Double#+(-##) = (-##)++infixl 7 *##+(*##) :: Double# -> Double# -> Double#+(*##) = (*##)++infixl 7 /##+(/##) :: Double# -> Double# -> Double#+(/##) = (/##)++negateDouble# :: Double# -> Double#+negateDouble# = negateDouble#++fabsDouble# :: Double# -> Double#+fabsDouble# = fabsDouble#++{-|Truncates a 'Double#' value to the nearest 'Int#'.+    Results are undefined if the truncation if truncation yields+    a value outside the range of 'Int#'.-}+double2Int# :: Double# -> Int#+double2Int# = double2Int#++double2Float# :: Double# -> Float#+double2Float# = double2Float#++expDouble# :: Double# -> Double#+expDouble# = expDouble#++expm1Double# :: Double# -> Double#+expm1Double# = expm1Double#++logDouble# :: Double# -> Double#+logDouble# = logDouble#++log1pDouble# :: Double# -> Double#+log1pDouble# = log1pDouble#++sqrtDouble# :: Double# -> Double#+sqrtDouble# = sqrtDouble#++sinDouble# :: Double# -> Double#+sinDouble# = sinDouble#++cosDouble# :: Double# -> Double#+cosDouble# = cosDouble#++tanDouble# :: Double# -> Double#+tanDouble# = tanDouble#++asinDouble# :: Double# -> Double#+asinDouble# = asinDouble#++acosDouble# :: Double# -> Double#+acosDouble# = acosDouble#++atanDouble# :: Double# -> Double#+atanDouble# = atanDouble#++sinhDouble# :: Double# -> Double#+sinhDouble# = sinhDouble#++coshDouble# :: Double# -> Double#+coshDouble# = coshDouble#++tanhDouble# :: Double# -> Double#+tanhDouble# = tanhDouble#++asinhDouble# :: Double# -> Double#+asinhDouble# = asinhDouble#++acoshDouble# :: Double# -> Double#+acoshDouble# = acoshDouble#++atanhDouble# :: Double# -> Double#+atanhDouble# = atanhDouble#++{-|Exponentiation.-}+(**##) :: Double# -> Double# -> Double#+(**##) = (**##)++{-|Convert to integer.+    First component of the result is -1 or 1, indicating the sign of the+    mantissa. The next two are the high and low 32 bits of the mantissa+    respectively, and the last is the exponent.-}+decodeDouble_2Int# :: Double# -> (# Int#,Word#,Word#,Int# #)+decodeDouble_2Int# = decodeDouble_2Int#++{-|Decode 'Double#' into mantissa and base-2 exponent.-}+decodeDouble_Int64# :: Double# -> (# Int64#,Int# #)+decodeDouble_Int64# = decodeDouble_Int64#++{-|Bitcast a 'Double#' into a 'Word64#'-}+castDoubleToWord64# :: Double# -> Word64#+castDoubleToWord64# = castDoubleToWord64#++{-|Bitcast a 'Word64#' into a 'Double#'-}+castWord64ToDouble# :: Word64# -> Double#+castWord64ToDouble# = castWord64ToDouble#++data Float#++gtFloat# :: Float# -> Float# -> Int#+gtFloat# = gtFloat#++geFloat# :: Float# -> Float# -> Int#+geFloat# = geFloat#++eqFloat# :: Float# -> Float# -> Int#+eqFloat# = eqFloat#++neFloat# :: Float# -> Float# -> Int#+neFloat# = neFloat#++ltFloat# :: Float# -> Float# -> Int#+ltFloat# = ltFloat#++leFloat# :: Float# -> Float# -> Int#+leFloat# = leFloat#++{-|Return the minimum of the arguments.+   When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@)+   or one of the arguments is not-a-number (NaN),+   it is unspecified which one is returned.-}+minFloat# :: Float# -> Float# -> Float#+minFloat# = minFloat#++{-|Return the maximum of the arguments.+   When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@)+   or one of the arguments is not-a-number (NaN),+   it is unspecified which one is returned.-}+maxFloat# :: Float# -> Float# -> Float#+maxFloat# = maxFloat#++plusFloat# :: Float# -> Float# -> Float#+plusFloat# = plusFloat#++minusFloat# :: Float# -> Float# -> Float#+minusFloat# = minusFloat#++timesFloat# :: Float# -> Float# -> Float#+timesFloat# = timesFloat#++divideFloat# :: Float# -> Float# -> Float#+divideFloat# = divideFloat#++negateFloat# :: Float# -> Float#+negateFloat# = negateFloat#++fabsFloat# :: Float# -> Float#+fabsFloat# = fabsFloat#++{-|Truncates a 'Float#' value to the nearest 'Int#'.+    Results are undefined if the truncation if truncation yields+    a value outside the range of 'Int#'.-}+float2Int# :: Float# -> Int#+float2Int# = float2Int#++expFloat# :: Float# -> Float#+expFloat# = expFloat#++expm1Float# :: Float# -> Float#+expm1Float# = expm1Float#++logFloat# :: Float# -> Float#+logFloat# = logFloat#++log1pFloat# :: Float# -> Float#+log1pFloat# = log1pFloat#++sqrtFloat# :: Float# -> Float#+sqrtFloat# = sqrtFloat#++sinFloat# :: Float# -> Float#+sinFloat# = sinFloat#++cosFloat# :: Float# -> Float#+cosFloat# = cosFloat#++tanFloat# :: Float# -> Float#+tanFloat# = tanFloat#++asinFloat# :: Float# -> Float#+asinFloat# = asinFloat#++acosFloat# :: Float# -> Float#+acosFloat# = acosFloat#++atanFloat# :: Float# -> Float#+atanFloat# = atanFloat#++sinhFloat# :: Float# -> Float#+sinhFloat# = sinhFloat#++coshFloat# :: Float# -> Float#+coshFloat# = coshFloat#++tanhFloat# :: Float# -> Float#+tanhFloat# = tanhFloat#++asinhFloat# :: Float# -> Float#+asinhFloat# = asinhFloat#++acoshFloat# :: Float# -> Float#+acoshFloat# = acoshFloat#++atanhFloat# :: Float# -> Float#+atanhFloat# = atanhFloat#++powerFloat# :: Float# -> Float# -> Float#+powerFloat# = powerFloat#++float2Double# :: Float# -> Double#+float2Double# = float2Double#++{-|Convert to integers.+    First 'Int#' in result is the mantissa; second is the exponent.-}+decodeFloat_Int# :: Float# -> (# Int#,Int# #)+decodeFloat_Int# = decodeFloat_Int#++{-|Bitcast a 'Float#' into a 'Word32#'-}+castFloatToWord32# :: Float# -> Word32#+castFloatToWord32# = castFloatToWord32#++{-|Bitcast a 'Word32#' into a 'Float#'-}+castWord32ToFloat# :: Word32# -> Float#+castWord32ToFloat# = castWord32ToFloat#++{-|Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".-}+fmaddFloat# :: Float# -> Float# -> Float# -> Float#+fmaddFloat# = fmaddFloat#++{-|Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".-}+fmsubFloat# :: Float# -> Float# -> Float# -> Float#+fmsubFloat# = fmsubFloat#++{-|Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".-}+fnmaddFloat# :: Float# -> Float# -> Float# -> Float#+fnmaddFloat# = fnmaddFloat#++{-|Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".-}+fnmsubFloat# :: Float# -> Float# -> Float# -> Float#+fnmsubFloat# = fnmsubFloat#++{-|Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".-}+fmaddDouble# :: Double# -> Double# -> Double# -> Double#+fmaddDouble# = fmaddDouble#++{-|Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".-}+fmsubDouble# :: Double# -> Double# -> Double# -> Double#+fmsubDouble# = fmsubDouble#++{-|Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".-}+fnmaddDouble# :: Double# -> Double# -> Double# -> Double#+fnmaddDouble# = fnmaddDouble#++{-|Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".-}+fnmsubDouble# :: Double# -> Double# -> Double# -> Double#+fnmsubDouble# = fnmsubDouble#++data Array# a++data MutableArray# s a++{-|Create a new mutable array with the specified number of elements,+    in the specified state thread,+    with each element containing the specified initial value.-}+newArray# :: Int# -> a_levpoly -> State# s -> (# State# s,MutableArray# s a_levpoly #)+newArray# = newArray#++{-|Read from specified index of mutable array. Result is not yet evaluated.++__/Warning:/__ this can fail with an unchecked exception.-}+readArray# :: MutableArray# s a_levpoly -> Int# -> State# s -> (# State# s,a_levpoly #)+readArray# = readArray#++{-|Write to specified index of mutable array.++__/Warning:/__ this can fail with an unchecked exception.-}+writeArray# :: MutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s+writeArray# = writeArray#++{-|Return the number of elements in the array.-}+sizeofArray# :: Array# a_levpoly -> Int#+sizeofArray# = sizeofArray#++{-|Return the number of elements in the array.-}+sizeofMutableArray# :: MutableArray# s a_levpoly -> Int#+sizeofMutableArray# = sizeofMutableArray#++{-|Read from the specified index of an immutable array. The result is packaged+    into an unboxed unary tuple; the result itself is not yet+    evaluated. Pattern matching on the tuple forces the indexing of the+    array to happen but does not evaluate the element itself. Evaluating+    the thunk prevents additional thunks from building up on the+    heap. Avoiding these thunks, in turn, reduces references to the+    argument array, allowing it to be garbage collected more promptly.-}+indexArray# :: Array# a_levpoly -> Int# -> (# a_levpoly #)+indexArray# = indexArray#++{-|Make a mutable array immutable, without copying.-}+unsafeFreezeArray# :: MutableArray# s a_levpoly -> State# s -> (# State# s,Array# a_levpoly #)+unsafeFreezeArray# = unsafeFreezeArray#++{-|Make an immutable array mutable, without copying.-}+unsafeThawArray# :: Array# a_levpoly -> State# s -> (# State# s,MutableArray# s a_levpoly #)+unsafeThawArray# = unsafeThawArray#++{-|Given a source array, an offset into the source array, a+   destination array, an offset into the destination array, and a+   number of elements to copy, copy the elements from the source array+   to the destination array. Both arrays must fully contain the+   specified ranges, but this is not checked. The two arrays must not+   be the same array in different states, but this is not checked+   either.++__/Warning:/__ this can fail with an unchecked exception.-}+copyArray# :: Array# a_levpoly -> Int# -> MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+copyArray# = copyArray#++{-|Given a source array, an offset into the source array, a+   destination array, an offset into the destination array, and a+   number of elements to copy, copy the elements from the source array+   to the destination array. Both arrays must fully contain the+   specified ranges, but this is not checked. In the case where+   the source and destination are the same array the source and+   destination regions may overlap.++__/Warning:/__ this can fail with an unchecked exception.-}+copyMutableArray# :: MutableArray# s a_levpoly -> Int# -> MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+copyMutableArray# = copyMutableArray#++{-|Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.++__/Warning:/__ this can fail with an unchecked exception.-}+cloneArray# :: Array# a_levpoly -> Int# -> Int# -> Array# a_levpoly+cloneArray# = cloneArray#++{-|Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.++__/Warning:/__ this can fail with an unchecked exception.-}+cloneMutableArray# :: MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s,MutableArray# s a_levpoly #)+cloneMutableArray# = cloneMutableArray#++{-|Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.++__/Warning:/__ this can fail with an unchecked exception.-}+freezeArray# :: MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s,Array# a_levpoly #)+freezeArray# = freezeArray#++{-|Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.++__/Warning:/__ this can fail with an unchecked exception.-}+thawArray# :: Array# a_levpoly -> Int# -> Int# -> State# s -> (# State# s,MutableArray# s a_levpoly #)+thawArray# = thawArray#++{-|Given an array, an offset, the expected old value, and+    the new value, perform an atomic compare and swap (i.e. write the new+    value if the current value and the old value are the same pointer).+    Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns+    the element at the offset after the operation completes. This means that+    on a success the new value is returned, and on a failure the actual old+    value (not the expected one) is returned. Implies a full memory barrier.+    The use of a pointer equality on a boxed value makes this function harder+    to use correctly than 'casIntArray#'. All of the difficulties+    of using 'reallyUnsafePtrEquality#' correctly apply to+    'casArray#' as well.+   ++__/Warning:/__ this can fail with an unchecked exception.-}+casArray# :: MutableArray# s a_levpoly -> Int# -> a_levpoly -> a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+casArray# = casArray#++data SmallArray# a++data SmallMutableArray# s a++{-|Create a new mutable array with the specified number of elements,+    in the specified state thread,+    with each element containing the specified initial value.-}+newSmallArray# :: Int# -> a_levpoly -> State# s -> (# State# s,SmallMutableArray# s a_levpoly #)+newSmallArray# = newSmallArray#++{-|Shrink mutable array to new specified size, in+    the specified state thread. The new size argument must be less than or+    equal to the current size as reported by 'getSizeofSmallMutableArray#'.++    Assuming the non-profiling RTS, for the copying garbage collector+    (default) this primitive compiles to an O(1) operation in C--, modifying+    the array in-place. For the non-moving garbage collector, however, the+    time is proportional to the number of elements shrinked out. Backends+    bypassing C-- representation (such as JavaScript) might behave+    differently.++    @since 0.6.1++__/Warning:/__ this can fail with an unchecked exception.-}+shrinkSmallMutableArray# :: SmallMutableArray# s a_levpoly -> Int# -> State# s -> State# s+shrinkSmallMutableArray# = shrinkSmallMutableArray#++{-|Read from specified index of mutable array. Result is not yet evaluated.++__/Warning:/__ this can fail with an unchecked exception.-}+readSmallArray# :: SmallMutableArray# s a_levpoly -> Int# -> State# s -> (# State# s,a_levpoly #)+readSmallArray# = readSmallArray#++{-|Write to specified index of mutable array.++__/Warning:/__ this can fail with an unchecked exception.-}+writeSmallArray# :: SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s+writeSmallArray# = writeSmallArray#++{-|Return the number of elements in the array.-}+sizeofSmallArray# :: SmallArray# a_levpoly -> Int#+sizeofSmallArray# = sizeofSmallArray#++{-|Return the number of elements in the array. __Deprecated__, it is+   unsafe in the presence of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@+   operations on the same small mutable array.-}+{-# DEPRECATED sizeofSmallMutableArray# " Use 'getSizeofSmallMutableArray#' instead " #-}+sizeofSmallMutableArray# :: SmallMutableArray# s a_levpoly -> Int#+sizeofSmallMutableArray# = sizeofSmallMutableArray#++{-|Return the number of elements in the array, correctly accounting for+   the effect of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@.++   @since 0.6.1-}+getSizeofSmallMutableArray# :: SmallMutableArray# s a_levpoly -> State# s -> (# State# s,Int# #)+getSizeofSmallMutableArray# = getSizeofSmallMutableArray#++{-|Read from specified index of immutable array. Result is packaged into+    an unboxed singleton; the result itself is not yet evaluated.-}+indexSmallArray# :: SmallArray# a_levpoly -> Int# -> (# a_levpoly #)+indexSmallArray# = indexSmallArray#++{-|Make a mutable array immutable, without copying.-}+unsafeFreezeSmallArray# :: SmallMutableArray# s a_levpoly -> State# s -> (# State# s,SmallArray# a_levpoly #)+unsafeFreezeSmallArray# = unsafeFreezeSmallArray#++{-|Make an immutable array mutable, without copying.-}+unsafeThawSmallArray# :: SmallArray# a_levpoly -> State# s -> (# State# s,SmallMutableArray# s a_levpoly #)+unsafeThawSmallArray# = unsafeThawSmallArray#++{-|Given a source array, an offset into the source array, a+   destination array, an offset into the destination array, and a+   number of elements to copy, copy the elements from the source array+   to the destination array. Both arrays must fully contain the+   specified ranges, but this is not checked. The two arrays must not+   be the same array in different states, but this is not checked+   either.++__/Warning:/__ this can fail with an unchecked exception.-}+copySmallArray# :: SmallArray# a_levpoly -> Int# -> SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+copySmallArray# = copySmallArray#++{-|Given a source array, an offset into the source array, a+   destination array, an offset into the destination array, and a+   number of elements to copy, copy the elements from the source array+   to the destination array. The source and destination arrays can+   refer to the same array. Both arrays must fully contain the+   specified ranges, but this is not checked.+   The regions are allowed to overlap, although this is only possible when the same+   array is provided as both the source and the destination. ++__/Warning:/__ this can fail with an unchecked exception.-}+copySmallMutableArray# :: SmallMutableArray# s a_levpoly -> Int# -> SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+copySmallMutableArray# = copySmallMutableArray#++{-|Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.++__/Warning:/__ this can fail with an unchecked exception.-}+cloneSmallArray# :: SmallArray# a_levpoly -> Int# -> Int# -> SmallArray# a_levpoly+cloneSmallArray# = cloneSmallArray#++{-|Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.++__/Warning:/__ this can fail with an unchecked exception.-}+cloneSmallMutableArray# :: SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s,SmallMutableArray# s a_levpoly #)+cloneSmallMutableArray# = cloneSmallMutableArray#++{-|Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.++__/Warning:/__ this can fail with an unchecked exception.-}+freezeSmallArray# :: SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s,SmallArray# a_levpoly #)+freezeSmallArray# = freezeSmallArray#++{-|Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.++__/Warning:/__ this can fail with an unchecked exception.-}+thawSmallArray# :: SmallArray# a_levpoly -> Int# -> Int# -> State# s -> (# State# s,SmallMutableArray# s a_levpoly #)+thawSmallArray# = thawSmallArray#++{-|Unsafe, machine-level atomic compare and swap on an element within an array.+    See the documentation of 'casArray#'.++__/Warning:/__ this can fail with an unchecked exception.-}+casSmallArray# :: SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+casSmallArray# = casSmallArray#++{-|+  A boxed, unlifted datatype representing a region of raw memory in the garbage-collected heap,+  which is not scanned for pointers during garbage collection.++  It is created by freezing a 'MutableByteArray#' with 'unsafeFreezeByteArray#'.+  Freezing is essentially a no-op, as 'MutableByteArray#' and 'ByteArray#' share the same heap structure under the hood.++  The immutable and mutable variants are commonly used for scenarios requiring high-performance data structures,+  like @Text@, @Primitive Vector@, @Unboxed Array@, and @ShortByteString@.++  Another application of fundamental importance is 'Integer', which is backed by 'ByteArray#'.++  The representation on the heap of a Byte Array is:++  > +------------+-----------------+-----------------------++  > |            |                 |                       |+  > |   HEADER   | SIZE (in bytes) |       PAYLOAD         |+  > |            |                 |                       |+  > +------------+-----------------+-----------------------+++  To obtain a pointer to actual payload (e.g., for FFI purposes) use 'byteArrayContents#' or 'mutableByteArrayContents#'.++  Alternatively, enabling the @UnliftedFFITypes@ extension+  allows to mention 'ByteArray#' and 'MutableByteArray#' in FFI type signatures directly.+-}+data ByteArray#++{-| A mutable 'ByteAray#'. It can be created in three ways:++  * 'newByteArray#': Create an unpinned array.+  * 'newPinnedByteArray#': This will create a pinned array,+  * 'newAlignedPinnedByteArray#': This will create a pinned array, with a custom alignment.++  Unpinned arrays can be moved around during garbage collection, so you must not store or pass pointers to these values+  if there is a chance for the garbage collector to kick in. That said, even unpinned arrays can be passed to unsafe FFI calls,+  because no garbage collection happens during these unsafe calls+  (see [Guaranteed Call Safety](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/ffi.html#guaranteed-call-safety)+  in the GHC Manual). For safe FFI calls, byte arrays must be not only pinned, but also kept alive by means of the keepAlive# function+  for the duration of a call (that's because garbage collection cannot move a pinned array, but is free to scrap it altogether).+-}+data MutableByteArray# s++{-|Create a new mutable byte array of specified size (in bytes), in+    the specified state thread. The size of the memory underlying the+    array will be rounded up to the platform's word size.-}+newByteArray# :: Int# -> State# s -> (# State# s,MutableByteArray# s #)+newByteArray# = newByteArray#++{-|Like 'newByteArray#' but GC guarantees not to move it.-}+newPinnedByteArray# :: Int# -> State# s -> (# State# s,MutableByteArray# s #)+newPinnedByteArray# = newPinnedByteArray#++{-|Like 'newPinnedByteArray#' but allow specifying an arbitrary+    alignment, which must be a power of two.++__/Warning:/__ this can fail with an unchecked exception.-}+newAlignedPinnedByteArray# :: Int# -> Int# -> State# s -> (# State# s,MutableByteArray# s #)+newAlignedPinnedByteArray# = newAlignedPinnedByteArray#++{-|Determine whether a 'MutableByteArray#' is guaranteed not to move+   during GC.-}+isMutableByteArrayPinned# :: MutableByteArray# s -> Int#+isMutableByteArrayPinned# = isMutableByteArrayPinned#++{-|Determine whether a 'ByteArray#' is guaranteed not to move.-}+isByteArrayPinned# :: ByteArray# -> Int#+isByteArrayPinned# = isByteArrayPinned#++{-|Similar to 'isByteArrayPinned#'. Weakly pinned byte arrays are allowed+    to be copied into compact regions by the user, potentially invalidating+    the results of earlier calls to 'byteArrayContents#'.++    See the section `Pinned Byte Arrays` in the user guide for more information.++    This function also returns true for regular pinned bytearrays.+   -}+isByteArrayWeaklyPinned# :: ByteArray# -> Int#+isByteArrayWeaklyPinned# = isByteArrayWeaklyPinned#++{-| 'isByteArrayWeaklyPinned#' but for mutable arrays.+   -}+isMutableByteArrayWeaklyPinned# :: MutableByteArray# s -> Int#+isMutableByteArrayWeaklyPinned# = isMutableByteArrayWeaklyPinned#++{-|Intended for use with pinned arrays; otherwise very unsafe!-}+byteArrayContents# :: ByteArray# -> Addr#+byteArrayContents# = byteArrayContents#++{-|Intended for use with pinned arrays; otherwise very unsafe!-}+mutableByteArrayContents# :: MutableByteArray# s -> Addr#+mutableByteArrayContents# = mutableByteArrayContents#++{-|Shrink mutable byte array to new specified size (in bytes), in+    the specified state thread. The new size argument must be less than or+    equal to the current size as reported by 'getSizeofMutableByteArray#'.++    Assuming the non-profiling RTS, this primitive compiles to an O(1)+    operation in C--, modifying the array in-place. Backends bypassing C--+    representation (such as JavaScript) might behave differently.++    @since 0.4.0.0++__/Warning:/__ this can fail with an unchecked exception.-}+shrinkMutableByteArray# :: MutableByteArray# s -> Int# -> State# s -> State# s+shrinkMutableByteArray# = shrinkMutableByteArray#++{-|Resize mutable byte array to new specified size (in bytes), shrinking or growing it.+    The returned 'MutableByteArray#' is either the original+    'MutableByteArray#' resized in-place or, if not possible, a newly+    allocated (unpinned) 'MutableByteArray#' (with the original content+    copied over).++    To avoid undefined behaviour, the original 'MutableByteArray#' shall+    not be accessed anymore after a 'resizeMutableByteArray#' has been+    performed.  Moreover, no reference to the old one should be kept in order+    to allow garbage collection of the original 'MutableByteArray#' in+    case a new 'MutableByteArray#' had to be allocated.++    @since 0.4.0.0-}+resizeMutableByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #)+resizeMutableByteArray# = resizeMutableByteArray#++{-|Make a mutable byte array immutable, without copying.-}+unsafeFreezeByteArray# :: MutableByteArray# s -> State# s -> (# State# s,ByteArray# #)+unsafeFreezeByteArray# = unsafeFreezeByteArray#++{-|Make an immutable byte array mutable, without copying.++    @since 0.12.0.0-}+unsafeThawByteArray# :: ByteArray# -> State# s -> (# State# s,MutableByteArray# s #)+unsafeThawByteArray# = unsafeThawByteArray#++{-|Return the size of the array in bytes.-}+sizeofByteArray# :: ByteArray# -> Int#+sizeofByteArray# = sizeofByteArray#++{-|Return the size of the array in bytes. __Deprecated__, it is+   unsafe in the presence of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'+   operations on the same mutable byte+   array.-}+{-# DEPRECATED sizeofMutableByteArray# " Use 'getSizeofMutableByteArray#' instead " #-}+sizeofMutableByteArray# :: MutableByteArray# s -> Int#+sizeofMutableByteArray# = sizeofMutableByteArray#++{-|Return the number of elements in the array, correctly accounting for+   the effect of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'.++   @since 0.5.0.0-}+getSizeofMutableByteArray# :: MutableByteArray# s -> State# s -> (# State# s,Int# #)+getSizeofMutableByteArray# = getSizeofMutableByteArray#++{-|Read an 8-bit character from immutable array; offset in bytes.-}+indexCharArray# :: ByteArray# -> Int# -> Char#+indexCharArray# = indexCharArray#++{-|Read a 32-bit character from immutable array; offset in 4-byte words.-}+indexWideCharArray# :: ByteArray# -> Int# -> Char#+indexWideCharArray# = indexWideCharArray#++{-|Read a word-sized integer from immutable array; offset in machine words.-}+indexIntArray# :: ByteArray# -> Int# -> Int#+indexIntArray# = indexIntArray#++{-|Read a word-sized unsigned integer from immutable array; offset in machine words.-}+indexWordArray# :: ByteArray# -> Int# -> Word#+indexWordArray# = indexWordArray#++{-|Read a machine address from immutable array; offset in machine words.-}+indexAddrArray# :: ByteArray# -> Int# -> Addr#+indexAddrArray# = indexAddrArray#++{-|Read a single-precision floating-point value from immutable array; offset in 4-byte words.-}+indexFloatArray# :: ByteArray# -> Int# -> Float#+indexFloatArray# = indexFloatArray#++{-|Read a double-precision floating-point value from immutable array; offset in 8-byte words.-}+indexDoubleArray# :: ByteArray# -> Int# -> Double#+indexDoubleArray# = indexDoubleArray#++{-|Read a 'StablePtr#' value from immutable array; offset in machine words.-}+indexStablePtrArray# :: ByteArray# -> Int# -> StablePtr# a+indexStablePtrArray# = indexStablePtrArray#++{-|Read an 8-bit signed integer from immutable array; offset in bytes.-}+indexInt8Array# :: ByteArray# -> Int# -> Int8#+indexInt8Array# = indexInt8Array#++{-|Read an 8-bit unsigned integer from immutable array; offset in bytes.-}+indexWord8Array# :: ByteArray# -> Int# -> Word8#+indexWord8Array# = indexWord8Array#++{-|Read a 16-bit signed integer from immutable array; offset in 2-byte words.-}+indexInt16Array# :: ByteArray# -> Int# -> Int16#+indexInt16Array# = indexInt16Array#++{-|Read a 16-bit unsigned integer from immutable array; offset in 2-byte words.-}+indexWord16Array# :: ByteArray# -> Int# -> Word16#+indexWord16Array# = indexWord16Array#++{-|Read a 32-bit signed integer from immutable array; offset in 4-byte words.-}+indexInt32Array# :: ByteArray# -> Int# -> Int32#+indexInt32Array# = indexInt32Array#++{-|Read a 32-bit unsigned integer from immutable array; offset in 4-byte words.-}+indexWord32Array# :: ByteArray# -> Int# -> Word32#+indexWord32Array# = indexWord32Array#++{-|Read a 64-bit signed integer from immutable array; offset in 8-byte words.-}+indexInt64Array# :: ByteArray# -> Int# -> Int64#+indexInt64Array# = indexInt64Array#++{-|Read a 64-bit unsigned integer from immutable array; offset in 8-byte words.-}+indexWord64Array# :: ByteArray# -> Int# -> Word64#+indexWord64Array# = indexWord64Array#++{-|Read an 8-bit character from immutable array; offset in bytes.-}+indexWord8ArrayAsChar# :: ByteArray# -> Int# -> Char#+indexWord8ArrayAsChar# = indexWord8ArrayAsChar#++{-|Read a 32-bit character from immutable array; offset in bytes.-}+indexWord8ArrayAsWideChar# :: ByteArray# -> Int# -> Char#+indexWord8ArrayAsWideChar# = indexWord8ArrayAsWideChar#++{-|Read a word-sized integer from immutable array; offset in bytes.-}+indexWord8ArrayAsInt# :: ByteArray# -> Int# -> Int#+indexWord8ArrayAsInt# = indexWord8ArrayAsInt#++{-|Read a word-sized unsigned integer from immutable array; offset in bytes.-}+indexWord8ArrayAsWord# :: ByteArray# -> Int# -> Word#+indexWord8ArrayAsWord# = indexWord8ArrayAsWord#++{-|Read a machine address from immutable array; offset in bytes.-}+indexWord8ArrayAsAddr# :: ByteArray# -> Int# -> Addr#+indexWord8ArrayAsAddr# = indexWord8ArrayAsAddr#++{-|Read a single-precision floating-point value from immutable array; offset in bytes.-}+indexWord8ArrayAsFloat# :: ByteArray# -> Int# -> Float#+indexWord8ArrayAsFloat# = indexWord8ArrayAsFloat#++{-|Read a double-precision floating-point value from immutable array; offset in bytes.-}+indexWord8ArrayAsDouble# :: ByteArray# -> Int# -> Double#+indexWord8ArrayAsDouble# = indexWord8ArrayAsDouble#++{-|Read a 'StablePtr#' value from immutable array; offset in bytes.-}+indexWord8ArrayAsStablePtr# :: ByteArray# -> Int# -> StablePtr# a+indexWord8ArrayAsStablePtr# = indexWord8ArrayAsStablePtr#++{-|Read a 16-bit signed integer from immutable array; offset in bytes.-}+indexWord8ArrayAsInt16# :: ByteArray# -> Int# -> Int16#+indexWord8ArrayAsInt16# = indexWord8ArrayAsInt16#++{-|Read a 16-bit unsigned integer from immutable array; offset in bytes.-}+indexWord8ArrayAsWord16# :: ByteArray# -> Int# -> Word16#+indexWord8ArrayAsWord16# = indexWord8ArrayAsWord16#++{-|Read a 32-bit signed integer from immutable array; offset in bytes.-}+indexWord8ArrayAsInt32# :: ByteArray# -> Int# -> Int32#+indexWord8ArrayAsInt32# = indexWord8ArrayAsInt32#++{-|Read a 32-bit unsigned integer from immutable array; offset in bytes.-}+indexWord8ArrayAsWord32# :: ByteArray# -> Int# -> Word32#+indexWord8ArrayAsWord32# = indexWord8ArrayAsWord32#++{-|Read a 64-bit signed integer from immutable array; offset in bytes.-}+indexWord8ArrayAsInt64# :: ByteArray# -> Int# -> Int64#+indexWord8ArrayAsInt64# = indexWord8ArrayAsInt64#++{-|Read a 64-bit unsigned integer from immutable array; offset in bytes.-}+indexWord8ArrayAsWord64# :: ByteArray# -> Int# -> Word64#+indexWord8ArrayAsWord64# = indexWord8ArrayAsWord64#++{-|Read an 8-bit character from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readCharArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readCharArray# = readCharArray#++{-|Read a 32-bit character from mutable array; offset in 4-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+readWideCharArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readWideCharArray# = readWideCharArray#++{-|Read a word-sized integer from mutable array; offset in machine words.++__/Warning:/__ this can fail with an unchecked exception.-}+readIntArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+readIntArray# = readIntArray#++{-|Read a word-sized unsigned integer from mutable array; offset in machine words.++__/Warning:/__ this can fail with an unchecked exception.-}+readWordArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #)+readWordArray# = readWordArray#++{-|Read a machine address from mutable array; offset in machine words.++__/Warning:/__ this can fail with an unchecked exception.-}+readAddrArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Addr# #)+readAddrArray# = readAddrArray#++{-|Read a single-precision floating-point value from mutable array; offset in 4-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Float# #)+readFloatArray# = readFloatArray#++{-|Read a double-precision floating-point value from mutable array; offset in 8-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Double# #)+readDoubleArray# = readDoubleArray#++{-|Read a 'StablePtr#' value from mutable array; offset in machine words.++__/Warning:/__ this can fail with an unchecked exception.-}+readStablePtrArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,StablePtr# a #)+readStablePtrArray# = readStablePtrArray#++{-|Read an 8-bit signed integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int8# #)+readInt8Array# = readInt8Array#++{-|Read an 8-bit unsigned integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word8# #)+readWord8Array# = readWord8Array#++{-|Read a 16-bit signed integer from mutable array; offset in 2-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16# #)+readInt16Array# = readInt16Array#++{-|Read a 16-bit unsigned integer from mutable array; offset in 2-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16# #)+readWord16Array# = readWord16Array#++{-|Read a 32-bit signed integer from mutable array; offset in 4-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32# #)+readInt32Array# = readInt32Array#++{-|Read a 32-bit unsigned integer from mutable array; offset in 4-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32# #)+readWord32Array# = readWord32Array#++{-|Read a 64-bit signed integer from mutable array; offset in 8-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64# #)+readInt64Array# = readInt64Array#++{-|Read a 64-bit unsigned integer from mutable array; offset in 8-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64# #)+readWord64Array# = readWord64Array#++{-|Read an 8-bit character from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsChar# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readWord8ArrayAsChar# = readWord8ArrayAsChar#++{-|Read a 32-bit character from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsWideChar# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readWord8ArrayAsWideChar# = readWord8ArrayAsWideChar#++{-|Read a word-sized integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsInt# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+readWord8ArrayAsInt# = readWord8ArrayAsInt#++{-|Read a word-sized unsigned integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsWord# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #)+readWord8ArrayAsWord# = readWord8ArrayAsWord#++{-|Read a machine address from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsAddr# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Addr# #)+readWord8ArrayAsAddr# = readWord8ArrayAsAddr#++{-|Read a single-precision floating-point value from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsFloat# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Float# #)+readWord8ArrayAsFloat# = readWord8ArrayAsFloat#++{-|Read a double-precision floating-point value from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsDouble# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Double# #)+readWord8ArrayAsDouble# = readWord8ArrayAsDouble#++{-|Read a 'StablePtr#' value from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsStablePtr# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,StablePtr# a #)+readWord8ArrayAsStablePtr# = readWord8ArrayAsStablePtr#++{-|Read a 16-bit signed integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsInt16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16# #)+readWord8ArrayAsInt16# = readWord8ArrayAsInt16#++{-|Read a 16-bit unsigned integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsWord16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16# #)+readWord8ArrayAsWord16# = readWord8ArrayAsWord16#++{-|Read a 32-bit signed integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsInt32# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32# #)+readWord8ArrayAsInt32# = readWord8ArrayAsInt32#++{-|Read a 32-bit unsigned integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsWord32# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32# #)+readWord8ArrayAsWord32# = readWord8ArrayAsWord32#++{-|Read a 64-bit signed integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsInt64# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64# #)+readWord8ArrayAsInt64# = readWord8ArrayAsInt64#++{-|Read a 64-bit unsigned integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsWord64# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64# #)+readWord8ArrayAsWord64# = readWord8ArrayAsWord64#++{-|Write an 8-bit character to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeCharArray# = writeCharArray#++{-|Write a 32-bit character to mutable array; offset in 4-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWideCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeWideCharArray# = writeWideCharArray#++{-|Write a word-sized integer to mutable array; offset in machine words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+writeIntArray# = writeIntArray#++{-|Write a word-sized unsigned integer to mutable array; offset in machine words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWordArray# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+writeWordArray# = writeWordArray#++{-|Write a machine address to mutable array; offset in machine words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeAddrArray# :: MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s+writeAddrArray# = writeAddrArray#++{-|Write a single-precision floating-point value to mutable array; offset in 4-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatArray# :: MutableByteArray# s -> Int# -> Float# -> State# s -> State# s+writeFloatArray# = writeFloatArray#++{-|Write a double-precision floating-point value to mutable array; offset in 8-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleArray# :: MutableByteArray# s -> Int# -> Double# -> State# s -> State# s+writeDoubleArray# = writeDoubleArray#++{-|Write a 'StablePtr#' value to mutable array; offset in machine words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeStablePtrArray# :: MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s+writeStablePtrArray# = writeStablePtrArray#++{-|Write an 8-bit signed integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8Array# :: MutableByteArray# s -> Int# -> Int8# -> State# s -> State# s+writeInt8Array# = writeInt8Array#++{-|Write an 8-bit unsigned integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8Array# :: MutableByteArray# s -> Int# -> Word8# -> State# s -> State# s+writeWord8Array# = writeWord8Array#++{-|Write a 16-bit signed integer to mutable array; offset in 2-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16Array# :: MutableByteArray# s -> Int# -> Int16# -> State# s -> State# s+writeInt16Array# = writeInt16Array#++{-|Write a 16-bit unsigned integer to mutable array; offset in 2-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16Array# :: MutableByteArray# s -> Int# -> Word16# -> State# s -> State# s+writeWord16Array# = writeWord16Array#++{-|Write a 32-bit signed integer to mutable array; offset in 4-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32Array# :: MutableByteArray# s -> Int# -> Int32# -> State# s -> State# s+writeInt32Array# = writeInt32Array#++{-|Write a 32-bit unsigned integer to mutable array; offset in 4-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32Array# :: MutableByteArray# s -> Int# -> Word32# -> State# s -> State# s+writeWord32Array# = writeWord32Array#++{-|Write a 64-bit signed integer to mutable array; offset in 8-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64Array# :: MutableByteArray# s -> Int# -> Int64# -> State# s -> State# s+writeInt64Array# = writeInt64Array#++{-|Write a 64-bit unsigned integer to mutable array; offset in 8-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64Array# :: MutableByteArray# s -> Int# -> Word64# -> State# s -> State# s+writeWord64Array# = writeWord64Array#++{-|Write an 8-bit character to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsChar# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeWord8ArrayAsChar# = writeWord8ArrayAsChar#++{-|Write a 32-bit character to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsWideChar# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeWord8ArrayAsWideChar# = writeWord8ArrayAsWideChar#++{-|Write a word-sized integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsInt# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+writeWord8ArrayAsInt# = writeWord8ArrayAsInt#++{-|Write a word-sized unsigned integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsWord# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+writeWord8ArrayAsWord# = writeWord8ArrayAsWord#++{-|Write a machine address to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsAddr# :: MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s+writeWord8ArrayAsAddr# = writeWord8ArrayAsAddr#++{-|Write a single-precision floating-point value to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsFloat# :: MutableByteArray# s -> Int# -> Float# -> State# s -> State# s+writeWord8ArrayAsFloat# = writeWord8ArrayAsFloat#++{-|Write a double-precision floating-point value to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsDouble# :: MutableByteArray# s -> Int# -> Double# -> State# s -> State# s+writeWord8ArrayAsDouble# = writeWord8ArrayAsDouble#++{-|Write a 'StablePtr#' value to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsStablePtr# :: MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s+writeWord8ArrayAsStablePtr# = writeWord8ArrayAsStablePtr#++{-|Write a 16-bit signed integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsInt16# :: MutableByteArray# s -> Int# -> Int16# -> State# s -> State# s+writeWord8ArrayAsInt16# = writeWord8ArrayAsInt16#++{-|Write a 16-bit unsigned integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsWord16# :: MutableByteArray# s -> Int# -> Word16# -> State# s -> State# s+writeWord8ArrayAsWord16# = writeWord8ArrayAsWord16#++{-|Write a 32-bit signed integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsInt32# :: MutableByteArray# s -> Int# -> Int32# -> State# s -> State# s+writeWord8ArrayAsInt32# = writeWord8ArrayAsInt32#++{-|Write a 32-bit unsigned integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsWord32# :: MutableByteArray# s -> Int# -> Word32# -> State# s -> State# s+writeWord8ArrayAsWord32# = writeWord8ArrayAsWord32#++{-|Write a 64-bit signed integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsInt64# :: MutableByteArray# s -> Int# -> Int64# -> State# s -> State# s+writeWord8ArrayAsInt64# = writeWord8ArrayAsInt64#++{-|Write a 64-bit unsigned integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsWord64# :: MutableByteArray# s -> Int# -> Word64# -> State# s -> State# s+writeWord8ArrayAsWord64# = writeWord8ArrayAsWord64#++{-|@'compareByteArrays#' src1 src1_ofs src2 src2_ofs n@ compares+    @n@ bytes starting at offset @src1_ofs@ in the first+    'ByteArray#' @src1@ to the range of @n@ bytes+    (i.e. same length) starting at offset @src2_ofs@ of the second+    'ByteArray#' @src2@.  Both arrays must fully contain the+    specified ranges, but this is not checked.  Returns an 'Int#'+    less than, equal to, or greater than zero if the range is found,+    respectively, to be byte-wise lexicographically less than, to+    match, or be greater than the second range.++    @since 0.5.2.0-}+compareByteArrays# :: ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int#+compareByteArrays# = compareByteArrays#++{-| @'copyByteArray#' src src_ofs dst dst_ofs len@ copies the range+    starting at offset @src_ofs@ of length @len@ from the+    'ByteArray#' @src@ to the 'MutableByteArray#' @dst@+    starting at offset @dst_ofs@.  Both arrays must fully contain+    the specified ranges, but this is not checked.  The two arrays must+    not be the same array in different states, but this is not checked+    either.+  ++__/Warning:/__ this can fail with an unchecked exception.-}+copyByteArray# :: ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+copyByteArray# = copyByteArray#++{-| @'copyMutableByteArray#' src src_ofs dst dst_ofs len@ copies the+    range starting at offset @src_ofs@ of length @len@ from the+    'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@+    starting at offset @dst_ofs@.  Both arrays must fully contain the+    specified ranges, but this is not checked.  The regions are+    allowed to overlap, although this is only possible when the same+    array is provided as both the source and the destination.+  ++__/Warning:/__ this can fail with an unchecked exception.-}+copyMutableByteArray# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+copyMutableByteArray# = copyMutableByteArray#++{-| @'copyMutableByteArrayNonOverlapping#' src src_ofs dst dst_ofs len@+    copies the range starting at offset @src_ofs@ of length @len@ from+    the 'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@+    starting at offset @dst_ofs@.  Both arrays must fully contain the+    specified ranges, but this is not checked.  The regions are /not/+    allowed to overlap, but this is also not checked.++    @since 0.11.0+  ++__/Warning:/__ this can fail with an unchecked exception.-}+copyMutableByteArrayNonOverlapping# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+copyMutableByteArrayNonOverlapping# = copyMutableByteArrayNonOverlapping#++{-|Copy a range of the ByteArray\# to the memory range starting at the Addr\#.+   The ByteArray\# and the memory region at Addr\# must fully contain the+   specified ranges, but this is not checked. The Addr\# must not point into the+   ByteArray\# (e.g. if the ByteArray\# were pinned), but this is not checked+   either.++__/Warning:/__ this can fail with an unchecked exception.-}+copyByteArrayToAddr# :: ByteArray# -> Int# -> Addr# -> Int# -> State# s -> State# s+copyByteArrayToAddr# = copyByteArrayToAddr#++{-|Copy a range of the MutableByteArray\# to the memory range starting at the+   Addr\#. The MutableByteArray\# and the memory region at Addr\# must fully+   contain the specified ranges, but this is not checked. The Addr\# must not+   point into the MutableByteArray\# (e.g. if the MutableByteArray\# were+   pinned), but this is not checked either.++__/Warning:/__ this can fail with an unchecked exception.-}+copyMutableByteArrayToAddr# :: MutableByteArray# s -> Int# -> Addr# -> Int# -> State# s -> State# s+copyMutableByteArrayToAddr# = copyMutableByteArrayToAddr#++{-|Copy a memory range starting at the Addr\# to the specified range in the+   MutableByteArray\#. The memory region at Addr\# and the ByteArray\# must fully+   contain the specified ranges, but this is not checked. The Addr\# must not+   point into the MutableByteArray\# (e.g. if the MutableByteArray\# were pinned),+   but this is not checked either.++__/Warning:/__ this can fail with an unchecked exception.-}+copyAddrToByteArray# :: Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+copyAddrToByteArray# = copyAddrToByteArray#++{-| @'copyAddrToAddr#' src dest len@ copies @len@ bytes+    from @src@ to @dest@.  These two memory ranges are allowed to overlap.++    Analogous to the standard C function @memmove@, but with a different+    argument order.++    @since 0.11.0+  ++__/Warning:/__ this can fail with an unchecked exception.-}+copyAddrToAddr# :: Addr# -> Addr# -> Int# -> State# (RealWorld) -> State# (RealWorld)+copyAddrToAddr# = copyAddrToAddr#++{-| @'copyAddrToAddrNonOverlapping#' src dest len@ copies @len@ bytes+    from @src@ to @dest@.  As the name suggests, these two memory ranges+    /must not overlap/, although this pre-condition is not checked.++    Analogous to the standard C function @memcpy@, but with a different+    argument order.++    @since 0.11.0+  ++__/Warning:/__ this can fail with an unchecked exception.-}+copyAddrToAddrNonOverlapping# :: Addr# -> Addr# -> Int# -> State# (RealWorld) -> State# (RealWorld)+copyAddrToAddrNonOverlapping# = copyAddrToAddrNonOverlapping#++{-|@'setByteArray#' ba off len c@ sets the byte range @[off, off+len)@ of+   the 'MutableByteArray#' to the byte @c@.++__/Warning:/__ this can fail with an unchecked exception.-}+setByteArray# :: MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> State# s+setByteArray# = setByteArray#++{-| @'setAddrRange#' dest len c@ sets all of the bytes in+    @[dest, dest+len)@ to the value @c@.++    Analogous to the standard C function @memset@, but with a different+    argument order.++    @since 0.11.0+  ++__/Warning:/__ this can fail with an unchecked exception.-}+setAddrRange# :: Addr# -> Int# -> Int# -> State# (RealWorld) -> State# (RealWorld)+setAddrRange# = setAddrRange#++{-|Given an array and an offset in machine words, read an element. The+    index is assumed to be in bounds. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicReadIntArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+atomicReadIntArray# = atomicReadIntArray#++{-|Given an array and an offset in machine words, write an element. The+    index is assumed to be in bounds. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicWriteIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+atomicWriteIntArray# = atomicWriteIntArray#++{-|Given an array, an offset in machine words, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+casIntArray# :: MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s,Int# #)+casIntArray# = casIntArray#++{-|Given an array, an offset in bytes, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+casInt8Array# :: MutableByteArray# s -> Int# -> Int8# -> Int8# -> State# s -> (# State# s,Int8# #)+casInt8Array# = casInt8Array#++{-|Given an array, an offset in 16 bit units, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+casInt16Array# :: MutableByteArray# s -> Int# -> Int16# -> Int16# -> State# s -> (# State# s,Int16# #)+casInt16Array# = casInt16Array#++{-|Given an array, an offset in 32 bit units, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+casInt32Array# :: MutableByteArray# s -> Int# -> Int32# -> Int32# -> State# s -> (# State# s,Int32# #)+casInt32Array# = casInt32Array#++{-|Given an array, an offset in 64 bit units, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+casInt64Array# :: MutableByteArray# s -> Int# -> Int64# -> Int64# -> State# s -> (# State# s,Int64# #)+casInt64Array# = casInt64Array#++{-|Given an array, and offset in machine words, and a value to add,+    atomically add the value to the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchAddIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchAddIntArray# = fetchAddIntArray#++{-|Given an array, and offset in machine words, and a value to subtract,+    atomically subtract the value from the element. Returns the value of+    the element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchSubIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchSubIntArray# = fetchSubIntArray#++{-|Given an array, and offset in machine words, and a value to AND,+    atomically AND the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchAndIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchAndIntArray# = fetchAndIntArray#++{-|Given an array, and offset in machine words, and a value to NAND,+    atomically NAND the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchNandIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchNandIntArray# = fetchNandIntArray#++{-|Given an array, and offset in machine words, and a value to OR,+    atomically OR the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchOrIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchOrIntArray# = fetchOrIntArray#++{-|Given an array, and offset in machine words, and a value to XOR,+    atomically XOR the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchXorIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchXorIntArray# = fetchXorIntArray#++{-| An arbitrary machine address assumed to point outside+         the garbage-collected heap. -}+data Addr#++{-| The null address. -}+nullAddr# :: Addr#+nullAddr# = nullAddr#++plusAddr# :: Addr# -> Int# -> Addr#+plusAddr# = plusAddr#++{-|Result is meaningless if two 'Addr#'s are so far apart that their+         difference doesn't fit in an 'Int#'.-}+minusAddr# :: Addr# -> Addr# -> Int#+minusAddr# = minusAddr#++{-|Return the remainder when the 'Addr#' arg, treated like an 'Int#',+          is divided by the 'Int#' arg.-}+remAddr# :: Addr# -> Int# -> Int#+remAddr# = remAddr#++{-|Coerce directly from address to int. Users are discouraged from using+         this operation as it makes little sense on platforms with tagged pointers.-}+addr2Int# :: Addr# -> Int#+addr2Int# = addr2Int#++{-|Coerce directly from int to address. Users are discouraged from using+         this operation as it makes little sense on platforms with tagged pointers.-}+int2Addr# :: Int# -> Addr#+int2Addr# = int2Addr#++gtAddr# :: Addr# -> Addr# -> Int#+gtAddr# = gtAddr#++geAddr# :: Addr# -> Addr# -> Int#+geAddr# = geAddr#++eqAddr# :: Addr# -> Addr# -> Int#+eqAddr# = eqAddr#++neAddr# :: Addr# -> Addr# -> Int#+neAddr# = neAddr#++ltAddr# :: Addr# -> Addr# -> Int#+ltAddr# = ltAddr#++leAddr# :: Addr# -> Addr# -> Int#+leAddr# = leAddr#++{-|Read an 8-bit character from immutable address; offset in bytes.++-}+indexCharOffAddr# :: Addr# -> Int# -> Char#+indexCharOffAddr# = indexCharOffAddr#++{-|Read a 32-bit character from immutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexWideCharOffAddr# :: Addr# -> Int# -> Char#+indexWideCharOffAddr# = indexWideCharOffAddr#++{-|Read a word-sized integer from immutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexIntOffAddr# :: Addr# -> Int# -> Int#+indexIntOffAddr# = indexIntOffAddr#++{-|Read a word-sized unsigned integer from immutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexWordOffAddr# :: Addr# -> Int# -> Word#+indexWordOffAddr# = indexWordOffAddr#++{-|Read a machine address from immutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexAddrOffAddr# :: Addr# -> Int# -> Addr#+indexAddrOffAddr# = indexAddrOffAddr#++{-|Read a single-precision floating-point value from immutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexFloatOffAddr# :: Addr# -> Int# -> Float#+indexFloatOffAddr# = indexFloatOffAddr#++{-|Read a double-precision floating-point value from immutable address; offset in 8-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexDoubleOffAddr# :: Addr# -> Int# -> Double#+indexDoubleOffAddr# = indexDoubleOffAddr#++{-|Read a 'StablePtr#' value from immutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexStablePtrOffAddr# :: Addr# -> Int# -> StablePtr# a+indexStablePtrOffAddr# = indexStablePtrOffAddr#++{-|Read an 8-bit signed integer from immutable address; offset in bytes.++-}+indexInt8OffAddr# :: Addr# -> Int# -> Int8#+indexInt8OffAddr# = indexInt8OffAddr#++{-|Read an 8-bit unsigned integer from immutable address; offset in bytes.++-}+indexWord8OffAddr# :: Addr# -> Int# -> Word8#+indexWord8OffAddr# = indexWord8OffAddr#++{-|Read a 16-bit signed integer from immutable address; offset in 2-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexInt16OffAddr# :: Addr# -> Int# -> Int16#+indexInt16OffAddr# = indexInt16OffAddr#++{-|Read a 16-bit unsigned integer from immutable address; offset in 2-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexWord16OffAddr# :: Addr# -> Int# -> Word16#+indexWord16OffAddr# = indexWord16OffAddr#++{-|Read a 32-bit signed integer from immutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexInt32OffAddr# :: Addr# -> Int# -> Int32#+indexInt32OffAddr# = indexInt32OffAddr#++{-|Read a 32-bit unsigned integer from immutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexWord32OffAddr# :: Addr# -> Int# -> Word32#+indexWord32OffAddr# = indexWord32OffAddr#++{-|Read a 64-bit signed integer from immutable address; offset in 8-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexInt64OffAddr# :: Addr# -> Int# -> Int64#+indexInt64OffAddr# = indexInt64OffAddr#++{-|Read a 64-bit unsigned integer from immutable address; offset in 8-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexWord64OffAddr# :: Addr# -> Int# -> Word64#+indexWord64OffAddr# = indexWord64OffAddr#++{-|Read an 8-bit character from immutable address; offset in bytes.-}+indexWord8OffAddrAsChar# :: Addr# -> Int# -> Char#+indexWord8OffAddrAsChar# = indexWord8OffAddrAsChar#++{-|Read a 32-bit character from immutable address; offset in bytes.-}+indexWord8OffAddrAsWideChar# :: Addr# -> Int# -> Char#+indexWord8OffAddrAsWideChar# = indexWord8OffAddrAsWideChar#++{-|Read a word-sized integer from immutable address; offset in bytes.-}+indexWord8OffAddrAsInt# :: Addr# -> Int# -> Int#+indexWord8OffAddrAsInt# = indexWord8OffAddrAsInt#++{-|Read a word-sized unsigned integer from immutable address; offset in bytes.-}+indexWord8OffAddrAsWord# :: Addr# -> Int# -> Word#+indexWord8OffAddrAsWord# = indexWord8OffAddrAsWord#++{-|Read a machine address from immutable address; offset in bytes.-}+indexWord8OffAddrAsAddr# :: Addr# -> Int# -> Addr#+indexWord8OffAddrAsAddr# = indexWord8OffAddrAsAddr#++{-|Read a single-precision floating-point value from immutable address; offset in bytes.-}+indexWord8OffAddrAsFloat# :: Addr# -> Int# -> Float#+indexWord8OffAddrAsFloat# = indexWord8OffAddrAsFloat#++{-|Read a double-precision floating-point value from immutable address; offset in bytes.-}+indexWord8OffAddrAsDouble# :: Addr# -> Int# -> Double#+indexWord8OffAddrAsDouble# = indexWord8OffAddrAsDouble#++{-|Read a 'StablePtr#' value from immutable address; offset in bytes.-}+indexWord8OffAddrAsStablePtr# :: Addr# -> Int# -> StablePtr# a+indexWord8OffAddrAsStablePtr# = indexWord8OffAddrAsStablePtr#++{-|Read a 16-bit signed integer from immutable address; offset in bytes.-}+indexWord8OffAddrAsInt16# :: Addr# -> Int# -> Int16#+indexWord8OffAddrAsInt16# = indexWord8OffAddrAsInt16#++{-|Read a 16-bit unsigned integer from immutable address; offset in bytes.-}+indexWord8OffAddrAsWord16# :: Addr# -> Int# -> Word16#+indexWord8OffAddrAsWord16# = indexWord8OffAddrAsWord16#++{-|Read a 32-bit signed integer from immutable address; offset in bytes.-}+indexWord8OffAddrAsInt32# :: Addr# -> Int# -> Int32#+indexWord8OffAddrAsInt32# = indexWord8OffAddrAsInt32#++{-|Read a 32-bit unsigned integer from immutable address; offset in bytes.-}+indexWord8OffAddrAsWord32# :: Addr# -> Int# -> Word32#+indexWord8OffAddrAsWord32# = indexWord8OffAddrAsWord32#++{-|Read a 64-bit signed integer from immutable address; offset in bytes.-}+indexWord8OffAddrAsInt64# :: Addr# -> Int# -> Int64#+indexWord8OffAddrAsInt64# = indexWord8OffAddrAsInt64#++{-|Read a 64-bit unsigned integer from immutable address; offset in bytes.-}+indexWord8OffAddrAsWord64# :: Addr# -> Int# -> Word64#+indexWord8OffAddrAsWord64# = indexWord8OffAddrAsWord64#++{-|Read an 8-bit character from mutable address; offset in bytes.++++__/Warning:/__ this can fail with an unchecked exception.-}+readCharOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readCharOffAddr# = readCharOffAddr#++{-|Read a 32-bit character from mutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readWideCharOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readWideCharOffAddr# = readWideCharOffAddr#++{-|Read a word-sized integer from mutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readIntOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #)+readIntOffAddr# = readIntOffAddr#++{-|Read a word-sized unsigned integer from mutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readWordOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #)+readWordOffAddr# = readWordOffAddr#++{-|Read a machine address from mutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readAddrOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Addr# #)+readAddrOffAddr# = readAddrOffAddr#++{-|Read a single-precision floating-point value from mutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Float# #)+readFloatOffAddr# = readFloatOffAddr#++{-|Read a double-precision floating-point value from mutable address; offset in 8-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Double# #)+readDoubleOffAddr# = readDoubleOffAddr#++{-|Read a 'StablePtr#' value from mutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readStablePtrOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,StablePtr# a #)+readStablePtrOffAddr# = readStablePtrOffAddr#++{-|Read an 8-bit signed integer from mutable address; offset in bytes.++++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int8# #)+readInt8OffAddr# = readInt8OffAddr#++{-|Read an 8-bit unsigned integer from mutable address; offset in bytes.++++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word8# #)+readWord8OffAddr# = readWord8OffAddr#++{-|Read a 16-bit signed integer from mutable address; offset in 2-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int16# #)+readInt16OffAddr# = readInt16OffAddr#++{-|Read a 16-bit unsigned integer from mutable address; offset in 2-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word16# #)+readWord16OffAddr# = readWord16OffAddr#++{-|Read a 32-bit signed integer from mutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int32# #)+readInt32OffAddr# = readInt32OffAddr#++{-|Read a 32-bit unsigned integer from mutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word32# #)+readWord32OffAddr# = readWord32OffAddr#++{-|Read a 64-bit signed integer from mutable address; offset in 8-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int64# #)+readInt64OffAddr# = readInt64OffAddr#++{-|Read a 64-bit unsigned integer from mutable address; offset in 8-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word64# #)+readWord64OffAddr# = readWord64OffAddr#++{-|Read an 8-bit character from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsChar# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readWord8OffAddrAsChar# = readWord8OffAddrAsChar#++{-|Read a 32-bit character from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsWideChar# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readWord8OffAddrAsWideChar# = readWord8OffAddrAsWideChar#++{-|Read a word-sized integer from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsInt# :: Addr# -> Int# -> State# s -> (# State# s,Int# #)+readWord8OffAddrAsInt# = readWord8OffAddrAsInt#++{-|Read a word-sized unsigned integer from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsWord# :: Addr# -> Int# -> State# s -> (# State# s,Word# #)+readWord8OffAddrAsWord# = readWord8OffAddrAsWord#++{-|Read a machine address from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsAddr# :: Addr# -> Int# -> State# s -> (# State# s,Addr# #)+readWord8OffAddrAsAddr# = readWord8OffAddrAsAddr#++{-|Read a single-precision floating-point value from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsFloat# :: Addr# -> Int# -> State# s -> (# State# s,Float# #)+readWord8OffAddrAsFloat# = readWord8OffAddrAsFloat#++{-|Read a double-precision floating-point value from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsDouble# :: Addr# -> Int# -> State# s -> (# State# s,Double# #)+readWord8OffAddrAsDouble# = readWord8OffAddrAsDouble#++{-|Read a 'StablePtr#' value from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsStablePtr# :: Addr# -> Int# -> State# s -> (# State# s,StablePtr# a #)+readWord8OffAddrAsStablePtr# = readWord8OffAddrAsStablePtr#++{-|Read a 16-bit signed integer from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsInt16# :: Addr# -> Int# -> State# s -> (# State# s,Int16# #)+readWord8OffAddrAsInt16# = readWord8OffAddrAsInt16#++{-|Read a 16-bit unsigned integer from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsWord16# :: Addr# -> Int# -> State# s -> (# State# s,Word16# #)+readWord8OffAddrAsWord16# = readWord8OffAddrAsWord16#++{-|Read a 32-bit signed integer from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsInt32# :: Addr# -> Int# -> State# s -> (# State# s,Int32# #)+readWord8OffAddrAsInt32# = readWord8OffAddrAsInt32#++{-|Read a 32-bit unsigned integer from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsWord32# :: Addr# -> Int# -> State# s -> (# State# s,Word32# #)+readWord8OffAddrAsWord32# = readWord8OffAddrAsWord32#++{-|Read a 64-bit signed integer from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsInt64# :: Addr# -> Int# -> State# s -> (# State# s,Int64# #)+readWord8OffAddrAsInt64# = readWord8OffAddrAsInt64#++{-|Read a 64-bit unsigned integer from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsWord64# :: Addr# -> Int# -> State# s -> (# State# s,Word64# #)+readWord8OffAddrAsWord64# = readWord8OffAddrAsWord64#++{-|Write an 8-bit character to mutable address; offset in bytes.++++__/Warning:/__ this can fail with an unchecked exception.-}+writeCharOffAddr# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeCharOffAddr# = writeCharOffAddr#++{-|Write a 32-bit character to mutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWideCharOffAddr# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeWideCharOffAddr# = writeWideCharOffAddr#++{-|Write a word-sized integer to mutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeIntOffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeIntOffAddr# = writeIntOffAddr#++{-|Write a word-sized unsigned integer to mutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWordOffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWordOffAddr# = writeWordOffAddr#++{-|Write a machine address to mutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeAddrOffAddr# :: Addr# -> Int# -> Addr# -> State# s -> State# s+writeAddrOffAddr# = writeAddrOffAddr#++{-|Write a single-precision floating-point value to mutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatOffAddr# :: Addr# -> Int# -> Float# -> State# s -> State# s+writeFloatOffAddr# = writeFloatOffAddr#++{-|Write a double-precision floating-point value to mutable address; offset in 8-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleOffAddr# :: Addr# -> Int# -> Double# -> State# s -> State# s+writeDoubleOffAddr# = writeDoubleOffAddr#++{-|Write a 'StablePtr#' value to mutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeStablePtrOffAddr# :: Addr# -> Int# -> StablePtr# a -> State# s -> State# s+writeStablePtrOffAddr# = writeStablePtrOffAddr#++{-|Write an 8-bit signed integer to mutable address; offset in bytes.++++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8OffAddr# :: Addr# -> Int# -> Int8# -> State# s -> State# s+writeInt8OffAddr# = writeInt8OffAddr#++{-|Write an 8-bit unsigned integer to mutable address; offset in bytes.++++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddr# :: Addr# -> Int# -> Word8# -> State# s -> State# s+writeWord8OffAddr# = writeWord8OffAddr#++{-|Write a 16-bit signed integer to mutable address; offset in 2-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16OffAddr# :: Addr# -> Int# -> Int16# -> State# s -> State# s+writeInt16OffAddr# = writeInt16OffAddr#++{-|Write a 16-bit unsigned integer to mutable address; offset in 2-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16OffAddr# :: Addr# -> Int# -> Word16# -> State# s -> State# s+writeWord16OffAddr# = writeWord16OffAddr#++{-|Write a 32-bit signed integer to mutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32OffAddr# :: Addr# -> Int# -> Int32# -> State# s -> State# s+writeInt32OffAddr# = writeInt32OffAddr#++{-|Write a 32-bit unsigned integer to mutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32OffAddr# :: Addr# -> Int# -> Word32# -> State# s -> State# s+writeWord32OffAddr# = writeWord32OffAddr#++{-|Write a 64-bit signed integer to mutable address; offset in 8-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64OffAddr# :: Addr# -> Int# -> Int64# -> State# s -> State# s+writeInt64OffAddr# = writeInt64OffAddr#++{-|Write a 64-bit unsigned integer to mutable address; offset in 8-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64OffAddr# :: Addr# -> Int# -> Word64# -> State# s -> State# s+writeWord64OffAddr# = writeWord64OffAddr#++{-|Write an 8-bit character to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsChar# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeWord8OffAddrAsChar# = writeWord8OffAddrAsChar#++{-|Write a 32-bit character to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsWideChar# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeWord8OffAddrAsWideChar# = writeWord8OffAddrAsWideChar#++{-|Write a word-sized integer to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsInt# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeWord8OffAddrAsInt# = writeWord8OffAddrAsInt#++{-|Write a word-sized unsigned integer to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsWord# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWord8OffAddrAsWord# = writeWord8OffAddrAsWord#++{-|Write a machine address to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsAddr# :: Addr# -> Int# -> Addr# -> State# s -> State# s+writeWord8OffAddrAsAddr# = writeWord8OffAddrAsAddr#++{-|Write a single-precision floating-point value to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsFloat# :: Addr# -> Int# -> Float# -> State# s -> State# s+writeWord8OffAddrAsFloat# = writeWord8OffAddrAsFloat#++{-|Write a double-precision floating-point value to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsDouble# :: Addr# -> Int# -> Double# -> State# s -> State# s+writeWord8OffAddrAsDouble# = writeWord8OffAddrAsDouble#++{-|Write a 'StablePtr#' value to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsStablePtr# :: Addr# -> Int# -> StablePtr# a -> State# s -> State# s+writeWord8OffAddrAsStablePtr# = writeWord8OffAddrAsStablePtr#++{-|Write a 16-bit signed integer to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsInt16# :: Addr# -> Int# -> Int16# -> State# s -> State# s+writeWord8OffAddrAsInt16# = writeWord8OffAddrAsInt16#++{-|Write a 16-bit unsigned integer to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsWord16# :: Addr# -> Int# -> Word16# -> State# s -> State# s+writeWord8OffAddrAsWord16# = writeWord8OffAddrAsWord16#++{-|Write a 32-bit signed integer to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsInt32# :: Addr# -> Int# -> Int32# -> State# s -> State# s+writeWord8OffAddrAsInt32# = writeWord8OffAddrAsInt32#++{-|Write a 32-bit unsigned integer to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsWord32# :: Addr# -> Int# -> Word32# -> State# s -> State# s+writeWord8OffAddrAsWord32# = writeWord8OffAddrAsWord32#++{-|Write a 64-bit signed integer to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsInt64# :: Addr# -> Int# -> Int64# -> State# s -> State# s+writeWord8OffAddrAsInt64# = writeWord8OffAddrAsInt64#++{-|Write a 64-bit unsigned integer to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsWord64# :: Addr# -> Int# -> Word64# -> State# s -> State# s+writeWord8OffAddrAsWord64# = writeWord8OffAddrAsWord64#++{-|The atomic exchange operation. Atomically exchanges the value at the first address+    with the Addr# given as second argument. Implies a read barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicExchangeAddrAddr# :: Addr# -> Addr# -> State# s -> (# State# s,Addr# #)+atomicExchangeAddrAddr# = atomicExchangeAddrAddr#++{-|The atomic exchange operation. Atomically exchanges the value at the address+    with the given value. Returns the old value. Implies a read barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicExchangeWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+atomicExchangeWordAddr# = atomicExchangeWordAddr#++{-| Compare and swap on a word-sized memory location.++     Use as: \s -> atomicCasAddrAddr# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicCasAddrAddr# :: Addr# -> Addr# -> Addr# -> State# s -> (# State# s,Addr# #)+atomicCasAddrAddr# = atomicCasAddrAddr#++{-| Compare and swap on a word-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicCasWordAddr# :: Addr# -> Word# -> Word# -> State# s -> (# State# s,Word# #)+atomicCasWordAddr# = atomicCasWordAddr#++{-| Compare and swap on a 8 bit-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr8# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicCasWord8Addr# :: Addr# -> Word8# -> Word8# -> State# s -> (# State# s,Word8# #)+atomicCasWord8Addr# = atomicCasWord8Addr#++{-| Compare and swap on a 16 bit-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr16# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicCasWord16Addr# :: Addr# -> Word16# -> Word16# -> State# s -> (# State# s,Word16# #)+atomicCasWord16Addr# = atomicCasWord16Addr#++{-| Compare and swap on a 32 bit-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr32# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicCasWord32Addr# :: Addr# -> Word32# -> Word32# -> State# s -> (# State# s,Word32# #)+atomicCasWord32Addr# = atomicCasWord32Addr#++{-| Compare and swap on a 64 bit-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr64# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicCasWord64Addr# :: Addr# -> Word64# -> Word64# -> State# s -> (# State# s,Word64# #)+atomicCasWord64Addr# = atomicCasWord64Addr#++{-|Given an address, and a value to add,+    atomically add the value to the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchAddWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchAddWordAddr# = fetchAddWordAddr#++{-|Given an address, and a value to subtract,+    atomically subtract the value from the element. Returns the value of+    the element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchSubWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchSubWordAddr# = fetchSubWordAddr#++{-|Given an address, and a value to AND,+    atomically AND the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchAndWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchAndWordAddr# = fetchAndWordAddr#++{-|Given an address, and a value to NAND,+    atomically NAND the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchNandWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchNandWordAddr# = fetchNandWordAddr#++{-|Given an address, and a value to OR,+    atomically OR the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchOrWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchOrWordAddr# = fetchOrWordAddr#++{-|Given an address, and a value to XOR,+    atomically XOR the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchXorWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchXorWordAddr# = fetchXorWordAddr#++{-|Given an address, read a machine word.  Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicReadWordAddr# :: Addr# -> State# s -> (# State# s,Word# #)+atomicReadWordAddr# = atomicReadWordAddr#++{-|Given an address, write a machine word. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicWriteWordAddr# :: Addr# -> Word# -> State# s -> State# s+atomicWriteWordAddr# = atomicWriteWordAddr#++{-|A 'MutVar#' behaves like a single-element mutable array.-}+data MutVar# s a++{-|Create 'MutVar#' with specified initial value in specified state thread.-}+newMutVar# :: a_levpoly -> State# s -> (# State# s,MutVar# s a_levpoly #)+newMutVar# = newMutVar#++{-|Read contents of 'MutVar#'. Result is not yet evaluated.-}+readMutVar# :: MutVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+readMutVar# = readMutVar#++{-|Write contents of 'MutVar#'.-}+writeMutVar# :: MutVar# s a_levpoly -> a_levpoly -> State# s -> State# s+writeMutVar# = writeMutVar#++{-|Atomically exchange the value of a 'MutVar#'.-}+atomicSwapMutVar# :: MutVar# s a_levpoly -> a_levpoly -> State# s -> (# State# s,a_levpoly #)+atomicSwapMutVar# = atomicSwapMutVar#++{-| Modify the contents of a 'MutVar#', returning the previous+     contents @x :: a@ and the result of applying the given function to the+     previous contents @f x :: c@.++     The @data@ type @c@ (not a @newtype@!) must be a record whose first field+     is of lifted type @a :: Type@ and is not unpacked. For example, product+     types @c ~ Solo a@ or @c ~ (a, b)@ work well. If the record type is both+     monomorphic and strict in its first field, it's recommended to mark the+     latter @{-# NOUNPACK #-}@ explicitly.++     Under the hood 'atomicModifyMutVar2#' atomically replaces a pointer to an+     old @x :: a@ with a pointer to a selector thunk @fst r@, where+     @fst@ is a selector for the first field of the record and @r@ is a+     function application thunk @r = f x@.++     @atomicModifyIORef2Native@ from @atomic-modify-general@ package makes an+     effort to reflect restrictions on @c@ faithfully, providing a+     well-typed high-level wrapper.-}+atomicModifyMutVar2# :: MutVar# s a -> (a -> c) -> State# s -> (# State# s,a,c #)+atomicModifyMutVar2# = atomicModifyMutVar2#++{-| Modify the contents of a 'MutVar#', returning the previous+     contents and the result of applying the given function to the+     previous contents. -}+atomicModifyMutVar_# :: MutVar# s a -> (a -> a) -> State# s -> (# State# s,a,a #)+atomicModifyMutVar_# = atomicModifyMutVar_#++{-| Compare-and-swap: perform a pointer equality test between+     the first value passed to this function and the value+     stored inside the 'MutVar#'. If the pointers are equal,+     replace the stored value with the second value passed to this+     function, otherwise do nothing.+     Returns the final value stored inside the 'MutVar#'.+     The 'Int#' indicates whether a swap took place,+     with @1#@ meaning that we didn't swap, and @0#@+     that we did.+     Implies a full memory barrier.+     Because the comparison is done on the level of pointers,+     all of the difficulties of using+     'reallyUnsafePtrEquality#' correctly apply to+     'casMutVar#' as well.+   -}+casMutVar# :: MutVar# s a_levpoly -> a_levpoly -> a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+casMutVar# = casMutVar#++{-| @'catch#' k handler s@ evaluates @k s@, invoking @handler@ on any exceptions+     thrown.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. -}+catch# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> (b_levpoly -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)+catch# = catch#++raise# :: a_levpoly -> b_reppoly+raise# = raise#++raiseUnderflow# :: (#  #) -> b_reppoly+raiseUnderflow# = raiseUnderflow#++raiseOverflow# :: (#  #) -> b_reppoly+raiseOverflow# = raiseOverflow#++raiseDivZero# :: (#  #) -> b_reppoly+raiseDivZero# = raiseDivZero#++raiseIO# :: a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),b_reppoly #)+raiseIO# = raiseIO#++{-| @'maskAsyncExceptions#' k s@ evaluates @k s@ such that asynchronous+     exceptions are deferred until after evaluation has finished.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. -}+maskAsyncExceptions# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)+maskAsyncExceptions# = maskAsyncExceptions#++{-| @'maskUninterruptible#' k s@ evaluates @k s@ such that asynchronous+     exceptions are deferred until after evaluation has finished.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. -}+maskUninterruptible# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)+maskUninterruptible# = maskUninterruptible#++{-| @'unmaskAsyncUninterruptible#' k s@ evaluates @k s@ such that asynchronous+     exceptions are unmasked.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. -}+unmaskAsyncExceptions# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)+unmaskAsyncExceptions# = unmaskAsyncExceptions#++getMaskingState# :: State# (RealWorld) -> (# State# (RealWorld),Int# #)+getMaskingState# = getMaskingState#++{-| See "GHC.Prim#continuations". -}+data PromptTag# a++{-| See "GHC.Prim#continuations". -}+newPromptTag# :: State# (RealWorld) -> (# State# (RealWorld),PromptTag# a #)+newPromptTag# = newPromptTag#++{-| See "GHC.Prim#continuations". -}+prompt# :: PromptTag# a -> (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)+prompt# = prompt#++{-| See "GHC.Prim#continuations". ++__/Warning:/__ this can fail with an unchecked exception.-}+control0# :: PromptTag# a -> (((State# (RealWorld) -> (# State# (RealWorld),b_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),b_reppoly #)+control0# = control0#++data TVar# s a++atomically# :: (State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+atomically# = atomically#++retry# :: State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+retry# = retry#++catchRetry# :: (State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> (State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+catchRetry# = catchRetry#++catchSTM# :: (State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> (b -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+catchSTM# = catchSTM#++{-|Create a new 'TVar#' holding a specified initial value.-}+newTVar# :: a_levpoly -> State# s -> (# State# s,TVar# s a_levpoly #)+newTVar# = newTVar#++{-|Read contents of 'TVar#' inside an STM transaction,+    i.e. within a call to 'atomically#'.+    Does not force evaluation of the result.-}+readTVar# :: TVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+readTVar# = readTVar#++{-|Read contents of 'TVar#' outside an STM transaction.+   Does not force evaluation of the result.-}+readTVarIO# :: TVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+readTVarIO# = readTVarIO#++{-|Write contents of 'TVar#'.-}+writeTVar# :: TVar# s a_levpoly -> a_levpoly -> State# s -> State# s+writeTVar# = writeTVar#++{-| A shared mutable variable (/not/ the same as a 'MutVar#'!).+        (Note: in a non-concurrent implementation, @('MVar#' a)@ can be+        represented by @('MutVar#' (Maybe a))@.) -}+data MVar# s a++{-|Create new 'MVar#'; initially empty.-}+newMVar# :: State# s -> (# State# s,MVar# s a_levpoly #)+newMVar# = newMVar#++{-|If 'MVar#' is empty, block until it becomes full.+   Then remove and return its contents, and set it empty.-}+takeMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+takeMVar# = takeMVar#++{-|If 'MVar#' is empty, immediately return with integer 0 and value undefined.+   Otherwise, return with integer 1 and contents of 'MVar#', and set 'MVar#' empty.-}+tryTakeMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+tryTakeMVar# = tryTakeMVar#++{-|If 'MVar#' is full, block until it becomes empty.+   Then store value arg as its new contents.-}+putMVar# :: MVar# s a_levpoly -> a_levpoly -> State# s -> State# s+putMVar# = putMVar#++{-|If 'MVar#' is full, immediately return with integer 0.+    Otherwise, store value arg as 'MVar#''s new contents, and return with integer 1.-}+tryPutMVar# :: MVar# s a_levpoly -> a_levpoly -> State# s -> (# State# s,Int# #)+tryPutMVar# = tryPutMVar#++{-|If 'MVar#' is empty, block until it becomes full.+   Then read its contents without modifying the MVar, without possibility+   of intervention from other threads.-}+readMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+readMVar# = readMVar#++{-|If 'MVar#' is empty, immediately return with integer 0 and value undefined.+   Otherwise, return with integer 1 and contents of 'MVar#'.-}+tryReadMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+tryReadMVar# = tryReadMVar#++{-|Return 1 if 'MVar#' is empty; 0 otherwise.-}+isEmptyMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,Int# #)+isEmptyMVar# = isEmptyMVar#++{-|Sleep specified number of microseconds.-}+delay# :: Int# -> State# s -> State# s+delay# = delay#++{-|Block until input is available on specified file descriptor.-}+waitRead# :: Int# -> State# s -> State# s+waitRead# = waitRead#++{-|Block until output is possible on specified file descriptor.-}+waitWrite# :: Int# -> State# s -> State# s+waitWrite# = waitWrite#++{-| 'State#' is the primitive, unlifted type of states.  It has+        one type parameter, thus @'State#' 'RealWorld'@, or @'State#' s@,+        where s is a type variable. The only purpose of the type parameter+        is to keep different state threads separate.  It is represented by+        nothing at all. -}+data State# s++{-| 'RealWorld' is deeply magical.  It is /primitive/, but it is not+        /unlifted/ (hence @ptrArg@).  We never manipulate values of type+        'RealWorld'; it's only used in the type system, to parameterise 'State#'. -}+data RealWorld++{-|(In a non-concurrent implementation, this can be a singleton+        type, whose (unique) value is returned by 'myThreadId#'.  The+        other operations can be omitted.)-}+data ThreadId#++fork# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),ThreadId# #)+fork# = fork#++forkOn# :: Int# -> (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),ThreadId# #)+forkOn# = forkOn#++killThread# :: ThreadId# -> a -> State# (RealWorld) -> State# (RealWorld)+killThread# = killThread#++yield# :: State# (RealWorld) -> State# (RealWorld)+yield# = yield#++myThreadId# :: State# (RealWorld) -> (# State# (RealWorld),ThreadId# #)+myThreadId# = myThreadId#++{-|Set the label of the given thread. The @ByteArray#@ should contain+    a UTF-8-encoded string.-}+labelThread# :: ThreadId# -> ByteArray# -> State# (RealWorld) -> State# (RealWorld)+labelThread# = labelThread#++isCurrentThreadBound# :: State# (RealWorld) -> (# State# (RealWorld),Int# #)+isCurrentThreadBound# = isCurrentThreadBound#++noDuplicate# :: State# s -> State# s+noDuplicate# = noDuplicate#++{-|Get the label of the given thread.+    Morally of type @ThreadId# -> IO (Maybe ByteArray#)@, with a @1#@ tag+    denoting @Just@.++    @since 0.10-}+threadLabel# :: ThreadId# -> State# (RealWorld) -> (# State# (RealWorld),Int#,ByteArray# #)+threadLabel# = threadLabel#++{-|Get the status of the given thread. Result is+    @(ThreadStatus, Capability, Locked)@ where+    @ThreadStatus@ is one of the status constants defined in+    @rts/Constants.h@, @Capability@ is the number of+    the capability which currently owns the thread, and+    @Locked@ is a boolean indicating whether the+    thread is bound to that capability.++    @since 0.9-}+threadStatus# :: ThreadId# -> State# (RealWorld) -> (# State# (RealWorld),Int#,Int#,Int# #)+threadStatus# = threadStatus#++{-| Returns an array of the threads started by the program. Note that this+     threads which have finished execution may or may not be present in this+     list, depending upon whether they have been collected by the garbage collector.++     @since 0.10-}+listThreads# :: State# (RealWorld) -> (# State# (RealWorld),Array# (ThreadId#) #)+listThreads# = listThreads#++data Weak# b++{-| @'mkWeak#' k v finalizer s@ creates a weak reference to value @k@,+     with an associated reference to some value @v@. If @k@ is still+     alive then @v@ can be retrieved using 'deRefWeak#'. Note that+     the type of @k@ must be represented by a pointer (i.e. of kind+     @'TYPE' ''LiftedRep' or @'TYPE' ''UnliftedRep'@). -}+mkWeak# :: a_levpoly -> b_levpoly -> (State# (RealWorld) -> (# State# (RealWorld),c #)) -> State# (RealWorld) -> (# State# (RealWorld),Weak# b_levpoly #)+mkWeak# = mkWeak#++mkWeakNoFinalizer# :: a_levpoly -> b_levpoly -> State# (RealWorld) -> (# State# (RealWorld),Weak# b_levpoly #)+mkWeakNoFinalizer# = mkWeakNoFinalizer#++{-| @'addCFinalizerToWeak#' fptr ptr flag eptr w@ attaches a C+     function pointer @fptr@ to a weak pointer @w@ as a finalizer. If+     @flag@ is zero, @fptr@ will be called with one argument,+     @ptr@. Otherwise, it will be called with two arguments,+     @eptr@ and @ptr@. 'addCFinalizerToWeak#' returns+     1 on success, or 0 if @w@ is already dead. -}+addCFinalizerToWeak# :: Addr# -> Addr# -> Int# -> Addr# -> Weak# b_levpoly -> State# (RealWorld) -> (# State# (RealWorld),Int# #)+addCFinalizerToWeak# = addCFinalizerToWeak#++deRefWeak# :: Weak# a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),Int#,a_levpoly #)+deRefWeak# = deRefWeak#++{-| Finalize a weak pointer. The return value is an unboxed tuple+     containing the new state of the world and an "unboxed Maybe",+     represented by an 'Int#' and a (possibly invalid) finalization+     action. An 'Int#' of @1@ indicates that the finalizer is valid. The+     return value @b@ from the finalizer should be ignored. -}+finalizeWeak# :: Weak# a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),Int#,State# (RealWorld) -> (# State# (RealWorld),b #) #)+finalizeWeak# = finalizeWeak#++touch# :: a_levpoly -> State# s -> State# s+touch# = touch#++data StablePtr# a++data StableName# a++makeStablePtr# :: a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),StablePtr# a_levpoly #)+makeStablePtr# = makeStablePtr#++deRefStablePtr# :: StablePtr# a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+deRefStablePtr# = deRefStablePtr#++eqStablePtr# :: StablePtr# a_levpoly -> StablePtr# a_levpoly -> Int#+eqStablePtr# = eqStablePtr#++makeStableName# :: a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),StableName# a_levpoly #)+makeStableName# = makeStableName#++stableNameToInt# :: StableName# a_levpoly -> Int#+stableNameToInt# = stableNameToInt#++data Compact#++{-| Create a new CNF with a single compact block. The argument is+     the capacity of the compact block (in bytes, not words).+     The capacity is rounded up to a multiple of the allocator block size+     and is capped to one mega block. -}+compactNew# :: Word# -> State# (RealWorld) -> (# State# (RealWorld),Compact# #)+compactNew# = compactNew#++{-| Set the new allocation size of the CNF. This value (in bytes)+     determines the capacity of each compact block in the CNF. It+     does not retroactively affect existing compact blocks in the CNF. -}+compactResize# :: Compact# -> Word# -> State# (RealWorld) -> State# (RealWorld)+compactResize# = compactResize#++{-| Returns 1\# if the object is contained in the CNF, 0\# otherwise. -}+compactContains# :: Compact# -> a -> State# (RealWorld) -> (# State# (RealWorld),Int# #)+compactContains# = compactContains#++{-| Returns 1\# if the object is in any CNF at all, 0\# otherwise. -}+compactContainsAny# :: a -> State# (RealWorld) -> (# State# (RealWorld),Int# #)+compactContainsAny# = compactContainsAny#++{-| Returns the address and the utilized size (in bytes) of the+     first compact block of a CNF.-}+compactGetFirstBlock# :: Compact# -> State# (RealWorld) -> (# State# (RealWorld),Addr#,Word# #)+compactGetFirstBlock# = compactGetFirstBlock#++{-| Given a CNF and the address of one its compact blocks, returns the+     next compact block and its utilized size, or 'nullAddr#' if the+     argument was the last compact block in the CNF. -}+compactGetNextBlock# :: Compact# -> Addr# -> State# (RealWorld) -> (# State# (RealWorld),Addr#,Word# #)+compactGetNextBlock# = compactGetNextBlock#++{-| Attempt to allocate a compact block with the capacity (in+     bytes) given by the first argument. The 'Addr#' is a pointer+     to previous compact block of the CNF or 'nullAddr#' to create a+     new CNF with a single compact block.++     The resulting block is not known to the GC until+     'compactFixupPointers#' is called on it, and care must be taken+     so that the address does not escape or memory will be leaked.+   -}+compactAllocateBlock# :: Word# -> Addr# -> State# (RealWorld) -> (# State# (RealWorld),Addr# #)+compactAllocateBlock# = compactAllocateBlock#++{-| Given the pointer to the first block of a CNF and the+     address of the root object in the old address space, fix up+     the internal pointers inside the CNF to account for+     a different position in memory than when it was serialized.+     This method must be called exactly once after importing+     a serialized CNF. It returns the new CNF and the new adjusted+     root address. -}+compactFixupPointers# :: Addr# -> Addr# -> State# (RealWorld) -> (# State# (RealWorld),Compact#,Addr# #)+compactFixupPointers# = compactFixupPointers#++{-| Recursively add a closure and its transitive closure to a+     'Compact#' (a CNF), evaluating any unevaluated components+     at the same time. Note: 'compactAdd#' is not thread-safe, so+     only one thread may call 'compactAdd#' with a particular+     'Compact#' at any given time. The primop does not+     enforce any mutual exclusion; the caller is expected to+     arrange this. -}+compactAdd# :: Compact# -> a -> State# (RealWorld) -> (# State# (RealWorld),a #)+compactAdd# = compactAdd#++{-| Like 'compactAdd#', but retains sharing and cycles+   during compaction. -}+compactAddWithSharing# :: Compact# -> a -> State# (RealWorld) -> (# State# (RealWorld),a #)+compactAddWithSharing# = compactAddWithSharing#++{-| Return the total capacity (in bytes) of all the compact blocks+     in the CNF. -}+compactSize# :: Compact# -> State# (RealWorld) -> (# State# (RealWorld),Word# #)+compactSize# = compactSize#++{-| Returns @1#@ if the given pointers are equal and @0#@ otherwise. -}+reallyUnsafePtrEquality# :: a_levpoly -> b_levpoly -> Int#+reallyUnsafePtrEquality# = reallyUnsafePtrEquality#++{-|Create a new spark evaluating the given argument.+    The return value should always be 1.+    Users are encouraged to use spark# instead.-}+par# :: a -> Int#+par# = par#++spark# :: a -> State# s -> (# State# s,a #)+spark# = spark#++getSpark# :: State# s -> (# State# s,Int#,a #)+getSpark# = getSpark#++{-| Returns the number of sparks in the local spark pool. -}+numSparks# :: State# s -> (# State# s,Int# #)+numSparks# = numSparks#++{-| @'keepAlive#' x s k@ keeps the value @x@ alive during the execution+     of the computation @k@.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. -}+keepAlive# :: a_levpoly -> State# s -> (State# s -> b_reppoly) -> b_reppoly+keepAlive# = keepAlive#++{-| Used internally to implement @dataToTag#@: Use that function instead!+     This one normally offers /no advantage/ and comes with no stability+     guarantees: it may change its type, its name, or its behavior+     with /no warning/ between compiler releases.++     It is expected that this function will be un-exposed in a future+     release of ghc.++     For more details, look at @Note [DataToTag overview]@+     in GHC.Tc.Instance.Class in the source code for+     /the specific compiler version you are using./+   -}+{-# DEPRECATED dataToTagSmall# " Use dataToTag# from \"GHC.Magic\" instead. " #-}+dataToTagSmall# :: a_levpoly -> Int#+dataToTagSmall# = dataToTagSmall#++{-| Used internally to implement @dataToTag#@: Use that function instead!+     This one offers /no advantage/ and comes with no stability+     guarantees: it may change its type, its name, or its behavior+     with /no warning/ between compiler releases.++     It is expected that this function will be un-exposed in a future+     release of ghc.++     For more details, look at @Note [DataToTag overview]@+     in GHC.Tc.Instance.Class in the source code for+     /the specific compiler version you are using./+   -}+{-# DEPRECATED dataToTagLarge# " Use dataToTag# from \"GHC.Magic\" instead. " #-}+dataToTagLarge# :: a_levpoly -> Int#+dataToTagLarge# = dataToTagLarge#++tagToEnum# :: Int# -> a+tagToEnum# = let x = x in x++{-| Primitive bytecode type. -}+data BCO++{-| Convert an 'Addr#' to a followable Any type. -}+addrToAny# :: Addr# -> (# a_levpoly #)+addrToAny# = addrToAny#++{-| Retrieve the address of any Haskell value. This is+     essentially an 'unsafeCoerce#', but if implemented as such+     the core lint pass complains and fails to compile.+     As a primop, it is opaque to core/stg, and only appears+     in cmm (where the copy propagation pass will get rid of it).+     Note that "a" must be a value, not a thunk! It's too late+     for strictness analysis to enforce this, so you're on your+     own to guarantee this. Also note that 'Addr#' is not a GC+     pointer - up to you to guarantee that it does not become+     a dangling pointer immediately after you get it.-}+anyToAddr# :: a -> State# (RealWorld) -> (# State# (RealWorld),Addr# #)+anyToAddr# = anyToAddr#++{-| Wrap a BCO in a @AP_UPD@ thunk which will be updated with the value of+     the BCO when evaluated. -}+mkApUpd0# :: BCO -> (# a #)+mkApUpd0# = mkApUpd0#++{-| @'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The+     resulting object encodes a function of the given arity with the instructions+     encoded in @instrs@, and a static reference table usage bitmap given by+     @bitmap@. -}+newBCO# :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s,BCO #)+newBCO# = newBCO#++{-| @'unpackClosure#' closure@ copies the closure and pointers in the+     payload of the given closure into two new arrays, and returns a pointer to+     the first word of the closure's info table, a non-pointer array for the raw+     bytes of the closure, and a pointer array for the pointers in the payload. -}+unpackClosure# :: a -> (# Addr#,ByteArray#,Array# b #)+unpackClosure# = unpackClosure#++{-| @'closureSize#' closure@ returns the size of the given closure in+     machine words. -}+closureSize# :: a -> Int#+closureSize# = closureSize#++getApStackVal# :: a -> Int# -> (# Int#,b #)+getApStackVal# = getApStackVal#++getCCSOf# :: a -> State# s -> (# State# s,Addr# #)+getCCSOf# = getCCSOf#++{-| Returns the current 'CostCentreStack' (value is @NULL@ if+     not profiling).  Takes a dummy argument which can be used to+     avoid the call to 'getCurrentCCS#' being floated out by the+     simplifier, which would result in an uninformative stack+     ("CAF"). -}+getCurrentCCS# :: a -> State# s -> (# State# s,Addr# #)+getCurrentCCS# = getCurrentCCS#++{-| Run the supplied IO action with an empty CCS.  For example, this+     is used by the interpreter to run an interpreted computation+     without the call stack showing that it was invoked from GHC. -}+clearCCS# :: (State# s -> (# State# s,a #)) -> State# s -> (# State# s,a #)+clearCCS# = clearCCS#++{-| Pushes an annotation frame to the stack which can be reported by backtraces. -}+annotateStack# :: b -> (State# s -> (# State# s,a_reppoly #)) -> State# s -> (# State# s,a_reppoly #)+annotateStack# = annotateStack#++{-| Fills the given buffer with the @InfoProvEnt@ for the info table of the+     given object. Returns @1#@ on success and @0#@ otherwise.-}+whereFrom# :: a -> Addr# -> State# s -> (# State# s,Int# #)+whereFrom# = whereFrom#++{-|The builtin function type, written in infix form as @a % m -> b@.+   Values of this type are functions taking inputs of type @a@ and+   producing outputs of type @b@. The multiplicity of the input is+   @m@.++   Note that @'FUN' m a b@ permits representation polymorphism in both+   @a@ and @b@, so that types like @'Int#' -> 'Int#'@ can still be+   well-kinded.+  -}+data FUN m a b++{-| The token used in the implementation of the IO monad as a state monad.+     It does not pass any information at runtime.+     See also 'GHC.Magic.runRW#'. -}+realWorld# :: State# (RealWorld)+realWorld# = realWorld#++{-| This is an alias for the unboxed unit tuple constructor.+     In earlier versions of GHC, 'void#' was a value+     of the primitive type 'Void#', which is now defined to be @(# #)@.+   -}+{-# DEPRECATED void# " Use an unboxed unit tuple instead " #-}+void# :: (#  #)+void# = void#++{-| The type constructor 'Proxy#' is used to bear witness to some+   type variable. It's used when you want to pass around proxy values+   for doing things like modelling type applications. A 'Proxy#'+   is not only unboxed, it also has a polymorphic kind, and has no+   runtime representation, being totally free. -}+data Proxy# a++{-| Witness for an unboxed 'Proxy#' value, which has no runtime+   representation. -}+proxy# :: Proxy# a+proxy# = proxy#++{-| The value of @'seq' a b@ is bottom if @a@ is bottom, and+     otherwise equal to @b@. In other words, it evaluates the first+     argument @a@ to weak head normal form (WHNF). 'seq' is usually+     introduced to improve performance by avoiding unneeded laziness.++     A note on evaluation order: the expression @'seq' a b@ does+     /not/ guarantee that @a@ will be evaluated before @b@.+     The only guarantee given by 'seq' is that the both @a@+     and @b@ will be evaluated before 'seq' returns a value.+     In particular, this means that @b@ may be evaluated before+     @a@. If you need to guarantee a specific order of evaluation,+     you must use the function 'pseq' from the "parallel" package. -}+infixr 0 `seq`+seq :: a -> b_reppoly -> b_reppoly+seq = seq++{-| Emits an event via the RTS tracing framework.  The contents+     of the event is the zero-terminated byte string passed as the first+     argument.  The event will be emitted either to the @.eventlog@ file,+     or to stderr, depending on the runtime RTS flags. -}+traceEvent# :: Addr# -> State# s -> State# s+traceEvent# = traceEvent#++{-| Emits an event via the RTS tracing framework.  The contents+     of the event is the binary object passed as the first argument with+     the given length passed as the second argument. The event will be+     emitted to the @.eventlog@ file. -}+traceBinaryEvent# :: Addr# -> Int# -> State# s -> State# s+traceBinaryEvent# = traceBinaryEvent#++{-| Emits a marker event via the RTS tracing framework.  The contents+     of the event is the zero-terminated byte string passed as the first+     argument.  The event will be emitted either to the @.eventlog@ file,+     or to stderr, depending on the runtime RTS flags. -}+traceMarker# :: Addr# -> State# s -> State# s+traceMarker# = traceMarker#++{-| Sets the allocation counter for the current thread to the given value. -}+setThreadAllocationCounter# :: Int64# -> State# (RealWorld) -> State# (RealWorld)+setThreadAllocationCounter# = setThreadAllocationCounter#++{-| Sets the allocation counter for the another thread to the given value.+     This doesn't take allocations into the current nursery chunk into account.+     Therefore it is only accurate if the other thread is not currently running. -}+setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# (RealWorld) -> State# (RealWorld)+setOtherThreadAllocationCounter# = setOtherThreadAllocationCounter#++{-| Haskell representation of a @StgStack*@ that was created (cloned)+     with a function in "GHC.Stack.CloneStack". Please check the+     documentation in that module for more detailed explanations. -}+data StackSnapshot#++{-| The function 'coerce' allows you to safely convert between values of+     types that have the same representation with no run-time overhead. In the+     simplest case you can use it instead of a newtype constructor, to go from+     the newtype's concrete type to the abstract type. But it also works in+     more complicated settings, e.g. converting a list of newtypes to a list of+     concrete types.++     When used in conversions involving a newtype wrapper,+     make sure the newtype constructor is in scope.++     This function is representation-polymorphic, but the+     'RuntimeRep' type argument is marked as 'Inferred', meaning+     that it is not available for visible type application. This means+     the typechecker will accept @'coerce' \@'Int' \@Age 42@.++     === __Examples__++     >>> newtype TTL = TTL Int deriving (Eq, Ord, Show)+     >>> newtype Age = Age Int deriving (Eq, Ord, Show)+     >>> coerce (Age 42) :: TTL+     TTL 42+     >>> coerce (+ (1 :: Int)) (Age 42) :: TTL+     TTL 43+     >>> coerce (map (+ (1 :: Int))) [Age 42, Age 24] :: [TTL]+     [TTL 43,TTL 25]++   -}+coerce :: Coercible a b => a -> b+coerce = coerce++data Int8X16#++data Int16X8#++data Int32X4#++data Int64X2#++data Int8X32#++data Int16X16#++data Int32X8#++data Int64X4#++data Int8X64#++data Int16X32#++data Int32X16#++data Int64X8#++data Word8X16#++data Word16X8#++data Word32X4#++data Word64X2#++data Word8X32#++data Word16X16#++data Word32X8#++data Word64X4#++data Word8X64#++data Word16X32#++data Word32X16#++data Word64X8#++data FloatX4#++data DoubleX2#++data FloatX8#++data DoubleX4#++data FloatX16#++data DoubleX8#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt8X16# :: Int8# -> Int8X16#+broadcastInt8X16# = broadcastInt8X16#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt16X8# :: Int16# -> Int16X8#+broadcastInt16X8# = broadcastInt16X8#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt32X4# :: Int32# -> Int32X4#+broadcastInt32X4# = broadcastInt32X4#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt64X2# :: Int64# -> Int64X2#+broadcastInt64X2# = broadcastInt64X2#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt8X32# :: Int8# -> Int8X32#+broadcastInt8X32# = broadcastInt8X32#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt16X16# :: Int16# -> Int16X16#+broadcastInt16X16# = broadcastInt16X16#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt32X8# :: Int32# -> Int32X8#+broadcastInt32X8# = broadcastInt32X8#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt64X4# :: Int64# -> Int64X4#+broadcastInt64X4# = broadcastInt64X4#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt8X64# :: Int8# -> Int8X64#+broadcastInt8X64# = broadcastInt8X64#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt16X32# :: Int16# -> Int16X32#+broadcastInt16X32# = broadcastInt16X32#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt32X16# :: Int32# -> Int32X16#+broadcastInt32X16# = broadcastInt32X16#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt64X8# :: Int64# -> Int64X8#+broadcastInt64X8# = broadcastInt64X8#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord8X16# :: Word8# -> Word8X16#+broadcastWord8X16# = broadcastWord8X16#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord16X8# :: Word16# -> Word16X8#+broadcastWord16X8# = broadcastWord16X8#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord32X4# :: Word32# -> Word32X4#+broadcastWord32X4# = broadcastWord32X4#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord64X2# :: Word64# -> Word64X2#+broadcastWord64X2# = broadcastWord64X2#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord8X32# :: Word8# -> Word8X32#+broadcastWord8X32# = broadcastWord8X32#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord16X16# :: Word16# -> Word16X16#+broadcastWord16X16# = broadcastWord16X16#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord32X8# :: Word32# -> Word32X8#+broadcastWord32X8# = broadcastWord32X8#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord64X4# :: Word64# -> Word64X4#+broadcastWord64X4# = broadcastWord64X4#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord8X64# :: Word8# -> Word8X64#+broadcastWord8X64# = broadcastWord8X64#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord16X32# :: Word16# -> Word16X32#+broadcastWord16X32# = broadcastWord16X32#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord32X16# :: Word32# -> Word32X16#+broadcastWord32X16# = broadcastWord32X16#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord64X8# :: Word64# -> Word64X8#+broadcastWord64X8# = broadcastWord64X8#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastFloatX4# :: Float# -> FloatX4#+broadcastFloatX4# = broadcastFloatX4#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastDoubleX2# :: Double# -> DoubleX2#+broadcastDoubleX2# = broadcastDoubleX2#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastFloatX8# :: Float# -> FloatX8#+broadcastFloatX8# = broadcastFloatX8#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastDoubleX4# :: Double# -> DoubleX4#+broadcastDoubleX4# = broadcastDoubleX4#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastFloatX16# :: Float# -> FloatX16#+broadcastFloatX16# = broadcastFloatX16#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastDoubleX8# :: Double# -> DoubleX8#+broadcastDoubleX8# = broadcastDoubleX8#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt8X16# :: (# Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8# #) -> Int8X16#+packInt8X16# = packInt8X16#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt16X8# :: (# Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16# #) -> Int16X8#+packInt16X8# = packInt16X8#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt32X4# :: (# Int32#,Int32#,Int32#,Int32# #) -> Int32X4#+packInt32X4# = packInt32X4#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt64X2# :: (# Int64#,Int64# #) -> Int64X2#+packInt64X2# = packInt64X2#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt8X32# :: (# Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8# #) -> Int8X32#+packInt8X32# = packInt8X32#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt16X16# :: (# Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16# #) -> Int16X16#+packInt16X16# = packInt16X16#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt32X8# :: (# Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32# #) -> Int32X8#+packInt32X8# = packInt32X8#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt64X4# :: (# Int64#,Int64#,Int64#,Int64# #) -> Int64X4#+packInt64X4# = packInt64X4#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt8X64# :: (# Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8# #) -> Int8X64#+packInt8X64# = packInt8X64#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt16X32# :: (# Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16# #) -> Int16X32#+packInt16X32# = packInt16X32#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt32X16# :: (# Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32# #) -> Int32X16#+packInt32X16# = packInt32X16#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt64X8# :: (# Int64#,Int64#,Int64#,Int64#,Int64#,Int64#,Int64#,Int64# #) -> Int64X8#+packInt64X8# = packInt64X8#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord8X16# :: (# Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8# #) -> Word8X16#+packWord8X16# = packWord8X16#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord16X8# :: (# Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16# #) -> Word16X8#+packWord16X8# = packWord16X8#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord32X4# :: (# Word32#,Word32#,Word32#,Word32# #) -> Word32X4#+packWord32X4# = packWord32X4#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord64X2# :: (# Word64#,Word64# #) -> Word64X2#+packWord64X2# = packWord64X2#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord8X32# :: (# Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8# #) -> Word8X32#+packWord8X32# = packWord8X32#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord16X16# :: (# Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16# #) -> Word16X16#+packWord16X16# = packWord16X16#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord32X8# :: (# Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32# #) -> Word32X8#+packWord32X8# = packWord32X8#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord64X4# :: (# Word64#,Word64#,Word64#,Word64# #) -> Word64X4#+packWord64X4# = packWord64X4#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord8X64# :: (# Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8# #) -> Word8X64#+packWord8X64# = packWord8X64#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord16X32# :: (# Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16# #) -> Word16X32#+packWord16X32# = packWord16X32#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord32X16# :: (# Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32# #) -> Word32X16#+packWord32X16# = packWord32X16#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord64X8# :: (# Word64#,Word64#,Word64#,Word64#,Word64#,Word64#,Word64#,Word64# #) -> Word64X8#+packWord64X8# = packWord64X8#++{-| Pack the elements of an unboxed tuple into a vector. -}+packFloatX4# :: (# Float#,Float#,Float#,Float# #) -> FloatX4#+packFloatX4# = packFloatX4#++{-| Pack the elements of an unboxed tuple into a vector. -}+packDoubleX2# :: (# Double#,Double# #) -> DoubleX2#+packDoubleX2# = packDoubleX2#++{-| Pack the elements of an unboxed tuple into a vector. -}+packFloatX8# :: (# Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float# #) -> FloatX8#+packFloatX8# = packFloatX8#++{-| Pack the elements of an unboxed tuple into a vector. -}+packDoubleX4# :: (# Double#,Double#,Double#,Double# #) -> DoubleX4#+packDoubleX4# = packDoubleX4#++{-| Pack the elements of an unboxed tuple into a vector. -}+packFloatX16# :: (# Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float# #) -> FloatX16#+packFloatX16# = packFloatX16#++{-| Pack the elements of an unboxed tuple into a vector. -}+packDoubleX8# :: (# Double#,Double#,Double#,Double#,Double#,Double#,Double#,Double# #) -> DoubleX8#+packDoubleX8# = packDoubleX8#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt8X16# :: Int8X16# -> (# Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8# #)+unpackInt8X16# = unpackInt8X16#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt16X8# :: Int16X8# -> (# Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16# #)+unpackInt16X8# = unpackInt16X8#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt32X4# :: Int32X4# -> (# Int32#,Int32#,Int32#,Int32# #)+unpackInt32X4# = unpackInt32X4#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt64X2# :: Int64X2# -> (# Int64#,Int64# #)+unpackInt64X2# = unpackInt64X2#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt8X32# :: Int8X32# -> (# Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8# #)+unpackInt8X32# = unpackInt8X32#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt16X16# :: Int16X16# -> (# Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16# #)+unpackInt16X16# = unpackInt16X16#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt32X8# :: Int32X8# -> (# Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32# #)+unpackInt32X8# = unpackInt32X8#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt64X4# :: Int64X4# -> (# Int64#,Int64#,Int64#,Int64# #)+unpackInt64X4# = unpackInt64X4#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt8X64# :: Int8X64# -> (# Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8# #)+unpackInt8X64# = unpackInt8X64#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt16X32# :: Int16X32# -> (# Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16# #)+unpackInt16X32# = unpackInt16X32#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt32X16# :: Int32X16# -> (# Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32# #)+unpackInt32X16# = unpackInt32X16#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt64X8# :: Int64X8# -> (# Int64#,Int64#,Int64#,Int64#,Int64#,Int64#,Int64#,Int64# #)+unpackInt64X8# = unpackInt64X8#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord8X16# :: Word8X16# -> (# Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8# #)+unpackWord8X16# = unpackWord8X16#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord16X8# :: Word16X8# -> (# Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16# #)+unpackWord16X8# = unpackWord16X8#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord32X4# :: Word32X4# -> (# Word32#,Word32#,Word32#,Word32# #)+unpackWord32X4# = unpackWord32X4#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord64X2# :: Word64X2# -> (# Word64#,Word64# #)+unpackWord64X2# = unpackWord64X2#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord8X32# :: Word8X32# -> (# Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8# #)+unpackWord8X32# = unpackWord8X32#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord16X16# :: Word16X16# -> (# Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16# #)+unpackWord16X16# = unpackWord16X16#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord32X8# :: Word32X8# -> (# Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32# #)+unpackWord32X8# = unpackWord32X8#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord64X4# :: Word64X4# -> (# Word64#,Word64#,Word64#,Word64# #)+unpackWord64X4# = unpackWord64X4#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord8X64# :: Word8X64# -> (# Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8# #)+unpackWord8X64# = unpackWord8X64#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord16X32# :: Word16X32# -> (# Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16# #)+unpackWord16X32# = unpackWord16X32#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord32X16# :: Word32X16# -> (# Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32# #)+unpackWord32X16# = unpackWord32X16#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord64X8# :: Word64X8# -> (# Word64#,Word64#,Word64#,Word64#,Word64#,Word64#,Word64#,Word64# #)+unpackWord64X8# = unpackWord64X8#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackFloatX4# :: FloatX4# -> (# Float#,Float#,Float#,Float# #)+unpackFloatX4# = unpackFloatX4#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackDoubleX2# :: DoubleX2# -> (# Double#,Double# #)+unpackDoubleX2# = unpackDoubleX2#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackFloatX8# :: FloatX8# -> (# Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float# #)+unpackFloatX8# = unpackFloatX8#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackDoubleX4# :: DoubleX4# -> (# Double#,Double#,Double#,Double# #)+unpackDoubleX4# = unpackDoubleX4#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackFloatX16# :: FloatX16# -> (# Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float# #)+unpackFloatX16# = unpackFloatX16#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackDoubleX8# :: DoubleX8# -> (# Double#,Double#,Double#,Double#,Double#,Double#,Double#,Double# #)+unpackDoubleX8# = unpackDoubleX8#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt8X16# :: Int8X16# -> Int8# -> Int# -> Int8X16#+insertInt8X16# = insertInt8X16#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt16X8# :: Int16X8# -> Int16# -> Int# -> Int16X8#+insertInt16X8# = insertInt16X8#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt32X4# :: Int32X4# -> Int32# -> Int# -> Int32X4#+insertInt32X4# = insertInt32X4#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt64X2# :: Int64X2# -> Int64# -> Int# -> Int64X2#+insertInt64X2# = insertInt64X2#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt8X32# :: Int8X32# -> Int8# -> Int# -> Int8X32#+insertInt8X32# = insertInt8X32#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt16X16# :: Int16X16# -> Int16# -> Int# -> Int16X16#+insertInt16X16# = insertInt16X16#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt32X8# :: Int32X8# -> Int32# -> Int# -> Int32X8#+insertInt32X8# = insertInt32X8#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt64X4# :: Int64X4# -> Int64# -> Int# -> Int64X4#+insertInt64X4# = insertInt64X4#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt8X64# :: Int8X64# -> Int8# -> Int# -> Int8X64#+insertInt8X64# = insertInt8X64#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt16X32# :: Int16X32# -> Int16# -> Int# -> Int16X32#+insertInt16X32# = insertInt16X32#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt32X16# :: Int32X16# -> Int32# -> Int# -> Int32X16#+insertInt32X16# = insertInt32X16#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt64X8# :: Int64X8# -> Int64# -> Int# -> Int64X8#+insertInt64X8# = insertInt64X8#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord8X16# :: Word8X16# -> Word8# -> Int# -> Word8X16#+insertWord8X16# = insertWord8X16#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord16X8# :: Word16X8# -> Word16# -> Int# -> Word16X8#+insertWord16X8# = insertWord16X8#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord32X4# :: Word32X4# -> Word32# -> Int# -> Word32X4#+insertWord32X4# = insertWord32X4#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord64X2# :: Word64X2# -> Word64# -> Int# -> Word64X2#+insertWord64X2# = insertWord64X2#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord8X32# :: Word8X32# -> Word8# -> Int# -> Word8X32#+insertWord8X32# = insertWord8X32#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord16X16# :: Word16X16# -> Word16# -> Int# -> Word16X16#+insertWord16X16# = insertWord16X16#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord32X8# :: Word32X8# -> Word32# -> Int# -> Word32X8#+insertWord32X8# = insertWord32X8#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord64X4# :: Word64X4# -> Word64# -> Int# -> Word64X4#+insertWord64X4# = insertWord64X4#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord8X64# :: Word8X64# -> Word8# -> Int# -> Word8X64#+insertWord8X64# = insertWord8X64#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord16X32# :: Word16X32# -> Word16# -> Int# -> Word16X32#+insertWord16X32# = insertWord16X32#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord32X16# :: Word32X16# -> Word32# -> Int# -> Word32X16#+insertWord32X16# = insertWord32X16#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord64X8# :: Word64X8# -> Word64# -> Int# -> Word64X8#+insertWord64X8# = insertWord64X8#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertFloatX4# :: FloatX4# -> Float# -> Int# -> FloatX4#+insertFloatX4# = insertFloatX4#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertDoubleX2# :: DoubleX2# -> Double# -> Int# -> DoubleX2#+insertDoubleX2# = insertDoubleX2#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertFloatX8# :: FloatX8# -> Float# -> Int# -> FloatX8#+insertFloatX8# = insertFloatX8#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertDoubleX4# :: DoubleX4# -> Double# -> Int# -> DoubleX4#+insertDoubleX4# = insertDoubleX4#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertFloatX16# :: FloatX16# -> Float# -> Int# -> FloatX16#+insertFloatX16# = insertFloatX16#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertDoubleX8# :: DoubleX8# -> Double# -> Int# -> DoubleX8#+insertDoubleX8# = insertDoubleX8#++{-| Add two vectors element-wise. -}+plusInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#+plusInt8X16# = plusInt8X16#++{-| Add two vectors element-wise. -}+plusInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#+plusInt16X8# = plusInt16X8#++{-| Add two vectors element-wise. -}+plusInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#+plusInt32X4# = plusInt32X4#++{-| Add two vectors element-wise. -}+plusInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#+plusInt64X2# = plusInt64X2#++{-| Add two vectors element-wise. -}+plusInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#+plusInt8X32# = plusInt8X32#++{-| Add two vectors element-wise. -}+plusInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#+plusInt16X16# = plusInt16X16#++{-| Add two vectors element-wise. -}+plusInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#+plusInt32X8# = plusInt32X8#++{-| Add two vectors element-wise. -}+plusInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#+plusInt64X4# = plusInt64X4#++{-| Add two vectors element-wise. -}+plusInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#+plusInt8X64# = plusInt8X64#++{-| Add two vectors element-wise. -}+plusInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#+plusInt16X32# = plusInt16X32#++{-| Add two vectors element-wise. -}+plusInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#+plusInt32X16# = plusInt32X16#++{-| Add two vectors element-wise. -}+plusInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#+plusInt64X8# = plusInt64X8#++{-| Add two vectors element-wise. -}+plusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#+plusWord8X16# = plusWord8X16#++{-| Add two vectors element-wise. -}+plusWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#+plusWord16X8# = plusWord16X8#++{-| Add two vectors element-wise. -}+plusWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#+plusWord32X4# = plusWord32X4#++{-| Add two vectors element-wise. -}+plusWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#+plusWord64X2# = plusWord64X2#++{-| Add two vectors element-wise. -}+plusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#+plusWord8X32# = plusWord8X32#++{-| Add two vectors element-wise. -}+plusWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#+plusWord16X16# = plusWord16X16#++{-| Add two vectors element-wise. -}+plusWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#+plusWord32X8# = plusWord32X8#++{-| Add two vectors element-wise. -}+plusWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#+plusWord64X4# = plusWord64X4#++{-| Add two vectors element-wise. -}+plusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#+plusWord8X64# = plusWord8X64#++{-| Add two vectors element-wise. -}+plusWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#+plusWord16X32# = plusWord16X32#++{-| Add two vectors element-wise. -}+plusWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#+plusWord32X16# = plusWord32X16#++{-| Add two vectors element-wise. -}+plusWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#+plusWord64X8# = plusWord64X8#++{-| Add two vectors element-wise. -}+plusFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#+plusFloatX4# = plusFloatX4#++{-| Add two vectors element-wise. -}+plusDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#+plusDoubleX2# = plusDoubleX2#++{-| Add two vectors element-wise. -}+plusFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#+plusFloatX8# = plusFloatX8#++{-| Add two vectors element-wise. -}+plusDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#+plusDoubleX4# = plusDoubleX4#++{-| Add two vectors element-wise. -}+plusFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#+plusFloatX16# = plusFloatX16#++{-| Add two vectors element-wise. -}+plusDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#+plusDoubleX8# = plusDoubleX8#++{-| Subtract two vectors element-wise. -}+minusInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#+minusInt8X16# = minusInt8X16#++{-| Subtract two vectors element-wise. -}+minusInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#+minusInt16X8# = minusInt16X8#++{-| Subtract two vectors element-wise. -}+minusInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#+minusInt32X4# = minusInt32X4#++{-| Subtract two vectors element-wise. -}+minusInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#+minusInt64X2# = minusInt64X2#++{-| Subtract two vectors element-wise. -}+minusInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#+minusInt8X32# = minusInt8X32#++{-| Subtract two vectors element-wise. -}+minusInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#+minusInt16X16# = minusInt16X16#++{-| Subtract two vectors element-wise. -}+minusInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#+minusInt32X8# = minusInt32X8#++{-| Subtract two vectors element-wise. -}+minusInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#+minusInt64X4# = minusInt64X4#++{-| Subtract two vectors element-wise. -}+minusInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#+minusInt8X64# = minusInt8X64#++{-| Subtract two vectors element-wise. -}+minusInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#+minusInt16X32# = minusInt16X32#++{-| Subtract two vectors element-wise. -}+minusInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#+minusInt32X16# = minusInt32X16#++{-| Subtract two vectors element-wise. -}+minusInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#+minusInt64X8# = minusInt64X8#++{-| Subtract two vectors element-wise. -}+minusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#+minusWord8X16# = minusWord8X16#++{-| Subtract two vectors element-wise. -}+minusWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#+minusWord16X8# = minusWord16X8#++{-| Subtract two vectors element-wise. -}+minusWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#+minusWord32X4# = minusWord32X4#++{-| Subtract two vectors element-wise. -}+minusWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#+minusWord64X2# = minusWord64X2#++{-| Subtract two vectors element-wise. -}+minusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#+minusWord8X32# = minusWord8X32#++{-| Subtract two vectors element-wise. -}+minusWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#+minusWord16X16# = minusWord16X16#++{-| Subtract two vectors element-wise. -}+minusWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#+minusWord32X8# = minusWord32X8#++{-| Subtract two vectors element-wise. -}+minusWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#+minusWord64X4# = minusWord64X4#++{-| Subtract two vectors element-wise. -}+minusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#+minusWord8X64# = minusWord8X64#++{-| Subtract two vectors element-wise. -}+minusWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#+minusWord16X32# = minusWord16X32#++{-| Subtract two vectors element-wise. -}+minusWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#+minusWord32X16# = minusWord32X16#++{-| Subtract two vectors element-wise. -}+minusWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#+minusWord64X8# = minusWord64X8#++{-| Subtract two vectors element-wise. -}+minusFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#+minusFloatX4# = minusFloatX4#++{-| Subtract two vectors element-wise. -}+minusDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#+minusDoubleX2# = minusDoubleX2#++{-| Subtract two vectors element-wise. -}+minusFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#+minusFloatX8# = minusFloatX8#++{-| Subtract two vectors element-wise. -}+minusDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#+minusDoubleX4# = minusDoubleX4#++{-| Subtract two vectors element-wise. -}+minusFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#+minusFloatX16# = minusFloatX16#++{-| Subtract two vectors element-wise. -}+minusDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#+minusDoubleX8# = minusDoubleX8#++{-| Multiply two vectors element-wise. -}+timesInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#+timesInt8X16# = timesInt8X16#++{-| Multiply two vectors element-wise. -}+timesInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#+timesInt16X8# = timesInt16X8#++{-| Multiply two vectors element-wise. -}+timesInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#+timesInt32X4# = timesInt32X4#++{-| Multiply two vectors element-wise. -}+timesInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#+timesInt64X2# = timesInt64X2#++{-| Multiply two vectors element-wise. -}+timesInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#+timesInt8X32# = timesInt8X32#++{-| Multiply two vectors element-wise. -}+timesInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#+timesInt16X16# = timesInt16X16#++{-| Multiply two vectors element-wise. -}+timesInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#+timesInt32X8# = timesInt32X8#++{-| Multiply two vectors element-wise. -}+timesInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#+timesInt64X4# = timesInt64X4#++{-| Multiply two vectors element-wise. -}+timesInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#+timesInt8X64# = timesInt8X64#++{-| Multiply two vectors element-wise. -}+timesInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#+timesInt16X32# = timesInt16X32#++{-| Multiply two vectors element-wise. -}+timesInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#+timesInt32X16# = timesInt32X16#++{-| Multiply two vectors element-wise. -}+timesInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#+timesInt64X8# = timesInt64X8#++{-| Multiply two vectors element-wise. -}+timesWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#+timesWord8X16# = timesWord8X16#++{-| Multiply two vectors element-wise. -}+timesWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#+timesWord16X8# = timesWord16X8#++{-| Multiply two vectors element-wise. -}+timesWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#+timesWord32X4# = timesWord32X4#++{-| Multiply two vectors element-wise. -}+timesWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#+timesWord64X2# = timesWord64X2#++{-| Multiply two vectors element-wise. -}+timesWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#+timesWord8X32# = timesWord8X32#++{-| Multiply two vectors element-wise. -}+timesWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#+timesWord16X16# = timesWord16X16#++{-| Multiply two vectors element-wise. -}+timesWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#+timesWord32X8# = timesWord32X8#++{-| Multiply two vectors element-wise. -}+timesWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#+timesWord64X4# = timesWord64X4#++{-| Multiply two vectors element-wise. -}+timesWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#+timesWord8X64# = timesWord8X64#++{-| Multiply two vectors element-wise. -}+timesWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#+timesWord16X32# = timesWord16X32#++{-| Multiply two vectors element-wise. -}+timesWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#+timesWord32X16# = timesWord32X16#++{-| Multiply two vectors element-wise. -}+timesWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#+timesWord64X8# = timesWord64X8#++{-| Multiply two vectors element-wise. -}+timesFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#+timesFloatX4# = timesFloatX4#++{-| Multiply two vectors element-wise. -}+timesDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#+timesDoubleX2# = timesDoubleX2#++{-| Multiply two vectors element-wise. -}+timesFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#+timesFloatX8# = timesFloatX8#++{-| Multiply two vectors element-wise. -}+timesDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#+timesDoubleX4# = timesDoubleX4#++{-| Multiply two vectors element-wise. -}+timesFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#+timesFloatX16# = timesFloatX16#++{-| Multiply two vectors element-wise. -}+timesDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#+timesDoubleX8# = timesDoubleX8#++{-| Divide two vectors element-wise. -}+divideFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#+divideFloatX4# = divideFloatX4#++{-| Divide two vectors element-wise. -}+divideDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#+divideDoubleX2# = divideDoubleX2#++{-| Divide two vectors element-wise. -}+divideFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#+divideFloatX8# = divideFloatX8#++{-| Divide two vectors element-wise. -}+divideDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#+divideDoubleX4# = divideDoubleX4#++{-| Divide two vectors element-wise. -}+divideFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#+divideFloatX16# = divideFloatX16#++{-| Divide two vectors element-wise. -}+divideDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#+divideDoubleX8# = divideDoubleX8#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#+quotInt8X16# = quotInt8X16#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#+quotInt16X8# = quotInt16X8#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#+quotInt32X4# = quotInt32X4#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#+quotInt64X2# = quotInt64X2#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#+quotInt8X32# = quotInt8X32#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#+quotInt16X16# = quotInt16X16#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#+quotInt32X8# = quotInt32X8#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#+quotInt64X4# = quotInt64X4#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#+quotInt8X64# = quotInt8X64#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#+quotInt16X32# = quotInt16X32#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#+quotInt32X16# = quotInt32X16#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#+quotInt64X8# = quotInt64X8#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#+quotWord8X16# = quotWord8X16#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#+quotWord16X8# = quotWord16X8#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#+quotWord32X4# = quotWord32X4#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#+quotWord64X2# = quotWord64X2#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#+quotWord8X32# = quotWord8X32#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#+quotWord16X16# = quotWord16X16#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#+quotWord32X8# = quotWord32X8#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#+quotWord64X4# = quotWord64X4#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#+quotWord8X64# = quotWord8X64#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#+quotWord16X32# = quotWord16X32#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#+quotWord32X16# = quotWord32X16#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#+quotWord64X8# = quotWord64X8#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#+remInt8X16# = remInt8X16#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#+remInt16X8# = remInt16X8#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#+remInt32X4# = remInt32X4#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#+remInt64X2# = remInt64X2#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#+remInt8X32# = remInt8X32#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#+remInt16X16# = remInt16X16#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#+remInt32X8# = remInt32X8#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#+remInt64X4# = remInt64X4#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#+remInt8X64# = remInt8X64#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#+remInt16X32# = remInt16X32#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#+remInt32X16# = remInt32X16#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#+remInt64X8# = remInt64X8#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#+remWord8X16# = remWord8X16#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#+remWord16X8# = remWord16X8#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#+remWord32X4# = remWord32X4#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#+remWord64X2# = remWord64X2#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#+remWord8X32# = remWord8X32#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#+remWord16X16# = remWord16X16#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#+remWord32X8# = remWord32X8#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#+remWord64X4# = remWord64X4#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#+remWord8X64# = remWord8X64#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#+remWord16X32# = remWord16X32#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#+remWord32X16# = remWord32X16#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#+remWord64X8# = remWord64X8#++{-| Negate element-wise. -}+negateInt8X16# :: Int8X16# -> Int8X16#+negateInt8X16# = negateInt8X16#++{-| Negate element-wise. -}+negateInt16X8# :: Int16X8# -> Int16X8#+negateInt16X8# = negateInt16X8#++{-| Negate element-wise. -}+negateInt32X4# :: Int32X4# -> Int32X4#+negateInt32X4# = negateInt32X4#++{-| Negate element-wise. -}+negateInt64X2# :: Int64X2# -> Int64X2#+negateInt64X2# = negateInt64X2#++{-| Negate element-wise. -}+negateInt8X32# :: Int8X32# -> Int8X32#+negateInt8X32# = negateInt8X32#++{-| Negate element-wise. -}+negateInt16X16# :: Int16X16# -> Int16X16#+negateInt16X16# = negateInt16X16#++{-| Negate element-wise. -}+negateInt32X8# :: Int32X8# -> Int32X8#+negateInt32X8# = negateInt32X8#++{-| Negate element-wise. -}+negateInt64X4# :: Int64X4# -> Int64X4#+negateInt64X4# = negateInt64X4#++{-| Negate element-wise. -}+negateInt8X64# :: Int8X64# -> Int8X64#+negateInt8X64# = negateInt8X64#++{-| Negate element-wise. -}+negateInt16X32# :: Int16X32# -> Int16X32#+negateInt16X32# = negateInt16X32#++{-| Negate element-wise. -}+negateInt32X16# :: Int32X16# -> Int32X16#+negateInt32X16# = negateInt32X16#++{-| Negate element-wise. -}+negateInt64X8# :: Int64X8# -> Int64X8#+negateInt64X8# = negateInt64X8#++{-| Negate element-wise. -}+negateFloatX4# :: FloatX4# -> FloatX4#+negateFloatX4# = negateFloatX4#++{-| Negate element-wise. -}+negateDoubleX2# :: DoubleX2# -> DoubleX2#+negateDoubleX2# = negateDoubleX2#++{-| Negate element-wise. -}+negateFloatX8# :: FloatX8# -> FloatX8#+negateFloatX8# = negateFloatX8#++{-| Negate element-wise. -}+negateDoubleX4# :: DoubleX4# -> DoubleX4#+negateDoubleX4# = negateDoubleX4#++{-| Negate element-wise. -}+negateFloatX16# :: FloatX16# -> FloatX16#+negateFloatX16# = negateFloatX16#++{-| Negate element-wise. -}+negateDoubleX8# :: DoubleX8# -> DoubleX8#+negateDoubleX8# = negateDoubleX8#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt8X16Array# :: ByteArray# -> Int# -> Int8X16#+indexInt8X16Array# = indexInt8X16Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt16X8Array# :: ByteArray# -> Int# -> Int16X8#+indexInt16X8Array# = indexInt16X8Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt32X4Array# :: ByteArray# -> Int# -> Int32X4#+indexInt32X4Array# = indexInt32X4Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt64X2Array# :: ByteArray# -> Int# -> Int64X2#+indexInt64X2Array# = indexInt64X2Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt8X32Array# :: ByteArray# -> Int# -> Int8X32#+indexInt8X32Array# = indexInt8X32Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt16X16Array# :: ByteArray# -> Int# -> Int16X16#+indexInt16X16Array# = indexInt16X16Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt32X8Array# :: ByteArray# -> Int# -> Int32X8#+indexInt32X8Array# = indexInt32X8Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt64X4Array# :: ByteArray# -> Int# -> Int64X4#+indexInt64X4Array# = indexInt64X4Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt8X64Array# :: ByteArray# -> Int# -> Int8X64#+indexInt8X64Array# = indexInt8X64Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt16X32Array# :: ByteArray# -> Int# -> Int16X32#+indexInt16X32Array# = indexInt16X32Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt32X16Array# :: ByteArray# -> Int# -> Int32X16#+indexInt32X16Array# = indexInt32X16Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt64X8Array# :: ByteArray# -> Int# -> Int64X8#+indexInt64X8Array# = indexInt64X8Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord8X16Array# :: ByteArray# -> Int# -> Word8X16#+indexWord8X16Array# = indexWord8X16Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord16X8Array# :: ByteArray# -> Int# -> Word16X8#+indexWord16X8Array# = indexWord16X8Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord32X4Array# :: ByteArray# -> Int# -> Word32X4#+indexWord32X4Array# = indexWord32X4Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord64X2Array# :: ByteArray# -> Int# -> Word64X2#+indexWord64X2Array# = indexWord64X2Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord8X32Array# :: ByteArray# -> Int# -> Word8X32#+indexWord8X32Array# = indexWord8X32Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord16X16Array# :: ByteArray# -> Int# -> Word16X16#+indexWord16X16Array# = indexWord16X16Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord32X8Array# :: ByteArray# -> Int# -> Word32X8#+indexWord32X8Array# = indexWord32X8Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord64X4Array# :: ByteArray# -> Int# -> Word64X4#+indexWord64X4Array# = indexWord64X4Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord8X64Array# :: ByteArray# -> Int# -> Word8X64#+indexWord8X64Array# = indexWord8X64Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord16X32Array# :: ByteArray# -> Int# -> Word16X32#+indexWord16X32Array# = indexWord16X32Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord32X16Array# :: ByteArray# -> Int# -> Word32X16#+indexWord32X16Array# = indexWord32X16Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord64X8Array# :: ByteArray# -> Int# -> Word64X8#+indexWord64X8Array# = indexWord64X8Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexFloatX4Array# :: ByteArray# -> Int# -> FloatX4#+indexFloatX4Array# = indexFloatX4Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexDoubleX2Array# :: ByteArray# -> Int# -> DoubleX2#+indexDoubleX2Array# = indexDoubleX2Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexFloatX8Array# :: ByteArray# -> Int# -> FloatX8#+indexFloatX8Array# = indexFloatX8Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexDoubleX4Array# :: ByteArray# -> Int# -> DoubleX4#+indexDoubleX4Array# = indexDoubleX4Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexFloatX16Array# :: ByteArray# -> Int# -> FloatX16#+indexFloatX16Array# = indexFloatX16Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexDoubleX8Array# :: ByteArray# -> Int# -> DoubleX8#+indexDoubleX8Array# = indexDoubleX8Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8X16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int8X16# #)+readInt8X16Array# = readInt8X16Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16X8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16X8# #)+readInt16X8Array# = readInt16X8Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32X4Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32X4# #)+readInt32X4Array# = readInt32X4Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64X2Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64X2# #)+readInt64X2Array# = readInt64X2Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8X32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int8X32# #)+readInt8X32Array# = readInt8X32Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16X16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16X16# #)+readInt16X16Array# = readInt16X16Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32X8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32X8# #)+readInt32X8Array# = readInt32X8Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64X4Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64X4# #)+readInt64X4Array# = readInt64X4Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8X64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int8X64# #)+readInt8X64Array# = readInt8X64Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16X32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16X32# #)+readInt16X32Array# = readInt16X32Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32X16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32X16# #)+readInt32X16Array# = readInt32X16Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64X8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64X8# #)+readInt64X8Array# = readInt64X8Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8X16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word8X16# #)+readWord8X16Array# = readWord8X16Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16X8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16X8# #)+readWord16X8Array# = readWord16X8Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32X4Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32X4# #)+readWord32X4Array# = readWord32X4Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64X2Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64X2# #)+readWord64X2Array# = readWord64X2Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8X32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word8X32# #)+readWord8X32Array# = readWord8X32Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16X16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16X16# #)+readWord16X16Array# = readWord16X16Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32X8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32X8# #)+readWord32X8Array# = readWord32X8Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64X4Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64X4# #)+readWord64X4Array# = readWord64X4Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8X64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word8X64# #)+readWord8X64Array# = readWord8X64Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16X32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16X32# #)+readWord16X32Array# = readWord16X32Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32X16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32X16# #)+readWord32X16Array# = readWord32X16Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64X8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64X8# #)+readWord64X8Array# = readWord64X8Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatX4Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,FloatX4# #)+readFloatX4Array# = readFloatX4Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleX2Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,DoubleX2# #)+readDoubleX2Array# = readDoubleX2Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatX8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,FloatX8# #)+readFloatX8Array# = readFloatX8Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleX4Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,DoubleX4# #)+readDoubleX4Array# = readDoubleX4Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatX16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,FloatX16# #)+readFloatX16Array# = readFloatX16Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleX8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,DoubleX8# #)+readDoubleX8Array# = readDoubleX8Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8X16Array# :: MutableByteArray# s -> Int# -> Int8X16# -> State# s -> State# s+writeInt8X16Array# = writeInt8X16Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16X8Array# :: MutableByteArray# s -> Int# -> Int16X8# -> State# s -> State# s+writeInt16X8Array# = writeInt16X8Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32X4Array# :: MutableByteArray# s -> Int# -> Int32X4# -> State# s -> State# s+writeInt32X4Array# = writeInt32X4Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64X2Array# :: MutableByteArray# s -> Int# -> Int64X2# -> State# s -> State# s+writeInt64X2Array# = writeInt64X2Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8X32Array# :: MutableByteArray# s -> Int# -> Int8X32# -> State# s -> State# s+writeInt8X32Array# = writeInt8X32Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16X16Array# :: MutableByteArray# s -> Int# -> Int16X16# -> State# s -> State# s+writeInt16X16Array# = writeInt16X16Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32X8Array# :: MutableByteArray# s -> Int# -> Int32X8# -> State# s -> State# s+writeInt32X8Array# = writeInt32X8Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64X4Array# :: MutableByteArray# s -> Int# -> Int64X4# -> State# s -> State# s+writeInt64X4Array# = writeInt64X4Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8X64Array# :: MutableByteArray# s -> Int# -> Int8X64# -> State# s -> State# s+writeInt8X64Array# = writeInt8X64Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16X32Array# :: MutableByteArray# s -> Int# -> Int16X32# -> State# s -> State# s+writeInt16X32Array# = writeInt16X32Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32X16Array# :: MutableByteArray# s -> Int# -> Int32X16# -> State# s -> State# s+writeInt32X16Array# = writeInt32X16Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64X8Array# :: MutableByteArray# s -> Int# -> Int64X8# -> State# s -> State# s+writeInt64X8Array# = writeInt64X8Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8X16Array# :: MutableByteArray# s -> Int# -> Word8X16# -> State# s -> State# s+writeWord8X16Array# = writeWord8X16Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16X8Array# :: MutableByteArray# s -> Int# -> Word16X8# -> State# s -> State# s+writeWord16X8Array# = writeWord16X8Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32X4Array# :: MutableByteArray# s -> Int# -> Word32X4# -> State# s -> State# s+writeWord32X4Array# = writeWord32X4Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64X2Array# :: MutableByteArray# s -> Int# -> Word64X2# -> State# s -> State# s+writeWord64X2Array# = writeWord64X2Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8X32Array# :: MutableByteArray# s -> Int# -> Word8X32# -> State# s -> State# s+writeWord8X32Array# = writeWord8X32Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16X16Array# :: MutableByteArray# s -> Int# -> Word16X16# -> State# s -> State# s+writeWord16X16Array# = writeWord16X16Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32X8Array# :: MutableByteArray# s -> Int# -> Word32X8# -> State# s -> State# s+writeWord32X8Array# = writeWord32X8Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64X4Array# :: MutableByteArray# s -> Int# -> Word64X4# -> State# s -> State# s+writeWord64X4Array# = writeWord64X4Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8X64Array# :: MutableByteArray# s -> Int# -> Word8X64# -> State# s -> State# s+writeWord8X64Array# = writeWord8X64Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16X32Array# :: MutableByteArray# s -> Int# -> Word16X32# -> State# s -> State# s+writeWord16X32Array# = writeWord16X32Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32X16Array# :: MutableByteArray# s -> Int# -> Word32X16# -> State# s -> State# s+writeWord32X16Array# = writeWord32X16Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64X8Array# :: MutableByteArray# s -> Int# -> Word64X8# -> State# s -> State# s+writeWord64X8Array# = writeWord64X8Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatX4Array# :: MutableByteArray# s -> Int# -> FloatX4# -> State# s -> State# s+writeFloatX4Array# = writeFloatX4Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleX2Array# :: MutableByteArray# s -> Int# -> DoubleX2# -> State# s -> State# s+writeDoubleX2Array# = writeDoubleX2Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatX8Array# :: MutableByteArray# s -> Int# -> FloatX8# -> State# s -> State# s+writeFloatX8Array# = writeFloatX8Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleX4Array# :: MutableByteArray# s -> Int# -> DoubleX4# -> State# s -> State# s+writeDoubleX4Array# = writeDoubleX4Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatX16Array# :: MutableByteArray# s -> Int# -> FloatX16# -> State# s -> State# s+writeFloatX16Array# = writeFloatX16Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleX8Array# :: MutableByteArray# s -> Int# -> DoubleX8# -> State# s -> State# s+writeDoubleX8Array# = writeDoubleX8Array#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt8X16OffAddr# :: Addr# -> Int# -> Int8X16#+indexInt8X16OffAddr# = indexInt8X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt16X8OffAddr# :: Addr# -> Int# -> Int16X8#+indexInt16X8OffAddr# = indexInt16X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt32X4OffAddr# :: Addr# -> Int# -> Int32X4#+indexInt32X4OffAddr# = indexInt32X4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt64X2OffAddr# :: Addr# -> Int# -> Int64X2#+indexInt64X2OffAddr# = indexInt64X2OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt8X32OffAddr# :: Addr# -> Int# -> Int8X32#+indexInt8X32OffAddr# = indexInt8X32OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt16X16OffAddr# :: Addr# -> Int# -> Int16X16#+indexInt16X16OffAddr# = indexInt16X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt32X8OffAddr# :: Addr# -> Int# -> Int32X8#+indexInt32X8OffAddr# = indexInt32X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt64X4OffAddr# :: Addr# -> Int# -> Int64X4#+indexInt64X4OffAddr# = indexInt64X4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt8X64OffAddr# :: Addr# -> Int# -> Int8X64#+indexInt8X64OffAddr# = indexInt8X64OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt16X32OffAddr# :: Addr# -> Int# -> Int16X32#+indexInt16X32OffAddr# = indexInt16X32OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt32X16OffAddr# :: Addr# -> Int# -> Int32X16#+indexInt32X16OffAddr# = indexInt32X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt64X8OffAddr# :: Addr# -> Int# -> Int64X8#+indexInt64X8OffAddr# = indexInt64X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord8X16OffAddr# :: Addr# -> Int# -> Word8X16#+indexWord8X16OffAddr# = indexWord8X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord16X8OffAddr# :: Addr# -> Int# -> Word16X8#+indexWord16X8OffAddr# = indexWord16X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord32X4OffAddr# :: Addr# -> Int# -> Word32X4#+indexWord32X4OffAddr# = indexWord32X4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord64X2OffAddr# :: Addr# -> Int# -> Word64X2#+indexWord64X2OffAddr# = indexWord64X2OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord8X32OffAddr# :: Addr# -> Int# -> Word8X32#+indexWord8X32OffAddr# = indexWord8X32OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord16X16OffAddr# :: Addr# -> Int# -> Word16X16#+indexWord16X16OffAddr# = indexWord16X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord32X8OffAddr# :: Addr# -> Int# -> Word32X8#+indexWord32X8OffAddr# = indexWord32X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord64X4OffAddr# :: Addr# -> Int# -> Word64X4#+indexWord64X4OffAddr# = indexWord64X4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord8X64OffAddr# :: Addr# -> Int# -> Word8X64#+indexWord8X64OffAddr# = indexWord8X64OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord16X32OffAddr# :: Addr# -> Int# -> Word16X32#+indexWord16X32OffAddr# = indexWord16X32OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord32X16OffAddr# :: Addr# -> Int# -> Word32X16#+indexWord32X16OffAddr# = indexWord32X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord64X8OffAddr# :: Addr# -> Int# -> Word64X8#+indexWord64X8OffAddr# = indexWord64X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexFloatX4OffAddr# :: Addr# -> Int# -> FloatX4#+indexFloatX4OffAddr# = indexFloatX4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexDoubleX2OffAddr# :: Addr# -> Int# -> DoubleX2#+indexDoubleX2OffAddr# = indexDoubleX2OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexFloatX8OffAddr# :: Addr# -> Int# -> FloatX8#+indexFloatX8OffAddr# = indexFloatX8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexDoubleX4OffAddr# :: Addr# -> Int# -> DoubleX4#+indexDoubleX4OffAddr# = indexDoubleX4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexFloatX16OffAddr# :: Addr# -> Int# -> FloatX16#+indexFloatX16OffAddr# = indexFloatX16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexDoubleX8OffAddr# :: Addr# -> Int# -> DoubleX8#+indexDoubleX8OffAddr# = indexDoubleX8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8X16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int8X16# #)+readInt8X16OffAddr# = readInt8X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16X8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int16X8# #)+readInt16X8OffAddr# = readInt16X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32X4OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int32X4# #)+readInt32X4OffAddr# = readInt32X4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64X2OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int64X2# #)+readInt64X2OffAddr# = readInt64X2OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8X32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int8X32# #)+readInt8X32OffAddr# = readInt8X32OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16X16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int16X16# #)+readInt16X16OffAddr# = readInt16X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32X8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int32X8# #)+readInt32X8OffAddr# = readInt32X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64X4OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int64X4# #)+readInt64X4OffAddr# = readInt64X4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8X64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int8X64# #)+readInt8X64OffAddr# = readInt8X64OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16X32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int16X32# #)+readInt16X32OffAddr# = readInt16X32OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32X16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int32X16# #)+readInt32X16OffAddr# = readInt32X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64X8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int64X8# #)+readInt64X8OffAddr# = readInt64X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8X16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word8X16# #)+readWord8X16OffAddr# = readWord8X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16X8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word16X8# #)+readWord16X8OffAddr# = readWord16X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32X4OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word32X4# #)+readWord32X4OffAddr# = readWord32X4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64X2OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word64X2# #)+readWord64X2OffAddr# = readWord64X2OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8X32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word8X32# #)+readWord8X32OffAddr# = readWord8X32OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16X16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word16X16# #)+readWord16X16OffAddr# = readWord16X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32X8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word32X8# #)+readWord32X8OffAddr# = readWord32X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64X4OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word64X4# #)+readWord64X4OffAddr# = readWord64X4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8X64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word8X64# #)+readWord8X64OffAddr# = readWord8X64OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16X32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word16X32# #)+readWord16X32OffAddr# = readWord16X32OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32X16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word32X16# #)+readWord32X16OffAddr# = readWord32X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64X8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word64X8# #)+readWord64X8OffAddr# = readWord64X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatX4OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,FloatX4# #)+readFloatX4OffAddr# = readFloatX4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleX2OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,DoubleX2# #)+readDoubleX2OffAddr# = readDoubleX2OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatX8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,FloatX8# #)+readFloatX8OffAddr# = readFloatX8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleX4OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,DoubleX4# #)+readDoubleX4OffAddr# = readDoubleX4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatX16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,FloatX16# #)+readFloatX16OffAddr# = readFloatX16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleX8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,DoubleX8# #)+readDoubleX8OffAddr# = readDoubleX8OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8X16OffAddr# :: Addr# -> Int# -> Int8X16# -> State# s -> State# s+writeInt8X16OffAddr# = writeInt8X16OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16X8OffAddr# :: Addr# -> Int# -> Int16X8# -> State# s -> State# s+writeInt16X8OffAddr# = writeInt16X8OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32X4OffAddr# :: Addr# -> Int# -> Int32X4# -> State# s -> State# s+writeInt32X4OffAddr# = writeInt32X4OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64X2OffAddr# :: Addr# -> Int# -> Int64X2# -> State# s -> State# s+writeInt64X2OffAddr# = writeInt64X2OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8X32OffAddr# :: Addr# -> Int# -> Int8X32# -> State# s -> State# s+writeInt8X32OffAddr# = writeInt8X32OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16X16OffAddr# :: Addr# -> Int# -> Int16X16# -> State# s -> State# s+writeInt16X16OffAddr# = writeInt16X16OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32X8OffAddr# :: Addr# -> Int# -> Int32X8# -> State# s -> State# s+writeInt32X8OffAddr# = writeInt32X8OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64X4OffAddr# :: Addr# -> Int# -> Int64X4# -> State# s -> State# s+writeInt64X4OffAddr# = writeInt64X4OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8X64OffAddr# :: Addr# -> Int# -> Int8X64# -> State# s -> State# s+writeInt8X64OffAddr# = writeInt8X64OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16X32OffAddr# :: Addr# -> Int# -> Int16X32# -> State# s -> State# s+writeInt16X32OffAddr# = writeInt16X32OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32X16OffAddr# :: Addr# -> Int# -> Int32X16# -> State# s -> State# s+writeInt32X16OffAddr# = writeInt32X16OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64X8OffAddr# :: Addr# -> Int# -> Int64X8# -> State# s -> State# s+writeInt64X8OffAddr# = writeInt64X8OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8X16OffAddr# :: Addr# -> Int# -> Word8X16# -> State# s -> State# s+writeWord8X16OffAddr# = writeWord8X16OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16X8OffAddr# :: Addr# -> Int# -> Word16X8# -> State# s -> State# s+writeWord16X8OffAddr# = writeWord16X8OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32X4OffAddr# :: Addr# -> Int# -> Word32X4# -> State# s -> State# s+writeWord32X4OffAddr# = writeWord32X4OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64X2OffAddr# :: Addr# -> Int# -> Word64X2# -> State# s -> State# s+writeWord64X2OffAddr# = writeWord64X2OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8X32OffAddr# :: Addr# -> Int# -> Word8X32# -> State# s -> State# s+writeWord8X32OffAddr# = writeWord8X32OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16X16OffAddr# :: Addr# -> Int# -> Word16X16# -> State# s -> State# s+writeWord16X16OffAddr# = writeWord16X16OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32X8OffAddr# :: Addr# -> Int# -> Word32X8# -> State# s -> State# s+writeWord32X8OffAddr# = writeWord32X8OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64X4OffAddr# :: Addr# -> Int# -> Word64X4# -> State# s -> State# s+writeWord64X4OffAddr# = writeWord64X4OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8X64OffAddr# :: Addr# -> Int# -> Word8X64# -> State# s -> State# s+writeWord8X64OffAddr# = writeWord8X64OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16X32OffAddr# :: Addr# -> Int# -> Word16X32# -> State# s -> State# s+writeWord16X32OffAddr# = writeWord16X32OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32X16OffAddr# :: Addr# -> Int# -> Word32X16# -> State# s -> State# s+writeWord32X16OffAddr# = writeWord32X16OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64X8OffAddr# :: Addr# -> Int# -> Word64X8# -> State# s -> State# s+writeWord64X8OffAddr# = writeWord64X8OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatX4OffAddr# :: Addr# -> Int# -> FloatX4# -> State# s -> State# s+writeFloatX4OffAddr# = writeFloatX4OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleX2OffAddr# :: Addr# -> Int# -> DoubleX2# -> State# s -> State# s+writeDoubleX2OffAddr# = writeDoubleX2OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatX8OffAddr# :: Addr# -> Int# -> FloatX8# -> State# s -> State# s+writeFloatX8OffAddr# = writeFloatX8OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleX4OffAddr# :: Addr# -> Int# -> DoubleX4# -> State# s -> State# s+writeDoubleX4OffAddr# = writeDoubleX4OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatX16OffAddr# :: Addr# -> Int# -> FloatX16# -> State# s -> State# s+writeFloatX16OffAddr# = writeFloatX16OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleX8OffAddr# :: Addr# -> Int# -> DoubleX8# -> State# s -> State# s+writeDoubleX8OffAddr# = writeDoubleX8OffAddr#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt8ArrayAsInt8X16# :: ByteArray# -> Int# -> Int8X16#+indexInt8ArrayAsInt8X16# = indexInt8ArrayAsInt8X16#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt16ArrayAsInt16X8# :: ByteArray# -> Int# -> Int16X8#+indexInt16ArrayAsInt16X8# = indexInt16ArrayAsInt16X8#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt32ArrayAsInt32X4# :: ByteArray# -> Int# -> Int32X4#+indexInt32ArrayAsInt32X4# = indexInt32ArrayAsInt32X4#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt64ArrayAsInt64X2# :: ByteArray# -> Int# -> Int64X2#+indexInt64ArrayAsInt64X2# = indexInt64ArrayAsInt64X2#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt8ArrayAsInt8X32# :: ByteArray# -> Int# -> Int8X32#+indexInt8ArrayAsInt8X32# = indexInt8ArrayAsInt8X32#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt16ArrayAsInt16X16# :: ByteArray# -> Int# -> Int16X16#+indexInt16ArrayAsInt16X16# = indexInt16ArrayAsInt16X16#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt32ArrayAsInt32X8# :: ByteArray# -> Int# -> Int32X8#+indexInt32ArrayAsInt32X8# = indexInt32ArrayAsInt32X8#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt64ArrayAsInt64X4# :: ByteArray# -> Int# -> Int64X4#+indexInt64ArrayAsInt64X4# = indexInt64ArrayAsInt64X4#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt8ArrayAsInt8X64# :: ByteArray# -> Int# -> Int8X64#+indexInt8ArrayAsInt8X64# = indexInt8ArrayAsInt8X64#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt16ArrayAsInt16X32# :: ByteArray# -> Int# -> Int16X32#+indexInt16ArrayAsInt16X32# = indexInt16ArrayAsInt16X32#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt32ArrayAsInt32X16# :: ByteArray# -> Int# -> Int32X16#+indexInt32ArrayAsInt32X16# = indexInt32ArrayAsInt32X16#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt64ArrayAsInt64X8# :: ByteArray# -> Int# -> Int64X8#+indexInt64ArrayAsInt64X8# = indexInt64ArrayAsInt64X8#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord8ArrayAsWord8X16# :: ByteArray# -> Int# -> Word8X16#+indexWord8ArrayAsWord8X16# = indexWord8ArrayAsWord8X16#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord16ArrayAsWord16X8# :: ByteArray# -> Int# -> Word16X8#+indexWord16ArrayAsWord16X8# = indexWord16ArrayAsWord16X8#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord32ArrayAsWord32X4# :: ByteArray# -> Int# -> Word32X4#+indexWord32ArrayAsWord32X4# = indexWord32ArrayAsWord32X4#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord64ArrayAsWord64X2# :: ByteArray# -> Int# -> Word64X2#+indexWord64ArrayAsWord64X2# = indexWord64ArrayAsWord64X2#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord8ArrayAsWord8X32# :: ByteArray# -> Int# -> Word8X32#+indexWord8ArrayAsWord8X32# = indexWord8ArrayAsWord8X32#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord16ArrayAsWord16X16# :: ByteArray# -> Int# -> Word16X16#+indexWord16ArrayAsWord16X16# = indexWord16ArrayAsWord16X16#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord32ArrayAsWord32X8# :: ByteArray# -> Int# -> Word32X8#+indexWord32ArrayAsWord32X8# = indexWord32ArrayAsWord32X8#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord64ArrayAsWord64X4# :: ByteArray# -> Int# -> Word64X4#+indexWord64ArrayAsWord64X4# = indexWord64ArrayAsWord64X4#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord8ArrayAsWord8X64# :: ByteArray# -> Int# -> Word8X64#+indexWord8ArrayAsWord8X64# = indexWord8ArrayAsWord8X64#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord16ArrayAsWord16X32# :: ByteArray# -> Int# -> Word16X32#+indexWord16ArrayAsWord16X32# = indexWord16ArrayAsWord16X32#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord32ArrayAsWord32X16# :: ByteArray# -> Int# -> Word32X16#+indexWord32ArrayAsWord32X16# = indexWord32ArrayAsWord32X16#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord64ArrayAsWord64X8# :: ByteArray# -> Int# -> Word64X8#+indexWord64ArrayAsWord64X8# = indexWord64ArrayAsWord64X8#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexFloatArrayAsFloatX4# :: ByteArray# -> Int# -> FloatX4#+indexFloatArrayAsFloatX4# = indexFloatArrayAsFloatX4#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexDoubleArrayAsDoubleX2# :: ByteArray# -> Int# -> DoubleX2#+indexDoubleArrayAsDoubleX2# = indexDoubleArrayAsDoubleX2#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexFloatArrayAsFloatX8# :: ByteArray# -> Int# -> FloatX8#+indexFloatArrayAsFloatX8# = indexFloatArrayAsFloatX8#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexDoubleArrayAsDoubleX4# :: ByteArray# -> Int# -> DoubleX4#+indexDoubleArrayAsDoubleX4# = indexDoubleArrayAsDoubleX4#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexFloatArrayAsFloatX16# :: ByteArray# -> Int# -> FloatX16#+indexFloatArrayAsFloatX16# = indexFloatArrayAsFloatX16#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexDoubleArrayAsDoubleX8# :: ByteArray# -> Int# -> DoubleX8#+indexDoubleArrayAsDoubleX8# = indexDoubleArrayAsDoubleX8#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8ArrayAsInt8X16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int8X16# #)+readInt8ArrayAsInt8X16# = readInt8ArrayAsInt8X16#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16ArrayAsInt16X8# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16X8# #)+readInt16ArrayAsInt16X8# = readInt16ArrayAsInt16X8#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32ArrayAsInt32X4# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32X4# #)+readInt32ArrayAsInt32X4# = readInt32ArrayAsInt32X4#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64ArrayAsInt64X2# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64X2# #)+readInt64ArrayAsInt64X2# = readInt64ArrayAsInt64X2#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8ArrayAsInt8X32# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int8X32# #)+readInt8ArrayAsInt8X32# = readInt8ArrayAsInt8X32#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16ArrayAsInt16X16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16X16# #)+readInt16ArrayAsInt16X16# = readInt16ArrayAsInt16X16#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32ArrayAsInt32X8# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32X8# #)+readInt32ArrayAsInt32X8# = readInt32ArrayAsInt32X8#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64ArrayAsInt64X4# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64X4# #)+readInt64ArrayAsInt64X4# = readInt64ArrayAsInt64X4#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8ArrayAsInt8X64# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int8X64# #)+readInt8ArrayAsInt8X64# = readInt8ArrayAsInt8X64#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16ArrayAsInt16X32# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16X32# #)+readInt16ArrayAsInt16X32# = readInt16ArrayAsInt16X32#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32ArrayAsInt32X16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32X16# #)+readInt32ArrayAsInt32X16# = readInt32ArrayAsInt32X16#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64ArrayAsInt64X8# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64X8# #)+readInt64ArrayAsInt64X8# = readInt64ArrayAsInt64X8#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsWord8X16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word8X16# #)+readWord8ArrayAsWord8X16# = readWord8ArrayAsWord8X16#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16ArrayAsWord16X8# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16X8# #)+readWord16ArrayAsWord16X8# = readWord16ArrayAsWord16X8#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32ArrayAsWord32X4# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32X4# #)+readWord32ArrayAsWord32X4# = readWord32ArrayAsWord32X4#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64ArrayAsWord64X2# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64X2# #)+readWord64ArrayAsWord64X2# = readWord64ArrayAsWord64X2#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsWord8X32# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word8X32# #)+readWord8ArrayAsWord8X32# = readWord8ArrayAsWord8X32#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16ArrayAsWord16X16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16X16# #)+readWord16ArrayAsWord16X16# = readWord16ArrayAsWord16X16#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32ArrayAsWord32X8# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32X8# #)+readWord32ArrayAsWord32X8# = readWord32ArrayAsWord32X8#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64ArrayAsWord64X4# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64X4# #)+readWord64ArrayAsWord64X4# = readWord64ArrayAsWord64X4#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsWord8X64# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word8X64# #)+readWord8ArrayAsWord8X64# = readWord8ArrayAsWord8X64#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16ArrayAsWord16X32# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16X32# #)+readWord16ArrayAsWord16X32# = readWord16ArrayAsWord16X32#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32ArrayAsWord32X16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32X16# #)+readWord32ArrayAsWord32X16# = readWord32ArrayAsWord32X16#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64ArrayAsWord64X8# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64X8# #)+readWord64ArrayAsWord64X8# = readWord64ArrayAsWord64X8#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatArrayAsFloatX4# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,FloatX4# #)+readFloatArrayAsFloatX4# = readFloatArrayAsFloatX4#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleArrayAsDoubleX2# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,DoubleX2# #)+readDoubleArrayAsDoubleX2# = readDoubleArrayAsDoubleX2#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatArrayAsFloatX8# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,FloatX8# #)+readFloatArrayAsFloatX8# = readFloatArrayAsFloatX8#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleArrayAsDoubleX4# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,DoubleX4# #)+readDoubleArrayAsDoubleX4# = readDoubleArrayAsDoubleX4#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatArrayAsFloatX16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,FloatX16# #)+readFloatArrayAsFloatX16# = readFloatArrayAsFloatX16#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleArrayAsDoubleX8# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,DoubleX8# #)+readDoubleArrayAsDoubleX8# = readDoubleArrayAsDoubleX8#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8ArrayAsInt8X16# :: MutableByteArray# s -> Int# -> Int8X16# -> State# s -> State# s+writeInt8ArrayAsInt8X16# = writeInt8ArrayAsInt8X16#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16ArrayAsInt16X8# :: MutableByteArray# s -> Int# -> Int16X8# -> State# s -> State# s+writeInt16ArrayAsInt16X8# = writeInt16ArrayAsInt16X8#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32ArrayAsInt32X4# :: MutableByteArray# s -> Int# -> Int32X4# -> State# s -> State# s+writeInt32ArrayAsInt32X4# = writeInt32ArrayAsInt32X4#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64ArrayAsInt64X2# :: MutableByteArray# s -> Int# -> Int64X2# -> State# s -> State# s+writeInt64ArrayAsInt64X2# = writeInt64ArrayAsInt64X2#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8ArrayAsInt8X32# :: MutableByteArray# s -> Int# -> Int8X32# -> State# s -> State# s+writeInt8ArrayAsInt8X32# = writeInt8ArrayAsInt8X32#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16ArrayAsInt16X16# :: MutableByteArray# s -> Int# -> Int16X16# -> State# s -> State# s+writeInt16ArrayAsInt16X16# = writeInt16ArrayAsInt16X16#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32ArrayAsInt32X8# :: MutableByteArray# s -> Int# -> Int32X8# -> State# s -> State# s+writeInt32ArrayAsInt32X8# = writeInt32ArrayAsInt32X8#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64ArrayAsInt64X4# :: MutableByteArray# s -> Int# -> Int64X4# -> State# s -> State# s+writeInt64ArrayAsInt64X4# = writeInt64ArrayAsInt64X4#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8ArrayAsInt8X64# :: MutableByteArray# s -> Int# -> Int8X64# -> State# s -> State# s+writeInt8ArrayAsInt8X64# = writeInt8ArrayAsInt8X64#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16ArrayAsInt16X32# :: MutableByteArray# s -> Int# -> Int16X32# -> State# s -> State# s+writeInt16ArrayAsInt16X32# = writeInt16ArrayAsInt16X32#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32ArrayAsInt32X16# :: MutableByteArray# s -> Int# -> Int32X16# -> State# s -> State# s+writeInt32ArrayAsInt32X16# = writeInt32ArrayAsInt32X16#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64ArrayAsInt64X8# :: MutableByteArray# s -> Int# -> Int64X8# -> State# s -> State# s+writeInt64ArrayAsInt64X8# = writeInt64ArrayAsInt64X8#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsWord8X16# :: MutableByteArray# s -> Int# -> Word8X16# -> State# s -> State# s+writeWord8ArrayAsWord8X16# = writeWord8ArrayAsWord8X16#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16ArrayAsWord16X8# :: MutableByteArray# s -> Int# -> Word16X8# -> State# s -> State# s+writeWord16ArrayAsWord16X8# = writeWord16ArrayAsWord16X8#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32ArrayAsWord32X4# :: MutableByteArray# s -> Int# -> Word32X4# -> State# s -> State# s+writeWord32ArrayAsWord32X4# = writeWord32ArrayAsWord32X4#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64ArrayAsWord64X2# :: MutableByteArray# s -> Int# -> Word64X2# -> State# s -> State# s+writeWord64ArrayAsWord64X2# = writeWord64ArrayAsWord64X2#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsWord8X32# :: MutableByteArray# s -> Int# -> Word8X32# -> State# s -> State# s+writeWord8ArrayAsWord8X32# = writeWord8ArrayAsWord8X32#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16ArrayAsWord16X16# :: MutableByteArray# s -> Int# -> Word16X16# -> State# s -> State# s+writeWord16ArrayAsWord16X16# = writeWord16ArrayAsWord16X16#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32ArrayAsWord32X8# :: MutableByteArray# s -> Int# -> Word32X8# -> State# s -> State# s+writeWord32ArrayAsWord32X8# = writeWord32ArrayAsWord32X8#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64ArrayAsWord64X4# :: MutableByteArray# s -> Int# -> Word64X4# -> State# s -> State# s+writeWord64ArrayAsWord64X4# = writeWord64ArrayAsWord64X4#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsWord8X64# :: MutableByteArray# s -> Int# -> Word8X64# -> State# s -> State# s+writeWord8ArrayAsWord8X64# = writeWord8ArrayAsWord8X64#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16ArrayAsWord16X32# :: MutableByteArray# s -> Int# -> Word16X32# -> State# s -> State# s+writeWord16ArrayAsWord16X32# = writeWord16ArrayAsWord16X32#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32ArrayAsWord32X16# :: MutableByteArray# s -> Int# -> Word32X16# -> State# s -> State# s+writeWord32ArrayAsWord32X16# = writeWord32ArrayAsWord32X16#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64ArrayAsWord64X8# :: MutableByteArray# s -> Int# -> Word64X8# -> State# s -> State# s+writeWord64ArrayAsWord64X8# = writeWord64ArrayAsWord64X8#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatArrayAsFloatX4# :: MutableByteArray# s -> Int# -> FloatX4# -> State# s -> State# s+writeFloatArrayAsFloatX4# = writeFloatArrayAsFloatX4#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleArrayAsDoubleX2# :: MutableByteArray# s -> Int# -> DoubleX2# -> State# s -> State# s+writeDoubleArrayAsDoubleX2# = writeDoubleArrayAsDoubleX2#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatArrayAsFloatX8# :: MutableByteArray# s -> Int# -> FloatX8# -> State# s -> State# s+writeFloatArrayAsFloatX8# = writeFloatArrayAsFloatX8#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleArrayAsDoubleX4# :: MutableByteArray# s -> Int# -> DoubleX4# -> State# s -> State# s+writeDoubleArrayAsDoubleX4# = writeDoubleArrayAsDoubleX4#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatArrayAsFloatX16# :: MutableByteArray# s -> Int# -> FloatX16# -> State# s -> State# s+writeFloatArrayAsFloatX16# = writeFloatArrayAsFloatX16#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleArrayAsDoubleX8# :: MutableByteArray# s -> Int# -> DoubleX8# -> State# s -> State# s+writeDoubleArrayAsDoubleX8# = writeDoubleArrayAsDoubleX8#++{-| Reads vector; offset in scalar elements. -}+indexInt8OffAddrAsInt8X16# :: Addr# -> Int# -> Int8X16#+indexInt8OffAddrAsInt8X16# = indexInt8OffAddrAsInt8X16#++{-| Reads vector; offset in scalar elements. -}+indexInt16OffAddrAsInt16X8# :: Addr# -> Int# -> Int16X8#+indexInt16OffAddrAsInt16X8# = indexInt16OffAddrAsInt16X8#++{-| Reads vector; offset in scalar elements. -}+indexInt32OffAddrAsInt32X4# :: Addr# -> Int# -> Int32X4#+indexInt32OffAddrAsInt32X4# = indexInt32OffAddrAsInt32X4#++{-| Reads vector; offset in scalar elements. -}+indexInt64OffAddrAsInt64X2# :: Addr# -> Int# -> Int64X2#+indexInt64OffAddrAsInt64X2# = indexInt64OffAddrAsInt64X2#++{-| Reads vector; offset in scalar elements. -}+indexInt8OffAddrAsInt8X32# :: Addr# -> Int# -> Int8X32#+indexInt8OffAddrAsInt8X32# = indexInt8OffAddrAsInt8X32#++{-| Reads vector; offset in scalar elements. -}+indexInt16OffAddrAsInt16X16# :: Addr# -> Int# -> Int16X16#+indexInt16OffAddrAsInt16X16# = indexInt16OffAddrAsInt16X16#++{-| Reads vector; offset in scalar elements. -}+indexInt32OffAddrAsInt32X8# :: Addr# -> Int# -> Int32X8#+indexInt32OffAddrAsInt32X8# = indexInt32OffAddrAsInt32X8#++{-| Reads vector; offset in scalar elements. -}+indexInt64OffAddrAsInt64X4# :: Addr# -> Int# -> Int64X4#+indexInt64OffAddrAsInt64X4# = indexInt64OffAddrAsInt64X4#++{-| Reads vector; offset in scalar elements. -}+indexInt8OffAddrAsInt8X64# :: Addr# -> Int# -> Int8X64#+indexInt8OffAddrAsInt8X64# = indexInt8OffAddrAsInt8X64#++{-| Reads vector; offset in scalar elements. -}+indexInt16OffAddrAsInt16X32# :: Addr# -> Int# -> Int16X32#+indexInt16OffAddrAsInt16X32# = indexInt16OffAddrAsInt16X32#++{-| Reads vector; offset in scalar elements. -}+indexInt32OffAddrAsInt32X16# :: Addr# -> Int# -> Int32X16#+indexInt32OffAddrAsInt32X16# = indexInt32OffAddrAsInt32X16#++{-| Reads vector; offset in scalar elements. -}+indexInt64OffAddrAsInt64X8# :: Addr# -> Int# -> Int64X8#+indexInt64OffAddrAsInt64X8# = indexInt64OffAddrAsInt64X8#++{-| Reads vector; offset in scalar elements. -}+indexWord8OffAddrAsWord8X16# :: Addr# -> Int# -> Word8X16#+indexWord8OffAddrAsWord8X16# = indexWord8OffAddrAsWord8X16#++{-| Reads vector; offset in scalar elements. -}+indexWord16OffAddrAsWord16X8# :: Addr# -> Int# -> Word16X8#+indexWord16OffAddrAsWord16X8# = indexWord16OffAddrAsWord16X8#++{-| Reads vector; offset in scalar elements. -}+indexWord32OffAddrAsWord32X4# :: Addr# -> Int# -> Word32X4#+indexWord32OffAddrAsWord32X4# = indexWord32OffAddrAsWord32X4#++{-| Reads vector; offset in scalar elements. -}+indexWord64OffAddrAsWord64X2# :: Addr# -> Int# -> Word64X2#+indexWord64OffAddrAsWord64X2# = indexWord64OffAddrAsWord64X2#++{-| Reads vector; offset in scalar elements. -}+indexWord8OffAddrAsWord8X32# :: Addr# -> Int# -> Word8X32#+indexWord8OffAddrAsWord8X32# = indexWord8OffAddrAsWord8X32#++{-| Reads vector; offset in scalar elements. -}+indexWord16OffAddrAsWord16X16# :: Addr# -> Int# -> Word16X16#+indexWord16OffAddrAsWord16X16# = indexWord16OffAddrAsWord16X16#++{-| Reads vector; offset in scalar elements. -}+indexWord32OffAddrAsWord32X8# :: Addr# -> Int# -> Word32X8#+indexWord32OffAddrAsWord32X8# = indexWord32OffAddrAsWord32X8#++{-| Reads vector; offset in scalar elements. -}+indexWord64OffAddrAsWord64X4# :: Addr# -> Int# -> Word64X4#+indexWord64OffAddrAsWord64X4# = indexWord64OffAddrAsWord64X4#++{-| Reads vector; offset in scalar elements. -}+indexWord8OffAddrAsWord8X64# :: Addr# -> Int# -> Word8X64#+indexWord8OffAddrAsWord8X64# = indexWord8OffAddrAsWord8X64#++{-| Reads vector; offset in scalar elements. -}+indexWord16OffAddrAsWord16X32# :: Addr# -> Int# -> Word16X32#+indexWord16OffAddrAsWord16X32# = indexWord16OffAddrAsWord16X32#++{-| Reads vector; offset in scalar elements. -}+indexWord32OffAddrAsWord32X16# :: Addr# -> Int# -> Word32X16#+indexWord32OffAddrAsWord32X16# = indexWord32OffAddrAsWord32X16#++{-| Reads vector; offset in scalar elements. -}+indexWord64OffAddrAsWord64X8# :: Addr# -> Int# -> Word64X8#+indexWord64OffAddrAsWord64X8# = indexWord64OffAddrAsWord64X8#++{-| Reads vector; offset in scalar elements. -}+indexFloatOffAddrAsFloatX4# :: Addr# -> Int# -> FloatX4#+indexFloatOffAddrAsFloatX4# = indexFloatOffAddrAsFloatX4#++{-| Reads vector; offset in scalar elements. -}+indexDoubleOffAddrAsDoubleX2# :: Addr# -> Int# -> DoubleX2#+indexDoubleOffAddrAsDoubleX2# = indexDoubleOffAddrAsDoubleX2#++{-| Reads vector; offset in scalar elements. -}+indexFloatOffAddrAsFloatX8# :: Addr# -> Int# -> FloatX8#+indexFloatOffAddrAsFloatX8# = indexFloatOffAddrAsFloatX8#++{-| Reads vector; offset in scalar elements. -}+indexDoubleOffAddrAsDoubleX4# :: Addr# -> Int# -> DoubleX4#+indexDoubleOffAddrAsDoubleX4# = indexDoubleOffAddrAsDoubleX4#++{-| Reads vector; offset in scalar elements. -}+indexFloatOffAddrAsFloatX16# :: Addr# -> Int# -> FloatX16#+indexFloatOffAddrAsFloatX16# = indexFloatOffAddrAsFloatX16#++{-| Reads vector; offset in scalar elements. -}+indexDoubleOffAddrAsDoubleX8# :: Addr# -> Int# -> DoubleX8#+indexDoubleOffAddrAsDoubleX8# = indexDoubleOffAddrAsDoubleX8#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8OffAddrAsInt8X16# :: Addr# -> Int# -> State# s -> (# State# s,Int8X16# #)+readInt8OffAddrAsInt8X16# = readInt8OffAddrAsInt8X16#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16OffAddrAsInt16X8# :: Addr# -> Int# -> State# s -> (# State# s,Int16X8# #)+readInt16OffAddrAsInt16X8# = readInt16OffAddrAsInt16X8#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32OffAddrAsInt32X4# :: Addr# -> Int# -> State# s -> (# State# s,Int32X4# #)+readInt32OffAddrAsInt32X4# = readInt32OffAddrAsInt32X4#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64OffAddrAsInt64X2# :: Addr# -> Int# -> State# s -> (# State# s,Int64X2# #)+readInt64OffAddrAsInt64X2# = readInt64OffAddrAsInt64X2#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8OffAddrAsInt8X32# :: Addr# -> Int# -> State# s -> (# State# s,Int8X32# #)+readInt8OffAddrAsInt8X32# = readInt8OffAddrAsInt8X32#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16OffAddrAsInt16X16# :: Addr# -> Int# -> State# s -> (# State# s,Int16X16# #)+readInt16OffAddrAsInt16X16# = readInt16OffAddrAsInt16X16#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32OffAddrAsInt32X8# :: Addr# -> Int# -> State# s -> (# State# s,Int32X8# #)+readInt32OffAddrAsInt32X8# = readInt32OffAddrAsInt32X8#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64OffAddrAsInt64X4# :: Addr# -> Int# -> State# s -> (# State# s,Int64X4# #)+readInt64OffAddrAsInt64X4# = readInt64OffAddrAsInt64X4#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8OffAddrAsInt8X64# :: Addr# -> Int# -> State# s -> (# State# s,Int8X64# #)+readInt8OffAddrAsInt8X64# = readInt8OffAddrAsInt8X64#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16OffAddrAsInt16X32# :: Addr# -> Int# -> State# s -> (# State# s,Int16X32# #)+readInt16OffAddrAsInt16X32# = readInt16OffAddrAsInt16X32#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32OffAddrAsInt32X16# :: Addr# -> Int# -> State# s -> (# State# s,Int32X16# #)+readInt32OffAddrAsInt32X16# = readInt32OffAddrAsInt32X16#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64OffAddrAsInt64X8# :: Addr# -> Int# -> State# s -> (# State# s,Int64X8# #)+readInt64OffAddrAsInt64X8# = readInt64OffAddrAsInt64X8#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsWord8X16# :: Addr# -> Int# -> State# s -> (# State# s,Word8X16# #)+readWord8OffAddrAsWord8X16# = readWord8OffAddrAsWord8X16#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16OffAddrAsWord16X8# :: Addr# -> Int# -> State# s -> (# State# s,Word16X8# #)+readWord16OffAddrAsWord16X8# = readWord16OffAddrAsWord16X8#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32OffAddrAsWord32X4# :: Addr# -> Int# -> State# s -> (# State# s,Word32X4# #)+readWord32OffAddrAsWord32X4# = readWord32OffAddrAsWord32X4#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64OffAddrAsWord64X2# :: Addr# -> Int# -> State# s -> (# State# s,Word64X2# #)+readWord64OffAddrAsWord64X2# = readWord64OffAddrAsWord64X2#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsWord8X32# :: Addr# -> Int# -> State# s -> (# State# s,Word8X32# #)+readWord8OffAddrAsWord8X32# = readWord8OffAddrAsWord8X32#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16OffAddrAsWord16X16# :: Addr# -> Int# -> State# s -> (# State# s,Word16X16# #)+readWord16OffAddrAsWord16X16# = readWord16OffAddrAsWord16X16#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32OffAddrAsWord32X8# :: Addr# -> Int# -> State# s -> (# State# s,Word32X8# #)+readWord32OffAddrAsWord32X8# = readWord32OffAddrAsWord32X8#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64OffAddrAsWord64X4# :: Addr# -> Int# -> State# s -> (# State# s,Word64X4# #)+readWord64OffAddrAsWord64X4# = readWord64OffAddrAsWord64X4#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsWord8X64# :: Addr# -> Int# -> State# s -> (# State# s,Word8X64# #)+readWord8OffAddrAsWord8X64# = readWord8OffAddrAsWord8X64#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16OffAddrAsWord16X32# :: Addr# -> Int# -> State# s -> (# State# s,Word16X32# #)+readWord16OffAddrAsWord16X32# = readWord16OffAddrAsWord16X32#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32OffAddrAsWord32X16# :: Addr# -> Int# -> State# s -> (# State# s,Word32X16# #)+readWord32OffAddrAsWord32X16# = readWord32OffAddrAsWord32X16#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64OffAddrAsWord64X8# :: Addr# -> Int# -> State# s -> (# State# s,Word64X8# #)+readWord64OffAddrAsWord64X8# = readWord64OffAddrAsWord64X8#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatOffAddrAsFloatX4# :: Addr# -> Int# -> State# s -> (# State# s,FloatX4# #)+readFloatOffAddrAsFloatX4# = readFloatOffAddrAsFloatX4#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleOffAddrAsDoubleX2# :: Addr# -> Int# -> State# s -> (# State# s,DoubleX2# #)+readDoubleOffAddrAsDoubleX2# = readDoubleOffAddrAsDoubleX2#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatOffAddrAsFloatX8# :: Addr# -> Int# -> State# s -> (# State# s,FloatX8# #)+readFloatOffAddrAsFloatX8# = readFloatOffAddrAsFloatX8#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleOffAddrAsDoubleX4# :: Addr# -> Int# -> State# s -> (# State# s,DoubleX4# #)+readDoubleOffAddrAsDoubleX4# = readDoubleOffAddrAsDoubleX4#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatOffAddrAsFloatX16# :: Addr# -> Int# -> State# s -> (# State# s,FloatX16# #)+readFloatOffAddrAsFloatX16# = readFloatOffAddrAsFloatX16#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleOffAddrAsDoubleX8# :: Addr# -> Int# -> State# s -> (# State# s,DoubleX8# #)+readDoubleOffAddrAsDoubleX8# = readDoubleOffAddrAsDoubleX8#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8OffAddrAsInt8X16# :: Addr# -> Int# -> Int8X16# -> State# s -> State# s+writeInt8OffAddrAsInt8X16# = writeInt8OffAddrAsInt8X16#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16OffAddrAsInt16X8# :: Addr# -> Int# -> Int16X8# -> State# s -> State# s+writeInt16OffAddrAsInt16X8# = writeInt16OffAddrAsInt16X8#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32OffAddrAsInt32X4# :: Addr# -> Int# -> Int32X4# -> State# s -> State# s+writeInt32OffAddrAsInt32X4# = writeInt32OffAddrAsInt32X4#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64OffAddrAsInt64X2# :: Addr# -> Int# -> Int64X2# -> State# s -> State# s+writeInt64OffAddrAsInt64X2# = writeInt64OffAddrAsInt64X2#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8OffAddrAsInt8X32# :: Addr# -> Int# -> Int8X32# -> State# s -> State# s+writeInt8OffAddrAsInt8X32# = writeInt8OffAddrAsInt8X32#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16OffAddrAsInt16X16# :: Addr# -> Int# -> Int16X16# -> State# s -> State# s+writeInt16OffAddrAsInt16X16# = writeInt16OffAddrAsInt16X16#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32OffAddrAsInt32X8# :: Addr# -> Int# -> Int32X8# -> State# s -> State# s+writeInt32OffAddrAsInt32X8# = writeInt32OffAddrAsInt32X8#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64OffAddrAsInt64X4# :: Addr# -> Int# -> Int64X4# -> State# s -> State# s+writeInt64OffAddrAsInt64X4# = writeInt64OffAddrAsInt64X4#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8OffAddrAsInt8X64# :: Addr# -> Int# -> Int8X64# -> State# s -> State# s+writeInt8OffAddrAsInt8X64# = writeInt8OffAddrAsInt8X64#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16OffAddrAsInt16X32# :: Addr# -> Int# -> Int16X32# -> State# s -> State# s+writeInt16OffAddrAsInt16X32# = writeInt16OffAddrAsInt16X32#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32OffAddrAsInt32X16# :: Addr# -> Int# -> Int32X16# -> State# s -> State# s+writeInt32OffAddrAsInt32X16# = writeInt32OffAddrAsInt32X16#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64OffAddrAsInt64X8# :: Addr# -> Int# -> Int64X8# -> State# s -> State# s+writeInt64OffAddrAsInt64X8# = writeInt64OffAddrAsInt64X8#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsWord8X16# :: Addr# -> Int# -> Word8X16# -> State# s -> State# s+writeWord8OffAddrAsWord8X16# = writeWord8OffAddrAsWord8X16#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16OffAddrAsWord16X8# :: Addr# -> Int# -> Word16X8# -> State# s -> State# s+writeWord16OffAddrAsWord16X8# = writeWord16OffAddrAsWord16X8#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32OffAddrAsWord32X4# :: Addr# -> Int# -> Word32X4# -> State# s -> State# s+writeWord32OffAddrAsWord32X4# = writeWord32OffAddrAsWord32X4#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64OffAddrAsWord64X2# :: Addr# -> Int# -> Word64X2# -> State# s -> State# s+writeWord64OffAddrAsWord64X2# = writeWord64OffAddrAsWord64X2#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsWord8X32# :: Addr# -> Int# -> Word8X32# -> State# s -> State# s+writeWord8OffAddrAsWord8X32# = writeWord8OffAddrAsWord8X32#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16OffAddrAsWord16X16# :: Addr# -> Int# -> Word16X16# -> State# s -> State# s+writeWord16OffAddrAsWord16X16# = writeWord16OffAddrAsWord16X16#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32OffAddrAsWord32X8# :: Addr# -> Int# -> Word32X8# -> State# s -> State# s+writeWord32OffAddrAsWord32X8# = writeWord32OffAddrAsWord32X8#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64OffAddrAsWord64X4# :: Addr# -> Int# -> Word64X4# -> State# s -> State# s+writeWord64OffAddrAsWord64X4# = writeWord64OffAddrAsWord64X4#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsWord8X64# :: Addr# -> Int# -> Word8X64# -> State# s -> State# s+writeWord8OffAddrAsWord8X64# = writeWord8OffAddrAsWord8X64#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16OffAddrAsWord16X32# :: Addr# -> Int# -> Word16X32# -> State# s -> State# s+writeWord16OffAddrAsWord16X32# = writeWord16OffAddrAsWord16X32#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32OffAddrAsWord32X16# :: Addr# -> Int# -> Word32X16# -> State# s -> State# s+writeWord32OffAddrAsWord32X16# = writeWord32OffAddrAsWord32X16#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64OffAddrAsWord64X8# :: Addr# -> Int# -> Word64X8# -> State# s -> State# s+writeWord64OffAddrAsWord64X8# = writeWord64OffAddrAsWord64X8#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatOffAddrAsFloatX4# :: Addr# -> Int# -> FloatX4# -> State# s -> State# s+writeFloatOffAddrAsFloatX4# = writeFloatOffAddrAsFloatX4#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleOffAddrAsDoubleX2# :: Addr# -> Int# -> DoubleX2# -> State# s -> State# s+writeDoubleOffAddrAsDoubleX2# = writeDoubleOffAddrAsDoubleX2#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatOffAddrAsFloatX8# :: Addr# -> Int# -> FloatX8# -> State# s -> State# s+writeFloatOffAddrAsFloatX8# = writeFloatOffAddrAsFloatX8#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleOffAddrAsDoubleX4# :: Addr# -> Int# -> DoubleX4# -> State# s -> State# s+writeDoubleOffAddrAsDoubleX4# = writeDoubleOffAddrAsDoubleX4#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatOffAddrAsFloatX16# :: Addr# -> Int# -> FloatX16# -> State# s -> State# s+writeFloatOffAddrAsFloatX16# = writeFloatOffAddrAsFloatX16#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleOffAddrAsDoubleX8# :: Addr# -> Int# -> DoubleX8# -> State# s -> State# s+writeDoubleOffAddrAsDoubleX8# = writeDoubleOffAddrAsDoubleX8#++{-|Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".-}+fmaddFloatX4# :: FloatX4# -> FloatX4# -> FloatX4# -> FloatX4#+fmaddFloatX4# = fmaddFloatX4#++{-|Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".-}+fmaddDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2# -> DoubleX2#+fmaddDoubleX2# = fmaddDoubleX2#++{-|Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".-}+fmaddFloatX8# :: FloatX8# -> FloatX8# -> FloatX8# -> FloatX8#+fmaddFloatX8# = fmaddFloatX8#++{-|Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".-}+fmaddDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4# -> DoubleX4#+fmaddDoubleX4# = fmaddDoubleX4#++{-|Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".-}+fmaddFloatX16# :: FloatX16# -> FloatX16# -> FloatX16# -> FloatX16#+fmaddFloatX16# = fmaddFloatX16#++{-|Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".-}+fmaddDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8# -> DoubleX8#+fmaddDoubleX8# = fmaddDoubleX8#++{-|Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".-}+fmsubFloatX4# :: FloatX4# -> FloatX4# -> FloatX4# -> FloatX4#+fmsubFloatX4# = fmsubFloatX4#++{-|Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".-}+fmsubDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2# -> DoubleX2#+fmsubDoubleX2# = fmsubDoubleX2#++{-|Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".-}+fmsubFloatX8# :: FloatX8# -> FloatX8# -> FloatX8# -> FloatX8#+fmsubFloatX8# = fmsubFloatX8#++{-|Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".-}+fmsubDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4# -> DoubleX4#+fmsubDoubleX4# = fmsubDoubleX4#++{-|Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".-}+fmsubFloatX16# :: FloatX16# -> FloatX16# -> FloatX16# -> FloatX16#+fmsubFloatX16# = fmsubFloatX16#++{-|Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".-}+fmsubDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8# -> DoubleX8#+fmsubDoubleX8# = fmsubDoubleX8#++{-|Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".-}+fnmaddFloatX4# :: FloatX4# -> FloatX4# -> FloatX4# -> FloatX4#+fnmaddFloatX4# = fnmaddFloatX4#++{-|Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".-}+fnmaddDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2# -> DoubleX2#+fnmaddDoubleX2# = fnmaddDoubleX2#++{-|Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".-}+fnmaddFloatX8# :: FloatX8# -> FloatX8# -> FloatX8# -> FloatX8#+fnmaddFloatX8# = fnmaddFloatX8#++{-|Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".-}+fnmaddDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4# -> DoubleX4#+fnmaddDoubleX4# = fnmaddDoubleX4#++{-|Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".-}+fnmaddFloatX16# :: FloatX16# -> FloatX16# -> FloatX16# -> FloatX16#+fnmaddFloatX16# = fnmaddFloatX16#++{-|Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".-}+fnmaddDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8# -> DoubleX8#+fnmaddDoubleX8# = fnmaddDoubleX8#++{-|Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".-}+fnmsubFloatX4# :: FloatX4# -> FloatX4# -> FloatX4# -> FloatX4#+fnmsubFloatX4# = fnmsubFloatX4#++{-|Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".-}+fnmsubDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2# -> DoubleX2#+fnmsubDoubleX2# = fnmsubDoubleX2#++{-|Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".-}+fnmsubFloatX8# :: FloatX8# -> FloatX8# -> FloatX8# -> FloatX8#+fnmsubFloatX8# = fnmsubFloatX8#++{-|Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".-}+fnmsubDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4# -> DoubleX4#+fnmsubDoubleX4# = fnmsubDoubleX4#++{-|Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".-}+fnmsubFloatX16# :: FloatX16# -> FloatX16# -> FloatX16# -> FloatX16#+fnmsubFloatX16# = fnmsubFloatX16#++{-|Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".-}+fnmsubDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8# -> DoubleX8#+fnmsubDoubleX8# = fnmsubDoubleX8#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt8X16# :: Int8X16# -> Int8X16# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Int8X16#+shuffleInt8X16# = shuffleInt8X16#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt16X8# :: Int16X8# -> Int16X8# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Int16X8#+shuffleInt16X8# = shuffleInt16X8#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt32X4# :: Int32X4# -> Int32X4# -> (# Int#,Int#,Int#,Int# #) -> Int32X4#+shuffleInt32X4# = shuffleInt32X4#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt64X2# :: Int64X2# -> Int64X2# -> (# Int#,Int# #) -> Int64X2#+shuffleInt64X2# = shuffleInt64X2#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt8X32# :: Int8X32# -> Int8X32# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Int8X32#+shuffleInt8X32# = shuffleInt8X32#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt16X16# :: Int16X16# -> Int16X16# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Int16X16#+shuffleInt16X16# = shuffleInt16X16#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt32X8# :: Int32X8# -> Int32X8# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Int32X8#+shuffleInt32X8# = shuffleInt32X8#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt64X4# :: Int64X4# -> Int64X4# -> (# Int#,Int#,Int#,Int# #) -> Int64X4#+shuffleInt64X4# = shuffleInt64X4#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt8X64# :: Int8X64# -> Int8X64# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Int8X64#+shuffleInt8X64# = shuffleInt8X64#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt16X32# :: Int16X32# -> Int16X32# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Int16X32#+shuffleInt16X32# = shuffleInt16X32#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt32X16# :: Int32X16# -> Int32X16# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Int32X16#+shuffleInt32X16# = shuffleInt32X16#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt64X8# :: Int64X8# -> Int64X8# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Int64X8#+shuffleInt64X8# = shuffleInt64X8#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord8X16# :: Word8X16# -> Word8X16# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Word8X16#+shuffleWord8X16# = shuffleWord8X16#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord16X8# :: Word16X8# -> Word16X8# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Word16X8#+shuffleWord16X8# = shuffleWord16X8#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord32X4# :: Word32X4# -> Word32X4# -> (# Int#,Int#,Int#,Int# #) -> Word32X4#+shuffleWord32X4# = shuffleWord32X4#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord64X2# :: Word64X2# -> Word64X2# -> (# Int#,Int# #) -> Word64X2#+shuffleWord64X2# = shuffleWord64X2#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord8X32# :: Word8X32# -> Word8X32# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Word8X32#+shuffleWord8X32# = shuffleWord8X32#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord16X16# :: Word16X16# -> Word16X16# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Word16X16#+shuffleWord16X16# = shuffleWord16X16#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord32X8# :: Word32X8# -> Word32X8# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Word32X8#+shuffleWord32X8# = shuffleWord32X8#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord64X4# :: Word64X4# -> Word64X4# -> (# Int#,Int#,Int#,Int# #) -> Word64X4#+shuffleWord64X4# = shuffleWord64X4#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord8X64# :: Word8X64# -> Word8X64# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Word8X64#+shuffleWord8X64# = shuffleWord8X64#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord16X32# :: Word16X32# -> Word16X32# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Word16X32#+shuffleWord16X32# = shuffleWord16X32#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord32X16# :: Word32X16# -> Word32X16# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Word32X16#+shuffleWord32X16# = shuffleWord32X16#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord64X8# :: Word64X8# -> Word64X8# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Word64X8#+shuffleWord64X8# = shuffleWord64X8#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleFloatX4# :: FloatX4# -> FloatX4# -> (# Int#,Int#,Int#,Int# #) -> FloatX4#+shuffleFloatX4# = shuffleFloatX4#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleDoubleX2# :: DoubleX2# -> DoubleX2# -> (# Int#,Int# #) -> DoubleX2#+shuffleDoubleX2# = shuffleDoubleX2#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleFloatX8# :: FloatX8# -> FloatX8# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> FloatX8#+shuffleFloatX8# = shuffleFloatX8#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleDoubleX4# :: DoubleX4# -> DoubleX4# -> (# Int#,Int#,Int#,Int# #) -> DoubleX4#+shuffleDoubleX4# = shuffleDoubleX4#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleFloatX16# :: FloatX16# -> FloatX16# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> FloatX16#+shuffleFloatX16# = shuffleFloatX16#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleDoubleX8# :: DoubleX8# -> DoubleX8# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> DoubleX8#+shuffleDoubleX8# = shuffleDoubleX8#++{-|Component-wise minimum of two vectors.-}+minInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#+minInt8X16# = minInt8X16#++{-|Component-wise minimum of two vectors.-}+minInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#+minInt16X8# = minInt16X8#++{-|Component-wise minimum of two vectors.-}+minInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#+minInt32X4# = minInt32X4#++{-|Component-wise minimum of two vectors.-}+minInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#+minInt64X2# = minInt64X2#++{-|Component-wise minimum of two vectors.-}+minInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#+minInt8X32# = minInt8X32#++{-|Component-wise minimum of two vectors.-}+minInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#+minInt16X16# = minInt16X16#++{-|Component-wise minimum of two vectors.-}+minInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#+minInt32X8# = minInt32X8#++{-|Component-wise minimum of two vectors.-}+minInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#+minInt64X4# = minInt64X4#++{-|Component-wise minimum of two vectors.-}+minInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#+minInt8X64# = minInt8X64#++{-|Component-wise minimum of two vectors.-}+minInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#+minInt16X32# = minInt16X32#++{-|Component-wise minimum of two vectors.-}+minInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#+minInt32X16# = minInt32X16#++{-|Component-wise minimum of two vectors.-}+minInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#+minInt64X8# = minInt64X8#++{-|Component-wise minimum of two vectors.-}+minWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#+minWord8X16# = minWord8X16#++{-|Component-wise minimum of two vectors.-}+minWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#+minWord16X8# = minWord16X8#++{-|Component-wise minimum of two vectors.-}+minWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#+minWord32X4# = minWord32X4#++{-|Component-wise minimum of two vectors.-}+minWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#+minWord64X2# = minWord64X2#++{-|Component-wise minimum of two vectors.-}+minWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#+minWord8X32# = minWord8X32#++{-|Component-wise minimum of two vectors.-}+minWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#+minWord16X16# = minWord16X16#++{-|Component-wise minimum of two vectors.-}+minWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#+minWord32X8# = minWord32X8#++{-|Component-wise minimum of two vectors.-}+minWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#+minWord64X4# = minWord64X4#++{-|Component-wise minimum of two vectors.-}+minWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#+minWord8X64# = minWord8X64#++{-|Component-wise minimum of two vectors.-}+minWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#+minWord16X32# = minWord16X32#++{-|Component-wise minimum of two vectors.-}+minWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#+minWord32X16# = minWord32X16#++{-|Component-wise minimum of two vectors.-}+minWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#+minWord64X8# = minWord64X8#++{-|Component-wise minimum of two vectors.-}+minFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#+minFloatX4# = minFloatX4#++{-|Component-wise minimum of two vectors.-}+minDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#+minDoubleX2# = minDoubleX2#++{-|Component-wise minimum of two vectors.-}+minFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#+minFloatX8# = minFloatX8#++{-|Component-wise minimum of two vectors.-}+minDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#+minDoubleX4# = minDoubleX4#++{-|Component-wise minimum of two vectors.-}+minFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#+minFloatX16# = minFloatX16#++{-|Component-wise minimum of two vectors.-}+minDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#+minDoubleX8# = minDoubleX8#++{-|Component-wise maximum of two vectors.-}+maxInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#+maxInt8X16# = maxInt8X16#++{-|Component-wise maximum of two vectors.-}+maxInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#+maxInt16X8# = maxInt16X8#++{-|Component-wise maximum of two vectors.-}+maxInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#+maxInt32X4# = maxInt32X4#++{-|Component-wise maximum of two vectors.-}+maxInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#+maxInt64X2# = maxInt64X2#++{-|Component-wise maximum of two vectors.-}+maxInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#+maxInt8X32# = maxInt8X32#++{-|Component-wise maximum of two vectors.-}+maxInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#+maxInt16X16# = maxInt16X16#++{-|Component-wise maximum of two vectors.-}+maxInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#+maxInt32X8# = maxInt32X8#++{-|Component-wise maximum of two vectors.-}+maxInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#+maxInt64X4# = maxInt64X4#++{-|Component-wise maximum of two vectors.-}+maxInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#+maxInt8X64# = maxInt8X64#++{-|Component-wise maximum of two vectors.-}+maxInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#+maxInt16X32# = maxInt16X32#++{-|Component-wise maximum of two vectors.-}+maxInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#+maxInt32X16# = maxInt32X16#++{-|Component-wise maximum of two vectors.-}+maxInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#+maxInt64X8# = maxInt64X8#++{-|Component-wise maximum of two vectors.-}+maxWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#+maxWord8X16# = maxWord8X16#++{-|Component-wise maximum of two vectors.-}+maxWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#+maxWord16X8# = maxWord16X8#++{-|Component-wise maximum of two vectors.-}+maxWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#+maxWord32X4# = maxWord32X4#++{-|Component-wise maximum of two vectors.-}+maxWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#+maxWord64X2# = maxWord64X2#++{-|Component-wise maximum of two vectors.-}+maxWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#+maxWord8X32# = maxWord8X32#++{-|Component-wise maximum of two vectors.-}+maxWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#+maxWord16X16# = maxWord16X16#++{-|Component-wise maximum of two vectors.-}+maxWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#+maxWord32X8# = maxWord32X8#++{-|Component-wise maximum of two vectors.-}+maxWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#+maxWord64X4# = maxWord64X4#++{-|Component-wise maximum of two vectors.-}+maxWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#+maxWord8X64# = maxWord8X64#++{-|Component-wise maximum of two vectors.-}+maxWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#+maxWord16X32# = maxWord16X32#++{-|Component-wise maximum of two vectors.-}+maxWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#+maxWord32X16# = maxWord32X16#++{-|Component-wise maximum of two vectors.-}+maxWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#+maxWord64X8# = maxWord64X8#++{-|Component-wise maximum of two vectors.-}+maxFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#+maxFloatX4# = maxFloatX4#++{-|Component-wise maximum of two vectors.-}+maxDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#+maxDoubleX2# = maxDoubleX2#++{-|Component-wise maximum of two vectors.-}+maxFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#+maxFloatX8# = maxFloatX8#++{-|Component-wise maximum of two vectors.-}+maxDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#+maxDoubleX4# = maxDoubleX4#++{-|Component-wise maximum of two vectors.-}+maxFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#+maxFloatX16# = maxFloatX16#++{-|Component-wise maximum of two vectors.-}+maxDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#+maxDoubleX8# = maxDoubleX8#++prefetchByteArray3# :: ByteArray# -> Int# -> State# s -> State# s+prefetchByteArray3# = prefetchByteArray3#++prefetchMutableByteArray3# :: MutableByteArray# s -> Int# -> State# s -> State# s+prefetchMutableByteArray3# = prefetchMutableByteArray3#++prefetchAddr3# :: Addr# -> Int# -> State# s -> State# s+prefetchAddr3# = prefetchAddr3#++prefetchValue3# :: a -> State# s -> State# s+prefetchValue3# = prefetchValue3#++prefetchByteArray2# :: ByteArray# -> Int# -> State# s -> State# s+prefetchByteArray2# = prefetchByteArray2#++prefetchMutableByteArray2# :: MutableByteArray# s -> Int# -> State# s -> State# s+prefetchMutableByteArray2# = prefetchMutableByteArray2#++prefetchAddr2# :: Addr# -> Int# -> State# s -> State# s+prefetchAddr2# = prefetchAddr2#++prefetchValue2# :: a -> State# s -> State# s+prefetchValue2# = prefetchValue2#++prefetchByteArray1# :: ByteArray# -> Int# -> State# s -> State# s+prefetchByteArray1# = prefetchByteArray1#++prefetchMutableByteArray1# :: MutableByteArray# s -> Int# -> State# s -> State# s+prefetchMutableByteArray1# = prefetchMutableByteArray1#++prefetchAddr1# :: Addr# -> Int# -> State# s -> State# s+prefetchAddr1# = prefetchAddr1#++prefetchValue1# :: a -> State# s -> State# s+prefetchValue1# = prefetchValue1#++prefetchByteArray0# :: ByteArray# -> Int# -> State# s -> State# s+prefetchByteArray0# = prefetchByteArray0#++prefetchMutableByteArray0# :: MutableByteArray# s -> Int# -> State# s -> State# s+prefetchMutableByteArray0# = prefetchMutableByteArray0#++prefetchAddr0# :: Addr# -> Int# -> State# s -> State# s+prefetchAddr0# = prefetchAddr0#++prefetchValue0# :: a -> State# s -> State# s+prefetchValue0# = prefetchValue0#+++
+ ghc-lib/stage0/libraries/ghc-internal/build/GHC/Internal/PrimopWrappers.hs view
@@ -0,0 +1,2210 @@+-- | Users should not import this module.  It is GHC internal only.+-- Use "GHC.Exts" instead.+{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples #-}+{-# OPTIONS_GHC -Wno-deprecations -O0 -fno-do-eta-reduction #-}+module GHC.Internal.PrimopWrappers where+import qualified GHC.Internal.Prim+import GHC.Internal.Tuple ()+import GHC.Internal.Prim (Char#, Int#, Int8#, Word8#, Word#, Int16#, Word16#, Int32#, Word32#, Int64#, Word64#, Float#, Double#, State#, MutableArray#, Array#, SmallMutableArray#, SmallArray#, MutableByteArray#, ByteArray#, Addr#, StablePtr#, RealWorld, MutVar#, PromptTag#, TVar#, MVar#, ThreadId#, Weak#, StableName#, Compact#, BCO)+{-# NOINLINE gtChar# #-}+gtChar# :: Char# -> Char# -> Int#+gtChar# a1 a2 = GHC.Internal.Prim.gtChar# a1 a2+{-# NOINLINE geChar# #-}+geChar# :: Char# -> Char# -> Int#+geChar# a1 a2 = GHC.Internal.Prim.geChar# a1 a2+{-# NOINLINE eqChar# #-}+eqChar# :: Char# -> Char# -> Int#+eqChar# a1 a2 = GHC.Internal.Prim.eqChar# a1 a2+{-# NOINLINE neChar# #-}+neChar# :: Char# -> Char# -> Int#+neChar# a1 a2 = GHC.Internal.Prim.neChar# a1 a2+{-# NOINLINE ltChar# #-}+ltChar# :: Char# -> Char# -> Int#+ltChar# a1 a2 = GHC.Internal.Prim.ltChar# a1 a2+{-# NOINLINE leChar# #-}+leChar# :: Char# -> Char# -> Int#+leChar# a1 a2 = GHC.Internal.Prim.leChar# a1 a2+{-# NOINLINE ord# #-}+ord# :: Char# -> Int#+ord# a1 = GHC.Internal.Prim.ord# a1+{-# NOINLINE int8ToInt# #-}+int8ToInt# :: Int8# -> Int#+int8ToInt# a1 = GHC.Internal.Prim.int8ToInt# a1+{-# NOINLINE intToInt8# #-}+intToInt8# :: Int# -> Int8#+intToInt8# a1 = GHC.Internal.Prim.intToInt8# a1+{-# NOINLINE negateInt8# #-}+negateInt8# :: Int8# -> Int8#+negateInt8# a1 = GHC.Internal.Prim.negateInt8# a1+{-# NOINLINE plusInt8# #-}+plusInt8# :: Int8# -> Int8# -> Int8#+plusInt8# a1 a2 = GHC.Internal.Prim.plusInt8# a1 a2+{-# NOINLINE subInt8# #-}+subInt8# :: Int8# -> Int8# -> Int8#+subInt8# a1 a2 = GHC.Internal.Prim.subInt8# a1 a2+{-# NOINLINE timesInt8# #-}+timesInt8# :: Int8# -> Int8# -> Int8#+timesInt8# a1 a2 = GHC.Internal.Prim.timesInt8# a1 a2+{-# NOINLINE quotInt8# #-}+quotInt8# :: Int8# -> Int8# -> Int8#+quotInt8# a1 a2 = GHC.Internal.Prim.quotInt8# a1 a2+{-# NOINLINE remInt8# #-}+remInt8# :: Int8# -> Int8# -> Int8#+remInt8# a1 a2 = GHC.Internal.Prim.remInt8# a1 a2+{-# NOINLINE quotRemInt8# #-}+quotRemInt8# :: Int8# -> Int8# -> (# Int8#,Int8# #)+quotRemInt8# a1 a2 = GHC.Internal.Prim.quotRemInt8# a1 a2+{-# NOINLINE uncheckedShiftLInt8# #-}+uncheckedShiftLInt8# :: Int8# -> Int# -> Int8#+uncheckedShiftLInt8# a1 a2 = GHC.Internal.Prim.uncheckedShiftLInt8# a1 a2+{-# NOINLINE uncheckedShiftRAInt8# #-}+uncheckedShiftRAInt8# :: Int8# -> Int# -> Int8#+uncheckedShiftRAInt8# a1 a2 = GHC.Internal.Prim.uncheckedShiftRAInt8# a1 a2+{-# NOINLINE uncheckedShiftRLInt8# #-}+uncheckedShiftRLInt8# :: Int8# -> Int# -> Int8#+uncheckedShiftRLInt8# a1 a2 = GHC.Internal.Prim.uncheckedShiftRLInt8# a1 a2+{-# NOINLINE int8ToWord8# #-}+int8ToWord8# :: Int8# -> Word8#+int8ToWord8# a1 = GHC.Internal.Prim.int8ToWord8# a1+{-# NOINLINE eqInt8# #-}+eqInt8# :: Int8# -> Int8# -> Int#+eqInt8# a1 a2 = GHC.Internal.Prim.eqInt8# a1 a2+{-# NOINLINE geInt8# #-}+geInt8# :: Int8# -> Int8# -> Int#+geInt8# a1 a2 = GHC.Internal.Prim.geInt8# a1 a2+{-# NOINLINE gtInt8# #-}+gtInt8# :: Int8# -> Int8# -> Int#+gtInt8# a1 a2 = GHC.Internal.Prim.gtInt8# a1 a2+{-# NOINLINE leInt8# #-}+leInt8# :: Int8# -> Int8# -> Int#+leInt8# a1 a2 = GHC.Internal.Prim.leInt8# a1 a2+{-# NOINLINE ltInt8# #-}+ltInt8# :: Int8# -> Int8# -> Int#+ltInt8# a1 a2 = GHC.Internal.Prim.ltInt8# a1 a2+{-# NOINLINE neInt8# #-}+neInt8# :: Int8# -> Int8# -> Int#+neInt8# a1 a2 = GHC.Internal.Prim.neInt8# a1 a2+{-# NOINLINE word8ToWord# #-}+word8ToWord# :: Word8# -> Word#+word8ToWord# a1 = GHC.Internal.Prim.word8ToWord# a1+{-# NOINLINE wordToWord8# #-}+wordToWord8# :: Word# -> Word8#+wordToWord8# a1 = GHC.Internal.Prim.wordToWord8# a1+{-# NOINLINE plusWord8# #-}+plusWord8# :: Word8# -> Word8# -> Word8#+plusWord8# a1 a2 = GHC.Internal.Prim.plusWord8# a1 a2+{-# NOINLINE subWord8# #-}+subWord8# :: Word8# -> Word8# -> Word8#+subWord8# a1 a2 = GHC.Internal.Prim.subWord8# a1 a2+{-# NOINLINE timesWord8# #-}+timesWord8# :: Word8# -> Word8# -> Word8#+timesWord8# a1 a2 = GHC.Internal.Prim.timesWord8# a1 a2+{-# NOINLINE quotWord8# #-}+quotWord8# :: Word8# -> Word8# -> Word8#+quotWord8# a1 a2 = GHC.Internal.Prim.quotWord8# a1 a2+{-# NOINLINE remWord8# #-}+remWord8# :: Word8# -> Word8# -> Word8#+remWord8# a1 a2 = GHC.Internal.Prim.remWord8# a1 a2+{-# NOINLINE quotRemWord8# #-}+quotRemWord8# :: Word8# -> Word8# -> (# Word8#,Word8# #)+quotRemWord8# a1 a2 = GHC.Internal.Prim.quotRemWord8# a1 a2+{-# NOINLINE andWord8# #-}+andWord8# :: Word8# -> Word8# -> Word8#+andWord8# a1 a2 = GHC.Internal.Prim.andWord8# a1 a2+{-# NOINLINE orWord8# #-}+orWord8# :: Word8# -> Word8# -> Word8#+orWord8# a1 a2 = GHC.Internal.Prim.orWord8# a1 a2+{-# NOINLINE xorWord8# #-}+xorWord8# :: Word8# -> Word8# -> Word8#+xorWord8# a1 a2 = GHC.Internal.Prim.xorWord8# a1 a2+{-# NOINLINE notWord8# #-}+notWord8# :: Word8# -> Word8#+notWord8# a1 = GHC.Internal.Prim.notWord8# a1+{-# NOINLINE uncheckedShiftLWord8# #-}+uncheckedShiftLWord8# :: Word8# -> Int# -> Word8#+uncheckedShiftLWord8# a1 a2 = GHC.Internal.Prim.uncheckedShiftLWord8# a1 a2+{-# NOINLINE uncheckedShiftRLWord8# #-}+uncheckedShiftRLWord8# :: Word8# -> Int# -> Word8#+uncheckedShiftRLWord8# a1 a2 = GHC.Internal.Prim.uncheckedShiftRLWord8# a1 a2+{-# NOINLINE word8ToInt8# #-}+word8ToInt8# :: Word8# -> Int8#+word8ToInt8# a1 = GHC.Internal.Prim.word8ToInt8# a1+{-# NOINLINE eqWord8# #-}+eqWord8# :: Word8# -> Word8# -> Int#+eqWord8# a1 a2 = GHC.Internal.Prim.eqWord8# a1 a2+{-# NOINLINE geWord8# #-}+geWord8# :: Word8# -> Word8# -> Int#+geWord8# a1 a2 = GHC.Internal.Prim.geWord8# a1 a2+{-# NOINLINE gtWord8# #-}+gtWord8# :: Word8# -> Word8# -> Int#+gtWord8# a1 a2 = GHC.Internal.Prim.gtWord8# a1 a2+{-# NOINLINE leWord8# #-}+leWord8# :: Word8# -> Word8# -> Int#+leWord8# a1 a2 = GHC.Internal.Prim.leWord8# a1 a2+{-# NOINLINE ltWord8# #-}+ltWord8# :: Word8# -> Word8# -> Int#+ltWord8# a1 a2 = GHC.Internal.Prim.ltWord8# a1 a2+{-# NOINLINE neWord8# #-}+neWord8# :: Word8# -> Word8# -> Int#+neWord8# a1 a2 = GHC.Internal.Prim.neWord8# a1 a2+{-# NOINLINE int16ToInt# #-}+int16ToInt# :: Int16# -> Int#+int16ToInt# a1 = GHC.Internal.Prim.int16ToInt# a1+{-# NOINLINE intToInt16# #-}+intToInt16# :: Int# -> Int16#+intToInt16# a1 = GHC.Internal.Prim.intToInt16# a1+{-# NOINLINE negateInt16# #-}+negateInt16# :: Int16# -> Int16#+negateInt16# a1 = GHC.Internal.Prim.negateInt16# a1+{-# NOINLINE plusInt16# #-}+plusInt16# :: Int16# -> Int16# -> Int16#+plusInt16# a1 a2 = GHC.Internal.Prim.plusInt16# a1 a2+{-# NOINLINE subInt16# #-}+subInt16# :: Int16# -> Int16# -> Int16#+subInt16# a1 a2 = GHC.Internal.Prim.subInt16# a1 a2+{-# NOINLINE timesInt16# #-}+timesInt16# :: Int16# -> Int16# -> Int16#+timesInt16# a1 a2 = GHC.Internal.Prim.timesInt16# a1 a2+{-# NOINLINE quotInt16# #-}+quotInt16# :: Int16# -> Int16# -> Int16#+quotInt16# a1 a2 = GHC.Internal.Prim.quotInt16# a1 a2+{-# NOINLINE remInt16# #-}+remInt16# :: Int16# -> Int16# -> Int16#+remInt16# a1 a2 = GHC.Internal.Prim.remInt16# a1 a2+{-# NOINLINE quotRemInt16# #-}+quotRemInt16# :: Int16# -> Int16# -> (# Int16#,Int16# #)+quotRemInt16# a1 a2 = GHC.Internal.Prim.quotRemInt16# a1 a2+{-# NOINLINE uncheckedShiftLInt16# #-}+uncheckedShiftLInt16# :: Int16# -> Int# -> Int16#+uncheckedShiftLInt16# a1 a2 = GHC.Internal.Prim.uncheckedShiftLInt16# a1 a2+{-# NOINLINE uncheckedShiftRAInt16# #-}+uncheckedShiftRAInt16# :: Int16# -> Int# -> Int16#+uncheckedShiftRAInt16# a1 a2 = GHC.Internal.Prim.uncheckedShiftRAInt16# a1 a2+{-# NOINLINE uncheckedShiftRLInt16# #-}+uncheckedShiftRLInt16# :: Int16# -> Int# -> Int16#+uncheckedShiftRLInt16# a1 a2 = GHC.Internal.Prim.uncheckedShiftRLInt16# a1 a2+{-# NOINLINE int16ToWord16# #-}+int16ToWord16# :: Int16# -> Word16#+int16ToWord16# a1 = GHC.Internal.Prim.int16ToWord16# a1+{-# NOINLINE eqInt16# #-}+eqInt16# :: Int16# -> Int16# -> Int#+eqInt16# a1 a2 = GHC.Internal.Prim.eqInt16# a1 a2+{-# NOINLINE geInt16# #-}+geInt16# :: Int16# -> Int16# -> Int#+geInt16# a1 a2 = GHC.Internal.Prim.geInt16# a1 a2+{-# NOINLINE gtInt16# #-}+gtInt16# :: Int16# -> Int16# -> Int#+gtInt16# a1 a2 = GHC.Internal.Prim.gtInt16# a1 a2+{-# NOINLINE leInt16# #-}+leInt16# :: Int16# -> Int16# -> Int#+leInt16# a1 a2 = GHC.Internal.Prim.leInt16# a1 a2+{-# NOINLINE ltInt16# #-}+ltInt16# :: Int16# -> Int16# -> Int#+ltInt16# a1 a2 = GHC.Internal.Prim.ltInt16# a1 a2+{-# NOINLINE neInt16# #-}+neInt16# :: Int16# -> Int16# -> Int#+neInt16# a1 a2 = GHC.Internal.Prim.neInt16# a1 a2+{-# NOINLINE word16ToWord# #-}+word16ToWord# :: Word16# -> Word#+word16ToWord# a1 = GHC.Internal.Prim.word16ToWord# a1+{-# NOINLINE wordToWord16# #-}+wordToWord16# :: Word# -> Word16#+wordToWord16# a1 = GHC.Internal.Prim.wordToWord16# a1+{-# NOINLINE plusWord16# #-}+plusWord16# :: Word16# -> Word16# -> Word16#+plusWord16# a1 a2 = GHC.Internal.Prim.plusWord16# a1 a2+{-# NOINLINE subWord16# #-}+subWord16# :: Word16# -> Word16# -> Word16#+subWord16# a1 a2 = GHC.Internal.Prim.subWord16# a1 a2+{-# NOINLINE timesWord16# #-}+timesWord16# :: Word16# -> Word16# -> Word16#+timesWord16# a1 a2 = GHC.Internal.Prim.timesWord16# a1 a2+{-# NOINLINE quotWord16# #-}+quotWord16# :: Word16# -> Word16# -> Word16#+quotWord16# a1 a2 = GHC.Internal.Prim.quotWord16# a1 a2+{-# NOINLINE remWord16# #-}+remWord16# :: Word16# -> Word16# -> Word16#+remWord16# a1 a2 = GHC.Internal.Prim.remWord16# a1 a2+{-# NOINLINE quotRemWord16# #-}+quotRemWord16# :: Word16# -> Word16# -> (# Word16#,Word16# #)+quotRemWord16# a1 a2 = GHC.Internal.Prim.quotRemWord16# a1 a2+{-# NOINLINE andWord16# #-}+andWord16# :: Word16# -> Word16# -> Word16#+andWord16# a1 a2 = GHC.Internal.Prim.andWord16# a1 a2+{-# NOINLINE orWord16# #-}+orWord16# :: Word16# -> Word16# -> Word16#+orWord16# a1 a2 = GHC.Internal.Prim.orWord16# a1 a2+{-# NOINLINE xorWord16# #-}+xorWord16# :: Word16# -> Word16# -> Word16#+xorWord16# a1 a2 = GHC.Internal.Prim.xorWord16# a1 a2+{-# NOINLINE notWord16# #-}+notWord16# :: Word16# -> Word16#+notWord16# a1 = GHC.Internal.Prim.notWord16# a1+{-# NOINLINE uncheckedShiftLWord16# #-}+uncheckedShiftLWord16# :: Word16# -> Int# -> Word16#+uncheckedShiftLWord16# a1 a2 = GHC.Internal.Prim.uncheckedShiftLWord16# a1 a2+{-# NOINLINE uncheckedShiftRLWord16# #-}+uncheckedShiftRLWord16# :: Word16# -> Int# -> Word16#+uncheckedShiftRLWord16# a1 a2 = GHC.Internal.Prim.uncheckedShiftRLWord16# a1 a2+{-# NOINLINE word16ToInt16# #-}+word16ToInt16# :: Word16# -> Int16#+word16ToInt16# a1 = GHC.Internal.Prim.word16ToInt16# a1+{-# NOINLINE eqWord16# #-}+eqWord16# :: Word16# -> Word16# -> Int#+eqWord16# a1 a2 = GHC.Internal.Prim.eqWord16# a1 a2+{-# NOINLINE geWord16# #-}+geWord16# :: Word16# -> Word16# -> Int#+geWord16# a1 a2 = GHC.Internal.Prim.geWord16# a1 a2+{-# NOINLINE gtWord16# #-}+gtWord16# :: Word16# -> Word16# -> Int#+gtWord16# a1 a2 = GHC.Internal.Prim.gtWord16# a1 a2+{-# NOINLINE leWord16# #-}+leWord16# :: Word16# -> Word16# -> Int#+leWord16# a1 a2 = GHC.Internal.Prim.leWord16# a1 a2+{-# NOINLINE ltWord16# #-}+ltWord16# :: Word16# -> Word16# -> Int#+ltWord16# a1 a2 = GHC.Internal.Prim.ltWord16# a1 a2+{-# NOINLINE neWord16# #-}+neWord16# :: Word16# -> Word16# -> Int#+neWord16# a1 a2 = GHC.Internal.Prim.neWord16# a1 a2+{-# NOINLINE int32ToInt# #-}+int32ToInt# :: Int32# -> Int#+int32ToInt# a1 = GHC.Internal.Prim.int32ToInt# a1+{-# NOINLINE intToInt32# #-}+intToInt32# :: Int# -> Int32#+intToInt32# a1 = GHC.Internal.Prim.intToInt32# a1+{-# NOINLINE negateInt32# #-}+negateInt32# :: Int32# -> Int32#+negateInt32# a1 = GHC.Internal.Prim.negateInt32# a1+{-# NOINLINE plusInt32# #-}+plusInt32# :: Int32# -> Int32# -> Int32#+plusInt32# a1 a2 = GHC.Internal.Prim.plusInt32# a1 a2+{-# NOINLINE subInt32# #-}+subInt32# :: Int32# -> Int32# -> Int32#+subInt32# a1 a2 = GHC.Internal.Prim.subInt32# a1 a2+{-# NOINLINE timesInt32# #-}+timesInt32# :: Int32# -> Int32# -> Int32#+timesInt32# a1 a2 = GHC.Internal.Prim.timesInt32# a1 a2+{-# NOINLINE quotInt32# #-}+quotInt32# :: Int32# -> Int32# -> Int32#+quotInt32# a1 a2 = GHC.Internal.Prim.quotInt32# a1 a2+{-# NOINLINE remInt32# #-}+remInt32# :: Int32# -> Int32# -> Int32#+remInt32# a1 a2 = GHC.Internal.Prim.remInt32# a1 a2+{-# NOINLINE quotRemInt32# #-}+quotRemInt32# :: Int32# -> Int32# -> (# Int32#,Int32# #)+quotRemInt32# a1 a2 = GHC.Internal.Prim.quotRemInt32# a1 a2+{-# NOINLINE uncheckedShiftLInt32# #-}+uncheckedShiftLInt32# :: Int32# -> Int# -> Int32#+uncheckedShiftLInt32# a1 a2 = GHC.Internal.Prim.uncheckedShiftLInt32# a1 a2+{-# NOINLINE uncheckedShiftRAInt32# #-}+uncheckedShiftRAInt32# :: Int32# -> Int# -> Int32#+uncheckedShiftRAInt32# a1 a2 = GHC.Internal.Prim.uncheckedShiftRAInt32# a1 a2+{-# NOINLINE uncheckedShiftRLInt32# #-}+uncheckedShiftRLInt32# :: Int32# -> Int# -> Int32#+uncheckedShiftRLInt32# a1 a2 = GHC.Internal.Prim.uncheckedShiftRLInt32# a1 a2+{-# NOINLINE int32ToWord32# #-}+int32ToWord32# :: Int32# -> Word32#+int32ToWord32# a1 = GHC.Internal.Prim.int32ToWord32# a1+{-# NOINLINE eqInt32# #-}+eqInt32# :: Int32# -> Int32# -> Int#+eqInt32# a1 a2 = GHC.Internal.Prim.eqInt32# a1 a2+{-# NOINLINE geInt32# #-}+geInt32# :: Int32# -> Int32# -> Int#+geInt32# a1 a2 = GHC.Internal.Prim.geInt32# a1 a2+{-# NOINLINE gtInt32# #-}+gtInt32# :: Int32# -> Int32# -> Int#+gtInt32# a1 a2 = GHC.Internal.Prim.gtInt32# a1 a2+{-# NOINLINE leInt32# #-}+leInt32# :: Int32# -> Int32# -> Int#+leInt32# a1 a2 = GHC.Internal.Prim.leInt32# a1 a2+{-# NOINLINE ltInt32# #-}+ltInt32# :: Int32# -> Int32# -> Int#+ltInt32# a1 a2 = GHC.Internal.Prim.ltInt32# a1 a2+{-# NOINLINE neInt32# #-}+neInt32# :: Int32# -> Int32# -> Int#+neInt32# a1 a2 = GHC.Internal.Prim.neInt32# a1 a2+{-# NOINLINE word32ToWord# #-}+word32ToWord# :: Word32# -> Word#+word32ToWord# a1 = GHC.Internal.Prim.word32ToWord# a1+{-# NOINLINE wordToWord32# #-}+wordToWord32# :: Word# -> Word32#+wordToWord32# a1 = GHC.Internal.Prim.wordToWord32# a1+{-# NOINLINE plusWord32# #-}+plusWord32# :: Word32# -> Word32# -> Word32#+plusWord32# a1 a2 = GHC.Internal.Prim.plusWord32# a1 a2+{-# NOINLINE subWord32# #-}+subWord32# :: Word32# -> Word32# -> Word32#+subWord32# a1 a2 = GHC.Internal.Prim.subWord32# a1 a2+{-# NOINLINE timesWord32# #-}+timesWord32# :: Word32# -> Word32# -> Word32#+timesWord32# a1 a2 = GHC.Internal.Prim.timesWord32# a1 a2+{-# NOINLINE quotWord32# #-}+quotWord32# :: Word32# -> Word32# -> Word32#+quotWord32# a1 a2 = GHC.Internal.Prim.quotWord32# a1 a2+{-# NOINLINE remWord32# #-}+remWord32# :: Word32# -> Word32# -> Word32#+remWord32# a1 a2 = GHC.Internal.Prim.remWord32# a1 a2+{-# NOINLINE quotRemWord32# #-}+quotRemWord32# :: Word32# -> Word32# -> (# Word32#,Word32# #)+quotRemWord32# a1 a2 = GHC.Internal.Prim.quotRemWord32# a1 a2+{-# NOINLINE andWord32# #-}+andWord32# :: Word32# -> Word32# -> Word32#+andWord32# a1 a2 = GHC.Internal.Prim.andWord32# a1 a2+{-# NOINLINE orWord32# #-}+orWord32# :: Word32# -> Word32# -> Word32#+orWord32# a1 a2 = GHC.Internal.Prim.orWord32# a1 a2+{-# NOINLINE xorWord32# #-}+xorWord32# :: Word32# -> Word32# -> Word32#+xorWord32# a1 a2 = GHC.Internal.Prim.xorWord32# a1 a2+{-# NOINLINE notWord32# #-}+notWord32# :: Word32# -> Word32#+notWord32# a1 = GHC.Internal.Prim.notWord32# a1+{-# NOINLINE uncheckedShiftLWord32# #-}+uncheckedShiftLWord32# :: Word32# -> Int# -> Word32#+uncheckedShiftLWord32# a1 a2 = GHC.Internal.Prim.uncheckedShiftLWord32# a1 a2+{-# NOINLINE uncheckedShiftRLWord32# #-}+uncheckedShiftRLWord32# :: Word32# -> Int# -> Word32#+uncheckedShiftRLWord32# a1 a2 = GHC.Internal.Prim.uncheckedShiftRLWord32# a1 a2+{-# NOINLINE word32ToInt32# #-}+word32ToInt32# :: Word32# -> Int32#+word32ToInt32# a1 = GHC.Internal.Prim.word32ToInt32# a1+{-# NOINLINE eqWord32# #-}+eqWord32# :: Word32# -> Word32# -> Int#+eqWord32# a1 a2 = GHC.Internal.Prim.eqWord32# a1 a2+{-# NOINLINE geWord32# #-}+geWord32# :: Word32# -> Word32# -> Int#+geWord32# a1 a2 = GHC.Internal.Prim.geWord32# a1 a2+{-# NOINLINE gtWord32# #-}+gtWord32# :: Word32# -> Word32# -> Int#+gtWord32# a1 a2 = GHC.Internal.Prim.gtWord32# a1 a2+{-# NOINLINE leWord32# #-}+leWord32# :: Word32# -> Word32# -> Int#+leWord32# a1 a2 = GHC.Internal.Prim.leWord32# a1 a2+{-# NOINLINE ltWord32# #-}+ltWord32# :: Word32# -> Word32# -> Int#+ltWord32# a1 a2 = GHC.Internal.Prim.ltWord32# a1 a2+{-# NOINLINE neWord32# #-}+neWord32# :: Word32# -> Word32# -> Int#+neWord32# a1 a2 = GHC.Internal.Prim.neWord32# a1 a2+{-# NOINLINE int64ToInt# #-}+int64ToInt# :: Int64# -> Int#+int64ToInt# a1 = GHC.Internal.Prim.int64ToInt# a1+{-# NOINLINE intToInt64# #-}+intToInt64# :: Int# -> Int64#+intToInt64# a1 = GHC.Internal.Prim.intToInt64# a1+{-# NOINLINE negateInt64# #-}+negateInt64# :: Int64# -> Int64#+negateInt64# a1 = GHC.Internal.Prim.negateInt64# a1+{-# NOINLINE plusInt64# #-}+plusInt64# :: Int64# -> Int64# -> Int64#+plusInt64# a1 a2 = GHC.Internal.Prim.plusInt64# a1 a2+{-# NOINLINE subInt64# #-}+subInt64# :: Int64# -> Int64# -> Int64#+subInt64# a1 a2 = GHC.Internal.Prim.subInt64# a1 a2+{-# NOINLINE timesInt64# #-}+timesInt64# :: Int64# -> Int64# -> Int64#+timesInt64# a1 a2 = GHC.Internal.Prim.timesInt64# a1 a2+{-# NOINLINE quotInt64# #-}+quotInt64# :: Int64# -> Int64# -> Int64#+quotInt64# a1 a2 = GHC.Internal.Prim.quotInt64# a1 a2+{-# NOINLINE remInt64# #-}+remInt64# :: Int64# -> Int64# -> Int64#+remInt64# a1 a2 = GHC.Internal.Prim.remInt64# a1 a2+{-# NOINLINE uncheckedIShiftL64# #-}+uncheckedIShiftL64# :: Int64# -> Int# -> Int64#+uncheckedIShiftL64# a1 a2 = GHC.Internal.Prim.uncheckedIShiftL64# a1 a2+{-# NOINLINE uncheckedIShiftRA64# #-}+uncheckedIShiftRA64# :: Int64# -> Int# -> Int64#+uncheckedIShiftRA64# a1 a2 = GHC.Internal.Prim.uncheckedIShiftRA64# a1 a2+{-# NOINLINE uncheckedIShiftRL64# #-}+uncheckedIShiftRL64# :: Int64# -> Int# -> Int64#+uncheckedIShiftRL64# a1 a2 = GHC.Internal.Prim.uncheckedIShiftRL64# a1 a2+{-# NOINLINE int64ToWord64# #-}+int64ToWord64# :: Int64# -> Word64#+int64ToWord64# a1 = GHC.Internal.Prim.int64ToWord64# a1+{-# NOINLINE eqInt64# #-}+eqInt64# :: Int64# -> Int64# -> Int#+eqInt64# a1 a2 = GHC.Internal.Prim.eqInt64# a1 a2+{-# NOINLINE geInt64# #-}+geInt64# :: Int64# -> Int64# -> Int#+geInt64# a1 a2 = GHC.Internal.Prim.geInt64# a1 a2+{-# NOINLINE gtInt64# #-}+gtInt64# :: Int64# -> Int64# -> Int#+gtInt64# a1 a2 = GHC.Internal.Prim.gtInt64# a1 a2+{-# NOINLINE leInt64# #-}+leInt64# :: Int64# -> Int64# -> Int#+leInt64# a1 a2 = GHC.Internal.Prim.leInt64# a1 a2+{-# NOINLINE ltInt64# #-}+ltInt64# :: Int64# -> Int64# -> Int#+ltInt64# a1 a2 = GHC.Internal.Prim.ltInt64# a1 a2+{-# NOINLINE neInt64# #-}+neInt64# :: Int64# -> Int64# -> Int#+neInt64# a1 a2 = GHC.Internal.Prim.neInt64# a1 a2+{-# NOINLINE word64ToWord# #-}+word64ToWord# :: Word64# -> Word#+word64ToWord# a1 = GHC.Internal.Prim.word64ToWord# a1+{-# NOINLINE wordToWord64# #-}+wordToWord64# :: Word# -> Word64#+wordToWord64# a1 = GHC.Internal.Prim.wordToWord64# a1+{-# NOINLINE plusWord64# #-}+plusWord64# :: Word64# -> Word64# -> Word64#+plusWord64# a1 a2 = GHC.Internal.Prim.plusWord64# a1 a2+{-# NOINLINE subWord64# #-}+subWord64# :: Word64# -> Word64# -> Word64#+subWord64# a1 a2 = GHC.Internal.Prim.subWord64# a1 a2+{-# NOINLINE timesWord64# #-}+timesWord64# :: Word64# -> Word64# -> Word64#+timesWord64# a1 a2 = GHC.Internal.Prim.timesWord64# a1 a2+{-# NOINLINE quotWord64# #-}+quotWord64# :: Word64# -> Word64# -> Word64#+quotWord64# a1 a2 = GHC.Internal.Prim.quotWord64# a1 a2+{-# NOINLINE remWord64# #-}+remWord64# :: Word64# -> Word64# -> Word64#+remWord64# a1 a2 = GHC.Internal.Prim.remWord64# a1 a2+{-# NOINLINE and64# #-}+and64# :: Word64# -> Word64# -> Word64#+and64# a1 a2 = GHC.Internal.Prim.and64# a1 a2+{-# NOINLINE or64# #-}+or64# :: Word64# -> Word64# -> Word64#+or64# a1 a2 = GHC.Internal.Prim.or64# a1 a2+{-# NOINLINE xor64# #-}+xor64# :: Word64# -> Word64# -> Word64#+xor64# a1 a2 = GHC.Internal.Prim.xor64# a1 a2+{-# NOINLINE not64# #-}+not64# :: Word64# -> Word64#+not64# a1 = GHC.Internal.Prim.not64# a1+{-# NOINLINE uncheckedShiftL64# #-}+uncheckedShiftL64# :: Word64# -> Int# -> Word64#+uncheckedShiftL64# a1 a2 = GHC.Internal.Prim.uncheckedShiftL64# a1 a2+{-# NOINLINE uncheckedShiftRL64# #-}+uncheckedShiftRL64# :: Word64# -> Int# -> Word64#+uncheckedShiftRL64# a1 a2 = GHC.Internal.Prim.uncheckedShiftRL64# a1 a2+{-# NOINLINE word64ToInt64# #-}+word64ToInt64# :: Word64# -> Int64#+word64ToInt64# a1 = GHC.Internal.Prim.word64ToInt64# a1+{-# NOINLINE eqWord64# #-}+eqWord64# :: Word64# -> Word64# -> Int#+eqWord64# a1 a2 = GHC.Internal.Prim.eqWord64# a1 a2+{-# NOINLINE geWord64# #-}+geWord64# :: Word64# -> Word64# -> Int#+geWord64# a1 a2 = GHC.Internal.Prim.geWord64# a1 a2+{-# NOINLINE gtWord64# #-}+gtWord64# :: Word64# -> Word64# -> Int#+gtWord64# a1 a2 = GHC.Internal.Prim.gtWord64# a1 a2+{-# NOINLINE leWord64# #-}+leWord64# :: Word64# -> Word64# -> Int#+leWord64# a1 a2 = GHC.Internal.Prim.leWord64# a1 a2+{-# NOINLINE ltWord64# #-}+ltWord64# :: Word64# -> Word64# -> Int#+ltWord64# a1 a2 = GHC.Internal.Prim.ltWord64# a1 a2+{-# NOINLINE neWord64# #-}+neWord64# :: Word64# -> Word64# -> Int#+neWord64# a1 a2 = GHC.Internal.Prim.neWord64# a1 a2+{-# NOINLINE (+#) #-}+(+#) :: Int# -> Int# -> Int#+(+#) a1 a2 = (GHC.Internal.Prim.+#) a1 a2+{-# NOINLINE (-#) #-}+(-#) :: Int# -> Int# -> Int#+(-#) a1 a2 = (GHC.Internal.Prim.-#) a1 a2+{-# NOINLINE (*#) #-}+(*#) :: Int# -> Int# -> Int#+(*#) a1 a2 = (GHC.Internal.Prim.*#) a1 a2+{-# NOINLINE timesInt2# #-}+timesInt2# :: Int# -> Int# -> (# Int#,Int#,Int# #)+timesInt2# a1 a2 = GHC.Internal.Prim.timesInt2# a1 a2+{-# NOINLINE mulIntMayOflo# #-}+mulIntMayOflo# :: Int# -> Int# -> Int#+mulIntMayOflo# a1 a2 = GHC.Internal.Prim.mulIntMayOflo# a1 a2+{-# NOINLINE quotInt# #-}+quotInt# :: Int# -> Int# -> Int#+quotInt# a1 a2 = GHC.Internal.Prim.quotInt# a1 a2+{-# NOINLINE remInt# #-}+remInt# :: Int# -> Int# -> Int#+remInt# a1 a2 = GHC.Internal.Prim.remInt# a1 a2+{-# NOINLINE quotRemInt# #-}+quotRemInt# :: Int# -> Int# -> (# Int#,Int# #)+quotRemInt# a1 a2 = GHC.Internal.Prim.quotRemInt# a1 a2+{-# NOINLINE andI# #-}+andI# :: Int# -> Int# -> Int#+andI# a1 a2 = GHC.Internal.Prim.andI# a1 a2+{-# NOINLINE orI# #-}+orI# :: Int# -> Int# -> Int#+orI# a1 a2 = GHC.Internal.Prim.orI# a1 a2+{-# NOINLINE xorI# #-}+xorI# :: Int# -> Int# -> Int#+xorI# a1 a2 = GHC.Internal.Prim.xorI# a1 a2+{-# NOINLINE notI# #-}+notI# :: Int# -> Int#+notI# a1 = GHC.Internal.Prim.notI# a1+{-# NOINLINE negateInt# #-}+negateInt# :: Int# -> Int#+negateInt# a1 = GHC.Internal.Prim.negateInt# a1+{-# NOINLINE addIntC# #-}+addIntC# :: Int# -> Int# -> (# Int#,Int# #)+addIntC# a1 a2 = GHC.Internal.Prim.addIntC# a1 a2+{-# NOINLINE subIntC# #-}+subIntC# :: Int# -> Int# -> (# Int#,Int# #)+subIntC# a1 a2 = GHC.Internal.Prim.subIntC# a1 a2+{-# NOINLINE (>#) #-}+(>#) :: Int# -> Int# -> Int#+(>#) a1 a2 = (GHC.Internal.Prim.>#) a1 a2+{-# NOINLINE (>=#) #-}+(>=#) :: Int# -> Int# -> Int#+(>=#) a1 a2 = (GHC.Internal.Prim.>=#) a1 a2+{-# NOINLINE (==#) #-}+(==#) :: Int# -> Int# -> Int#+(==#) a1 a2 = (GHC.Internal.Prim.==#) a1 a2+{-# NOINLINE (/=#) #-}+(/=#) :: Int# -> Int# -> Int#+(/=#) a1 a2 = (GHC.Internal.Prim./=#) a1 a2+{-# NOINLINE (<#) #-}+(<#) :: Int# -> Int# -> Int#+(<#) a1 a2 = (GHC.Internal.Prim.<#) a1 a2+{-# NOINLINE (<=#) #-}+(<=#) :: Int# -> Int# -> Int#+(<=#) a1 a2 = (GHC.Internal.Prim.<=#) a1 a2+{-# NOINLINE chr# #-}+chr# :: Int# -> Char#+chr# a1 = GHC.Internal.Prim.chr# a1+{-# NOINLINE int2Word# #-}+int2Word# :: Int# -> Word#+int2Word# a1 = GHC.Internal.Prim.int2Word# a1+{-# NOINLINE int2Float# #-}+int2Float# :: Int# -> Float#+int2Float# a1 = GHC.Internal.Prim.int2Float# a1+{-# NOINLINE int2Double# #-}+int2Double# :: Int# -> Double#+int2Double# a1 = GHC.Internal.Prim.int2Double# a1+{-# NOINLINE word2Float# #-}+word2Float# :: Word# -> Float#+word2Float# a1 = GHC.Internal.Prim.word2Float# a1+{-# NOINLINE word2Double# #-}+word2Double# :: Word# -> Double#+word2Double# a1 = GHC.Internal.Prim.word2Double# a1+{-# NOINLINE uncheckedIShiftL# #-}+uncheckedIShiftL# :: Int# -> Int# -> Int#+uncheckedIShiftL# a1 a2 = GHC.Internal.Prim.uncheckedIShiftL# a1 a2+{-# NOINLINE uncheckedIShiftRA# #-}+uncheckedIShiftRA# :: Int# -> Int# -> Int#+uncheckedIShiftRA# a1 a2 = GHC.Internal.Prim.uncheckedIShiftRA# a1 a2+{-# NOINLINE uncheckedIShiftRL# #-}+uncheckedIShiftRL# :: Int# -> Int# -> Int#+uncheckedIShiftRL# a1 a2 = GHC.Internal.Prim.uncheckedIShiftRL# a1 a2+{-# NOINLINE plusWord# #-}+plusWord# :: Word# -> Word# -> Word#+plusWord# a1 a2 = GHC.Internal.Prim.plusWord# a1 a2+{-# NOINLINE addWordC# #-}+addWordC# :: Word# -> Word# -> (# Word#,Int# #)+addWordC# a1 a2 = GHC.Internal.Prim.addWordC# a1 a2+{-# NOINLINE subWordC# #-}+subWordC# :: Word# -> Word# -> (# Word#,Int# #)+subWordC# a1 a2 = GHC.Internal.Prim.subWordC# a1 a2+{-# NOINLINE plusWord2# #-}+plusWord2# :: Word# -> Word# -> (# Word#,Word# #)+plusWord2# a1 a2 = GHC.Internal.Prim.plusWord2# a1 a2+{-# NOINLINE minusWord# #-}+minusWord# :: Word# -> Word# -> Word#+minusWord# a1 a2 = GHC.Internal.Prim.minusWord# a1 a2+{-# NOINLINE timesWord# #-}+timesWord# :: Word# -> Word# -> Word#+timesWord# a1 a2 = GHC.Internal.Prim.timesWord# a1 a2+{-# NOINLINE timesWord2# #-}+timesWord2# :: Word# -> Word# -> (# Word#,Word# #)+timesWord2# a1 a2 = GHC.Internal.Prim.timesWord2# a1 a2+{-# NOINLINE quotWord# #-}+quotWord# :: Word# -> Word# -> Word#+quotWord# a1 a2 = GHC.Internal.Prim.quotWord# a1 a2+{-# NOINLINE remWord# #-}+remWord# :: Word# -> Word# -> Word#+remWord# a1 a2 = GHC.Internal.Prim.remWord# a1 a2+{-# NOINLINE quotRemWord# #-}+quotRemWord# :: Word# -> Word# -> (# Word#,Word# #)+quotRemWord# a1 a2 = GHC.Internal.Prim.quotRemWord# a1 a2+{-# NOINLINE quotRemWord2# #-}+quotRemWord2# :: Word# -> Word# -> Word# -> (# Word#,Word# #)+quotRemWord2# a1 a2 a3 = GHC.Internal.Prim.quotRemWord2# a1 a2 a3+{-# NOINLINE and# #-}+and# :: Word# -> Word# -> Word#+and# a1 a2 = GHC.Internal.Prim.and# a1 a2+{-# NOINLINE or# #-}+or# :: Word# -> Word# -> Word#+or# a1 a2 = GHC.Internal.Prim.or# a1 a2+{-# NOINLINE xor# #-}+xor# :: Word# -> Word# -> Word#+xor# a1 a2 = GHC.Internal.Prim.xor# a1 a2+{-# NOINLINE not# #-}+not# :: Word# -> Word#+not# a1 = GHC.Internal.Prim.not# a1+{-# NOINLINE uncheckedShiftL# #-}+uncheckedShiftL# :: Word# -> Int# -> Word#+uncheckedShiftL# a1 a2 = GHC.Internal.Prim.uncheckedShiftL# a1 a2+{-# NOINLINE uncheckedShiftRL# #-}+uncheckedShiftRL# :: Word# -> Int# -> Word#+uncheckedShiftRL# a1 a2 = GHC.Internal.Prim.uncheckedShiftRL# a1 a2+{-# NOINLINE word2Int# #-}+word2Int# :: Word# -> Int#+word2Int# a1 = GHC.Internal.Prim.word2Int# a1+{-# NOINLINE gtWord# #-}+gtWord# :: Word# -> Word# -> Int#+gtWord# a1 a2 = GHC.Internal.Prim.gtWord# a1 a2+{-# NOINLINE geWord# #-}+geWord# :: Word# -> Word# -> Int#+geWord# a1 a2 = GHC.Internal.Prim.geWord# a1 a2+{-# NOINLINE eqWord# #-}+eqWord# :: Word# -> Word# -> Int#+eqWord# a1 a2 = GHC.Internal.Prim.eqWord# a1 a2+{-# NOINLINE neWord# #-}+neWord# :: Word# -> Word# -> Int#+neWord# a1 a2 = GHC.Internal.Prim.neWord# a1 a2+{-# NOINLINE ltWord# #-}+ltWord# :: Word# -> Word# -> Int#+ltWord# a1 a2 = GHC.Internal.Prim.ltWord# a1 a2+{-# NOINLINE leWord# #-}+leWord# :: Word# -> Word# -> Int#+leWord# a1 a2 = GHC.Internal.Prim.leWord# a1 a2+{-# NOINLINE popCnt8# #-}+popCnt8# :: Word# -> Word#+popCnt8# a1 = GHC.Internal.Prim.popCnt8# a1+{-# NOINLINE popCnt16# #-}+popCnt16# :: Word# -> Word#+popCnt16# a1 = GHC.Internal.Prim.popCnt16# a1+{-# NOINLINE popCnt32# #-}+popCnt32# :: Word# -> Word#+popCnt32# a1 = GHC.Internal.Prim.popCnt32# a1+{-# NOINLINE popCnt64# #-}+popCnt64# :: Word64# -> Word#+popCnt64# a1 = GHC.Internal.Prim.popCnt64# a1+{-# NOINLINE popCnt# #-}+popCnt# :: Word# -> Word#+popCnt# a1 = GHC.Internal.Prim.popCnt# a1+{-# NOINLINE pdep8# #-}+pdep8# :: Word# -> Word# -> Word#+pdep8# a1 a2 = GHC.Internal.Prim.pdep8# a1 a2+{-# NOINLINE pdep16# #-}+pdep16# :: Word# -> Word# -> Word#+pdep16# a1 a2 = GHC.Internal.Prim.pdep16# a1 a2+{-# NOINLINE pdep32# #-}+pdep32# :: Word# -> Word# -> Word#+pdep32# a1 a2 = GHC.Internal.Prim.pdep32# a1 a2+{-# NOINLINE pdep64# #-}+pdep64# :: Word64# -> Word64# -> Word64#+pdep64# a1 a2 = GHC.Internal.Prim.pdep64# a1 a2+{-# NOINLINE pdep# #-}+pdep# :: Word# -> Word# -> Word#+pdep# a1 a2 = GHC.Internal.Prim.pdep# a1 a2+{-# NOINLINE pext8# #-}+pext8# :: Word# -> Word# -> Word#+pext8# a1 a2 = GHC.Internal.Prim.pext8# a1 a2+{-# NOINLINE pext16# #-}+pext16# :: Word# -> Word# -> Word#+pext16# a1 a2 = GHC.Internal.Prim.pext16# a1 a2+{-# NOINLINE pext32# #-}+pext32# :: Word# -> Word# -> Word#+pext32# a1 a2 = GHC.Internal.Prim.pext32# a1 a2+{-# NOINLINE pext64# #-}+pext64# :: Word64# -> Word64# -> Word64#+pext64# a1 a2 = GHC.Internal.Prim.pext64# a1 a2+{-# NOINLINE pext# #-}+pext# :: Word# -> Word# -> Word#+pext# a1 a2 = GHC.Internal.Prim.pext# a1 a2+{-# NOINLINE clz8# #-}+clz8# :: Word# -> Word#+clz8# a1 = GHC.Internal.Prim.clz8# a1+{-# NOINLINE clz16# #-}+clz16# :: Word# -> Word#+clz16# a1 = GHC.Internal.Prim.clz16# a1+{-# NOINLINE clz32# #-}+clz32# :: Word# -> Word#+clz32# a1 = GHC.Internal.Prim.clz32# a1+{-# NOINLINE clz64# #-}+clz64# :: Word64# -> Word#+clz64# a1 = GHC.Internal.Prim.clz64# a1+{-# NOINLINE clz# #-}+clz# :: Word# -> Word#+clz# a1 = GHC.Internal.Prim.clz# a1+{-# NOINLINE ctz8# #-}+ctz8# :: Word# -> Word#+ctz8# a1 = GHC.Internal.Prim.ctz8# a1+{-# NOINLINE ctz16# #-}+ctz16# :: Word# -> Word#+ctz16# a1 = GHC.Internal.Prim.ctz16# a1+{-# NOINLINE ctz32# #-}+ctz32# :: Word# -> Word#+ctz32# a1 = GHC.Internal.Prim.ctz32# a1+{-# NOINLINE ctz64# #-}+ctz64# :: Word64# -> Word#+ctz64# a1 = GHC.Internal.Prim.ctz64# a1+{-# NOINLINE ctz# #-}+ctz# :: Word# -> Word#+ctz# a1 = GHC.Internal.Prim.ctz# a1+{-# NOINLINE byteSwap16# #-}+byteSwap16# :: Word# -> Word#+byteSwap16# a1 = GHC.Internal.Prim.byteSwap16# a1+{-# NOINLINE byteSwap32# #-}+byteSwap32# :: Word# -> Word#+byteSwap32# a1 = GHC.Internal.Prim.byteSwap32# a1+{-# NOINLINE byteSwap64# #-}+byteSwap64# :: Word64# -> Word64#+byteSwap64# a1 = GHC.Internal.Prim.byteSwap64# a1+{-# NOINLINE byteSwap# #-}+byteSwap# :: Word# -> Word#+byteSwap# a1 = GHC.Internal.Prim.byteSwap# a1+{-# NOINLINE bitReverse8# #-}+bitReverse8# :: Word# -> Word#+bitReverse8# a1 = GHC.Internal.Prim.bitReverse8# a1+{-# NOINLINE bitReverse16# #-}+bitReverse16# :: Word# -> Word#+bitReverse16# a1 = GHC.Internal.Prim.bitReverse16# a1+{-# NOINLINE bitReverse32# #-}+bitReverse32# :: Word# -> Word#+bitReverse32# a1 = GHC.Internal.Prim.bitReverse32# a1+{-# NOINLINE bitReverse64# #-}+bitReverse64# :: Word64# -> Word64#+bitReverse64# a1 = GHC.Internal.Prim.bitReverse64# a1+{-# NOINLINE bitReverse# #-}+bitReverse# :: Word# -> Word#+bitReverse# a1 = GHC.Internal.Prim.bitReverse# a1+{-# NOINLINE narrow8Int# #-}+narrow8Int# :: Int# -> Int#+narrow8Int# a1 = GHC.Internal.Prim.narrow8Int# a1+{-# NOINLINE narrow16Int# #-}+narrow16Int# :: Int# -> Int#+narrow16Int# a1 = GHC.Internal.Prim.narrow16Int# a1+{-# NOINLINE narrow32Int# #-}+narrow32Int# :: Int# -> Int#+narrow32Int# a1 = GHC.Internal.Prim.narrow32Int# a1+{-# NOINLINE narrow8Word# #-}+narrow8Word# :: Word# -> Word#+narrow8Word# a1 = GHC.Internal.Prim.narrow8Word# a1+{-# NOINLINE narrow16Word# #-}+narrow16Word# :: Word# -> Word#+narrow16Word# a1 = GHC.Internal.Prim.narrow16Word# a1+{-# NOINLINE narrow32Word# #-}+narrow32Word# :: Word# -> Word#+narrow32Word# a1 = GHC.Internal.Prim.narrow32Word# a1+{-# NOINLINE (>##) #-}+(>##) :: Double# -> Double# -> Int#+(>##) a1 a2 = (GHC.Internal.Prim.>##) a1 a2+{-# NOINLINE (>=##) #-}+(>=##) :: Double# -> Double# -> Int#+(>=##) a1 a2 = (GHC.Internal.Prim.>=##) a1 a2+{-# NOINLINE (==##) #-}+(==##) :: Double# -> Double# -> Int#+(==##) a1 a2 = (GHC.Internal.Prim.==##) a1 a2+{-# NOINLINE (/=##) #-}+(/=##) :: Double# -> Double# -> Int#+(/=##) a1 a2 = (GHC.Internal.Prim./=##) a1 a2+{-# NOINLINE (<##) #-}+(<##) :: Double# -> Double# -> Int#+(<##) a1 a2 = (GHC.Internal.Prim.<##) a1 a2+{-# NOINLINE (<=##) #-}+(<=##) :: Double# -> Double# -> Int#+(<=##) a1 a2 = (GHC.Internal.Prim.<=##) a1 a2+{-# NOINLINE minDouble# #-}+minDouble# :: Double# -> Double# -> Double#+minDouble# a1 a2 = GHC.Internal.Prim.minDouble# a1 a2+{-# NOINLINE maxDouble# #-}+maxDouble# :: Double# -> Double# -> Double#+maxDouble# a1 a2 = GHC.Internal.Prim.maxDouble# a1 a2+{-# NOINLINE (+##) #-}+(+##) :: Double# -> Double# -> Double#+(+##) a1 a2 = (GHC.Internal.Prim.+##) a1 a2+{-# NOINLINE (-##) #-}+(-##) :: Double# -> Double# -> Double#+(-##) a1 a2 = (GHC.Internal.Prim.-##) a1 a2+{-# NOINLINE (*##) #-}+(*##) :: Double# -> Double# -> Double#+(*##) a1 a2 = (GHC.Internal.Prim.*##) a1 a2+{-# NOINLINE (/##) #-}+(/##) :: Double# -> Double# -> Double#+(/##) a1 a2 = (GHC.Internal.Prim./##) a1 a2+{-# NOINLINE negateDouble# #-}+negateDouble# :: Double# -> Double#+negateDouble# a1 = GHC.Internal.Prim.negateDouble# a1+{-# NOINLINE fabsDouble# #-}+fabsDouble# :: Double# -> Double#+fabsDouble# a1 = GHC.Internal.Prim.fabsDouble# a1+{-# NOINLINE double2Int# #-}+double2Int# :: Double# -> Int#+double2Int# a1 = GHC.Internal.Prim.double2Int# a1+{-# NOINLINE double2Float# #-}+double2Float# :: Double# -> Float#+double2Float# a1 = GHC.Internal.Prim.double2Float# a1+{-# NOINLINE expDouble# #-}+expDouble# :: Double# -> Double#+expDouble# a1 = GHC.Internal.Prim.expDouble# a1+{-# NOINLINE expm1Double# #-}+expm1Double# :: Double# -> Double#+expm1Double# a1 = GHC.Internal.Prim.expm1Double# a1+{-# NOINLINE logDouble# #-}+logDouble# :: Double# -> Double#+logDouble# a1 = GHC.Internal.Prim.logDouble# a1+{-# NOINLINE log1pDouble# #-}+log1pDouble# :: Double# -> Double#+log1pDouble# a1 = GHC.Internal.Prim.log1pDouble# a1+{-# NOINLINE sqrtDouble# #-}+sqrtDouble# :: Double# -> Double#+sqrtDouble# a1 = GHC.Internal.Prim.sqrtDouble# a1+{-# NOINLINE sinDouble# #-}+sinDouble# :: Double# -> Double#+sinDouble# a1 = GHC.Internal.Prim.sinDouble# a1+{-# NOINLINE cosDouble# #-}+cosDouble# :: Double# -> Double#+cosDouble# a1 = GHC.Internal.Prim.cosDouble# a1+{-# NOINLINE tanDouble# #-}+tanDouble# :: Double# -> Double#+tanDouble# a1 = GHC.Internal.Prim.tanDouble# a1+{-# NOINLINE asinDouble# #-}+asinDouble# :: Double# -> Double#+asinDouble# a1 = GHC.Internal.Prim.asinDouble# a1+{-# NOINLINE acosDouble# #-}+acosDouble# :: Double# -> Double#+acosDouble# a1 = GHC.Internal.Prim.acosDouble# a1+{-# NOINLINE atanDouble# #-}+atanDouble# :: Double# -> Double#+atanDouble# a1 = GHC.Internal.Prim.atanDouble# a1+{-# NOINLINE sinhDouble# #-}+sinhDouble# :: Double# -> Double#+sinhDouble# a1 = GHC.Internal.Prim.sinhDouble# a1+{-# NOINLINE coshDouble# #-}+coshDouble# :: Double# -> Double#+coshDouble# a1 = GHC.Internal.Prim.coshDouble# a1+{-# NOINLINE tanhDouble# #-}+tanhDouble# :: Double# -> Double#+tanhDouble# a1 = GHC.Internal.Prim.tanhDouble# a1+{-# NOINLINE asinhDouble# #-}+asinhDouble# :: Double# -> Double#+asinhDouble# a1 = GHC.Internal.Prim.asinhDouble# a1+{-# NOINLINE acoshDouble# #-}+acoshDouble# :: Double# -> Double#+acoshDouble# a1 = GHC.Internal.Prim.acoshDouble# a1+{-# NOINLINE atanhDouble# #-}+atanhDouble# :: Double# -> Double#+atanhDouble# a1 = GHC.Internal.Prim.atanhDouble# a1+{-# NOINLINE (**##) #-}+(**##) :: Double# -> Double# -> Double#+(**##) a1 a2 = (GHC.Internal.Prim.**##) a1 a2+{-# NOINLINE decodeDouble_2Int# #-}+decodeDouble_2Int# :: Double# -> (# Int#,Word#,Word#,Int# #)+decodeDouble_2Int# a1 = GHC.Internal.Prim.decodeDouble_2Int# a1+{-# NOINLINE decodeDouble_Int64# #-}+decodeDouble_Int64# :: Double# -> (# Int64#,Int# #)+decodeDouble_Int64# a1 = GHC.Internal.Prim.decodeDouble_Int64# a1+{-# NOINLINE castDoubleToWord64# #-}+castDoubleToWord64# :: Double# -> Word64#+castDoubleToWord64# a1 = GHC.Internal.Prim.castDoubleToWord64# a1+{-# NOINLINE castWord64ToDouble# #-}+castWord64ToDouble# :: Word64# -> Double#+castWord64ToDouble# a1 = GHC.Internal.Prim.castWord64ToDouble# a1+{-# NOINLINE gtFloat# #-}+gtFloat# :: Float# -> Float# -> Int#+gtFloat# a1 a2 = GHC.Internal.Prim.gtFloat# a1 a2+{-# NOINLINE geFloat# #-}+geFloat# :: Float# -> Float# -> Int#+geFloat# a1 a2 = GHC.Internal.Prim.geFloat# a1 a2+{-# NOINLINE eqFloat# #-}+eqFloat# :: Float# -> Float# -> Int#+eqFloat# a1 a2 = GHC.Internal.Prim.eqFloat# a1 a2+{-# NOINLINE neFloat# #-}+neFloat# :: Float# -> Float# -> Int#+neFloat# a1 a2 = GHC.Internal.Prim.neFloat# a1 a2+{-# NOINLINE ltFloat# #-}+ltFloat# :: Float# -> Float# -> Int#+ltFloat# a1 a2 = GHC.Internal.Prim.ltFloat# a1 a2+{-# NOINLINE leFloat# #-}+leFloat# :: Float# -> Float# -> Int#+leFloat# a1 a2 = GHC.Internal.Prim.leFloat# a1 a2+{-# NOINLINE minFloat# #-}+minFloat# :: Float# -> Float# -> Float#+minFloat# a1 a2 = GHC.Internal.Prim.minFloat# a1 a2+{-# NOINLINE maxFloat# #-}+maxFloat# :: Float# -> Float# -> Float#+maxFloat# a1 a2 = GHC.Internal.Prim.maxFloat# a1 a2+{-# NOINLINE plusFloat# #-}+plusFloat# :: Float# -> Float# -> Float#+plusFloat# a1 a2 = GHC.Internal.Prim.plusFloat# a1 a2+{-# NOINLINE minusFloat# #-}+minusFloat# :: Float# -> Float# -> Float#+minusFloat# a1 a2 = GHC.Internal.Prim.minusFloat# a1 a2+{-# NOINLINE timesFloat# #-}+timesFloat# :: Float# -> Float# -> Float#+timesFloat# a1 a2 = GHC.Internal.Prim.timesFloat# a1 a2+{-# NOINLINE divideFloat# #-}+divideFloat# :: Float# -> Float# -> Float#+divideFloat# a1 a2 = GHC.Internal.Prim.divideFloat# a1 a2+{-# NOINLINE negateFloat# #-}+negateFloat# :: Float# -> Float#+negateFloat# a1 = GHC.Internal.Prim.negateFloat# a1+{-# NOINLINE fabsFloat# #-}+fabsFloat# :: Float# -> Float#+fabsFloat# a1 = GHC.Internal.Prim.fabsFloat# a1+{-# NOINLINE float2Int# #-}+float2Int# :: Float# -> Int#+float2Int# a1 = GHC.Internal.Prim.float2Int# a1+{-# NOINLINE expFloat# #-}+expFloat# :: Float# -> Float#+expFloat# a1 = GHC.Internal.Prim.expFloat# a1+{-# NOINLINE expm1Float# #-}+expm1Float# :: Float# -> Float#+expm1Float# a1 = GHC.Internal.Prim.expm1Float# a1+{-# NOINLINE logFloat# #-}+logFloat# :: Float# -> Float#+logFloat# a1 = GHC.Internal.Prim.logFloat# a1+{-# NOINLINE log1pFloat# #-}+log1pFloat# :: Float# -> Float#+log1pFloat# a1 = GHC.Internal.Prim.log1pFloat# a1+{-# NOINLINE sqrtFloat# #-}+sqrtFloat# :: Float# -> Float#+sqrtFloat# a1 = GHC.Internal.Prim.sqrtFloat# a1+{-# NOINLINE sinFloat# #-}+sinFloat# :: Float# -> Float#+sinFloat# a1 = GHC.Internal.Prim.sinFloat# a1+{-# NOINLINE cosFloat# #-}+cosFloat# :: Float# -> Float#+cosFloat# a1 = GHC.Internal.Prim.cosFloat# a1+{-# NOINLINE tanFloat# #-}+tanFloat# :: Float# -> Float#+tanFloat# a1 = GHC.Internal.Prim.tanFloat# a1+{-# NOINLINE asinFloat# #-}+asinFloat# :: Float# -> Float#+asinFloat# a1 = GHC.Internal.Prim.asinFloat# a1+{-# NOINLINE acosFloat# #-}+acosFloat# :: Float# -> Float#+acosFloat# a1 = GHC.Internal.Prim.acosFloat# a1+{-# NOINLINE atanFloat# #-}+atanFloat# :: Float# -> Float#+atanFloat# a1 = GHC.Internal.Prim.atanFloat# a1+{-# NOINLINE sinhFloat# #-}+sinhFloat# :: Float# -> Float#+sinhFloat# a1 = GHC.Internal.Prim.sinhFloat# a1+{-# NOINLINE coshFloat# #-}+coshFloat# :: Float# -> Float#+coshFloat# a1 = GHC.Internal.Prim.coshFloat# a1+{-# NOINLINE tanhFloat# #-}+tanhFloat# :: Float# -> Float#+tanhFloat# a1 = GHC.Internal.Prim.tanhFloat# a1+{-# NOINLINE asinhFloat# #-}+asinhFloat# :: Float# -> Float#+asinhFloat# a1 = GHC.Internal.Prim.asinhFloat# a1+{-# NOINLINE acoshFloat# #-}+acoshFloat# :: Float# -> Float#+acoshFloat# a1 = GHC.Internal.Prim.acoshFloat# a1+{-# NOINLINE atanhFloat# #-}+atanhFloat# :: Float# -> Float#+atanhFloat# a1 = GHC.Internal.Prim.atanhFloat# a1+{-# NOINLINE powerFloat# #-}+powerFloat# :: Float# -> Float# -> Float#+powerFloat# a1 a2 = GHC.Internal.Prim.powerFloat# a1 a2+{-# NOINLINE float2Double# #-}+float2Double# :: Float# -> Double#+float2Double# a1 = GHC.Internal.Prim.float2Double# a1+{-# NOINLINE decodeFloat_Int# #-}+decodeFloat_Int# :: Float# -> (# Int#,Int# #)+decodeFloat_Int# a1 = GHC.Internal.Prim.decodeFloat_Int# a1+{-# NOINLINE castFloatToWord32# #-}+castFloatToWord32# :: Float# -> Word32#+castFloatToWord32# a1 = GHC.Internal.Prim.castFloatToWord32# a1+{-# NOINLINE castWord32ToFloat# #-}+castWord32ToFloat# :: Word32# -> Float#+castWord32ToFloat# a1 = GHC.Internal.Prim.castWord32ToFloat# a1+{-# NOINLINE fmaddFloat# #-}+fmaddFloat# :: Float# -> Float# -> Float# -> Float#+fmaddFloat# a1 a2 a3 = GHC.Internal.Prim.fmaddFloat# a1 a2 a3+{-# NOINLINE fmsubFloat# #-}+fmsubFloat# :: Float# -> Float# -> Float# -> Float#+fmsubFloat# a1 a2 a3 = GHC.Internal.Prim.fmsubFloat# a1 a2 a3+{-# NOINLINE fnmaddFloat# #-}+fnmaddFloat# :: Float# -> Float# -> Float# -> Float#+fnmaddFloat# a1 a2 a3 = GHC.Internal.Prim.fnmaddFloat# a1 a2 a3+{-# NOINLINE fnmsubFloat# #-}+fnmsubFloat# :: Float# -> Float# -> Float# -> Float#+fnmsubFloat# a1 a2 a3 = GHC.Internal.Prim.fnmsubFloat# a1 a2 a3+{-# NOINLINE fmaddDouble# #-}+fmaddDouble# :: Double# -> Double# -> Double# -> Double#+fmaddDouble# a1 a2 a3 = GHC.Internal.Prim.fmaddDouble# a1 a2 a3+{-# NOINLINE fmsubDouble# #-}+fmsubDouble# :: Double# -> Double# -> Double# -> Double#+fmsubDouble# a1 a2 a3 = GHC.Internal.Prim.fmsubDouble# a1 a2 a3+{-# NOINLINE fnmaddDouble# #-}+fnmaddDouble# :: Double# -> Double# -> Double# -> Double#+fnmaddDouble# a1 a2 a3 = GHC.Internal.Prim.fnmaddDouble# a1 a2 a3+{-# NOINLINE fnmsubDouble# #-}+fnmsubDouble# :: Double# -> Double# -> Double# -> Double#+fnmsubDouble# a1 a2 a3 = GHC.Internal.Prim.fnmsubDouble# a1 a2 a3+{-# NOINLINE newArray# #-}+newArray# :: Int# -> a_levpoly -> State# s -> (# State# s,MutableArray# s a_levpoly #)+newArray# a1 a2 a3 = GHC.Internal.Prim.newArray# a1 a2 a3+{-# NOINLINE readArray# #-}+readArray# :: MutableArray# s a_levpoly -> Int# -> State# s -> (# State# s,a_levpoly #)+readArray# a1 a2 a3 = GHC.Internal.Prim.readArray# a1 a2 a3+{-# NOINLINE writeArray# #-}+writeArray# :: MutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s+writeArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeArray# a1 a2 a3 a4+{-# NOINLINE sizeofArray# #-}+sizeofArray# :: Array# a_levpoly -> Int#+sizeofArray# a1 = GHC.Internal.Prim.sizeofArray# a1+{-# NOINLINE sizeofMutableArray# #-}+sizeofMutableArray# :: MutableArray# s a_levpoly -> Int#+sizeofMutableArray# a1 = GHC.Internal.Prim.sizeofMutableArray# a1+{-# NOINLINE indexArray# #-}+indexArray# :: Array# a_levpoly -> Int# -> (# a_levpoly #)+indexArray# a1 a2 = GHC.Internal.Prim.indexArray# a1 a2+{-# NOINLINE unsafeFreezeArray# #-}+unsafeFreezeArray# :: MutableArray# s a_levpoly -> State# s -> (# State# s,Array# a_levpoly #)+unsafeFreezeArray# a1 a2 = GHC.Internal.Prim.unsafeFreezeArray# a1 a2+{-# NOINLINE unsafeThawArray# #-}+unsafeThawArray# :: Array# a_levpoly -> State# s -> (# State# s,MutableArray# s a_levpoly #)+unsafeThawArray# a1 a2 = GHC.Internal.Prim.unsafeThawArray# a1 a2+{-# NOINLINE copyArray# #-}+copyArray# :: Array# a_levpoly -> Int# -> MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+copyArray# a1 a2 a3 a4 a5 a6 = GHC.Internal.Prim.copyArray# a1 a2 a3 a4 a5 a6+{-# NOINLINE copyMutableArray# #-}+copyMutableArray# :: MutableArray# s a_levpoly -> Int# -> MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+copyMutableArray# a1 a2 a3 a4 a5 a6 = GHC.Internal.Prim.copyMutableArray# a1 a2 a3 a4 a5 a6+{-# NOINLINE cloneArray# #-}+cloneArray# :: Array# a_levpoly -> Int# -> Int# -> Array# a_levpoly+cloneArray# a1 a2 a3 = GHC.Internal.Prim.cloneArray# a1 a2 a3+{-# NOINLINE cloneMutableArray# #-}+cloneMutableArray# :: MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s,MutableArray# s a_levpoly #)+cloneMutableArray# a1 a2 a3 a4 = GHC.Internal.Prim.cloneMutableArray# a1 a2 a3 a4+{-# NOINLINE freezeArray# #-}+freezeArray# :: MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s,Array# a_levpoly #)+freezeArray# a1 a2 a3 a4 = GHC.Internal.Prim.freezeArray# a1 a2 a3 a4+{-# NOINLINE thawArray# #-}+thawArray# :: Array# a_levpoly -> Int# -> Int# -> State# s -> (# State# s,MutableArray# s a_levpoly #)+thawArray# a1 a2 a3 a4 = GHC.Internal.Prim.thawArray# a1 a2 a3 a4+{-# NOINLINE casArray# #-}+casArray# :: MutableArray# s a_levpoly -> Int# -> a_levpoly -> a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+casArray# a1 a2 a3 a4 a5 = GHC.Internal.Prim.casArray# a1 a2 a3 a4 a5+{-# NOINLINE newSmallArray# #-}+newSmallArray# :: Int# -> a_levpoly -> State# s -> (# State# s,SmallMutableArray# s a_levpoly #)+newSmallArray# a1 a2 a3 = GHC.Internal.Prim.newSmallArray# a1 a2 a3+{-# NOINLINE shrinkSmallMutableArray# #-}+shrinkSmallMutableArray# :: SmallMutableArray# s a_levpoly -> Int# -> State# s -> State# s+shrinkSmallMutableArray# a1 a2 a3 = GHC.Internal.Prim.shrinkSmallMutableArray# a1 a2 a3+{-# NOINLINE readSmallArray# #-}+readSmallArray# :: SmallMutableArray# s a_levpoly -> Int# -> State# s -> (# State# s,a_levpoly #)+readSmallArray# a1 a2 a3 = GHC.Internal.Prim.readSmallArray# a1 a2 a3+{-# NOINLINE writeSmallArray# #-}+writeSmallArray# :: SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s+writeSmallArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeSmallArray# a1 a2 a3 a4+{-# NOINLINE sizeofSmallArray# #-}+sizeofSmallArray# :: SmallArray# a_levpoly -> Int#+sizeofSmallArray# a1 = GHC.Internal.Prim.sizeofSmallArray# a1+{-# NOINLINE sizeofSmallMutableArray# #-}+sizeofSmallMutableArray# :: SmallMutableArray# s a_levpoly -> Int#+sizeofSmallMutableArray# a1 = GHC.Internal.Prim.sizeofSmallMutableArray# a1+{-# NOINLINE getSizeofSmallMutableArray# #-}+getSizeofSmallMutableArray# :: SmallMutableArray# s a_levpoly -> State# s -> (# State# s,Int# #)+getSizeofSmallMutableArray# a1 a2 = GHC.Internal.Prim.getSizeofSmallMutableArray# a1 a2+{-# NOINLINE indexSmallArray# #-}+indexSmallArray# :: SmallArray# a_levpoly -> Int# -> (# a_levpoly #)+indexSmallArray# a1 a2 = GHC.Internal.Prim.indexSmallArray# a1 a2+{-# NOINLINE unsafeFreezeSmallArray# #-}+unsafeFreezeSmallArray# :: SmallMutableArray# s a_levpoly -> State# s -> (# State# s,SmallArray# a_levpoly #)+unsafeFreezeSmallArray# a1 a2 = GHC.Internal.Prim.unsafeFreezeSmallArray# a1 a2+{-# NOINLINE unsafeThawSmallArray# #-}+unsafeThawSmallArray# :: SmallArray# a_levpoly -> State# s -> (# State# s,SmallMutableArray# s a_levpoly #)+unsafeThawSmallArray# a1 a2 = GHC.Internal.Prim.unsafeThawSmallArray# a1 a2+{-# NOINLINE copySmallArray# #-}+copySmallArray# :: SmallArray# a_levpoly -> Int# -> SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+copySmallArray# a1 a2 a3 a4 a5 a6 = GHC.Internal.Prim.copySmallArray# a1 a2 a3 a4 a5 a6+{-# NOINLINE copySmallMutableArray# #-}+copySmallMutableArray# :: SmallMutableArray# s a_levpoly -> Int# -> SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+copySmallMutableArray# a1 a2 a3 a4 a5 a6 = GHC.Internal.Prim.copySmallMutableArray# a1 a2 a3 a4 a5 a6+{-# NOINLINE cloneSmallArray# #-}+cloneSmallArray# :: SmallArray# a_levpoly -> Int# -> Int# -> SmallArray# a_levpoly+cloneSmallArray# a1 a2 a3 = GHC.Internal.Prim.cloneSmallArray# a1 a2 a3+{-# NOINLINE cloneSmallMutableArray# #-}+cloneSmallMutableArray# :: SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s,SmallMutableArray# s a_levpoly #)+cloneSmallMutableArray# a1 a2 a3 a4 = GHC.Internal.Prim.cloneSmallMutableArray# a1 a2 a3 a4+{-# NOINLINE freezeSmallArray# #-}+freezeSmallArray# :: SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s,SmallArray# a_levpoly #)+freezeSmallArray# a1 a2 a3 a4 = GHC.Internal.Prim.freezeSmallArray# a1 a2 a3 a4+{-# NOINLINE thawSmallArray# #-}+thawSmallArray# :: SmallArray# a_levpoly -> Int# -> Int# -> State# s -> (# State# s,SmallMutableArray# s a_levpoly #)+thawSmallArray# a1 a2 a3 a4 = GHC.Internal.Prim.thawSmallArray# a1 a2 a3 a4+{-# NOINLINE casSmallArray# #-}+casSmallArray# :: SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+casSmallArray# a1 a2 a3 a4 a5 = GHC.Internal.Prim.casSmallArray# a1 a2 a3 a4 a5+{-# NOINLINE newByteArray# #-}+newByteArray# :: Int# -> State# s -> (# State# s,MutableByteArray# s #)+newByteArray# a1 a2 = GHC.Internal.Prim.newByteArray# a1 a2+{-# NOINLINE newPinnedByteArray# #-}+newPinnedByteArray# :: Int# -> State# s -> (# State# s,MutableByteArray# s #)+newPinnedByteArray# a1 a2 = GHC.Internal.Prim.newPinnedByteArray# a1 a2+{-# NOINLINE newAlignedPinnedByteArray# #-}+newAlignedPinnedByteArray# :: Int# -> Int# -> State# s -> (# State# s,MutableByteArray# s #)+newAlignedPinnedByteArray# a1 a2 a3 = GHC.Internal.Prim.newAlignedPinnedByteArray# a1 a2 a3+{-# NOINLINE isMutableByteArrayPinned# #-}+isMutableByteArrayPinned# :: MutableByteArray# s -> Int#+isMutableByteArrayPinned# a1 = GHC.Internal.Prim.isMutableByteArrayPinned# a1+{-# NOINLINE isByteArrayPinned# #-}+isByteArrayPinned# :: ByteArray# -> Int#+isByteArrayPinned# a1 = GHC.Internal.Prim.isByteArrayPinned# a1+{-# NOINLINE isByteArrayWeaklyPinned# #-}+isByteArrayWeaklyPinned# :: ByteArray# -> Int#+isByteArrayWeaklyPinned# a1 = GHC.Internal.Prim.isByteArrayWeaklyPinned# a1+{-# NOINLINE isMutableByteArrayWeaklyPinned# #-}+isMutableByteArrayWeaklyPinned# :: MutableByteArray# s -> Int#+isMutableByteArrayWeaklyPinned# a1 = GHC.Internal.Prim.isMutableByteArrayWeaklyPinned# a1+{-# NOINLINE byteArrayContents# #-}+byteArrayContents# :: ByteArray# -> Addr#+byteArrayContents# a1 = GHC.Internal.Prim.byteArrayContents# a1+{-# NOINLINE mutableByteArrayContents# #-}+mutableByteArrayContents# :: MutableByteArray# s -> Addr#+mutableByteArrayContents# a1 = GHC.Internal.Prim.mutableByteArrayContents# a1+{-# NOINLINE shrinkMutableByteArray# #-}+shrinkMutableByteArray# :: MutableByteArray# s -> Int# -> State# s -> State# s+shrinkMutableByteArray# a1 a2 a3 = GHC.Internal.Prim.shrinkMutableByteArray# a1 a2 a3+{-# NOINLINE resizeMutableByteArray# #-}+resizeMutableByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #)+resizeMutableByteArray# a1 a2 a3 = GHC.Internal.Prim.resizeMutableByteArray# a1 a2 a3+{-# NOINLINE unsafeFreezeByteArray# #-}+unsafeFreezeByteArray# :: MutableByteArray# s -> State# s -> (# State# s,ByteArray# #)+unsafeFreezeByteArray# a1 a2 = GHC.Internal.Prim.unsafeFreezeByteArray# a1 a2+{-# NOINLINE unsafeThawByteArray# #-}+unsafeThawByteArray# :: ByteArray# -> State# s -> (# State# s,MutableByteArray# s #)+unsafeThawByteArray# a1 a2 = GHC.Internal.Prim.unsafeThawByteArray# a1 a2+{-# NOINLINE sizeofByteArray# #-}+sizeofByteArray# :: ByteArray# -> Int#+sizeofByteArray# a1 = GHC.Internal.Prim.sizeofByteArray# a1+{-# NOINLINE sizeofMutableByteArray# #-}+sizeofMutableByteArray# :: MutableByteArray# s -> Int#+sizeofMutableByteArray# a1 = GHC.Internal.Prim.sizeofMutableByteArray# a1+{-# NOINLINE getSizeofMutableByteArray# #-}+getSizeofMutableByteArray# :: MutableByteArray# s -> State# s -> (# State# s,Int# #)+getSizeofMutableByteArray# a1 a2 = GHC.Internal.Prim.getSizeofMutableByteArray# a1 a2+{-# NOINLINE indexCharArray# #-}+indexCharArray# :: ByteArray# -> Int# -> Char#+indexCharArray# a1 a2 = GHC.Internal.Prim.indexCharArray# a1 a2+{-# NOINLINE indexWideCharArray# #-}+indexWideCharArray# :: ByteArray# -> Int# -> Char#+indexWideCharArray# a1 a2 = GHC.Internal.Prim.indexWideCharArray# a1 a2+{-# NOINLINE indexIntArray# #-}+indexIntArray# :: ByteArray# -> Int# -> Int#+indexIntArray# a1 a2 = GHC.Internal.Prim.indexIntArray# a1 a2+{-# NOINLINE indexWordArray# #-}+indexWordArray# :: ByteArray# -> Int# -> Word#+indexWordArray# a1 a2 = GHC.Internal.Prim.indexWordArray# a1 a2+{-# NOINLINE indexAddrArray# #-}+indexAddrArray# :: ByteArray# -> Int# -> Addr#+indexAddrArray# a1 a2 = GHC.Internal.Prim.indexAddrArray# a1 a2+{-# NOINLINE indexFloatArray# #-}+indexFloatArray# :: ByteArray# -> Int# -> Float#+indexFloatArray# a1 a2 = GHC.Internal.Prim.indexFloatArray# a1 a2+{-# NOINLINE indexDoubleArray# #-}+indexDoubleArray# :: ByteArray# -> Int# -> Double#+indexDoubleArray# a1 a2 = GHC.Internal.Prim.indexDoubleArray# a1 a2+{-# NOINLINE indexStablePtrArray# #-}+indexStablePtrArray# :: ByteArray# -> Int# -> StablePtr# a+indexStablePtrArray# a1 a2 = GHC.Internal.Prim.indexStablePtrArray# a1 a2+{-# NOINLINE indexInt8Array# #-}+indexInt8Array# :: ByteArray# -> Int# -> Int8#+indexInt8Array# a1 a2 = GHC.Internal.Prim.indexInt8Array# a1 a2+{-# NOINLINE indexWord8Array# #-}+indexWord8Array# :: ByteArray# -> Int# -> Word8#+indexWord8Array# a1 a2 = GHC.Internal.Prim.indexWord8Array# a1 a2+{-# NOINLINE indexInt16Array# #-}+indexInt16Array# :: ByteArray# -> Int# -> Int16#+indexInt16Array# a1 a2 = GHC.Internal.Prim.indexInt16Array# a1 a2+{-# NOINLINE indexWord16Array# #-}+indexWord16Array# :: ByteArray# -> Int# -> Word16#+indexWord16Array# a1 a2 = GHC.Internal.Prim.indexWord16Array# a1 a2+{-# NOINLINE indexInt32Array# #-}+indexInt32Array# :: ByteArray# -> Int# -> Int32#+indexInt32Array# a1 a2 = GHC.Internal.Prim.indexInt32Array# a1 a2+{-# NOINLINE indexWord32Array# #-}+indexWord32Array# :: ByteArray# -> Int# -> Word32#+indexWord32Array# a1 a2 = GHC.Internal.Prim.indexWord32Array# a1 a2+{-# NOINLINE indexInt64Array# #-}+indexInt64Array# :: ByteArray# -> Int# -> Int64#+indexInt64Array# a1 a2 = GHC.Internal.Prim.indexInt64Array# a1 a2+{-# NOINLINE indexWord64Array# #-}+indexWord64Array# :: ByteArray# -> Int# -> Word64#+indexWord64Array# a1 a2 = GHC.Internal.Prim.indexWord64Array# a1 a2+{-# NOINLINE indexWord8ArrayAsChar# #-}+indexWord8ArrayAsChar# :: ByteArray# -> Int# -> Char#+indexWord8ArrayAsChar# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsChar# a1 a2+{-# NOINLINE indexWord8ArrayAsWideChar# #-}+indexWord8ArrayAsWideChar# :: ByteArray# -> Int# -> Char#+indexWord8ArrayAsWideChar# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsWideChar# a1 a2+{-# NOINLINE indexWord8ArrayAsInt# #-}+indexWord8ArrayAsInt# :: ByteArray# -> Int# -> Int#+indexWord8ArrayAsInt# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsInt# a1 a2+{-# NOINLINE indexWord8ArrayAsWord# #-}+indexWord8ArrayAsWord# :: ByteArray# -> Int# -> Word#+indexWord8ArrayAsWord# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsWord# a1 a2+{-# NOINLINE indexWord8ArrayAsAddr# #-}+indexWord8ArrayAsAddr# :: ByteArray# -> Int# -> Addr#+indexWord8ArrayAsAddr# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsAddr# a1 a2+{-# NOINLINE indexWord8ArrayAsFloat# #-}+indexWord8ArrayAsFloat# :: ByteArray# -> Int# -> Float#+indexWord8ArrayAsFloat# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsFloat# a1 a2+{-# NOINLINE indexWord8ArrayAsDouble# #-}+indexWord8ArrayAsDouble# :: ByteArray# -> Int# -> Double#+indexWord8ArrayAsDouble# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsDouble# a1 a2+{-# NOINLINE indexWord8ArrayAsStablePtr# #-}+indexWord8ArrayAsStablePtr# :: ByteArray# -> Int# -> StablePtr# a+indexWord8ArrayAsStablePtr# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsStablePtr# a1 a2+{-# NOINLINE indexWord8ArrayAsInt16# #-}+indexWord8ArrayAsInt16# :: ByteArray# -> Int# -> Int16#+indexWord8ArrayAsInt16# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsInt16# a1 a2+{-# NOINLINE indexWord8ArrayAsWord16# #-}+indexWord8ArrayAsWord16# :: ByteArray# -> Int# -> Word16#+indexWord8ArrayAsWord16# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsWord16# a1 a2+{-# NOINLINE indexWord8ArrayAsInt32# #-}+indexWord8ArrayAsInt32# :: ByteArray# -> Int# -> Int32#+indexWord8ArrayAsInt32# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsInt32# a1 a2+{-# NOINLINE indexWord8ArrayAsWord32# #-}+indexWord8ArrayAsWord32# :: ByteArray# -> Int# -> Word32#+indexWord8ArrayAsWord32# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsWord32# a1 a2+{-# NOINLINE indexWord8ArrayAsInt64# #-}+indexWord8ArrayAsInt64# :: ByteArray# -> Int# -> Int64#+indexWord8ArrayAsInt64# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsInt64# a1 a2+{-# NOINLINE indexWord8ArrayAsWord64# #-}+indexWord8ArrayAsWord64# :: ByteArray# -> Int# -> Word64#+indexWord8ArrayAsWord64# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsWord64# a1 a2+{-# NOINLINE readCharArray# #-}+readCharArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readCharArray# a1 a2 a3 = GHC.Internal.Prim.readCharArray# a1 a2 a3+{-# NOINLINE readWideCharArray# #-}+readWideCharArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readWideCharArray# a1 a2 a3 = GHC.Internal.Prim.readWideCharArray# a1 a2 a3+{-# NOINLINE readIntArray# #-}+readIntArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+readIntArray# a1 a2 a3 = GHC.Internal.Prim.readIntArray# a1 a2 a3+{-# NOINLINE readWordArray# #-}+readWordArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #)+readWordArray# a1 a2 a3 = GHC.Internal.Prim.readWordArray# a1 a2 a3+{-# NOINLINE readAddrArray# #-}+readAddrArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Addr# #)+readAddrArray# a1 a2 a3 = GHC.Internal.Prim.readAddrArray# a1 a2 a3+{-# NOINLINE readFloatArray# #-}+readFloatArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Float# #)+readFloatArray# a1 a2 a3 = GHC.Internal.Prim.readFloatArray# a1 a2 a3+{-# NOINLINE readDoubleArray# #-}+readDoubleArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Double# #)+readDoubleArray# a1 a2 a3 = GHC.Internal.Prim.readDoubleArray# a1 a2 a3+{-# NOINLINE readStablePtrArray# #-}+readStablePtrArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,StablePtr# a #)+readStablePtrArray# a1 a2 a3 = GHC.Internal.Prim.readStablePtrArray# a1 a2 a3+{-# NOINLINE readInt8Array# #-}+readInt8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int8# #)+readInt8Array# a1 a2 a3 = GHC.Internal.Prim.readInt8Array# a1 a2 a3+{-# NOINLINE readWord8Array# #-}+readWord8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word8# #)+readWord8Array# a1 a2 a3 = GHC.Internal.Prim.readWord8Array# a1 a2 a3+{-# NOINLINE readInt16Array# #-}+readInt16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16# #)+readInt16Array# a1 a2 a3 = GHC.Internal.Prim.readInt16Array# a1 a2 a3+{-# NOINLINE readWord16Array# #-}+readWord16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16# #)+readWord16Array# a1 a2 a3 = GHC.Internal.Prim.readWord16Array# a1 a2 a3+{-# NOINLINE readInt32Array# #-}+readInt32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32# #)+readInt32Array# a1 a2 a3 = GHC.Internal.Prim.readInt32Array# a1 a2 a3+{-# NOINLINE readWord32Array# #-}+readWord32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32# #)+readWord32Array# a1 a2 a3 = GHC.Internal.Prim.readWord32Array# a1 a2 a3+{-# NOINLINE readInt64Array# #-}+readInt64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64# #)+readInt64Array# a1 a2 a3 = GHC.Internal.Prim.readInt64Array# a1 a2 a3+{-# NOINLINE readWord64Array# #-}+readWord64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64# #)+readWord64Array# a1 a2 a3 = GHC.Internal.Prim.readWord64Array# a1 a2 a3+{-# NOINLINE readWord8ArrayAsChar# #-}+readWord8ArrayAsChar# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readWord8ArrayAsChar# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsChar# a1 a2 a3+{-# NOINLINE readWord8ArrayAsWideChar# #-}+readWord8ArrayAsWideChar# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readWord8ArrayAsWideChar# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsWideChar# a1 a2 a3+{-# NOINLINE readWord8ArrayAsInt# #-}+readWord8ArrayAsInt# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+readWord8ArrayAsInt# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsInt# a1 a2 a3+{-# NOINLINE readWord8ArrayAsWord# #-}+readWord8ArrayAsWord# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #)+readWord8ArrayAsWord# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsWord# a1 a2 a3+{-# NOINLINE readWord8ArrayAsAddr# #-}+readWord8ArrayAsAddr# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Addr# #)+readWord8ArrayAsAddr# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsAddr# a1 a2 a3+{-# NOINLINE readWord8ArrayAsFloat# #-}+readWord8ArrayAsFloat# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Float# #)+readWord8ArrayAsFloat# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsFloat# a1 a2 a3+{-# NOINLINE readWord8ArrayAsDouble# #-}+readWord8ArrayAsDouble# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Double# #)+readWord8ArrayAsDouble# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsDouble# a1 a2 a3+{-# NOINLINE readWord8ArrayAsStablePtr# #-}+readWord8ArrayAsStablePtr# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,StablePtr# a #)+readWord8ArrayAsStablePtr# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsStablePtr# a1 a2 a3+{-# NOINLINE readWord8ArrayAsInt16# #-}+readWord8ArrayAsInt16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16# #)+readWord8ArrayAsInt16# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsInt16# a1 a2 a3+{-# NOINLINE readWord8ArrayAsWord16# #-}+readWord8ArrayAsWord16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16# #)+readWord8ArrayAsWord16# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsWord16# a1 a2 a3+{-# NOINLINE readWord8ArrayAsInt32# #-}+readWord8ArrayAsInt32# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32# #)+readWord8ArrayAsInt32# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsInt32# a1 a2 a3+{-# NOINLINE readWord8ArrayAsWord32# #-}+readWord8ArrayAsWord32# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32# #)+readWord8ArrayAsWord32# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsWord32# a1 a2 a3+{-# NOINLINE readWord8ArrayAsInt64# #-}+readWord8ArrayAsInt64# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64# #)+readWord8ArrayAsInt64# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsInt64# a1 a2 a3+{-# NOINLINE readWord8ArrayAsWord64# #-}+readWord8ArrayAsWord64# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64# #)+readWord8ArrayAsWord64# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsWord64# a1 a2 a3+{-# NOINLINE writeCharArray# #-}+writeCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeCharArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeCharArray# a1 a2 a3 a4+{-# NOINLINE writeWideCharArray# #-}+writeWideCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeWideCharArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeWideCharArray# a1 a2 a3 a4+{-# NOINLINE writeIntArray# #-}+writeIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+writeIntArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeIntArray# a1 a2 a3 a4+{-# NOINLINE writeWordArray# #-}+writeWordArray# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+writeWordArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeWordArray# a1 a2 a3 a4+{-# NOINLINE writeAddrArray# #-}+writeAddrArray# :: MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s+writeAddrArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeAddrArray# a1 a2 a3 a4+{-# NOINLINE writeFloatArray# #-}+writeFloatArray# :: MutableByteArray# s -> Int# -> Float# -> State# s -> State# s+writeFloatArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeFloatArray# a1 a2 a3 a4+{-# NOINLINE writeDoubleArray# #-}+writeDoubleArray# :: MutableByteArray# s -> Int# -> Double# -> State# s -> State# s+writeDoubleArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeDoubleArray# a1 a2 a3 a4+{-# NOINLINE writeStablePtrArray# #-}+writeStablePtrArray# :: MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s+writeStablePtrArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeStablePtrArray# a1 a2 a3 a4+{-# NOINLINE writeInt8Array# #-}+writeInt8Array# :: MutableByteArray# s -> Int# -> Int8# -> State# s -> State# s+writeInt8Array# a1 a2 a3 a4 = GHC.Internal.Prim.writeInt8Array# a1 a2 a3 a4+{-# NOINLINE writeWord8Array# #-}+writeWord8Array# :: MutableByteArray# s -> Int# -> Word8# -> State# s -> State# s+writeWord8Array# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8Array# a1 a2 a3 a4+{-# NOINLINE writeInt16Array# #-}+writeInt16Array# :: MutableByteArray# s -> Int# -> Int16# -> State# s -> State# s+writeInt16Array# a1 a2 a3 a4 = GHC.Internal.Prim.writeInt16Array# a1 a2 a3 a4+{-# NOINLINE writeWord16Array# #-}+writeWord16Array# :: MutableByteArray# s -> Int# -> Word16# -> State# s -> State# s+writeWord16Array# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord16Array# a1 a2 a3 a4+{-# NOINLINE writeInt32Array# #-}+writeInt32Array# :: MutableByteArray# s -> Int# -> Int32# -> State# s -> State# s+writeInt32Array# a1 a2 a3 a4 = GHC.Internal.Prim.writeInt32Array# a1 a2 a3 a4+{-# NOINLINE writeWord32Array# #-}+writeWord32Array# :: MutableByteArray# s -> Int# -> Word32# -> State# s -> State# s+writeWord32Array# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord32Array# a1 a2 a3 a4+{-# NOINLINE writeInt64Array# #-}+writeInt64Array# :: MutableByteArray# s -> Int# -> Int64# -> State# s -> State# s+writeInt64Array# a1 a2 a3 a4 = GHC.Internal.Prim.writeInt64Array# a1 a2 a3 a4+{-# NOINLINE writeWord64Array# #-}+writeWord64Array# :: MutableByteArray# s -> Int# -> Word64# -> State# s -> State# s+writeWord64Array# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord64Array# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsChar# #-}+writeWord8ArrayAsChar# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeWord8ArrayAsChar# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsChar# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsWideChar# #-}+writeWord8ArrayAsWideChar# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeWord8ArrayAsWideChar# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsWideChar# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsInt# #-}+writeWord8ArrayAsInt# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+writeWord8ArrayAsInt# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsInt# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsWord# #-}+writeWord8ArrayAsWord# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+writeWord8ArrayAsWord# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsWord# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsAddr# #-}+writeWord8ArrayAsAddr# :: MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s+writeWord8ArrayAsAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsAddr# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsFloat# #-}+writeWord8ArrayAsFloat# :: MutableByteArray# s -> Int# -> Float# -> State# s -> State# s+writeWord8ArrayAsFloat# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsFloat# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsDouble# #-}+writeWord8ArrayAsDouble# :: MutableByteArray# s -> Int# -> Double# -> State# s -> State# s+writeWord8ArrayAsDouble# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsDouble# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsStablePtr# #-}+writeWord8ArrayAsStablePtr# :: MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s+writeWord8ArrayAsStablePtr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsStablePtr# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsInt16# #-}+writeWord8ArrayAsInt16# :: MutableByteArray# s -> Int# -> Int16# -> State# s -> State# s+writeWord8ArrayAsInt16# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsInt16# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsWord16# #-}+writeWord8ArrayAsWord16# :: MutableByteArray# s -> Int# -> Word16# -> State# s -> State# s+writeWord8ArrayAsWord16# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsWord16# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsInt32# #-}+writeWord8ArrayAsInt32# :: MutableByteArray# s -> Int# -> Int32# -> State# s -> State# s+writeWord8ArrayAsInt32# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsInt32# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsWord32# #-}+writeWord8ArrayAsWord32# :: MutableByteArray# s -> Int# -> Word32# -> State# s -> State# s+writeWord8ArrayAsWord32# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsWord32# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsInt64# #-}+writeWord8ArrayAsInt64# :: MutableByteArray# s -> Int# -> Int64# -> State# s -> State# s+writeWord8ArrayAsInt64# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsInt64# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsWord64# #-}+writeWord8ArrayAsWord64# :: MutableByteArray# s -> Int# -> Word64# -> State# s -> State# s+writeWord8ArrayAsWord64# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsWord64# a1 a2 a3 a4+{-# NOINLINE compareByteArrays# #-}+compareByteArrays# :: ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int#+compareByteArrays# a1 a2 a3 a4 a5 = GHC.Internal.Prim.compareByteArrays# a1 a2 a3 a4 a5+{-# NOINLINE copyByteArray# #-}+copyByteArray# :: ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+copyByteArray# a1 a2 a3 a4 a5 a6 = GHC.Internal.Prim.copyByteArray# a1 a2 a3 a4 a5 a6+{-# NOINLINE copyMutableByteArray# #-}+copyMutableByteArray# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+copyMutableByteArray# a1 a2 a3 a4 a5 a6 = GHC.Internal.Prim.copyMutableByteArray# a1 a2 a3 a4 a5 a6+{-# NOINLINE copyMutableByteArrayNonOverlapping# #-}+copyMutableByteArrayNonOverlapping# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+copyMutableByteArrayNonOverlapping# a1 a2 a3 a4 a5 a6 = GHC.Internal.Prim.copyMutableByteArrayNonOverlapping# a1 a2 a3 a4 a5 a6+{-# NOINLINE copyByteArrayToAddr# #-}+copyByteArrayToAddr# :: ByteArray# -> Int# -> Addr# -> Int# -> State# s -> State# s+copyByteArrayToAddr# a1 a2 a3 a4 a5 = GHC.Internal.Prim.copyByteArrayToAddr# a1 a2 a3 a4 a5+{-# NOINLINE copyMutableByteArrayToAddr# #-}+copyMutableByteArrayToAddr# :: MutableByteArray# s -> Int# -> Addr# -> Int# -> State# s -> State# s+copyMutableByteArrayToAddr# a1 a2 a3 a4 a5 = GHC.Internal.Prim.copyMutableByteArrayToAddr# a1 a2 a3 a4 a5+{-# NOINLINE copyAddrToByteArray# #-}+copyAddrToByteArray# :: Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+copyAddrToByteArray# a1 a2 a3 a4 a5 = GHC.Internal.Prim.copyAddrToByteArray# a1 a2 a3 a4 a5+{-# NOINLINE copyAddrToAddr# #-}+copyAddrToAddr# :: Addr# -> Addr# -> Int# -> State# (RealWorld) -> State# (RealWorld)+copyAddrToAddr# a1 a2 a3 a4 = GHC.Internal.Prim.copyAddrToAddr# a1 a2 a3 a4+{-# NOINLINE copyAddrToAddrNonOverlapping# #-}+copyAddrToAddrNonOverlapping# :: Addr# -> Addr# -> Int# -> State# (RealWorld) -> State# (RealWorld)+copyAddrToAddrNonOverlapping# a1 a2 a3 a4 = GHC.Internal.Prim.copyAddrToAddrNonOverlapping# a1 a2 a3 a4+{-# NOINLINE setByteArray# #-}+setByteArray# :: MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> State# s+setByteArray# a1 a2 a3 a4 a5 = GHC.Internal.Prim.setByteArray# a1 a2 a3 a4 a5+{-# NOINLINE setAddrRange# #-}+setAddrRange# :: Addr# -> Int# -> Int# -> State# (RealWorld) -> State# (RealWorld)+setAddrRange# a1 a2 a3 a4 = GHC.Internal.Prim.setAddrRange# a1 a2 a3 a4+{-# NOINLINE atomicReadIntArray# #-}+atomicReadIntArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+atomicReadIntArray# a1 a2 a3 = GHC.Internal.Prim.atomicReadIntArray# a1 a2 a3+{-# NOINLINE atomicWriteIntArray# #-}+atomicWriteIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+atomicWriteIntArray# a1 a2 a3 a4 = GHC.Internal.Prim.atomicWriteIntArray# a1 a2 a3 a4+{-# NOINLINE casIntArray# #-}+casIntArray# :: MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s,Int# #)+casIntArray# a1 a2 a3 a4 a5 = GHC.Internal.Prim.casIntArray# a1 a2 a3 a4 a5+{-# NOINLINE casInt8Array# #-}+casInt8Array# :: MutableByteArray# s -> Int# -> Int8# -> Int8# -> State# s -> (# State# s,Int8# #)+casInt8Array# a1 a2 a3 a4 a5 = GHC.Internal.Prim.casInt8Array# a1 a2 a3 a4 a5+{-# NOINLINE casInt16Array# #-}+casInt16Array# :: MutableByteArray# s -> Int# -> Int16# -> Int16# -> State# s -> (# State# s,Int16# #)+casInt16Array# a1 a2 a3 a4 a5 = GHC.Internal.Prim.casInt16Array# a1 a2 a3 a4 a5+{-# NOINLINE casInt32Array# #-}+casInt32Array# :: MutableByteArray# s -> Int# -> Int32# -> Int32# -> State# s -> (# State# s,Int32# #)+casInt32Array# a1 a2 a3 a4 a5 = GHC.Internal.Prim.casInt32Array# a1 a2 a3 a4 a5+{-# NOINLINE casInt64Array# #-}+casInt64Array# :: MutableByteArray# s -> Int# -> Int64# -> Int64# -> State# s -> (# State# s,Int64# #)+casInt64Array# a1 a2 a3 a4 a5 = GHC.Internal.Prim.casInt64Array# a1 a2 a3 a4 a5+{-# NOINLINE fetchAddIntArray# #-}+fetchAddIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchAddIntArray# a1 a2 a3 a4 = GHC.Internal.Prim.fetchAddIntArray# a1 a2 a3 a4+{-# NOINLINE fetchSubIntArray# #-}+fetchSubIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchSubIntArray# a1 a2 a3 a4 = GHC.Internal.Prim.fetchSubIntArray# a1 a2 a3 a4+{-# NOINLINE fetchAndIntArray# #-}+fetchAndIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchAndIntArray# a1 a2 a3 a4 = GHC.Internal.Prim.fetchAndIntArray# a1 a2 a3 a4+{-# NOINLINE fetchNandIntArray# #-}+fetchNandIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchNandIntArray# a1 a2 a3 a4 = GHC.Internal.Prim.fetchNandIntArray# a1 a2 a3 a4+{-# NOINLINE fetchOrIntArray# #-}+fetchOrIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchOrIntArray# a1 a2 a3 a4 = GHC.Internal.Prim.fetchOrIntArray# a1 a2 a3 a4+{-# NOINLINE fetchXorIntArray# #-}+fetchXorIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchXorIntArray# a1 a2 a3 a4 = GHC.Internal.Prim.fetchXorIntArray# a1 a2 a3 a4+{-# NOINLINE plusAddr# #-}+plusAddr# :: Addr# -> Int# -> Addr#+plusAddr# a1 a2 = GHC.Internal.Prim.plusAddr# a1 a2+{-# NOINLINE minusAddr# #-}+minusAddr# :: Addr# -> Addr# -> Int#+minusAddr# a1 a2 = GHC.Internal.Prim.minusAddr# a1 a2+{-# NOINLINE remAddr# #-}+remAddr# :: Addr# -> Int# -> Int#+remAddr# a1 a2 = GHC.Internal.Prim.remAddr# a1 a2+{-# NOINLINE addr2Int# #-}+addr2Int# :: Addr# -> Int#+addr2Int# a1 = GHC.Internal.Prim.addr2Int# a1+{-# NOINLINE int2Addr# #-}+int2Addr# :: Int# -> Addr#+int2Addr# a1 = GHC.Internal.Prim.int2Addr# a1+{-# NOINLINE gtAddr# #-}+gtAddr# :: Addr# -> Addr# -> Int#+gtAddr# a1 a2 = GHC.Internal.Prim.gtAddr# a1 a2+{-# NOINLINE geAddr# #-}+geAddr# :: Addr# -> Addr# -> Int#+geAddr# a1 a2 = GHC.Internal.Prim.geAddr# a1 a2+{-# NOINLINE eqAddr# #-}+eqAddr# :: Addr# -> Addr# -> Int#+eqAddr# a1 a2 = GHC.Internal.Prim.eqAddr# a1 a2+{-# NOINLINE neAddr# #-}+neAddr# :: Addr# -> Addr# -> Int#+neAddr# a1 a2 = GHC.Internal.Prim.neAddr# a1 a2+{-# NOINLINE ltAddr# #-}+ltAddr# :: Addr# -> Addr# -> Int#+ltAddr# a1 a2 = GHC.Internal.Prim.ltAddr# a1 a2+{-# NOINLINE leAddr# #-}+leAddr# :: Addr# -> Addr# -> Int#+leAddr# a1 a2 = GHC.Internal.Prim.leAddr# a1 a2+{-# NOINLINE indexCharOffAddr# #-}+indexCharOffAddr# :: Addr# -> Int# -> Char#+indexCharOffAddr# a1 a2 = GHC.Internal.Prim.indexCharOffAddr# a1 a2+{-# NOINLINE indexWideCharOffAddr# #-}+indexWideCharOffAddr# :: Addr# -> Int# -> Char#+indexWideCharOffAddr# a1 a2 = GHC.Internal.Prim.indexWideCharOffAddr# a1 a2+{-# NOINLINE indexIntOffAddr# #-}+indexIntOffAddr# :: Addr# -> Int# -> Int#+indexIntOffAddr# a1 a2 = GHC.Internal.Prim.indexIntOffAddr# a1 a2+{-# NOINLINE indexWordOffAddr# #-}+indexWordOffAddr# :: Addr# -> Int# -> Word#+indexWordOffAddr# a1 a2 = GHC.Internal.Prim.indexWordOffAddr# a1 a2+{-# NOINLINE indexAddrOffAddr# #-}+indexAddrOffAddr# :: Addr# -> Int# -> Addr#+indexAddrOffAddr# a1 a2 = GHC.Internal.Prim.indexAddrOffAddr# a1 a2+{-# NOINLINE indexFloatOffAddr# #-}+indexFloatOffAddr# :: Addr# -> Int# -> Float#+indexFloatOffAddr# a1 a2 = GHC.Internal.Prim.indexFloatOffAddr# a1 a2+{-# NOINLINE indexDoubleOffAddr# #-}+indexDoubleOffAddr# :: Addr# -> Int# -> Double#+indexDoubleOffAddr# a1 a2 = GHC.Internal.Prim.indexDoubleOffAddr# a1 a2+{-# NOINLINE indexStablePtrOffAddr# #-}+indexStablePtrOffAddr# :: Addr# -> Int# -> StablePtr# a+indexStablePtrOffAddr# a1 a2 = GHC.Internal.Prim.indexStablePtrOffAddr# a1 a2+{-# NOINLINE indexInt8OffAddr# #-}+indexInt8OffAddr# :: Addr# -> Int# -> Int8#+indexInt8OffAddr# a1 a2 = GHC.Internal.Prim.indexInt8OffAddr# a1 a2+{-# NOINLINE indexWord8OffAddr# #-}+indexWord8OffAddr# :: Addr# -> Int# -> Word8#+indexWord8OffAddr# a1 a2 = GHC.Internal.Prim.indexWord8OffAddr# a1 a2+{-# NOINLINE indexInt16OffAddr# #-}+indexInt16OffAddr# :: Addr# -> Int# -> Int16#+indexInt16OffAddr# a1 a2 = GHC.Internal.Prim.indexInt16OffAddr# a1 a2+{-# NOINLINE indexWord16OffAddr# #-}+indexWord16OffAddr# :: Addr# -> Int# -> Word16#+indexWord16OffAddr# a1 a2 = GHC.Internal.Prim.indexWord16OffAddr# a1 a2+{-# NOINLINE indexInt32OffAddr# #-}+indexInt32OffAddr# :: Addr# -> Int# -> Int32#+indexInt32OffAddr# a1 a2 = GHC.Internal.Prim.indexInt32OffAddr# a1 a2+{-# NOINLINE indexWord32OffAddr# #-}+indexWord32OffAddr# :: Addr# -> Int# -> Word32#+indexWord32OffAddr# a1 a2 = GHC.Internal.Prim.indexWord32OffAddr# a1 a2+{-# NOINLINE indexInt64OffAddr# #-}+indexInt64OffAddr# :: Addr# -> Int# -> Int64#+indexInt64OffAddr# a1 a2 = GHC.Internal.Prim.indexInt64OffAddr# a1 a2+{-# NOINLINE indexWord64OffAddr# #-}+indexWord64OffAddr# :: Addr# -> Int# -> Word64#+indexWord64OffAddr# a1 a2 = GHC.Internal.Prim.indexWord64OffAddr# a1 a2+{-# NOINLINE indexWord8OffAddrAsChar# #-}+indexWord8OffAddrAsChar# :: Addr# -> Int# -> Char#+indexWord8OffAddrAsChar# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsChar# a1 a2+{-# NOINLINE indexWord8OffAddrAsWideChar# #-}+indexWord8OffAddrAsWideChar# :: Addr# -> Int# -> Char#+indexWord8OffAddrAsWideChar# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsWideChar# a1 a2+{-# NOINLINE indexWord8OffAddrAsInt# #-}+indexWord8OffAddrAsInt# :: Addr# -> Int# -> Int#+indexWord8OffAddrAsInt# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsInt# a1 a2+{-# NOINLINE indexWord8OffAddrAsWord# #-}+indexWord8OffAddrAsWord# :: Addr# -> Int# -> Word#+indexWord8OffAddrAsWord# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsWord# a1 a2+{-# NOINLINE indexWord8OffAddrAsAddr# #-}+indexWord8OffAddrAsAddr# :: Addr# -> Int# -> Addr#+indexWord8OffAddrAsAddr# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsAddr# a1 a2+{-# NOINLINE indexWord8OffAddrAsFloat# #-}+indexWord8OffAddrAsFloat# :: Addr# -> Int# -> Float#+indexWord8OffAddrAsFloat# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsFloat# a1 a2+{-# NOINLINE indexWord8OffAddrAsDouble# #-}+indexWord8OffAddrAsDouble# :: Addr# -> Int# -> Double#+indexWord8OffAddrAsDouble# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsDouble# a1 a2+{-# NOINLINE indexWord8OffAddrAsStablePtr# #-}+indexWord8OffAddrAsStablePtr# :: Addr# -> Int# -> StablePtr# a+indexWord8OffAddrAsStablePtr# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsStablePtr# a1 a2+{-# NOINLINE indexWord8OffAddrAsInt16# #-}+indexWord8OffAddrAsInt16# :: Addr# -> Int# -> Int16#+indexWord8OffAddrAsInt16# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsInt16# a1 a2+{-# NOINLINE indexWord8OffAddrAsWord16# #-}+indexWord8OffAddrAsWord16# :: Addr# -> Int# -> Word16#+indexWord8OffAddrAsWord16# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsWord16# a1 a2+{-# NOINLINE indexWord8OffAddrAsInt32# #-}+indexWord8OffAddrAsInt32# :: Addr# -> Int# -> Int32#+indexWord8OffAddrAsInt32# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsInt32# a1 a2+{-# NOINLINE indexWord8OffAddrAsWord32# #-}+indexWord8OffAddrAsWord32# :: Addr# -> Int# -> Word32#+indexWord8OffAddrAsWord32# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsWord32# a1 a2+{-# NOINLINE indexWord8OffAddrAsInt64# #-}+indexWord8OffAddrAsInt64# :: Addr# -> Int# -> Int64#+indexWord8OffAddrAsInt64# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsInt64# a1 a2+{-# NOINLINE indexWord8OffAddrAsWord64# #-}+indexWord8OffAddrAsWord64# :: Addr# -> Int# -> Word64#+indexWord8OffAddrAsWord64# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsWord64# a1 a2+{-# NOINLINE readCharOffAddr# #-}+readCharOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readCharOffAddr# a1 a2 a3 = GHC.Internal.Prim.readCharOffAddr# a1 a2 a3+{-# NOINLINE readWideCharOffAddr# #-}+readWideCharOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readWideCharOffAddr# a1 a2 a3 = GHC.Internal.Prim.readWideCharOffAddr# a1 a2 a3+{-# NOINLINE readIntOffAddr# #-}+readIntOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #)+readIntOffAddr# a1 a2 a3 = GHC.Internal.Prim.readIntOffAddr# a1 a2 a3+{-# NOINLINE readWordOffAddr# #-}+readWordOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #)+readWordOffAddr# a1 a2 a3 = GHC.Internal.Prim.readWordOffAddr# a1 a2 a3+{-# NOINLINE readAddrOffAddr# #-}+readAddrOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Addr# #)+readAddrOffAddr# a1 a2 a3 = GHC.Internal.Prim.readAddrOffAddr# a1 a2 a3+{-# NOINLINE readFloatOffAddr# #-}+readFloatOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Float# #)+readFloatOffAddr# a1 a2 a3 = GHC.Internal.Prim.readFloatOffAddr# a1 a2 a3+{-# NOINLINE readDoubleOffAddr# #-}+readDoubleOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Double# #)+readDoubleOffAddr# a1 a2 a3 = GHC.Internal.Prim.readDoubleOffAddr# a1 a2 a3+{-# NOINLINE readStablePtrOffAddr# #-}+readStablePtrOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,StablePtr# a #)+readStablePtrOffAddr# a1 a2 a3 = GHC.Internal.Prim.readStablePtrOffAddr# a1 a2 a3+{-# NOINLINE readInt8OffAddr# #-}+readInt8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int8# #)+readInt8OffAddr# a1 a2 a3 = GHC.Internal.Prim.readInt8OffAddr# a1 a2 a3+{-# NOINLINE readWord8OffAddr# #-}+readWord8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word8# #)+readWord8OffAddr# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddr# a1 a2 a3+{-# NOINLINE readInt16OffAddr# #-}+readInt16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int16# #)+readInt16OffAddr# a1 a2 a3 = GHC.Internal.Prim.readInt16OffAddr# a1 a2 a3+{-# NOINLINE readWord16OffAddr# #-}+readWord16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word16# #)+readWord16OffAddr# a1 a2 a3 = GHC.Internal.Prim.readWord16OffAddr# a1 a2 a3+{-# NOINLINE readInt32OffAddr# #-}+readInt32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int32# #)+readInt32OffAddr# a1 a2 a3 = GHC.Internal.Prim.readInt32OffAddr# a1 a2 a3+{-# NOINLINE readWord32OffAddr# #-}+readWord32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word32# #)+readWord32OffAddr# a1 a2 a3 = GHC.Internal.Prim.readWord32OffAddr# a1 a2 a3+{-# NOINLINE readInt64OffAddr# #-}+readInt64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int64# #)+readInt64OffAddr# a1 a2 a3 = GHC.Internal.Prim.readInt64OffAddr# a1 a2 a3+{-# NOINLINE readWord64OffAddr# #-}+readWord64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word64# #)+readWord64OffAddr# a1 a2 a3 = GHC.Internal.Prim.readWord64OffAddr# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsChar# #-}+readWord8OffAddrAsChar# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readWord8OffAddrAsChar# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsChar# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsWideChar# #-}+readWord8OffAddrAsWideChar# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readWord8OffAddrAsWideChar# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsWideChar# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsInt# #-}+readWord8OffAddrAsInt# :: Addr# -> Int# -> State# s -> (# State# s,Int# #)+readWord8OffAddrAsInt# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsInt# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsWord# #-}+readWord8OffAddrAsWord# :: Addr# -> Int# -> State# s -> (# State# s,Word# #)+readWord8OffAddrAsWord# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsWord# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsAddr# #-}+readWord8OffAddrAsAddr# :: Addr# -> Int# -> State# s -> (# State# s,Addr# #)+readWord8OffAddrAsAddr# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsAddr# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsFloat# #-}+readWord8OffAddrAsFloat# :: Addr# -> Int# -> State# s -> (# State# s,Float# #)+readWord8OffAddrAsFloat# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsFloat# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsDouble# #-}+readWord8OffAddrAsDouble# :: Addr# -> Int# -> State# s -> (# State# s,Double# #)+readWord8OffAddrAsDouble# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsDouble# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsStablePtr# #-}+readWord8OffAddrAsStablePtr# :: Addr# -> Int# -> State# s -> (# State# s,StablePtr# a #)+readWord8OffAddrAsStablePtr# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsStablePtr# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsInt16# #-}+readWord8OffAddrAsInt16# :: Addr# -> Int# -> State# s -> (# State# s,Int16# #)+readWord8OffAddrAsInt16# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsInt16# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsWord16# #-}+readWord8OffAddrAsWord16# :: Addr# -> Int# -> State# s -> (# State# s,Word16# #)+readWord8OffAddrAsWord16# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsWord16# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsInt32# #-}+readWord8OffAddrAsInt32# :: Addr# -> Int# -> State# s -> (# State# s,Int32# #)+readWord8OffAddrAsInt32# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsInt32# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsWord32# #-}+readWord8OffAddrAsWord32# :: Addr# -> Int# -> State# s -> (# State# s,Word32# #)+readWord8OffAddrAsWord32# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsWord32# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsInt64# #-}+readWord8OffAddrAsInt64# :: Addr# -> Int# -> State# s -> (# State# s,Int64# #)+readWord8OffAddrAsInt64# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsInt64# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsWord64# #-}+readWord8OffAddrAsWord64# :: Addr# -> Int# -> State# s -> (# State# s,Word64# #)+readWord8OffAddrAsWord64# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsWord64# a1 a2 a3+{-# NOINLINE writeCharOffAddr# #-}+writeCharOffAddr# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeCharOffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeCharOffAddr# a1 a2 a3 a4+{-# NOINLINE writeWideCharOffAddr# #-}+writeWideCharOffAddr# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeWideCharOffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWideCharOffAddr# a1 a2 a3 a4+{-# NOINLINE writeIntOffAddr# #-}+writeIntOffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeIntOffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeIntOffAddr# a1 a2 a3 a4+{-# NOINLINE writeWordOffAddr# #-}+writeWordOffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWordOffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWordOffAddr# a1 a2 a3 a4+{-# NOINLINE writeAddrOffAddr# #-}+writeAddrOffAddr# :: Addr# -> Int# -> Addr# -> State# s -> State# s+writeAddrOffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeAddrOffAddr# a1 a2 a3 a4+{-# NOINLINE writeFloatOffAddr# #-}+writeFloatOffAddr# :: Addr# -> Int# -> Float# -> State# s -> State# s+writeFloatOffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeFloatOffAddr# a1 a2 a3 a4+{-# NOINLINE writeDoubleOffAddr# #-}+writeDoubleOffAddr# :: Addr# -> Int# -> Double# -> State# s -> State# s+writeDoubleOffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeDoubleOffAddr# a1 a2 a3 a4+{-# NOINLINE writeStablePtrOffAddr# #-}+writeStablePtrOffAddr# :: Addr# -> Int# -> StablePtr# a -> State# s -> State# s+writeStablePtrOffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeStablePtrOffAddr# a1 a2 a3 a4+{-# NOINLINE writeInt8OffAddr# #-}+writeInt8OffAddr# :: Addr# -> Int# -> Int8# -> State# s -> State# s+writeInt8OffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeInt8OffAddr# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddr# #-}+writeWord8OffAddr# :: Addr# -> Int# -> Word8# -> State# s -> State# s+writeWord8OffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddr# a1 a2 a3 a4+{-# NOINLINE writeInt16OffAddr# #-}+writeInt16OffAddr# :: Addr# -> Int# -> Int16# -> State# s -> State# s+writeInt16OffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeInt16OffAddr# a1 a2 a3 a4+{-# NOINLINE writeWord16OffAddr# #-}+writeWord16OffAddr# :: Addr# -> Int# -> Word16# -> State# s -> State# s+writeWord16OffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord16OffAddr# a1 a2 a3 a4+{-# NOINLINE writeInt32OffAddr# #-}+writeInt32OffAddr# :: Addr# -> Int# -> Int32# -> State# s -> State# s+writeInt32OffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeInt32OffAddr# a1 a2 a3 a4+{-# NOINLINE writeWord32OffAddr# #-}+writeWord32OffAddr# :: Addr# -> Int# -> Word32# -> State# s -> State# s+writeWord32OffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord32OffAddr# a1 a2 a3 a4+{-# NOINLINE writeInt64OffAddr# #-}+writeInt64OffAddr# :: Addr# -> Int# -> Int64# -> State# s -> State# s+writeInt64OffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeInt64OffAddr# a1 a2 a3 a4+{-# NOINLINE writeWord64OffAddr# #-}+writeWord64OffAddr# :: Addr# -> Int# -> Word64# -> State# s -> State# s+writeWord64OffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord64OffAddr# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsChar# #-}+writeWord8OffAddrAsChar# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeWord8OffAddrAsChar# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsChar# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsWideChar# #-}+writeWord8OffAddrAsWideChar# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeWord8OffAddrAsWideChar# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsWideChar# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsInt# #-}+writeWord8OffAddrAsInt# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeWord8OffAddrAsInt# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsInt# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsWord# #-}+writeWord8OffAddrAsWord# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWord8OffAddrAsWord# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsWord# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsAddr# #-}+writeWord8OffAddrAsAddr# :: Addr# -> Int# -> Addr# -> State# s -> State# s+writeWord8OffAddrAsAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsAddr# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsFloat# #-}+writeWord8OffAddrAsFloat# :: Addr# -> Int# -> Float# -> State# s -> State# s+writeWord8OffAddrAsFloat# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsFloat# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsDouble# #-}+writeWord8OffAddrAsDouble# :: Addr# -> Int# -> Double# -> State# s -> State# s+writeWord8OffAddrAsDouble# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsDouble# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsStablePtr# #-}+writeWord8OffAddrAsStablePtr# :: Addr# -> Int# -> StablePtr# a -> State# s -> State# s+writeWord8OffAddrAsStablePtr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsStablePtr# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsInt16# #-}+writeWord8OffAddrAsInt16# :: Addr# -> Int# -> Int16# -> State# s -> State# s+writeWord8OffAddrAsInt16# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsInt16# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsWord16# #-}+writeWord8OffAddrAsWord16# :: Addr# -> Int# -> Word16# -> State# s -> State# s+writeWord8OffAddrAsWord16# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsWord16# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsInt32# #-}+writeWord8OffAddrAsInt32# :: Addr# -> Int# -> Int32# -> State# s -> State# s+writeWord8OffAddrAsInt32# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsInt32# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsWord32# #-}+writeWord8OffAddrAsWord32# :: Addr# -> Int# -> Word32# -> State# s -> State# s+writeWord8OffAddrAsWord32# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsWord32# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsInt64# #-}+writeWord8OffAddrAsInt64# :: Addr# -> Int# -> Int64# -> State# s -> State# s+writeWord8OffAddrAsInt64# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsInt64# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsWord64# #-}+writeWord8OffAddrAsWord64# :: Addr# -> Int# -> Word64# -> State# s -> State# s+writeWord8OffAddrAsWord64# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsWord64# a1 a2 a3 a4+{-# NOINLINE atomicExchangeAddrAddr# #-}+atomicExchangeAddrAddr# :: Addr# -> Addr# -> State# s -> (# State# s,Addr# #)+atomicExchangeAddrAddr# a1 a2 a3 = GHC.Internal.Prim.atomicExchangeAddrAddr# a1 a2 a3+{-# NOINLINE atomicExchangeWordAddr# #-}+atomicExchangeWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+atomicExchangeWordAddr# a1 a2 a3 = GHC.Internal.Prim.atomicExchangeWordAddr# a1 a2 a3+{-# NOINLINE atomicCasAddrAddr# #-}+atomicCasAddrAddr# :: Addr# -> Addr# -> Addr# -> State# s -> (# State# s,Addr# #)+atomicCasAddrAddr# a1 a2 a3 a4 = GHC.Internal.Prim.atomicCasAddrAddr# a1 a2 a3 a4+{-# NOINLINE atomicCasWordAddr# #-}+atomicCasWordAddr# :: Addr# -> Word# -> Word# -> State# s -> (# State# s,Word# #)+atomicCasWordAddr# a1 a2 a3 a4 = GHC.Internal.Prim.atomicCasWordAddr# a1 a2 a3 a4+{-# NOINLINE atomicCasWord8Addr# #-}+atomicCasWord8Addr# :: Addr# -> Word8# -> Word8# -> State# s -> (# State# s,Word8# #)+atomicCasWord8Addr# a1 a2 a3 a4 = GHC.Internal.Prim.atomicCasWord8Addr# a1 a2 a3 a4+{-# NOINLINE atomicCasWord16Addr# #-}+atomicCasWord16Addr# :: Addr# -> Word16# -> Word16# -> State# s -> (# State# s,Word16# #)+atomicCasWord16Addr# a1 a2 a3 a4 = GHC.Internal.Prim.atomicCasWord16Addr# a1 a2 a3 a4+{-# NOINLINE atomicCasWord32Addr# #-}+atomicCasWord32Addr# :: Addr# -> Word32# -> Word32# -> State# s -> (# State# s,Word32# #)+atomicCasWord32Addr# a1 a2 a3 a4 = GHC.Internal.Prim.atomicCasWord32Addr# a1 a2 a3 a4+{-# NOINLINE atomicCasWord64Addr# #-}+atomicCasWord64Addr# :: Addr# -> Word64# -> Word64# -> State# s -> (# State# s,Word64# #)+atomicCasWord64Addr# a1 a2 a3 a4 = GHC.Internal.Prim.atomicCasWord64Addr# a1 a2 a3 a4+{-# NOINLINE fetchAddWordAddr# #-}+fetchAddWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchAddWordAddr# a1 a2 a3 = GHC.Internal.Prim.fetchAddWordAddr# a1 a2 a3+{-# NOINLINE fetchSubWordAddr# #-}+fetchSubWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchSubWordAddr# a1 a2 a3 = GHC.Internal.Prim.fetchSubWordAddr# a1 a2 a3+{-# NOINLINE fetchAndWordAddr# #-}+fetchAndWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchAndWordAddr# a1 a2 a3 = GHC.Internal.Prim.fetchAndWordAddr# a1 a2 a3+{-# NOINLINE fetchNandWordAddr# #-}+fetchNandWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchNandWordAddr# a1 a2 a3 = GHC.Internal.Prim.fetchNandWordAddr# a1 a2 a3+{-# NOINLINE fetchOrWordAddr# #-}+fetchOrWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchOrWordAddr# a1 a2 a3 = GHC.Internal.Prim.fetchOrWordAddr# a1 a2 a3+{-# NOINLINE fetchXorWordAddr# #-}+fetchXorWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchXorWordAddr# a1 a2 a3 = GHC.Internal.Prim.fetchXorWordAddr# a1 a2 a3+{-# NOINLINE atomicReadWordAddr# #-}+atomicReadWordAddr# :: Addr# -> State# s -> (# State# s,Word# #)+atomicReadWordAddr# a1 a2 = GHC.Internal.Prim.atomicReadWordAddr# a1 a2+{-# NOINLINE atomicWriteWordAddr# #-}+atomicWriteWordAddr# :: Addr# -> Word# -> State# s -> State# s+atomicWriteWordAddr# a1 a2 a3 = GHC.Internal.Prim.atomicWriteWordAddr# a1 a2 a3+{-# NOINLINE newMutVar# #-}+newMutVar# :: a_levpoly -> State# s -> (# State# s,MutVar# s a_levpoly #)+newMutVar# a1 a2 = GHC.Internal.Prim.newMutVar# a1 a2+{-# NOINLINE readMutVar# #-}+readMutVar# :: MutVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+readMutVar# a1 a2 = GHC.Internal.Prim.readMutVar# a1 a2+{-# NOINLINE writeMutVar# #-}+writeMutVar# :: MutVar# s a_levpoly -> a_levpoly -> State# s -> State# s+writeMutVar# a1 a2 a3 = GHC.Internal.Prim.writeMutVar# a1 a2 a3+{-# NOINLINE atomicSwapMutVar# #-}+atomicSwapMutVar# :: MutVar# s a_levpoly -> a_levpoly -> State# s -> (# State# s,a_levpoly #)+atomicSwapMutVar# a1 a2 a3 = GHC.Internal.Prim.atomicSwapMutVar# a1 a2 a3+{-# NOINLINE atomicModifyMutVar2# #-}+atomicModifyMutVar2# :: MutVar# s a -> (a -> c) -> State# s -> (# State# s,a,c #)+atomicModifyMutVar2# a1 a2 a3 = GHC.Internal.Prim.atomicModifyMutVar2# a1 a2 a3+{-# NOINLINE atomicModifyMutVar_# #-}+atomicModifyMutVar_# :: MutVar# s a -> (a -> a) -> State# s -> (# State# s,a,a #)+atomicModifyMutVar_# a1 a2 a3 = GHC.Internal.Prim.atomicModifyMutVar_# a1 a2 a3+{-# NOINLINE casMutVar# #-}+casMutVar# :: MutVar# s a_levpoly -> a_levpoly -> a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+casMutVar# a1 a2 a3 a4 = GHC.Internal.Prim.casMutVar# a1 a2 a3 a4+{-# NOINLINE catch# #-}+catch# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> (b_levpoly -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)+catch# a1 a2 a3 = GHC.Internal.Prim.catch# a1 a2 a3+{-# NOINLINE raise# #-}+raise# :: a_levpoly -> b_reppoly+raise# a1 = GHC.Internal.Prim.raise# a1+{-# NOINLINE raiseUnderflow# #-}+raiseUnderflow# :: (#  #) -> b_reppoly+raiseUnderflow# a1 = GHC.Internal.Prim.raiseUnderflow# a1+{-# NOINLINE raiseOverflow# #-}+raiseOverflow# :: (#  #) -> b_reppoly+raiseOverflow# a1 = GHC.Internal.Prim.raiseOverflow# a1+{-# NOINLINE raiseDivZero# #-}+raiseDivZero# :: (#  #) -> b_reppoly+raiseDivZero# a1 = GHC.Internal.Prim.raiseDivZero# a1+{-# NOINLINE raiseIO# #-}+raiseIO# :: a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),b_reppoly #)+raiseIO# a1 a2 = GHC.Internal.Prim.raiseIO# a1 a2+{-# NOINLINE maskAsyncExceptions# #-}+maskAsyncExceptions# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)+maskAsyncExceptions# a1 a2 = GHC.Internal.Prim.maskAsyncExceptions# a1 a2+{-# NOINLINE maskUninterruptible# #-}+maskUninterruptible# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)+maskUninterruptible# a1 a2 = GHC.Internal.Prim.maskUninterruptible# a1 a2+{-# NOINLINE unmaskAsyncExceptions# #-}+unmaskAsyncExceptions# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)+unmaskAsyncExceptions# a1 a2 = GHC.Internal.Prim.unmaskAsyncExceptions# a1 a2+{-# NOINLINE getMaskingState# #-}+getMaskingState# :: State# (RealWorld) -> (# State# (RealWorld),Int# #)+getMaskingState# a1 = GHC.Internal.Prim.getMaskingState# a1+{-# NOINLINE newPromptTag# #-}+newPromptTag# :: State# (RealWorld) -> (# State# (RealWorld),PromptTag# a #)+newPromptTag# a1 = GHC.Internal.Prim.newPromptTag# a1+{-# NOINLINE prompt# #-}+prompt# :: PromptTag# a -> (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)+prompt# a1 a2 a3 = GHC.Internal.Prim.prompt# a1 a2 a3+{-# NOINLINE control0# #-}+control0# :: PromptTag# a -> (((State# (RealWorld) -> (# State# (RealWorld),b_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),b_reppoly #)+control0# a1 a2 a3 = GHC.Internal.Prim.control0# a1 a2 a3+{-# NOINLINE atomically# #-}+atomically# :: (State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+atomically# a1 a2 = GHC.Internal.Prim.atomically# a1 a2+{-# NOINLINE retry# #-}+retry# :: State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+retry# a1 = GHC.Internal.Prim.retry# a1+{-# NOINLINE catchRetry# #-}+catchRetry# :: (State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> (State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+catchRetry# a1 a2 a3 = GHC.Internal.Prim.catchRetry# a1 a2 a3+{-# NOINLINE catchSTM# #-}+catchSTM# :: (State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> (b -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+catchSTM# a1 a2 a3 = GHC.Internal.Prim.catchSTM# a1 a2 a3+{-# NOINLINE newTVar# #-}+newTVar# :: a_levpoly -> State# s -> (# State# s,TVar# s a_levpoly #)+newTVar# a1 a2 = GHC.Internal.Prim.newTVar# a1 a2+{-# NOINLINE readTVar# #-}+readTVar# :: TVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+readTVar# a1 a2 = GHC.Internal.Prim.readTVar# a1 a2+{-# NOINLINE readTVarIO# #-}+readTVarIO# :: TVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+readTVarIO# a1 a2 = GHC.Internal.Prim.readTVarIO# a1 a2+{-# NOINLINE writeTVar# #-}+writeTVar# :: TVar# s a_levpoly -> a_levpoly -> State# s -> State# s+writeTVar# a1 a2 a3 = GHC.Internal.Prim.writeTVar# a1 a2 a3+{-# NOINLINE newMVar# #-}+newMVar# :: State# s -> (# State# s,MVar# s a_levpoly #)+newMVar# a1 = GHC.Internal.Prim.newMVar# a1+{-# NOINLINE takeMVar# #-}+takeMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+takeMVar# a1 a2 = GHC.Internal.Prim.takeMVar# a1 a2+{-# NOINLINE tryTakeMVar# #-}+tryTakeMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+tryTakeMVar# a1 a2 = GHC.Internal.Prim.tryTakeMVar# a1 a2+{-# NOINLINE putMVar# #-}+putMVar# :: MVar# s a_levpoly -> a_levpoly -> State# s -> State# s+putMVar# a1 a2 a3 = GHC.Internal.Prim.putMVar# a1 a2 a3+{-# NOINLINE tryPutMVar# #-}+tryPutMVar# :: MVar# s a_levpoly -> a_levpoly -> State# s -> (# State# s,Int# #)+tryPutMVar# a1 a2 a3 = GHC.Internal.Prim.tryPutMVar# a1 a2 a3+{-# NOINLINE readMVar# #-}+readMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+readMVar# a1 a2 = GHC.Internal.Prim.readMVar# a1 a2+{-# NOINLINE tryReadMVar# #-}+tryReadMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+tryReadMVar# a1 a2 = GHC.Internal.Prim.tryReadMVar# a1 a2+{-# NOINLINE isEmptyMVar# #-}+isEmptyMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,Int# #)+isEmptyMVar# a1 a2 = GHC.Internal.Prim.isEmptyMVar# a1 a2+{-# NOINLINE delay# #-}+delay# :: Int# -> State# s -> State# s+delay# a1 a2 = GHC.Internal.Prim.delay# a1 a2+{-# NOINLINE waitRead# #-}+waitRead# :: Int# -> State# s -> State# s+waitRead# a1 a2 = GHC.Internal.Prim.waitRead# a1 a2+{-# NOINLINE waitWrite# #-}+waitWrite# :: Int# -> State# s -> State# s+waitWrite# a1 a2 = GHC.Internal.Prim.waitWrite# a1 a2+{-# NOINLINE fork# #-}+fork# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),ThreadId# #)+fork# a1 a2 = GHC.Internal.Prim.fork# a1 a2+{-# NOINLINE forkOn# #-}+forkOn# :: Int# -> (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),ThreadId# #)+forkOn# a1 a2 a3 = GHC.Internal.Prim.forkOn# a1 a2 a3+{-# NOINLINE killThread# #-}+killThread# :: ThreadId# -> a -> State# (RealWorld) -> State# (RealWorld)+killThread# a1 a2 a3 = GHC.Internal.Prim.killThread# a1 a2 a3+{-# NOINLINE yield# #-}+yield# :: State# (RealWorld) -> State# (RealWorld)+yield# a1 = GHC.Internal.Prim.yield# a1+{-# NOINLINE myThreadId# #-}+myThreadId# :: State# (RealWorld) -> (# State# (RealWorld),ThreadId# #)+myThreadId# a1 = GHC.Internal.Prim.myThreadId# a1+{-# NOINLINE labelThread# #-}+labelThread# :: ThreadId# -> ByteArray# -> State# (RealWorld) -> State# (RealWorld)+labelThread# a1 a2 a3 = GHC.Internal.Prim.labelThread# a1 a2 a3+{-# NOINLINE isCurrentThreadBound# #-}+isCurrentThreadBound# :: State# (RealWorld) -> (# State# (RealWorld),Int# #)+isCurrentThreadBound# a1 = GHC.Internal.Prim.isCurrentThreadBound# a1+{-# NOINLINE noDuplicate# #-}+noDuplicate# :: State# s -> State# s+noDuplicate# a1 = GHC.Internal.Prim.noDuplicate# a1+{-# NOINLINE threadLabel# #-}+threadLabel# :: ThreadId# -> State# (RealWorld) -> (# State# (RealWorld),Int#,ByteArray# #)+threadLabel# a1 a2 = GHC.Internal.Prim.threadLabel# a1 a2+{-# NOINLINE threadStatus# #-}+threadStatus# :: ThreadId# -> State# (RealWorld) -> (# State# (RealWorld),Int#,Int#,Int# #)+threadStatus# a1 a2 = GHC.Internal.Prim.threadStatus# a1 a2+{-# NOINLINE listThreads# #-}+listThreads# :: State# (RealWorld) -> (# State# (RealWorld),Array# (ThreadId#) #)+listThreads# a1 = GHC.Internal.Prim.listThreads# a1+{-# NOINLINE mkWeak# #-}+mkWeak# :: a_levpoly -> b_levpoly -> (State# (RealWorld) -> (# State# (RealWorld),c #)) -> State# (RealWorld) -> (# State# (RealWorld),Weak# b_levpoly #)+mkWeak# a1 a2 a3 a4 = GHC.Internal.Prim.mkWeak# a1 a2 a3 a4+{-# NOINLINE mkWeakNoFinalizer# #-}+mkWeakNoFinalizer# :: a_levpoly -> b_levpoly -> State# (RealWorld) -> (# State# (RealWorld),Weak# b_levpoly #)+mkWeakNoFinalizer# a1 a2 a3 = GHC.Internal.Prim.mkWeakNoFinalizer# a1 a2 a3+{-# NOINLINE addCFinalizerToWeak# #-}+addCFinalizerToWeak# :: Addr# -> Addr# -> Int# -> Addr# -> Weak# b_levpoly -> State# (RealWorld) -> (# State# (RealWorld),Int# #)+addCFinalizerToWeak# a1 a2 a3 a4 a5 a6 = GHC.Internal.Prim.addCFinalizerToWeak# a1 a2 a3 a4 a5 a6+{-# NOINLINE deRefWeak# #-}+deRefWeak# :: Weak# a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),Int#,a_levpoly #)+deRefWeak# a1 a2 = GHC.Internal.Prim.deRefWeak# a1 a2+{-# NOINLINE finalizeWeak# #-}+finalizeWeak# :: Weak# a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),Int#,State# (RealWorld) -> (# State# (RealWorld),b #) #)+finalizeWeak# a1 a2 = GHC.Internal.Prim.finalizeWeak# a1 a2+{-# NOINLINE touch# #-}+touch# :: a_levpoly -> State# s -> State# s+touch# a1 a2 = GHC.Internal.Prim.touch# a1 a2+{-# NOINLINE makeStablePtr# #-}+makeStablePtr# :: a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),StablePtr# a_levpoly #)+makeStablePtr# a1 a2 = GHC.Internal.Prim.makeStablePtr# a1 a2+{-# NOINLINE deRefStablePtr# #-}+deRefStablePtr# :: StablePtr# a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+deRefStablePtr# a1 a2 = GHC.Internal.Prim.deRefStablePtr# a1 a2+{-# NOINLINE eqStablePtr# #-}+eqStablePtr# :: StablePtr# a_levpoly -> StablePtr# a_levpoly -> Int#+eqStablePtr# a1 a2 = GHC.Internal.Prim.eqStablePtr# a1 a2+{-# NOINLINE makeStableName# #-}+makeStableName# :: a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),StableName# a_levpoly #)+makeStableName# a1 a2 = GHC.Internal.Prim.makeStableName# a1 a2+{-# NOINLINE stableNameToInt# #-}+stableNameToInt# :: StableName# a_levpoly -> Int#+stableNameToInt# a1 = GHC.Internal.Prim.stableNameToInt# a1+{-# NOINLINE compactNew# #-}+compactNew# :: Word# -> State# (RealWorld) -> (# State# (RealWorld),Compact# #)+compactNew# a1 a2 = GHC.Internal.Prim.compactNew# a1 a2+{-# NOINLINE compactResize# #-}+compactResize# :: Compact# -> Word# -> State# (RealWorld) -> State# (RealWorld)+compactResize# a1 a2 a3 = GHC.Internal.Prim.compactResize# a1 a2 a3+{-# NOINLINE compactContains# #-}+compactContains# :: Compact# -> a -> State# (RealWorld) -> (# State# (RealWorld),Int# #)+compactContains# a1 a2 a3 = GHC.Internal.Prim.compactContains# a1 a2 a3+{-# NOINLINE compactContainsAny# #-}+compactContainsAny# :: a -> State# (RealWorld) -> (# State# (RealWorld),Int# #)+compactContainsAny# a1 a2 = GHC.Internal.Prim.compactContainsAny# a1 a2+{-# NOINLINE compactGetFirstBlock# #-}+compactGetFirstBlock# :: Compact# -> State# (RealWorld) -> (# State# (RealWorld),Addr#,Word# #)+compactGetFirstBlock# a1 a2 = GHC.Internal.Prim.compactGetFirstBlock# a1 a2+{-# NOINLINE compactGetNextBlock# #-}+compactGetNextBlock# :: Compact# -> Addr# -> State# (RealWorld) -> (# State# (RealWorld),Addr#,Word# #)+compactGetNextBlock# a1 a2 a3 = GHC.Internal.Prim.compactGetNextBlock# a1 a2 a3+{-# NOINLINE compactAllocateBlock# #-}+compactAllocateBlock# :: Word# -> Addr# -> State# (RealWorld) -> (# State# (RealWorld),Addr# #)+compactAllocateBlock# a1 a2 a3 = GHC.Internal.Prim.compactAllocateBlock# a1 a2 a3+{-# NOINLINE compactFixupPointers# #-}+compactFixupPointers# :: Addr# -> Addr# -> State# (RealWorld) -> (# State# (RealWorld),Compact#,Addr# #)+compactFixupPointers# a1 a2 a3 = GHC.Internal.Prim.compactFixupPointers# a1 a2 a3+{-# NOINLINE compactAdd# #-}+compactAdd# :: Compact# -> a -> State# (RealWorld) -> (# State# (RealWorld),a #)+compactAdd# a1 a2 a3 = GHC.Internal.Prim.compactAdd# a1 a2 a3+{-# NOINLINE compactAddWithSharing# #-}+compactAddWithSharing# :: Compact# -> a -> State# (RealWorld) -> (# State# (RealWorld),a #)+compactAddWithSharing# a1 a2 a3 = GHC.Internal.Prim.compactAddWithSharing# a1 a2 a3+{-# NOINLINE compactSize# #-}+compactSize# :: Compact# -> State# (RealWorld) -> (# State# (RealWorld),Word# #)+compactSize# a1 a2 = GHC.Internal.Prim.compactSize# a1 a2+{-# NOINLINE reallyUnsafePtrEquality# #-}+reallyUnsafePtrEquality# :: a_levpoly -> b_levpoly -> Int#+reallyUnsafePtrEquality# a1 a2 = GHC.Internal.Prim.reallyUnsafePtrEquality# a1 a2+{-# NOINLINE par# #-}+par# :: a -> Int#+par# a1 = GHC.Internal.Prim.par# a1+{-# NOINLINE spark# #-}+spark# :: a -> State# s -> (# State# s,a #)+spark# a1 a2 = GHC.Internal.Prim.spark# a1 a2+{-# NOINLINE getSpark# #-}+getSpark# :: State# s -> (# State# s,Int#,a #)+getSpark# a1 = GHC.Internal.Prim.getSpark# a1+{-# NOINLINE numSparks# #-}+numSparks# :: State# s -> (# State# s,Int# #)+numSparks# a1 = GHC.Internal.Prim.numSparks# a1+{-# NOINLINE keepAlive# #-}+keepAlive# :: a_levpoly -> State# s -> (State# s -> b_reppoly) -> b_reppoly+keepAlive# a1 a2 a3 = GHC.Internal.Prim.keepAlive# a1 a2 a3+{-# NOINLINE dataToTagSmall# #-}+dataToTagSmall# :: a_levpoly -> Int#+dataToTagSmall# a1 = GHC.Internal.Prim.dataToTagSmall# a1+{-# NOINLINE dataToTagLarge# #-}+dataToTagLarge# :: a_levpoly -> Int#+dataToTagLarge# a1 = GHC.Internal.Prim.dataToTagLarge# a1+{-# NOINLINE addrToAny# #-}+addrToAny# :: Addr# -> (# a_levpoly #)+addrToAny# a1 = GHC.Internal.Prim.addrToAny# a1+{-# NOINLINE anyToAddr# #-}+anyToAddr# :: a -> State# (RealWorld) -> (# State# (RealWorld),Addr# #)+anyToAddr# a1 a2 = GHC.Internal.Prim.anyToAddr# a1 a2+{-# NOINLINE mkApUpd0# #-}+mkApUpd0# :: BCO -> (# a #)+mkApUpd0# a1 = GHC.Internal.Prim.mkApUpd0# a1+{-# NOINLINE newBCO# #-}+newBCO# :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s,BCO #)+newBCO# a1 a2 a3 a4 a5 a6 = GHC.Internal.Prim.newBCO# a1 a2 a3 a4 a5 a6+{-# NOINLINE unpackClosure# #-}+unpackClosure# :: a -> (# Addr#,ByteArray#,Array# b #)+unpackClosure# a1 = GHC.Internal.Prim.unpackClosure# a1+{-# NOINLINE closureSize# #-}+closureSize# :: a -> Int#+closureSize# a1 = GHC.Internal.Prim.closureSize# a1+{-# NOINLINE getApStackVal# #-}+getApStackVal# :: a -> Int# -> (# Int#,b #)+getApStackVal# a1 a2 = GHC.Internal.Prim.getApStackVal# a1 a2+{-# NOINLINE getCCSOf# #-}+getCCSOf# :: a -> State# s -> (# State# s,Addr# #)+getCCSOf# a1 a2 = GHC.Internal.Prim.getCCSOf# a1 a2+{-# NOINLINE getCurrentCCS# #-}+getCurrentCCS# :: a -> State# s -> (# State# s,Addr# #)+getCurrentCCS# a1 a2 = GHC.Internal.Prim.getCurrentCCS# a1 a2+{-# NOINLINE clearCCS# #-}+clearCCS# :: (State# s -> (# State# s,a #)) -> State# s -> (# State# s,a #)+clearCCS# a1 a2 = GHC.Internal.Prim.clearCCS# a1 a2+{-# NOINLINE annotateStack# #-}+annotateStack# :: b -> (State# s -> (# State# s,a_reppoly #)) -> State# s -> (# State# s,a_reppoly #)+annotateStack# a1 a2 a3 = GHC.Internal.Prim.annotateStack# a1 a2 a3+{-# NOINLINE whereFrom# #-}+whereFrom# :: a -> Addr# -> State# s -> (# State# s,Int# #)+whereFrom# a1 a2 a3 = GHC.Internal.Prim.whereFrom# a1 a2 a3+{-# NOINLINE traceEvent# #-}+traceEvent# :: Addr# -> State# s -> State# s+traceEvent# a1 a2 = GHC.Internal.Prim.traceEvent# a1 a2+{-# NOINLINE traceBinaryEvent# #-}+traceBinaryEvent# :: Addr# -> Int# -> State# s -> State# s+traceBinaryEvent# a1 a2 a3 = GHC.Internal.Prim.traceBinaryEvent# a1 a2 a3+{-# NOINLINE traceMarker# #-}+traceMarker# :: Addr# -> State# s -> State# s+traceMarker# a1 a2 = GHC.Internal.Prim.traceMarker# a1 a2+{-# NOINLINE setThreadAllocationCounter# #-}+setThreadAllocationCounter# :: Int64# -> State# (RealWorld) -> State# (RealWorld)+setThreadAllocationCounter# a1 a2 = GHC.Internal.Prim.setThreadAllocationCounter# a1 a2+{-# NOINLINE setOtherThreadAllocationCounter# #-}+setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# (RealWorld) -> State# (RealWorld)+setOtherThreadAllocationCounter# a1 a2 a3 = GHC.Internal.Prim.setOtherThreadAllocationCounter# a1 a2 a3+{-# NOINLINE prefetchByteArray3# #-}+prefetchByteArray3# :: ByteArray# -> Int# -> State# s -> State# s+prefetchByteArray3# a1 a2 a3 = GHC.Internal.Prim.prefetchByteArray3# a1 a2 a3+{-# NOINLINE prefetchMutableByteArray3# #-}+prefetchMutableByteArray3# :: MutableByteArray# s -> Int# -> State# s -> State# s+prefetchMutableByteArray3# a1 a2 a3 = GHC.Internal.Prim.prefetchMutableByteArray3# a1 a2 a3+{-# NOINLINE prefetchAddr3# #-}+prefetchAddr3# :: Addr# -> Int# -> State# s -> State# s+prefetchAddr3# a1 a2 a3 = GHC.Internal.Prim.prefetchAddr3# a1 a2 a3+{-# NOINLINE prefetchValue3# #-}+prefetchValue3# :: a -> State# s -> State# s+prefetchValue3# a1 a2 = GHC.Internal.Prim.prefetchValue3# a1 a2+{-# NOINLINE prefetchByteArray2# #-}+prefetchByteArray2# :: ByteArray# -> Int# -> State# s -> State# s+prefetchByteArray2# a1 a2 a3 = GHC.Internal.Prim.prefetchByteArray2# a1 a2 a3+{-# NOINLINE prefetchMutableByteArray2# #-}+prefetchMutableByteArray2# :: MutableByteArray# s -> Int# -> State# s -> State# s+prefetchMutableByteArray2# a1 a2 a3 = GHC.Internal.Prim.prefetchMutableByteArray2# a1 a2 a3+{-# NOINLINE prefetchAddr2# #-}+prefetchAddr2# :: Addr# -> Int# -> State# s -> State# s+prefetchAddr2# a1 a2 a3 = GHC.Internal.Prim.prefetchAddr2# a1 a2 a3+{-# NOINLINE prefetchValue2# #-}+prefetchValue2# :: a -> State# s -> State# s+prefetchValue2# a1 a2 = GHC.Internal.Prim.prefetchValue2# a1 a2+{-# NOINLINE prefetchByteArray1# #-}+prefetchByteArray1# :: ByteArray# -> Int# -> State# s -> State# s+prefetchByteArray1# a1 a2 a3 = GHC.Internal.Prim.prefetchByteArray1# a1 a2 a3+{-# NOINLINE prefetchMutableByteArray1# #-}+prefetchMutableByteArray1# :: MutableByteArray# s -> Int# -> State# s -> State# s+prefetchMutableByteArray1# a1 a2 a3 = GHC.Internal.Prim.prefetchMutableByteArray1# a1 a2 a3+{-# NOINLINE prefetchAddr1# #-}+prefetchAddr1# :: Addr# -> Int# -> State# s -> State# s+prefetchAddr1# a1 a2 a3 = GHC.Internal.Prim.prefetchAddr1# a1 a2 a3+{-# NOINLINE prefetchValue1# #-}+prefetchValue1# :: a -> State# s -> State# s+prefetchValue1# a1 a2 = GHC.Internal.Prim.prefetchValue1# a1 a2+{-# NOINLINE prefetchByteArray0# #-}+prefetchByteArray0# :: ByteArray# -> Int# -> State# s -> State# s+prefetchByteArray0# a1 a2 a3 = GHC.Internal.Prim.prefetchByteArray0# a1 a2 a3+{-# NOINLINE prefetchMutableByteArray0# #-}+prefetchMutableByteArray0# :: MutableByteArray# s -> Int# -> State# s -> State# s+prefetchMutableByteArray0# a1 a2 a3 = GHC.Internal.Prim.prefetchMutableByteArray0# a1 a2 a3+{-# NOINLINE prefetchAddr0# #-}+prefetchAddr0# :: Addr# -> Int# -> State# s -> State# s+prefetchAddr0# a1 a2 a3 = GHC.Internal.Prim.prefetchAddr0# a1 a2 a3+{-# NOINLINE prefetchValue0# #-}+prefetchValue0# :: a -> State# s -> State# s+prefetchValue0# a1 a2 = GHC.Internal.Prim.prefetchValue0# a1 a2
ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h view
@@ -8,7 +8,7 @@ // WORD_SIZE 8 // BITMAP_BITS_SHIFT 6 // TAG_BITS 3-#define HS_CONSTANTS "291,1,2,4096,252,9,0,8,16,24,32,40,48,56,64,72,80,84,88,92,96,100,104,112,120,128,136,144,152,168,184,200,216,232,248,280,312,344,376,408,440,504,568,632,696,760,824,832,840,848,856,864,872,888,904,-24,-16,-8,24,0,8,48,46,96,72,8,48,8,8,16,8,64,8,16,8,0,72,56,8,8,16,0,8,8,0,8,0,112,128,16,8,16,0,0,4,4,24,20,4,15,7,1,-16,255,0,255,7,10,6,6,1,6,6,6,6,6,0,16384,21,1024,8,4,8,8,6,3,30,1152921503533105152,0,1152921504606846976,1"+#define HS_CONSTANTS "291,1,2,4096,252,9,0,8,16,24,32,40,48,56,64,72,80,84,88,92,96,100,104,112,120,128,136,144,152,168,184,200,216,232,248,280,312,344,376,408,440,504,568,632,696,760,824,832,840,848,856,864,872,888,904,-24,-16,-8,24,0,8,48,46,96,72,8,48,8,8,16,8,64,8,16,8,0,72,56,8,8,8,16,0,8,8,0,8,0,112,128,16,8,16,0,0,4,4,24,20,4,15,7,1,-16,255,0,255,7,10,6,6,1,6,6,6,6,6,0,16384,21,1024,8,4,8,8,6,3,30,1152921503533105152,0,1152921504606846976,1" #define CONTROL_GROUP_CONST_291 291 #define STD_HDR_SIZE 1 #define PROF_HDR_SIZE 2@@ -188,6 +188,11 @@ #define OFFSET_StgDeadThreadFrame_result 0 #define REP_StgDeadThreadFrame_result b64 #define StgDeadThreadFrame_result(__ptr__) REP_StgDeadThreadFrame_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgDeadThreadFrame_result]+#define SIZEOF_StgAnnFrame_NoHdr 8+#define SIZEOF_StgAnnFrame (SIZEOF_StgHeader+8)+#define OFFSET_StgAnnFrame_ann 0+#define REP_StgAnnFrame_ann b64+#define StgAnnFrame_ann(__ptr__) REP_StgAnnFrame_ann[__ptr__+SIZEOF_StgHeader+OFFSET_StgAnnFrame_ann] #define SIZEOF_StgMutArrPtrs_NoHdr 16 #define SIZEOF_StgMutArrPtrs (SIZEOF_StgHeader+16) #define OFFSET_StgMutArrPtrs_ptrs 0@@ -536,19 +541,19 @@ #define OFFSET_StgCompactNFDataBlock_next 16 #define REP_StgCompactNFDataBlock_next b64 #define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next]-#define OFFSET_RtsFlags_ProfFlags_doHeapProfile 288+#define OFFSET_RtsFlags_ProfFlags_doHeapProfile 296 #define REP_RtsFlags_ProfFlags_doHeapProfile b32 #define RtsFlags_ProfFlags_doHeapProfile(__ptr__) REP_RtsFlags_ProfFlags_doHeapProfile[__ptr__+OFFSET_RtsFlags_ProfFlags_doHeapProfile]-#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 311+#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 319 #define REP_RtsFlags_ProfFlags_showCCSOnException b8 #define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException]-#define OFFSET_RtsFlags_DebugFlags_apply 253+#define OFFSET_RtsFlags_DebugFlags_apply 261 #define REP_RtsFlags_DebugFlags_apply b8 #define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply]-#define OFFSET_RtsFlags_DebugFlags_sanity 247+#define OFFSET_RtsFlags_DebugFlags_sanity 255 #define REP_RtsFlags_DebugFlags_sanity b8 #define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity]-#define OFFSET_RtsFlags_DebugFlags_weak 242+#define OFFSET_RtsFlags_DebugFlags_weak 250 #define REP_RtsFlags_DebugFlags_weak b8 #define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak] #define OFFSET_RtsFlags_GcFlags_initialStkSize 16@@ -631,75 +636,75 @@ #define OFFSET_HsIface_heapOverflow_closure 72 #define REP_HsIface_heapOverflow_closure b64 #define HsIface_heapOverflow_closure(__ptr__) REP_HsIface_heapOverflow_closure[__ptr__+OFFSET_HsIface_heapOverflow_closure]-#define OFFSET_HsIface_doubleReadException_closure 80-#define REP_HsIface_doubleReadException_closure b64-#define HsIface_doubleReadException_closure(__ptr__) REP_HsIface_doubleReadException_closure[__ptr__+OFFSET_HsIface_doubleReadException_closure]-#define OFFSET_HsIface_allocationLimitExceeded_closure 88+#define OFFSET_HsIface_allocationLimitExceeded_closure 80 #define REP_HsIface_allocationLimitExceeded_closure b64 #define HsIface_allocationLimitExceeded_closure(__ptr__) REP_HsIface_allocationLimitExceeded_closure[__ptr__+OFFSET_HsIface_allocationLimitExceeded_closure]-#define OFFSET_HsIface_blockedIndefinitelyOnMVar_closure 96+#define OFFSET_HsIface_blockedIndefinitelyOnMVar_closure 88 #define REP_HsIface_blockedIndefinitelyOnMVar_closure b64 #define HsIface_blockedIndefinitelyOnMVar_closure(__ptr__) REP_HsIface_blockedIndefinitelyOnMVar_closure[__ptr__+OFFSET_HsIface_blockedIndefinitelyOnMVar_closure]-#define OFFSET_HsIface_blockedIndefinitelyOnSTM_closure 104+#define OFFSET_HsIface_blockedIndefinitelyOnSTM_closure 96 #define REP_HsIface_blockedIndefinitelyOnSTM_closure b64 #define HsIface_blockedIndefinitelyOnSTM_closure(__ptr__) REP_HsIface_blockedIndefinitelyOnSTM_closure[__ptr__+OFFSET_HsIface_blockedIndefinitelyOnSTM_closure]-#define OFFSET_HsIface_cannotCompactFunction_closure 112+#define OFFSET_HsIface_cannotCompactFunction_closure 104 #define REP_HsIface_cannotCompactFunction_closure b64 #define HsIface_cannotCompactFunction_closure(__ptr__) REP_HsIface_cannotCompactFunction_closure[__ptr__+OFFSET_HsIface_cannotCompactFunction_closure]-#define OFFSET_HsIface_cannotCompactPinned_closure 120+#define OFFSET_HsIface_cannotCompactPinned_closure 112 #define REP_HsIface_cannotCompactPinned_closure b64 #define HsIface_cannotCompactPinned_closure(__ptr__) REP_HsIface_cannotCompactPinned_closure[__ptr__+OFFSET_HsIface_cannotCompactPinned_closure]-#define OFFSET_HsIface_cannotCompactMutable_closure 128+#define OFFSET_HsIface_cannotCompactMutable_closure 120 #define REP_HsIface_cannotCompactMutable_closure b64 #define HsIface_cannotCompactMutable_closure(__ptr__) REP_HsIface_cannotCompactMutable_closure[__ptr__+OFFSET_HsIface_cannotCompactMutable_closure]-#define OFFSET_HsIface_nonTermination_closure 136+#define OFFSET_HsIface_nonTermination_closure 128 #define REP_HsIface_nonTermination_closure b64 #define HsIface_nonTermination_closure(__ptr__) REP_HsIface_nonTermination_closure[__ptr__+OFFSET_HsIface_nonTermination_closure]-#define OFFSET_HsIface_nestedAtomically_closure 144+#define OFFSET_HsIface_nestedAtomically_closure 136 #define REP_HsIface_nestedAtomically_closure b64 #define HsIface_nestedAtomically_closure(__ptr__) REP_HsIface_nestedAtomically_closure[__ptr__+OFFSET_HsIface_nestedAtomically_closure]-#define OFFSET_HsIface_noMatchingContinuationPrompt_closure 152+#define OFFSET_HsIface_noMatchingContinuationPrompt_closure 144 #define REP_HsIface_noMatchingContinuationPrompt_closure b64 #define HsIface_noMatchingContinuationPrompt_closure(__ptr__) REP_HsIface_noMatchingContinuationPrompt_closure[__ptr__+OFFSET_HsIface_noMatchingContinuationPrompt_closure]-#define OFFSET_HsIface_blockedOnBadFD_closure 160+#define OFFSET_HsIface_blockedOnBadFD_closure 152 #define REP_HsIface_blockedOnBadFD_closure b64 #define HsIface_blockedOnBadFD_closure(__ptr__) REP_HsIface_blockedOnBadFD_closure[__ptr__+OFFSET_HsIface_blockedOnBadFD_closure]-#define OFFSET_HsIface_runSparks_closure 168+#define OFFSET_HsIface_runSparks_closure 160 #define REP_HsIface_runSparks_closure b64 #define HsIface_runSparks_closure(__ptr__) REP_HsIface_runSparks_closure[__ptr__+OFFSET_HsIface_runSparks_closure]-#define OFFSET_HsIface_ensureIOManagerIsRunning_closure 176+#define OFFSET_HsIface_ensureIOManagerIsRunning_closure 168 #define REP_HsIface_ensureIOManagerIsRunning_closure b64 #define HsIface_ensureIOManagerIsRunning_closure(__ptr__) REP_HsIface_ensureIOManagerIsRunning_closure[__ptr__+OFFSET_HsIface_ensureIOManagerIsRunning_closure]-#define OFFSET_HsIface_interruptIOManager_closure 184+#define OFFSET_HsIface_interruptIOManager_closure 176 #define REP_HsIface_interruptIOManager_closure b64 #define HsIface_interruptIOManager_closure(__ptr__) REP_HsIface_interruptIOManager_closure[__ptr__+OFFSET_HsIface_interruptIOManager_closure]-#define OFFSET_HsIface_ioManagerCapabilitiesChanged_closure 192+#define OFFSET_HsIface_ioManagerCapabilitiesChanged_closure 184 #define REP_HsIface_ioManagerCapabilitiesChanged_closure b64 #define HsIface_ioManagerCapabilitiesChanged_closure(__ptr__) REP_HsIface_ioManagerCapabilitiesChanged_closure[__ptr__+OFFSET_HsIface_ioManagerCapabilitiesChanged_closure]-#define OFFSET_HsIface_runHandlersPtr_closure 200+#define OFFSET_HsIface_runHandlersPtr_closure 192 #define REP_HsIface_runHandlersPtr_closure b64 #define HsIface_runHandlersPtr_closure(__ptr__) REP_HsIface_runHandlersPtr_closure[__ptr__+OFFSET_HsIface_runHandlersPtr_closure]-#define OFFSET_HsIface_flushStdHandles_closure 208+#define OFFSET_HsIface_flushStdHandles_closure 200 #define REP_HsIface_flushStdHandles_closure b64 #define HsIface_flushStdHandles_closure(__ptr__) REP_HsIface_flushStdHandles_closure[__ptr__+OFFSET_HsIface_flushStdHandles_closure]-#define OFFSET_HsIface_runMainIO_closure 216+#define OFFSET_HsIface_runMainIO_closure 208 #define REP_HsIface_runMainIO_closure b64 #define HsIface_runMainIO_closure(__ptr__) REP_HsIface_runMainIO_closure[__ptr__+OFFSET_HsIface_runMainIO_closure]-#define OFFSET_HsIface_Czh_con_info 224+#define OFFSET_HsIface_Czh_con_info 216 #define REP_HsIface_Czh_con_info b64 #define HsIface_Czh_con_info(__ptr__) REP_HsIface_Czh_con_info[__ptr__+OFFSET_HsIface_Czh_con_info]-#define OFFSET_HsIface_Izh_con_info 232+#define OFFSET_HsIface_Izh_con_info 224 #define REP_HsIface_Izh_con_info b64 #define HsIface_Izh_con_info(__ptr__) REP_HsIface_Izh_con_info[__ptr__+OFFSET_HsIface_Izh_con_info]-#define OFFSET_HsIface_Fzh_con_info 240+#define OFFSET_HsIface_Fzh_con_info 232 #define REP_HsIface_Fzh_con_info b64 #define HsIface_Fzh_con_info(__ptr__) REP_HsIface_Fzh_con_info[__ptr__+OFFSET_HsIface_Fzh_con_info]-#define OFFSET_HsIface_Dzh_con_info 248+#define OFFSET_HsIface_Dzh_con_info 240 #define REP_HsIface_Dzh_con_info b64 #define HsIface_Dzh_con_info(__ptr__) REP_HsIface_Dzh_con_info[__ptr__+OFFSET_HsIface_Dzh_con_info]-#define OFFSET_HsIface_Wzh_con_info 256+#define OFFSET_HsIface_Wzh_con_info 248 #define REP_HsIface_Wzh_con_info b64 #define HsIface_Wzh_con_info(__ptr__) REP_HsIface_Wzh_con_info[__ptr__+OFFSET_HsIface_Wzh_con_info]+#define OFFSET_HsIface_runAllocationLimitHandler_closure 264+#define REP_HsIface_runAllocationLimitHandler_closure b64+#define HsIface_runAllocationLimitHandler_closure(__ptr__) REP_HsIface_runAllocationLimitHandler_closure[__ptr__+OFFSET_HsIface_runAllocationLimitHandler_closure] #define OFFSET_HsIface_Ptr_con_info 272 #define REP_HsIface_Ptr_con_info b64 #define HsIface_Ptr_con_info(__ptr__) REP_HsIface_Ptr_con_info[__ptr__+OFFSET_HsIface_Ptr_con_info]
ghc-lib/stage0/rts/build/include/ghcautoconf.h view
@@ -72,9 +72,6 @@ /* Define (to 1) if C compiler has an LLVM back end */ #define CC_LLVM_BACKEND 1 -/* Define to 1 if __thread is supported */-#define CC_SUPPORTS_TLS 1- /* Define to 1 if using 'alloca.c'. */ /* #undef C_ALLOCA */ @@ -85,9 +82,6 @@ /* Has musttail */ #define HAS_MUSTTAIL 1 -/* Has visibility hidden */-#define HAS_VISIBILITY_HIDDEN 1- /* Define to 1 if you have 'alloca', as a function or macro. */ #define HAVE_ALLOCA 1 @@ -171,6 +165,9 @@  /* Define to 1 if you have the 'getuid' function. */ #define HAVE_GETUID 1++/* Define (to 1) if GNU-style non-executable stack note is supported */+/* #undef HAVE_GNU_NONEXEC_STACK */  /* Define to 1 if you have the <grp.h> header file. */ #define HAVE_GRP_H 1
ghc/ghc-bin.cabal view
@@ -2,7 +2,7 @@ -- ./configure.  Make sure you are editing ghc-bin.cabal.in, not ghc-bin.cabal.  Name: ghc-bin-Version: 9.12.3+Version: 9.14.1 Copyright: XXX -- License: XXX -- License-File: XXX@@ -31,16 +31,19 @@     Default-Language: GHC2021      Main-Is: Main.hs+    Other-Modules:+        GHC.Driver.Session.Lint,+        GHC.Driver.Session.Mode     Build-Depends: base       >= 4   && < 5,                    array      >= 0.1 && < 0.6,                    bytestring >= 0.9 && < 0.13,                    directory  >= 1   && < 1.4,                    process    >= 1   && < 1.7,                    filepath   >= 1.5 && < 1.6,-                   containers >= 0.5 && < 0.8,+                   containers >= 0.5 && < 0.9,                    transformers >= 0.5 && < 0.7,-                   ghc-boot      == 9.12.3,-                   ghc           == 9.12.3+                   ghc-boot      == 9.14.1,+                   ghc           == 9.14.1      if os(windows)         Build-Depends: Win32  >= 2.3 && < 2.15@@ -58,16 +61,17 @@         Build-depends:             deepseq        >= 1.4 && < 1.6,             ghc-prim       >= 0.5.0 && < 0.14,-            ghci           == 9.12.3,+            ghci           == 9.14.1,             haskeline      == 0.8.*,             exceptions     == 0.10.*,-            time           >= 1.8 && < 1.15+            time           >= 1.8 && < 1.16         CPP-Options: -DHAVE_INTERNAL_INTERPRETER         Other-Modules:             GHCi.Leak             GHCi.UI             GHCi.UI.Info             GHCi.UI.Monad+            GHCi.UI.Print             GHCi.UI.Exception             GHCi.Util         Other-Extensions:
libraries/containers/containers/include/containers.h view
@@ -6,13 +6,13 @@ #define HASKELL_CONTAINERS_H  /*- * On GHC, include MachDeps.h to get WORD_SIZE_IN_BITS macro.+ * On GHC and MicroHs, include MachDeps.h to get WORD_SIZE_IN_BITS macro.  */-#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__) #include "MachDeps.h" #endif -#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__) #define DEFINE_PATTERN_SYNONYMS 1 #endif 
libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs view
@@ -398,7 +398,8 @@             <+> braces (sep $ punctuate comma $                         map (\(s,p) -> pprName' Applied s <+> equals <+> ppr p) fs) pprPat _ (ListP ps) = brackets (commaSep ps)-pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t+pprPat i (SigP p t) = parensIf (i > noPrec) $ pprPat sigPrec p+                                          <+> dcolon <+> pprType sigPrec t pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p pprPat _ (TypeP t) = parens $ text "type" <+> ppr t pprPat _ (InvisP t) = parens $ text "@" <+> ppr t@@ -645,28 +646,20 @@      <+> text "#-}"     ppr (OpaqueP n)        = text "{-# OPAQUE" <+> pprName' Applied n <+> text "#-}"-    ppr (SpecialiseP n ty inline phases)-       =   text "{-# SPECIALISE"-       <+> maybe empty ppr inline-       <+> ppr phases-       <+> sep [ pprName' Applied n <+> dcolon-               , nest 2 $ ppr ty ]-       <+> text "#-}"+    ppr (SpecialiseEP ty_bndrs tm_bndrs spec_e inline phases)+       = sep [ text "{-# SPECIALISE"+                 <+> maybe empty ppr inline+                 <+> ppr phases+             , nest 2 $ sep [ ppr_ty_forall ty_bndrs <+> ppr_tm_forall ty_bndrs tm_bndrs+                            , nest 2 (ppr spec_e) ]+                        <+> text "#-}" ]     ppr (SpecialiseInstP inst)        = text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}"     ppr (RuleP n ty_bndrs tm_bndrs lhs rhs phases)        = sep [ text "{-# RULES" <+> pprString n <+> ppr phases-             , nest 4 $ ppr_ty_forall ty_bndrs <+> ppr_tm_forall ty_bndrs+             , nest 4 $ ppr_ty_forall ty_bndrs <+> ppr_tm_forall ty_bndrs tm_bndrs                                                <+> ppr lhs              , nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ]-      where ppr_ty_forall Nothing      = empty-            ppr_ty_forall (Just bndrs) = text "forall"-                                         <+> fsep (map ppr bndrs)-                                         <+> char '.'-            ppr_tm_forall Nothing | null tm_bndrs = empty-            ppr_tm_forall _ = text "forall"-                              <+> fsep (map ppr tm_bndrs)-                              <+> char '.'     ppr (AnnP tgt expr)        = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}"       where target1 ModuleAnnotation    = text "module"@@ -680,6 +673,17 @@     ppr (SCCP nm str)        = text "{-# SCC" <+> pprName' Applied nm <+> maybe empty pprString str <+> text "#-}" +ppr_ty_forall :: Maybe [TyVarBndr ()] -> Doc+ppr_ty_forall Nothing      = empty+ppr_ty_forall (Just bndrs) = text "forall"+                             <+> fsep (map ppr bndrs)+                             <+> char '.'++ppr_tm_forall :: Maybe [TyVarBndr ()] -> [RuleBndr] -> Doc+ppr_tm_forall Nothing []       = empty+ppr_tm_forall _       tm_bndrs = text "forall"+                                 <+> fsep (map ppr tm_bndrs)+                                 <+> char '.' ------------------------------ instance Ppr Inline where     ppr NoInline  = text "NOINLINE"@@ -708,31 +712,27 @@  ------------------------------ instance Ppr Con where-    ppr (NormalC c sts) = pprName' Applied c <+> sep (map pprBangType sts)--    ppr (RecC c vsts)-        = pprName' Applied c <+> braces (sep (punctuate comma $ map pprVarBangType vsts))--    ppr (InfixC st1 c st2) = pprBangType st1-                         <+> pprName' Infix c-                         <+> pprBangType st2--    ppr (ForallC ns ctxt (GadtC cs sts ty))-        = commaSepApplied cs <+> dcolon <+> pprForall ns ctxt-      <+> pprGadtRHS sts ty--    ppr (ForallC ns ctxt (RecGadtC cs vsts ty))-        = commaSepApplied cs <+> dcolon <+> pprForall ns ctxt-      <+> pprRecFields vsts ty--    ppr (ForallC ns ctxt con)-        = pprForall ns ctxt <+> ppr con--    ppr (GadtC cs sts ty)-        = commaSepApplied cs <+> dcolon <+> pprGadtRHS sts ty--    ppr (RecGadtC cs vsts ty)-        = commaSepApplied cs <+> dcolon <+> pprRecFields vsts ty+  ppr = ppr_con id+    where+      ppr_con :: (Doc -> Doc) -> Con -> Doc+      ppr_con ppr_foralls (NormalC c sts) =+        ppr_foralls $ pprName' Applied c <+> sep (map pprBangType sts)+      ppr_con ppr_foralls (RecC c vsts) =+        ppr_foralls $ pprName' Applied c <+> ppr_rec vsts+        where+          ppr_rec :: [VarBangType] -> Doc+          ppr_rec = braces . sep . punctuate comma . map pprVarBangType+      ppr_con ppr_foralls (InfixC st1 c st2) =+        ppr_foralls $+              pprBangType st1+          <+> pprName' Infix c+          <+> pprBangType st2+      ppr_con ppr_foralls (ForallC ns ctxt con)+        = ppr_con (\d -> ppr_foralls $ sep [pprForall ns ctxt, d]) con+      ppr_con ppr_foralls (GadtC cs sts ty)+        = commaSepApplied cs <+> dcolon <+> ppr_foralls (pprGadtRHS sts ty)+      ppr_con ppr_foralls (RecGadtC cs vsts ty)+        = commaSepApplied cs <+> dcolon <+> ppr_foralls (pprRecFields vsts ty)  instance Ppr PatSynDir where   ppr Unidir        = text "<-"
libraries/ghc-boot-th/ghc-boot-th.cabal view
@@ -3,7 +3,7 @@ -- ghc-boot-th.cabal.in, not ghc-boot-th.cabal.  name:           ghc-boot-th-version:        9.12.3+version:        9.14.1 license:        BSD3 license-file:   LICENSE category:       GHC@@ -29,7 +29,7 @@ Flag bootstrap         Description:           Enabled when building the stage1 compiler in order to vendor the in-tree-          `ghc-boot-th` library, and through that the in-tree TH AST defintions from+          `ghc-boot-th` library, and through that the in-tree TH AST definitions from           `ghc-internal`.           See Note [Bootstrapping Template Haskell]         Default: False@@ -49,12 +49,13 @@             GHC.Lexeme      build-depends:-        base       >= 4.7 && < 4.22,-        ghc-prim,-        pretty      == 1.1.*+        base       >= 4.7 && < 4.23,+        pretty     == 1.1.*      if flag(bootstrap)         cpp-options: -DBOOTSTRAP_TH+        build-depends:+            ghc-prim         hs-source-dirs: . ../ghc-internal/src         exposed-modules:             GHC.Boot.TH.Lib
libraries/ghc-boot/GHC/BaseDir.hs view
@@ -24,7 +24,7 @@ import Data.Maybe (listToMaybe) import System.FilePath -#if MIN_VERSION_base(4,17,0) && !defined(openbsd_HOST_OS)+#if !defined(openbsd_HOST_OS) import System.Environment (executablePath) #else import System.Environment (getExecutablePath)@@ -45,16 +45,12 @@ expandPathVar var value (x:xs) = x : expandPathVar var value xs expandPathVar _ _ [] = [] -#if !MIN_VERSION_base(4,17,0) || defined(openbsd_HOST_OS)+#if defined(openbsd_HOST_OS) -- Polyfill for base-4.17 executablePath and OpenBSD which doesn't -- have executablePath. The best it can do is use argv[0] which is -- good enough for most uses of getBaseDir. executablePath :: Maybe (IO (Maybe FilePath)) executablePath = Just (Just <$> getExecutablePath)-#elif !MIN_VERSION_base(4,18,0) && defined(js_HOST_ARCH)--- executablePath is missing from base < 4.18.0 on js_HOST_ARCH-executablePath :: Maybe (IO (Maybe FilePath))-executablePath = Nothing #endif  -- | Calculate the location of the base dir
libraries/ghc-boot/GHC/Data/ShortText.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, GeneralizedNewtypeDeriving, DerivingStrategies, CPP #-}+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, GeneralizedNewtypeDeriving, DerivingStrategies #-} {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} -- gross hack: we maneuvered ourselves into a position where we can't boot GHC with a LLVM based GHC anymore. -- LLVM based GHC's fail to compile memcmp ffi calls.  These end up as memcmp$def in the llvm ir, however we@@ -11,12 +11,6 @@ -- bootstrap compiler.  This will produce a slower (slightly less optimised) stage1 compiler only. -- -- See issue 18857. hsyl20 deserves credit for coming up with the idea for the solution.------ This can be removed when we exit the boot compiler window. Thus once we drop GHC-9.2 as boot compiler,--- we can drop this code as well.-#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)-{-# OPTIONS_GHC -fignore-interface-pragmas #-}-#endif -- | -- An Unicode string for internal GHC use. Meant to replace String -- in places where being a lazy linked is not very useful and a more
libraries/ghc-boot/GHC/Data/SizedSeq.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving, DeriveGeneric, CPP #-} module GHC.Data.SizedSeq   ( SizedSeq(..)   , emptySS@@ -11,9 +11,12 @@ import Prelude -- See note [Why do we import Prelude here?] import Control.DeepSeq import Data.Binary-import Data.List (genericLength) import GHC.Generics +#if ! MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif+ data SizedSeq a = SizedSeq {-# UNPACK #-} !Word [a]   deriving (Generic, Show) @@ -37,9 +40,9 @@ addToSS :: SizedSeq a -> a -> SizedSeq a addToSS (SizedSeq n r_xs) x = SizedSeq (n+1) (x:r_xs) +-- NB, important this is eta-expand so that foldl' is inlined. addListToSS :: SizedSeq a -> [a] -> SizedSeq a-addListToSS (SizedSeq n r_xs) xs-  = SizedSeq (n + genericLength xs) (reverse xs ++ r_xs)+addListToSS s xs = foldl' addToSS s xs  ssElts :: SizedSeq a -> [a] ssElts (SizedSeq _ r_xs) = reverse r_xs
libraries/ghc-boot/GHC/Serialized.hs view
@@ -22,10 +22,14 @@ import Data.Bits import Data.Word        ( Word8 ) import Data.Data+import Control.DeepSeq   -- | Represents a serialized value of a particular type. Attempts can be made to deserialize it at certain types data Serialized = Serialized TypeRep [Word8]++instance NFData Serialized where+  rnf (Serialized tr ws) = rnf tr `seq` rnf ws  -- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later toSerialized :: forall a. Typeable a => (a -> [Word8]) -> a -> Serialized
libraries/ghc-boot/GHC/Utils/Encoding.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, MultiWayIf #-} {-# OPTIONS_GHC -O2 -fno-warn-name-shadowing #-} -- We always optimise this, otherwise performance of a non-optimised@@ -88,15 +89,48 @@   zEncodeString :: UserString -> EncodedString-zEncodeString cs = case maybe_tuple cs of-                Just n  -> n            -- Tuples go to Z2T etc-                Nothing -> go cs-          where-                go []     = []-                go (c:cs) = encode_digit_ch c ++ go' cs-                go' []     = []-                go' (c:cs) = encode_ch c ++ go' cs+zEncodeString = \case+  []     -> []+  (c:cs)+    -- If a digit is at the start of a symbol then we need to encode it.+    -- Otherwise package names like 9pH-0.1 give linker errors.+    | c >= '0' && c <= '9' -> encode_as_unicode_char c ++ go cs+    | otherwise            -> go (c:cs)+  where+    go = \case+      [] -> []+      -- encode boxed/unboxed tuples respectively as ZnT/ZnH (e.g. Z3T/Z3H for+      -- 3-tuples). Note that the arity corresponds to the number of+      -- commas+1. No comma means 0-arity, i.e. Z0T/Z0H.+      --+      -- The 1-arity unboxed tuple "(# #)" (notice the space between the '#'s)+      -- isn't special-cased, i.e. it is encoded as "ZLzhz20UzhZR". There is no+      -- 1-arity boxed tuple (we use Solo/MkSolo instead).+      --+      -- arity        boxed       z-name        unboxed       z-name+      -- 0            ()          Z0T           (##)          Z0H+      -- 1            N/A         N/A           (# #)         ZLzhz20UzhZR+      -- 2            (,)         Z2T           (#,#)         Z2H+      -- 3            (,,)        Z3T           (#,,#)        Z3H+      -- ...+      --+      '(':'#':'#':')':cs -> "Z0H" ++ go cs+      '(':')':cs         -> "Z0T" ++ go cs+      '(':'#':cs+        | (n, '#':')':cs') <- count_commas cs+        -> 'Z' : shows (n+1) ('H': go cs')+      '(':cs+        | (n, ')':cs') <- count_commas cs+        -> 'Z' : shows (n+1) ('T': go cs')+      c:cs -> encode_ch c ++ go cs +count_commas :: String -> (Int, String)+count_commas = go 0+  where+    go !n = \case+      ',':cs -> go (n+1) cs+      cs     -> (n,cs)+ unencodedChar :: Char -> Bool   -- True for chars that don't need encoding unencodedChar 'Z' = False unencodedChar 'z' = False@@ -104,12 +138,6 @@                   || c >= 'A' && c <= 'Z'                   || c >= '0' && c <= '9' --- If a digit is at the start of a symbol then we need to encode it.--- Otherwise package names like 9pH-0.1 give linker errors.-encode_digit_ch :: Char -> EncodedString-encode_digit_ch c | c >= '0' && c <= '9' = encode_as_unicode_char c-encode_digit_ch c | otherwise            = encode_ch c- encode_ch :: Char -> EncodedString encode_ch c | unencodedChar c = [c]     -- Common case first @@ -214,34 +242,6 @@     go n ('T':rest)     = '(' : replicate (n-1) ',' ++ ")" ++ zDecodeString rest     go n ('H':rest)     = '(' : '#' : replicate (n-1) ',' ++ "#)" ++ zDecodeString rest     go n other = error ("decode_tuple: " ++ show n ++ ' ':other)--{--Tuples are encoded as-        Z3T or Z3H-for 3-tuples or unboxed 3-tuples respectively.  No other encoding starts-        Z<digit>--* "(##)" is the tycon for an unboxed 0-tuple--* "()" is the tycon for a boxed 0-tuple--}--maybe_tuple :: UserString -> Maybe EncodedString--maybe_tuple "(##)" = Just("Z0H")-maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of-                                 (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")-                                 _                  -> Nothing-maybe_tuple "()" = Just("Z0T")-maybe_tuple ('(' : cs)       = case count_commas (0::Int) cs of-                                 (n, ')' : _) -> Just ('Z' : shows (n+1) "T")-                                 _            -> Nothing-maybe_tuple _                = Nothing--count_commas :: Int -> String -> (Int, String)-count_commas n (',' : cs) = count_commas (n+1) cs-count_commas n cs         = (n,cs)-  {- ************************************************************************
libraries/ghc-boot/GHC/Utils/Encoding/UTF8.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, MultiWayIf #-} {-# OPTIONS_GHC -O2 -fno-warn-name-shadowing #-} -- We always optimise this, otherwise performance of a non-optimised@@ -45,14 +44,7 @@  import Foreign import GHC.IO-#if MIN_VERSION_base(4,18,0) import GHC.Encoding.UTF8-#else-import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)-import Data.Char-import GHC.Exts-import GHC.ST-#endif  import Data.ByteString (ByteString) import qualified Data.ByteString.Internal as BS@@ -106,256 +98,3 @@  utf8CompareShortByteString :: ShortByteString -> ShortByteString -> Ordering utf8CompareShortByteString (SBS a1) (SBS a2) = utf8CompareByteArray# a1 a2-------------------------------------------------------------- Everything below was moved into base in GHC 9.6------ These can be dropped in GHC 9.6 + 2 major releases.------------------------------------------------------------#if !MIN_VERSION_base(4,18,0)---- We can't write the decoder as efficiently as we'd like without--- resorting to unboxed extensions, unfortunately.  I tried to write--- an IO version of this function, but GHC can't eliminate boxed--- results from an IO-returning function.------ We assume we can ignore overflow when parsing a multibyte character here.--- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences--- before decoding them (see "GHC.Data.StringBuffer").--{-# INLINE utf8DecodeChar# #-}--- | Decode a single codepoint from a byte buffer indexed by the given indexing--- function.-utf8DecodeChar# :: (Int# -> Word#) -> (# Char#, Int# #)-utf8DecodeChar# indexWord8# =-  let !ch0 = word2Int# (indexWord8# 0#) in-  case () of-    _ | isTrue# (ch0 <=# 0x7F#) -> (# chr# ch0, 1# #)--      | isTrue# ((ch0 >=# 0xC0#) `andI#` (ch0 <=# 0xDF#)) ->-        let !ch1 = word2Int# (indexWord8# 1#) in-        if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else-        (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +#-                  (ch1 -# 0x80#)),-           2# #)--      | isTrue# ((ch0 >=# 0xE0#) `andI#` (ch0 <=# 0xEF#)) ->-        let !ch1 = word2Int# (indexWord8# 1#) in-        if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else-        let !ch2 = word2Int# (indexWord8# 2#) in-        if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else-        (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +#-                 ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#)  +#-                  (ch2 -# 0x80#)),-           3# #)--     | isTrue# ((ch0 >=# 0xF0#) `andI#` (ch0 <=# 0xF8#)) ->-        let !ch1 = word2Int# (indexWord8# 1#) in-        if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else-        let !ch2 = word2Int# (indexWord8# 2#) in-        if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else-        let !ch3 = word2Int# (indexWord8# 3#) in-        if isTrue# ((ch3 <# 0x80#) `orI#` (ch3 >=# 0xC0#)) then fail 3# else-        (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +#-                 ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +#-                 ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#)  +#-                  (ch3 -# 0x80#)),-           4# #)--      | otherwise -> fail 1#-  where-        -- all invalid sequences end up here:-        fail :: Int# -> (# Char#, Int# #)-        fail nBytes# = (# '\0'#, nBytes# #)-        -- '\xFFFD' would be the usual replacement character, but-        -- that's a valid symbol in Haskell, so will result in a-        -- confusing parse error later on.  Instead we use '\0' which-        -- will signal a lexer error immediately.---- | Decode a single character at the given 'Addr#'.-utf8DecodeCharAddr# :: Addr# -> Int# -> (# Char#, Int# #)-utf8DecodeCharAddr# a# off# =-#if !MIN_VERSION_base(4,16,0)-    utf8DecodeChar# (\i# -> indexWord8OffAddr# a# (i# +# off#))-#else-    utf8DecodeChar# (\i# -> word8ToWord# (indexWord8OffAddr# a# (i# +# off#)))-#endif---- | Decode a single codepoint starting at the given 'Ptr'.-utf8DecodeCharPtr :: Ptr Word8 -> (Char, Int)-utf8DecodeCharPtr !(Ptr a#) =-  case utf8DecodeCharAddr# a# 0# of-    (# c#, nBytes# #) -> ( C# c#, I# nBytes# )---- | Decode a single codepoint starting at the given byte offset into a--- 'ByteArray#'.-utf8DecodeCharByteArray# :: ByteArray# -> Int# -> (# Char#, Int# #)-utf8DecodeCharByteArray# ba# off# =-#if !MIN_VERSION_base(4,16,0)-    utf8DecodeChar# (\i# -> indexWord8Array# ba# (i# +# off#))-#else-    utf8DecodeChar# (\i# -> word8ToWord# (indexWord8Array# ba# (i# +# off#)))-#endif--{-# INLINE utf8Decode# #-}-utf8Decode# :: (IO ()) -> (Int# -> (# Char#, Int# #)) -> Int# -> IO [Char]-utf8Decode# retain decodeChar# len#-  = unpack 0#-  where-    unpack i#-        | isTrue# (i# >=# len#) = retain >> return []-        | otherwise =-            case decodeChar# i# of-              (# c#, nBytes# #) -> do-                rest <- unsafeDupableInterleaveIO $ unpack (i# +# nBytes#)-                return (C# c# : rest)--utf8DecodeForeignPtr :: ForeignPtr Word8 -> Int -> Int -> [Char]-utf8DecodeForeignPtr fp offset (I# len#)-  = unsafeDupablePerformIO $ do-      let !(Ptr a#) = unsafeForeignPtrToPtr fp `plusPtr` offset-      utf8Decode# (touchForeignPtr fp) (utf8DecodeCharAddr# a#) len#--- Note that since utf8Decode# returns a thunk the lifetime of the--- ForeignPtr actually needs to be longer than the lexical lifetime--- withForeignPtr would provide here. That's why we use touchForeignPtr to--- keep the fp alive until the last character has actually been decoded.--utf8DecodeByteArray# :: ByteArray# -> [Char]-utf8DecodeByteArray# ba#-  = unsafeDupablePerformIO $-      let len# = sizeofByteArray# ba# in-      utf8Decode# (return ()) (utf8DecodeCharByteArray# ba#) len#--utf8CompareByteArray# :: ByteArray# -> ByteArray# -> Ordering-utf8CompareByteArray# a1 a2 = go 0# 0#-   -- UTF-8 has the property that sorting by bytes values also sorts by-   -- code-points.-   -- BUT we use "Modified UTF-8" which encodes \0 as 0xC080 so this property-   -- doesn't hold and we must explicitly check this case here.-   -- Note that decoding every code point would also work but it would be much-   -- more costly.-   where-       !sz1 = sizeofByteArray# a1-       !sz2 = sizeofByteArray# a2-       go off1 off2-         | isTrue# ((off1 >=# sz1) `andI#` (off2 >=# sz2)) = EQ-         | isTrue# (off1 >=# sz1)                          = LT-         | isTrue# (off2 >=# sz2)                          = GT-         | otherwise =-#if !MIN_VERSION_base(4,16,0)-               let !b1_1 = indexWord8Array# a1 off1-                   !b2_1 = indexWord8Array# a2 off2-#else-               let !b1_1 = word8ToWord# (indexWord8Array# a1 off1)-                   !b2_1 = word8ToWord# (indexWord8Array# a2 off2)-#endif-               in case b1_1 of-                  0xC0## -> case b2_1 of-                     0xC0## -> go (off1 +# 1#) (off2 +# 1#)-#if !MIN_VERSION_base(4,16,0)-                     _      -> case indexWord8Array# a1 (off1 +# 1#) of-#else-                     _      -> case word8ToWord# (indexWord8Array# a1 (off1 +# 1#)) of-#endif-                        0x80## -> LT-                        _      -> go (off1 +# 1#) (off2 +# 1#)-                  _      -> case b2_1 of-#if !MIN_VERSION_base(4,16,0)-                     0xC0## -> case indexWord8Array# a2 (off2 +# 1#) of-#else-                     0xC0## -> case word8ToWord# (indexWord8Array# a2 (off2 +# 1#)) of-#endif-                        0x80## -> GT-                        _      -> go (off1 +# 1#) (off2 +# 1#)-                     _   | isTrue# (b1_1 `gtWord#` b2_1) -> GT-                         | isTrue# (b1_1 `ltWord#` b2_1) -> LT-                         | otherwise                     -> go (off1 +# 1#) (off2 +# 1#)--utf8CountCharsByteArray# :: ByteArray# -> Int-utf8CountCharsByteArray# ba = go 0# 0#-  where-    len# = sizeofByteArray# ba-    go i# n#-      | isTrue# (i# >=# len#) = I# n#-      | otherwise =-          case utf8DecodeCharByteArray# ba i# of-            (# _, nBytes# #) -> go (i# +# nBytes#) (n# +# 1#)--{-# INLINE utf8EncodeChar #-}-utf8EncodeChar :: (Int# -> Word8# -> State# s -> State# s)-               -> Char -> ST s Int-utf8EncodeChar write# c =-  let x = fromIntegral (ord c) in-  case () of-    _ | x > 0 && x <= 0x007f -> do-          write 0 x-          return 1-        -- NB. '\0' is encoded as '\xC0\x80', not '\0'.  This is so that we-        -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8).-      | x <= 0x07ff -> do-          write 0 (0xC0 .|. ((x `shiftR` 6) .&. 0x1F))-          write 1 (0x80 .|. (x .&. 0x3F))-          return 2-      | x <= 0xffff -> do-          write 0 (0xE0 .|. (x `shiftR` 12) .&. 0x0F)-          write 1 (0x80 .|. (x `shiftR` 6) .&. 0x3F)-          write 2 (0x80 .|. (x .&. 0x3F))-          return 3-      | otherwise -> do-          write 0 (0xF0 .|. (x `shiftR` 18))-          write 1 (0x80 .|. ((x `shiftR` 12) .&. 0x3F))-          write 2 (0x80 .|. ((x `shiftR` 6) .&. 0x3F))-          write 3 (0x80 .|. (x .&. 0x3F))-          return 4-  where-    {-# INLINE write #-}-    write (I# off#) (W# c#) = ST $ \s ->-#if !MIN_VERSION_base(4,16,0)-      case write# off# (narrowWord8# c#) s of-#else-      case write# off# (wordToWord8# c#) s of-#endif-        s -> (# s, () #)--utf8EncodePtr :: Ptr Word8 -> String -> IO ()-utf8EncodePtr (Ptr a#) str = go a# str-  where go !_   []   = return ()-        go a# (c:cs) = do-#if !MIN_VERSION_base(4,16,0)-          -- writeWord8OffAddr# was taking a Word#-          I# off# <- stToIO $ utf8EncodeChar (\i w -> writeWord8OffAddr# a# i (extendWord8# w)) c-#else-          I# off# <- stToIO $ utf8EncodeChar (writeWord8OffAddr# a#) c-#endif-          go (a# `plusAddr#` off#) cs--utf8EncodeByteArray# :: String -> ByteArray#-utf8EncodeByteArray# str = runRW# $ \s ->-  case utf8EncodedLength str         of { I# len# ->-  case newByteArray# len# s          of { (# s, mba# #) ->-  case go mba# 0# str                of { ST f_go ->-  case f_go s                        of { (# s, () #) ->-  case unsafeFreezeByteArray# mba# s of { (# _, ba# #) ->-  ba# }}}}}-  where-    go _ _ [] = return ()-    go mba# i# (c:cs) = do-#if !MIN_VERSION_base(4,16,0)-      -- writeWord8Array# was taking a Word#-      I# off# <- utf8EncodeChar (\j# w -> writeWord8Array# mba# (i# +# j#) (extendWord8# w)) c-#else-      I# off# <- utf8EncodeChar (\j# -> writeWord8Array# mba# (i# +# j#)) c-#endif-      go mba# (i# +# off#) cs--utf8EncodedLength :: String -> Int-utf8EncodedLength str = go 0 str-  where go !n [] = n-        go n (c:cs)-          | ord c > 0 && ord c <= 0x007f = go (n+1) cs-          | ord c <= 0x07ff = go (n+2) cs-          | ord c <= 0xffff = go (n+3) cs-          | otherwise       = go (n+4) cs--#endif /* MIN_VERSION_base(4,18,0) */
libraries/ghc-boot/ghc-boot.cabal view
@@ -5,7 +5,7 @@ -- ghc-boot.cabal.  name:           ghc-boot-version:        9.12.3+version:        9.14.1 license:        BSD-3-Clause license-file:   LICENSE category:       GHC@@ -75,10 +75,10 @@             GHC.Version             GHC.Platform.Host -    build-depends: base       >= 4.7 && < 4.22,+    build-depends: base       >= 4.7 && < 4.23,                    binary     == 0.8.*,                    bytestring >= 0.10 && < 0.13,-                   containers >= 0.5 && < 0.8,+                   containers >= 0.5 && < 0.9,                    directory  >= 1.2 && < 1.4,                    filepath   >= 1.3 && < 1.6,                    deepseq    >= 1.4 && < 1.6,@@ -94,10 +94,10 @@      if flag(bootstrap)       build-depends:-              ghc-boot-th-next    == 9.12.3+              ghc-boot-th-next    == 9.14.1     else       build-depends:-              ghc-boot-th         == 9.12.3+              ghc-boot-th         == 9.14.1      if !os(windows)         build-depends:
libraries/ghc-heap/GHC/Exts/Heap.hs view
@@ -29,6 +29,10 @@     , WhyBlocked(..)     , TsoFlags(..)     , HasHeapRep(getClosureData)+    , getClosureInfoTbl+    , getClosureInfoTbl_maybe+    , getClosurePtrArgs+    , getClosurePtrArgs_maybe     , getClosureDataFromHeapRep     , getClosureDataFromHeapRepPrim @@ -63,10 +67,26 @@ import GHC.Exts.Heap.Constants import GHC.Exts.Heap.ProfInfo.Types #if defined(PROFILING)+import GHC.Exts.Heap.InfoTable () -- See Note [No way-dependent imports] import GHC.Exts.Heap.InfoTableProf #else import GHC.Exts.Heap.InfoTable+import GHC.Exts.Heap.InfoTableProf () -- See Note [No way-dependent imports]++{-+Note [No way-dependent imports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+`ghc -M` currently assumes that the imports for a module are the same+in every way.  This is arguably a bug, but breaking this assumption by+importing different things in different ways can cause trouble.  For+example, this module in the profiling way imports and uses+GHC.Exts.Heap.InfoTableProf.  When it was not also imported in the+vanilla way, there were intermittent build failures due to this module+being compiled in the profiling way before GHC.Exts.Heap.InfoTableProf+in the profiling way. (#15197)+-} #endif+ import GHC.Exts.Heap.Utils import qualified GHC.Exts.Heap.FFIClosures as FFIClosures import qualified GHC.Exts.Heap.ProfInfo.PeekProfInfo as PPI@@ -88,18 +108,10 @@         -> IO Closure         -- ^ Heap representation of the closure. -#if __GLASGOW_HASKELL__ >= 901 instance HasHeapRep (a :: TYPE ('BoxedRep 'Lifted)) where-#else-instance HasHeapRep (a :: TYPE 'LiftedRep) where-#endif     getClosureData = getClosureDataFromHeapObject -#if __GLASGOW_HASKELL__ >= 901 instance HasHeapRep (a :: TYPE ('BoxedRep 'Unlifted)) where-#else-instance HasHeapRep (a :: TYPE 'UnliftedRep) where-#endif     getClosureData x = getClosureDataFromHeapObject (unsafeCoerce# x)  instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where@@ -370,9 +382,7 @@                                 { info = itbl                                 , stack_size = FFIClosures.stack_size fields                                 , stack_dirty = FFIClosures.stack_dirty fields-#if __GLASGOW_HASKELL__ >= 811                                 , stack_marking = FFIClosures.stack_marking fields-#endif                                 })             | otherwise                 -> fail $ "Expected 0 ptr argument to STACK, found "
libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs view
@@ -7,86 +7,7 @@     ) where  import Prelude -- See note [Why do we import Prelude here?]-#if __GLASGOW_HASKELL__ >= 909 import GHC.Internal.ClosureTypes-#else-import GHC.Generics--{- ------------------------------------------------ Enum representing closure types--- This is a mirror of:--- rts/include/rts/storage/ClosureTypes.h--- ---------------------------------------------}--data ClosureType-    = INVALID_OBJECT-    | CONSTR-    | CONSTR_1_0-    | CONSTR_0_1-    | CONSTR_2_0-    | CONSTR_1_1-    | CONSTR_0_2-    | CONSTR_NOCAF-    | FUN-    | FUN_1_0-    | FUN_0_1-    | FUN_2_0-    | FUN_1_1-    | FUN_0_2-    | FUN_STATIC-    | THUNK-    | THUNK_1_0-    | THUNK_0_1-    | THUNK_2_0-    | THUNK_1_1-    | THUNK_0_2-    | THUNK_STATIC-    | THUNK_SELECTOR-    | BCO-    | AP-    | PAP-    | AP_STACK-    | IND-    | IND_STATIC-    | RET_BCO-    | RET_SMALL-    | RET_BIG-    | RET_FUN-    | UPDATE_FRAME-    | CATCH_FRAME-    | UNDERFLOW_FRAME-    | STOP_FRAME-    | BLOCKING_QUEUE-    | BLACKHOLE-    | MVAR_CLEAN-    | MVAR_DIRTY-    | TVAR-    | ARR_WORDS-    | MUT_ARR_PTRS_CLEAN-    | MUT_ARR_PTRS_DIRTY-    | MUT_ARR_PTRS_FROZEN_DIRTY-    | MUT_ARR_PTRS_FROZEN_CLEAN-    | MUT_VAR_CLEAN-    | MUT_VAR_DIRTY-    | WEAK-    | PRIM-    | MUT_PRIM-    | TSO-    | STACK-    | TREC_CHUNK-    | ATOMICALLY_FRAME-    | CATCH_RETRY_FRAME-    | CATCH_STM_FRAME-    | WHITEHOLE-    | SMALL_MUT_ARR_PTRS_CLEAN-    | SMALL_MUT_ARR_PTRS_DIRTY-    | SMALL_MUT_ARR_PTRS_FROZEN_DIRTY-    | SMALL_MUT_ARR_PTRS_FROZEN_CLEAN-    | COMPACT_NFDATA-    | CONTINUATION-    | N_CLOSURE_TYPES- deriving (Enum, Eq, Ord, Show, Generic)-#endif  -- | Return the size of the closures header in words closureTypeHeaderSize :: ClosureType -> Int
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs view
@@ -8,12 +8,18 @@ {-# LANGUAGE DeriveTraversable #-} -- Late cost centres introduce a thunk in the asBox function, which leads to -- an additional wrapper being added to any value placed inside a box.+-- This can be removed once our boot compiler is no longer affected by #25212 {-# OPTIONS_GHC -fno-prof-late  #-}+{-# LANGUAGE NamedFieldPuns #-}  module GHC.Exts.Heap.Closures (     -- * Closures       Closure     , GenClosure(..)+    , getClosureInfoTbl+    , getClosureInfoTbl_maybe+    , getClosurePtrArgs+    , getClosurePtrArgs_maybe     , PrimType(..)     , WhatNext(..)     , WhyBlocked(..)@@ -35,521 +41,4 @@     , asBox     ) where -import Prelude -- See note [Why do we import Prelude here?]-import GHC.Exts.Heap.Constants-#if defined(PROFILING)-import GHC.Exts.Heap.InfoTable () -- see Note [No way-dependent imports]-import GHC.Exts.Heap.InfoTableProf-#else-import GHC.Exts.Heap.InfoTable-import GHC.Exts.Heap.InfoTableProf () -- see Note [No way-dependent imports]--{--Note [No way-dependent imports]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-`ghc -M` currently assumes that the imports for a module are the same-in every way.  This is arguably a bug, but breaking this assumption by-importing different things in different ways can cause trouble.  For-example, this module in the profiling way imports and uses-GHC.Exts.Heap.InfoTableProf.  When it was not also imported in the-vanilla way, there were intermittent build failures due to this module-being compiled in the profiling way before GHC.Exts.Heap.InfoTableProf-in the profiling way. (#15197)--}-#endif--import GHC.Exts.Heap.ProfInfo.Types--import Data.Bits-import Data.Foldable (toList)-import Data.Int-import Data.Word-import GHC.Exts-import GHC.Generics-import Numeric----------------------------------------------------------------------------- Boxes--foreign import prim "Ghclib_aToWordzh" aToWord# :: Any -> Word#--foreign import prim "Ghclib_reallyUnsafePtrEqualityUpToTag"-    reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#---- | An arbitrary Haskell value in a safe Box. The point is that even--- unevaluated thunks can safely be moved around inside the Box, and when--- required, e.g. in 'getBoxedClosureData', the function knows how far it has--- to evaluate the argument.-data Box = Box Any--instance Show Box where--- From libraries/base/GHC/Ptr.lhs-   showsPrec _ (Box a) rs =-    -- unsafePerformIO (print "↓" >> pClosure a) `seq`-    pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs-     where-       ptr  = W# (aToWord# a)-       tag  = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)-       addr = ptr - tag-       pad_out ls = '0':'x':ls---- |This takes an arbitrary value and puts it into a box.--- Note that calls like------ > asBox (head list)------ will put the thunk \"head list\" into the box, /not/ the element at the head--- of the list. For that, use careful case expressions:------ > case list of x:_ -> asBox x-asBox :: a -> Box-asBox x = Box (unsafeCoerce# x)---- | Boxes can be compared, but this is not pure, as different heap objects can,--- after garbage collection, become the same object.-areBoxesEqual :: Box -> Box -> IO Bool-areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of-    0# -> pure False-    _  -> pure True------------------------------------------------------------------------------ Closures-type Closure = GenClosure Box---- | This is the representation of a Haskell value on the heap. It reflects--- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/Closures.h>------ The data type is parametrized by `b`: the type to store references in.--- Usually this is a 'Box' with the type synonym 'Closure'.------ All Heap objects have the same basic layout. A header containing a pointer to--- the info table and a payload with various fields. The @info@ field below--- always refers to the info table pointed to by the header. The remaining--- fields are the payload.------ See--- <https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/storage/heap-objects>--- for more information.-data GenClosure b-  = -- | A data constructor-    ConstrClosure-        { info       :: !StgInfoTable-        , ptrArgs    :: ![b]            -- ^ Pointer arguments-        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments-        , pkg        :: !String         -- ^ Package name-        , modl       :: !String         -- ^ Module name-        , name       :: !String         -- ^ Constructor name-        }--    -- | A function-  | FunClosure-        { info       :: !StgInfoTable-        , ptrArgs    :: ![b]            -- ^ Pointer arguments-        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments-        }--    -- | A thunk, an expression not obviously in head normal form-  | ThunkClosure-        { info       :: !StgInfoTable-        , ptrArgs    :: ![b]            -- ^ Pointer arguments-        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments-        }--    -- | A thunk which performs a simple selection operation-  | SelectorClosure-        { info       :: !StgInfoTable-        , selectee   :: !b              -- ^ Pointer to the object being-                                        --   selected from-        }--    -- | An unsaturated function application-  | PAPClosure-        { info       :: !StgInfoTable-        , arity      :: !HalfWord       -- ^ Arity of the partial application-        , n_args     :: !HalfWord       -- ^ Size of the payload in words-        , fun        :: !b              -- ^ Pointer to a 'FunClosure'-        , payload    :: ![b]            -- ^ Sequence of already applied-                                        --   arguments-        }--    -- In GHCi, if Linker.h would allow a reverse lookup, we could for exported-    -- functions fun actually find the name here.-    -- At least the other direction works via "lookupSymbol-    -- base_GHCziBase_zpzp_closure" and yields the same address (up to tags)-    -- | A function application-  | APClosure-        { info       :: !StgInfoTable-        , arity      :: !HalfWord       -- ^ Always 0-        , n_args     :: !HalfWord       -- ^ Size of payload in words-        , fun        :: !b              -- ^ Pointer to a 'FunClosure'-        , payload    :: ![b]            -- ^ Sequence of already applied-                                        --   arguments-        }--    -- | A suspended thunk evaluation-  | APStackClosure-        { info       :: !StgInfoTable-        , fun        :: !b              -- ^ Function closure-        , payload    :: ![b]            -- ^ Stack right before suspension-        }--    -- | A pointer to another closure, introduced when a thunk is updated-    -- to point at its value-  | IndClosure-        { info       :: !StgInfoTable-        , indirectee :: !b              -- ^ Target closure-        }--   -- | A byte-code object (BCO) which can be interpreted by GHC's byte-code-   -- interpreter (e.g. as used by GHCi)-  | BCOClosure-        { info       :: !StgInfoTable-        , instrs     :: !b              -- ^ A pointer to an ArrWords-                                        --   of instructions-        , literals   :: !b              -- ^ A pointer to an ArrWords-                                        --   of literals-        , bcoptrs    :: !b              -- ^ A pointer to an ArrWords-                                        --   of byte code objects-        , arity      :: !HalfWord       -- ^ The arity of this BCO-        , size       :: !HalfWord       -- ^ The size of this BCO in words-        , bitmap     :: ![Word]         -- ^ An StgLargeBitmap describing the-                                        --   pointerhood of its args/free vars-        }--    -- | A thunk under evaluation by another thread-  | BlackholeClosure-        { info       :: !StgInfoTable-        , indirectee :: !b              -- ^ The target closure-        }--    -- | A @ByteArray#@-  | ArrWordsClosure-        { info       :: !StgInfoTable-        , bytes      :: !Word           -- ^ Size of array in bytes-        , arrWords   :: ![Word]         -- ^ Array payload-        }--    -- | A @MutableByteArray#@-  | MutArrClosure-        { info       :: !StgInfoTable-        , mccPtrs    :: !Word           -- ^ Number of pointers-        , mccSize    :: !Word           -- ^ ?? Closures.h vs ClosureMacros.h-        , mccPayload :: ![b]            -- ^ Array payload-        -- Card table ignored-        }--    -- | A @SmallMutableArray#@-    ---    -- @since 8.10.1-  | SmallMutArrClosure-        { info       :: !StgInfoTable-        , mccPtrs    :: !Word           -- ^ Number of pointers-        , mccPayload :: ![b]            -- ^ Array payload-        }--  -- | An @MVar#@, with a queue of thread state objects blocking on them-  | MVarClosure-    { info       :: !StgInfoTable-    , queueHead  :: !b              -- ^ Pointer to head of queue-    , queueTail  :: !b              -- ^ Pointer to tail of queue-    , value      :: !b              -- ^ Pointer to closure-    }--    -- | An @IOPort#@, with a queue of thread state objects blocking on them-  | IOPortClosure-        { info       :: !StgInfoTable-        , queueHead  :: !b              -- ^ Pointer to head of queue-        , queueTail  :: !b              -- ^ Pointer to tail of queue-        , value      :: !b              -- ^ Pointer to closure-        }--    -- | A @MutVar#@-  | MutVarClosure-        { info       :: !StgInfoTable-        , var        :: !b              -- ^ Pointer to contents-        }--    -- | An STM blocking queue.-  | BlockingQueueClosure-        { info       :: !StgInfoTable-        , link       :: !b              -- ^ ?? Here so it looks like an IND-        , blackHole  :: !b              -- ^ The blackhole closure-        , owner      :: !b              -- ^ The owning thread state object-        , queue      :: !b              -- ^ ??-        }--  | WeakClosure-        { info        :: !StgInfoTable-        , cfinalizers :: !b-        , key         :: !b-        , value       :: !b-        , finalizer   :: !b-        , weakLink    :: !(Maybe b) -- ^ next weak pointer for the capability-        }--  -- | Representation of StgTSO: A Thread State Object. The values for-  -- 'what_next', 'why_blocked' and 'flags' are defined in @Constants.h@.-  | TSOClosure-      { info                :: !StgInfoTable-      -- pointers-      , link                :: !b-      , global_link         :: !b-      , tsoStack            :: !b -- ^ stackobj from StgTSO-      , trec                :: !b-      , blocked_exceptions  :: !b-      , bq                  :: !b-      , thread_label        :: !(Maybe b)-      -- values-      , what_next           :: !WhatNext-      , why_blocked         :: !WhyBlocked-      , flags               :: ![TsoFlags]-      , threadId            :: !Word64-      , saved_errno         :: !Word32-      , tso_dirty           :: !Word32 -- ^ non-zero => dirty-      , alloc_limit         :: !Int64-      , tot_stack_size      :: !Word32-      , prof                :: !(Maybe StgTSOProfInfo)-      }--  -- | Representation of StgStack: The 'tsoStack ' of a 'TSOClosure'.-  | StackClosure-      { info            :: !StgInfoTable-      , stack_size      :: !Word32 -- ^ stack size in *words*-      , stack_dirty     :: !Word8 -- ^ non-zero => dirty-#if __GLASGOW_HASKELL__ >= 811-      , stack_marking   :: !Word8-#endif-      }--    -------------------------------------------------------------    -- Unboxed unlifted closures--    -- | Primitive Int-  | IntClosure-        { ptipe      :: PrimType-        , intVal     :: !Int }--    -- | Primitive Word-  | WordClosure-        { ptipe      :: PrimType-        , wordVal    :: !Word }--    -- | Primitive Int64-  | Int64Closure-        { ptipe      :: PrimType-        , int64Val   :: !Int64 }--    -- | Primitive Word64-  | Word64Closure-        { ptipe      :: PrimType-        , word64Val  :: !Word64 }--    -- | Primitive Addr-  | AddrClosure-        { ptipe      :: PrimType-        , addrVal    :: !(Ptr ()) }--    -- | Primitive Float-  | FloatClosure-        { ptipe      :: PrimType-        , floatVal   :: !Float }--    -- | Primitive Double-  | DoubleClosure-        { ptipe      :: PrimType-        , doubleVal  :: !Double }--    ------------------------------------------------------------    -- Anything else--    -- | Another kind of closure-  | OtherClosure-        { info       :: !StgInfoTable-        , hvalues    :: ![b]-        , rawWords   :: ![Word]-        }--  | UnsupportedClosure-        { info       :: !StgInfoTable-        }--    -- | A primitive word from a bitmap encoded stack frame payload-    ---    -- The type itself cannot be restored (i.e. it might represent a Word8#-    -- or an Int#).-  |  UnknownTypeWordSizedPrimitive-        { wordVal :: !Word }-  deriving (Show, Generic, Functor, Foldable, Traversable)--type StgStackClosure = GenStgStackClosure Box---- | A decoded @StgStack@ with `StackFrame`s------ Stack related data structures (`GenStgStackClosure`, `GenStackField`,--- `GenStackFrame`) are defined separately from `GenClosure` as their related--- functions are very different. Though, both are closures in the sense of RTS--- structures, their decoding logic differs: While it's safe to keep a reference--- to a heap closure, the garbage collector does not update references to stack--- located closures.------ Additionally, stack frames don't appear outside of the stack. Thus, keeping--- `GenStackFrame` and `GenClosure` separated, makes these types more precise--- (in the sense what values to expect.)-data GenStgStackClosure b = GenStgStackClosure-      { ssc_info            :: !StgInfoTable-      , ssc_stack_size      :: !Word32 -- ^ stack size in *words*-      , ssc_stack           :: ![GenStackFrame b]-      }-  deriving (Foldable, Functor, Generic, Show, Traversable)--type StackField = GenStackField Box---- | Bitmap-encoded payload on the stack-data GenStackField b-    -- | A non-pointer field-    = StackWord !Word-    -- | A pointer field-    | StackBox  !b-  deriving (Foldable, Functor, Generic, Show, Traversable)--type StackFrame = GenStackFrame Box---- | A single stack frame-data GenStackFrame b =-   UpdateFrame-      { info_tbl           :: !StgInfoTable-      , updatee            :: !b-      }--  | CatchFrame-      { info_tbl            :: !StgInfoTable-      , handler             :: !b-      }--  | CatchStmFrame-      { info_tbl            :: !StgInfoTable-      , catchFrameCode      :: !b-      , handler             :: !b-      }--  | CatchRetryFrame-      { info_tbl            :: !StgInfoTable-      , running_alt_code    :: !Word-      , first_code          :: !b-      , alt_code            :: !b-      }--  | AtomicallyFrame-      { info_tbl            :: !StgInfoTable-      , atomicallyFrameCode :: !b-      , result              :: !b-      }--  | UnderflowFrame-      { info_tbl            :: !StgInfoTable-      , nextChunk           :: !(GenStgStackClosure b)-      }--  | StopFrame-      { info_tbl            :: !StgInfoTable }--  | RetSmall-      { info_tbl            :: !StgInfoTable-      , stack_payload       :: ![GenStackField b]-      }--  | RetBig-      { info_tbl            :: !StgInfoTable-      , stack_payload       :: ![GenStackField b]-      }--  | RetFun-      { info_tbl            :: !StgInfoTable-      , retFunSize          :: !Word-      , retFunFun           :: !b-      , retFunPayload       :: ![GenStackField b]-      }--  |  RetBCO-      { info_tbl            :: !StgInfoTable-      , bco                 :: !b -- ^ always a BCOClosure-      , bcoArgs             :: ![GenStackField b]-      }-  deriving (Foldable, Functor, Generic, Show, Traversable)--data PrimType-  = PInt-  | PWord-  | PInt64-  | PWord64-  | PAddr-  | PFloat-  | PDouble-  deriving (Eq, Show, Generic, Ord)--data WhatNext-  = ThreadRunGHC-  | ThreadInterpret-  | ThreadKilled-  | ThreadComplete-  | WhatNextUnknownValue Word16 -- ^ Please report this as a bug-  deriving (Eq, Show, Generic, Ord)--data WhyBlocked-  = NotBlocked-  | BlockedOnMVar-  | BlockedOnMVarRead-  | BlockedOnBlackHole-  | BlockedOnRead-  | BlockedOnWrite-  | BlockedOnDelay-  | BlockedOnSTM-  | BlockedOnDoProc-  | BlockedOnCCall-  | BlockedOnCCall_Interruptible-  | BlockedOnMsgThrowTo-  | ThreadMigrating-  | WhyBlockedUnknownValue Word16 -- ^ Please report this as a bug-  deriving (Eq, Show, Generic, Ord)--data TsoFlags-  = TsoLocked-  | TsoBlockx-  | TsoInterruptible-  | TsoStoppedOnBreakpoint-  | TsoMarked-  | TsoSqueezed-  | TsoAllocLimit-  | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug-  deriving (Eq, Show, Generic, Ord)---- | For generic code, this function returns all referenced closures.-allClosures :: GenClosure b -> [b]-allClosures (ConstrClosure {..}) = ptrArgs-allClosures (ThunkClosure {..}) = ptrArgs-allClosures (SelectorClosure {..}) = [selectee]-allClosures (IndClosure {..}) = [indirectee]-allClosures (BlackholeClosure {..}) = [indirectee]-allClosures (APClosure {..}) = fun:payload-allClosures (PAPClosure {..}) = fun:payload-allClosures (APStackClosure {..}) = fun:payload-allClosures (BCOClosure {..}) = [instrs,literals,bcoptrs]-allClosures (ArrWordsClosure {}) = []-allClosures (MutArrClosure {..}) = mccPayload-allClosures (SmallMutArrClosure {..}) = mccPayload-allClosures (MutVarClosure {..}) = [var]-allClosures (MVarClosure {..}) = [queueHead,queueTail,value]-allClosures (IOPortClosure {..}) = [queueHead,queueTail,value]-allClosures (FunClosure {..}) = ptrArgs-allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]-allClosures (WeakClosure {..}) = [cfinalizers, key, value, finalizer] ++ Data.Foldable.toList weakLink-allClosures (OtherClosure {..}) = hvalues-allClosures _ = []---- | Get the size of the top-level closure in words.--- Includes header and payload. Does not follow pointers.------ @since 8.10.1-closureSize :: Box -> Int-closureSize (Box x) = I# (closureSize# x)+import GHC.Internal.Heap.Closures
+ libraries/ghc-heap/GHC/Exts/Heap/Constants.hs view
@@ -0,0 +1,7 @@+module GHC.Exts.Heap.Constants+    ( wORD_SIZE+    , tAG_MASK+    , wORD_SIZE_IN_BITS+    ) where++import GHC.Internal.Heap.Constants
− libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc 
@@ -1,17 +0,0 @@-{-# LANGUAGE CPP #-}--module GHC.Exts.Heap.Constants-    ( wORD_SIZE-    , tAG_MASK-    , wORD_SIZE_IN_BITS-    ) where--#include "MachDeps.h"--import Prelude -- See note [Why do we import Prelude here?]-import Data.Bits--wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS :: Int-wORD_SIZE = #const SIZEOF_HSWORD-wORD_SIZE_IN_BITS = #const WORD_SIZE_IN_BITS-tAG_MASK = (1 `shift` #const TAG_BITS) - 1
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc view
@@ -87,6 +87,10 @@                 | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w)                 | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w)                 | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w)+#if __GLASGOW_HASKELL__ >= 913+                | isSet (#const TSO_STOP_NEXT_BREAKPOINT) w = TsoStopNextBreakpoint : parseTsoFlags (unset (#const TSO_STOP_NEXT_BREAKPOINT) w)+                | isSet (#const TSO_STOP_AFTER_RETURN) w = TsoStopAfterReturn : parseTsoFlags (unset (#const TSO_STOP_AFTER_RETURN) w)+#endif parseTsoFlags 0 = [] parseTsoFlags w = [TsoFlagsUnknownValue w] @@ -99,9 +103,7 @@ data StackFields = StackFields {     stack_size :: Word32,     stack_dirty :: Word8,-#if __GLASGOW_HASKELL__ >= 811     stack_marking :: Word8,-#endif     stack_sp :: Addr## } @@ -110,9 +112,7 @@ peekStackFields ptr = do     stack_size' <- (#peek struct StgStack_, stack_size) ptr ::IO Word32     dirty' <- (#peek struct StgStack_, dirty) ptr-#if __GLASGOW_HASKELL__ >= 811     marking' <- (#peek struct StgStack_, marking) ptr-#endif     Ptr sp' <- (#peek struct StgStack_, sp) ptr      -- TODO decode the stack.@@ -120,9 +120,6 @@     return StackFields {         stack_size = stack_size',         stack_dirty = dirty',-#if __GLASGOW_HASKELL__ >= 811         stack_marking = marking',-#endif         stack_sp = sp'     }-
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc view
@@ -87,6 +87,10 @@                 | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w)                 | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w)                 | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w)+#if __GLASGOW_HASKELL__ >= 913+                | isSet (#const TSO_STOP_NEXT_BREAKPOINT) w = TsoStopNextBreakpoint : parseTsoFlags (unset (#const TSO_STOP_NEXT_BREAKPOINT) w)+                | isSet (#const TSO_STOP_AFTER_RETURN) w = TsoStopAfterReturn : parseTsoFlags (unset (#const TSO_STOP_AFTER_RETURN) w)+#endif parseTsoFlags 0 = [] parseTsoFlags w = [TsoFlagsUnknownValue w] @@ -99,9 +103,7 @@ data StackFields = StackFields {     stack_size :: Word32,     stack_dirty :: Word8,-#if __GLASGOW_HASKELL__ >= 811     stack_marking :: Word8,-#endif     stack_sp :: Addr## } @@ -110,9 +112,7 @@ peekStackFields ptr = do     stack_size' <- (#peek struct StgStack_, stack_size) ptr ::IO Word32     dirty' <- (#peek struct StgStack_, dirty) ptr-#if __GLASGOW_HASKELL__ >= 811     marking' <- (#peek struct StgStack_, marking) ptr-#endif     Ptr sp' <- (#peek struct StgStack_, sp) ptr      -- TODO decode the stack.@@ -120,8 +120,6 @@     return StackFields {         stack_size = stack_size',         stack_dirty = dirty',-#if __GLASGOW_HASKELL__ >= 811         stack_marking = marking',-#endif         stack_sp = sp'     }
+ libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hs view
@@ -0,0 +1,9 @@+module GHC.Exts.Heap.InfoTable+    ( module GHC.Exts.Heap.InfoTable.Types+    , itblSize+    , peekItbl+    , pokeItbl+    ) where++import GHC.Exts.Heap.InfoTable.Types+import GHC.Internal.Heap.InfoTable
− libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc 
@@ -1,74 +0,0 @@-{-# LANGUAGE NoMonoLocalBinds #-}-module GHC.Exts.Heap.InfoTable-    ( module GHC.Exts.Heap.InfoTable.Types-    , itblSize-    , peekItbl-    , pokeItbl-    ) where--#include "Rts.h"--import Prelude -- See note [Why do we import Prelude here?]-import GHC.Exts.Heap.InfoTable.Types-#if !defined(TABLES_NEXT_TO_CODE)-import GHC.Exts.Heap.Constants-import Data.Maybe-#endif-import Foreign------------------------------------------------------------------------------ Profiling specific code------ The functions that follow all rely on PROFILING. They are duplicated in--- ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc where PROFILING is defined. This--- allows hsc2hs to generate values for both profiling and non-profiling builds.---- | Read an InfoTable from the heap into a haskell type.--- WARNING: This code assumes it is passed a pointer to a "standard" info--- table. If tables_next_to_code is enabled, it will look 1 byte before the--- start for the entry field.-peekItbl :: Ptr StgInfoTable -> IO StgInfoTable-peekItbl a0 = do-#if !defined(TABLES_NEXT_TO_CODE)-  let ptr = a0 `plusPtr` (negate wORD_SIZE)-  entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr-#else-  let ptr = a0-      entry' = Nothing-#endif-  ptrs'   <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr-  nptrs'  <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr-  tipe'   <- (#peek struct StgInfoTable_, type) ptr-  srtlen' <- (#peek struct StgInfoTable_, srt) a0-  return StgInfoTable-    { entry  = entry'-    , ptrs   = ptrs'-    , nptrs  = nptrs'-    , tipe   = toEnum (fromIntegral (tipe' :: HalfWord))-    , srtlen = srtlen'-    , code   = Nothing-    }--pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()-pokeItbl a0 itbl = do-#if !defined(TABLES_NEXT_TO_CODE)-  (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))-#endif-  (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)-  (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)-  (#poke StgInfoTable, type) a0 (toHalfWord (fromEnum (tipe itbl)))-  (#poke StgInfoTable, srt) a0 (srtlen itbl)-#if defined(TABLES_NEXT_TO_CODE)-  let code_offset = a0 `plusPtr` (#offset StgInfoTable, code)-  case code itbl of-    Nothing -> return ()-    Just (Left xs) -> pokeArray code_offset xs-    Just (Right xs) -> pokeArray code_offset xs-#endif-  where-    toHalfWord :: Int -> HalfWord-    toHalfWord i = fromIntegral i---- | Size in bytes of a standard InfoTable-itblSize :: Int-itblSize = (#size struct StgInfoTable_)
+ libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hs view
@@ -0,0 +1,8 @@+module GHC.Exts.Heap.InfoTable.Types+    ( StgInfoTable(..)+    , EntryFunPtr+    , HalfWord(..)+    , ItblCodes+    ) where++import GHC.Internal.Heap.InfoTable.Types
− libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc 
@@ -1,46 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module GHC.Exts.Heap.InfoTable.Types-    ( StgInfoTable(..)-    , EntryFunPtr-    , HalfWord(..)-    , ItblCodes-    ) where--#include "Rts.h"--import Prelude -- See note [Why do we import Prelude here?]-import GHC.Generics-import GHC.Exts.Heap.ClosureTypes-import Foreign--type ItblCodes = Either [Word8] [Word32]--#include "ghcautoconf.h"--- Ultra-minimalist version specially for constructors-#if SIZEOF_VOID_P == 8-type HalfWord' = Word32-#elif SIZEOF_VOID_P == 4-type HalfWord' = Word16-#else-#error Unknown SIZEOF_VOID_P-#endif--newtype HalfWord = HalfWord HalfWord'-    deriving newtype (Enum, Eq, Integral, Num, Ord, Real, Show, Storable)--type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))---- | This is a somewhat faithful representation of an info table. See--- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/InfoTables.h>--- for more details on this data structure.-data StgInfoTable = StgInfoTable {-   entry  :: Maybe EntryFunPtr, -- Just <=> not TABLES_NEXT_TO_CODE-   ptrs   :: HalfWord,-   nptrs  :: HalfWord,-   tipe   :: ClosureType,-   srtlen :: HalfWord,-   code   :: Maybe ItblCodes -- Just <=> TABLES_NEXT_TO_CODE-  } deriving (Eq, Show, Generic)
+ libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hs view
@@ -0,0 +1,9 @@+module GHC.Exts.Heap.InfoTableProf+    ( module GHC.Exts.Heap.InfoTable.Types+    , itblSize+    , peekItbl+    , pokeItbl+    ) where++import GHC.Exts.Heap.InfoTable.Types+import GHC.Internal.Heap.InfoTableProf
− libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc 
@@ -1,67 +0,0 @@-{-# LANGUAGE NoMonoLocalBinds #-}-module GHC.Exts.Heap.InfoTableProf-    ( module GHC.Exts.Heap.InfoTable.Types-    , itblSize-    , peekItbl-    , pokeItbl-    ) where---- This file overrides InfoTable.hsc's implementation of peekItbl and pokeItbl.--- Manually defining PROFILING gives the #peek and #poke macros an accurate--- representation of StgInfoTable_ when hsc2hs runs.-#define PROFILING-#include "Rts.h"--import Prelude -- See note [Why do we import Prelude here?]-import GHC.Exts.Heap.InfoTable.Types-#if !defined(TABLES_NEXT_TO_CODE)-import GHC.Exts.Heap.Constants-import Data.Maybe-#endif-import Foreign---- | Read an InfoTable from the heap into a haskell type.--- WARNING: This code assumes it is passed a pointer to a "standard" info--- table. If tables_next_to_code is enabled, it will look 1 byte before the--- start for the entry field.-peekItbl :: Ptr StgInfoTable -> IO StgInfoTable-peekItbl a0 = do-#if !defined(TABLES_NEXT_TO_CODE)-  let ptr = a0 `plusPtr` (negate wORD_SIZE)-  entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr-#else-  let ptr = a0-      entry' = Nothing-#endif-  ptrs'   <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr-  nptrs'  <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr-  tipe'   <- (#peek struct StgInfoTable_, type) ptr-  srtlen' <- (#peek struct StgInfoTable_, srt) a0-  return StgInfoTable-    { entry  = entry'-    , ptrs   = ptrs'-    , nptrs  = nptrs'-    , tipe   = toEnum (fromIntegral (tipe' :: HalfWord))-    , srtlen = srtlen'-    , code   = Nothing-    }--pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()-pokeItbl a0 itbl = do-#if !defined(TABLES_NEXT_TO_CODE)-  (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))-#endif-  (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)-  (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)-  (#poke StgInfoTable, type) a0 (fromEnum (tipe itbl))-  (#poke StgInfoTable, srt) a0 (srtlen itbl)-#if defined(TABLES_NEXT_TO_CODE)-  let code_offset = a0 `plusPtr` (#offset StgInfoTable, code)-  case code itbl of-    Nothing -> return ()-    Just (Left xs) -> pokeArray code_offset xs-    Just (Right xs) -> pokeArray code_offset xs-#endif--itblSize :: Int-itblSize = (#size struct StgInfoTable_)
libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc view
@@ -6,7 +6,6 @@     , peekTopCCS ) where -#if __GLASGOW_HASKELL__ >= 811  -- See [hsc and CPP workaround] @@ -158,16 +157,3 @@ -- | casts a @Ptr@ to an @Int@ ptrToInt :: Ptr a -> Int ptrToInt (Ptr a##) = I## (addr2Int## a##)--#else-import Prelude-import Foreign--import GHC.Exts.Heap.ProfInfo.Types--peekStgTSOProfInfo :: (Ptr b -> IO (Maybe CostCentreStack)) -> Ptr a -> IO (Maybe StgTSOProfInfo)-peekStgTSOProfInfo _ _ = return Nothing--peekTopCCS :: Ptr a -> IO (Maybe CostCentreStack)-peekTopCCS _ = return Nothing-#endif
libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs view
@@ -1,56 +1,9 @@-{-# LANGUAGE DeriveGeneric #-}--module GHC.Exts.Heap.ProfInfo.Types where--import Prelude-import Data.Word-import GHC.Generics---- | This is a somewhat faithful representation of StgTSOProfInfo. See--- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/TSO.h>--- for more details on this data structure.-newtype StgTSOProfInfo = StgTSOProfInfo {-    cccs :: Maybe CostCentreStack-} deriving (Show, Generic, Eq, Ord)---- | This is a somewhat faithful representation of CostCentreStack. See--- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h>--- for more details on this data structure.-data CostCentreStack = CostCentreStack {-    ccs_ccsID :: Int,-    ccs_cc :: CostCentre,-    ccs_prevStack :: Maybe CostCentreStack,-    ccs_indexTable :: Maybe IndexTable,-    ccs_root :: Maybe CostCentreStack,-    ccs_depth :: Word,-    ccs_scc_count :: Word64,-    ccs_selected :: Word,-    ccs_time_ticks :: Word,-    ccs_mem_alloc :: Word64,-    ccs_inherited_alloc :: Word64,-    ccs_inherited_ticks :: Word-} deriving (Show, Generic, Eq, Ord)---- | This is a somewhat faithful representation of CostCentre. See--- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h>--- for more details on this data structure.-data CostCentre = CostCentre {-    cc_ccID :: Int,-    cc_label :: String,-    cc_module :: String,-    cc_srcloc :: Maybe String,-    cc_mem_alloc :: Word64,-    cc_time_ticks :: Word,-    cc_is_caf :: Bool,-    cc_link :: Maybe CostCentre-} deriving (Show, Generic, Eq, Ord)+module GHC.Exts.Heap.ProfInfo.Types (+  StgTSOProfInfo(..),+  CostCentreStack(..),+  CostCentre(..),+  IndexTable(..),+)+  where --- | This is a somewhat faithful representation of IndexTable. See--- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h>--- for more details on this data structure.-data IndexTable = IndexTable {-    it_cc :: CostCentre,-    it_ccs :: Maybe CostCentreStack,-    it_next :: Maybe IndexTable,-    it_back_edge :: Bool-} deriving (Show, Generic, Eq, Ord)+import GHC.Internal.Heap.ProfInfo.Types
libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc view
@@ -13,7 +13,6 @@ import Data.Char import Data.List (intercalate) import Foreign-import GHC.CString import GHC.Exts  {- To find the string in the constructor's info table we need to consider
− libraries/ghc-heap/cbits/HeapPrim.cmm 
@@ -1,13 +0,0 @@-#include "Cmm.h"--Ghclib_aToWordzh (P_ clos)-{-    return (clos);-}--Ghclib_reallyUnsafePtrEqualityUpToTag (W_ clos1, W_  clos2)-{-    clos1 = UNTAG(clos1);-    clos2 = UNTAG(clos2);-    return (clos1 == clos2);-}
libraries/ghc-heap/ghc-heap.cabal view
@@ -1,6 +1,6 @@ cabal-version:  3.0 name:           ghc-heap-version:        9.12.3+version:        9.14.1 license:        BSD-3-Clause license-file:   LICENSE maintainer:     libraries@haskell.org@@ -23,18 +23,12 @@   default-language: Haskell2010    build-depends:    base             >= 4.9.0 && < 5.0-                  , ghc-prim         > 0.2 && < 0.14                   , rts              == 1.0.*-                  , containers       >= 0.6.2.1 && < 0.8+                  , containers       >= 0.6.2.1 && < 0.9 -  if impl(ghc >= 9.9)-    build-depends:  ghc-internal     >= 9.900 && < 9.1203.99999+  build-depends:  ghc-internal >= 9.1401.0 && < 9.1401.99999    ghc-options:      -Wall-  if !os(ghcjs)-    cmm-sources:      cbits/HeapPrim.cmm-                      cbits/Stack.cmm-  c-sources:        cbits/Stack_c.c    default-extensions: NoImplicitPrelude 
+ libraries/ghc-internal/cbits/HeapPrim.cmm view
@@ -0,0 +1,13 @@+#include "Cmm.h"++Ghclib_aToWordzh (P_ clos)+{+    return (clos);+}++Ghclib_reallyUnsafePtrEqualityUpToTag (W_ clos1, W_  clos2)+{+    clos1 = UNTAG(clos1);+    clos2 = UNTAG(clos2);+    return (clos1 == clos2);+}
+ libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs view
@@ -0,0 +1,658 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GHCForeignImportPrim #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+-- Late cost centres introduce a thunk in the asBox function, which leads to+-- an additional wrapper being added to any value placed inside a box.+-- This can be removed once our boot compiler is no longer affected by #25212+{-# OPTIONS_GHC -fno-prof-late  #-}+{-# LANGUAGE NamedFieldPuns #-}++module GHC.Internal.Heap.Closures (+    -- * Closures+      Closure+    , GenClosure(..)+    , getClosureInfoTbl+    , getClosureInfoTbl_maybe+    , getClosurePtrArgs+    , getClosurePtrArgs_maybe+    , PrimType(..)+    , WhatNext(..)+    , WhyBlocked(..)+    , TsoFlags(..)+    , allClosures+    , closureSize++    -- * Stack+    , StgStackClosure+    , GenStgStackClosure(..)+    , StackFrame+    , GenStackFrame(..)+    , StackField+    , GenStackField(..)++    -- * Boxes+    , Box(..)+    , areBoxesEqual+    , asBox+    ) where++import GHC.Internal.Base+import GHC.Internal.Show++import GHC.Internal.Heap.Constants+#if defined(PROFILING)+import GHC.Internal.Heap.InfoTable () -- see Note [No way-dependent imports]+import GHC.Internal.Heap.InfoTableProf+#else+import GHC.Internal.Heap.InfoTable+import GHC.Internal.Heap.InfoTableProf () -- see Note [No way-dependent imports]++{-+Note [No way-dependent imports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+`ghc -M` currently assumes that the imports for a module are the same+in every way.  This is arguably a bug, but breaking this assumption by+importing different things in different ways can cause trouble.  For+example, this module in the profiling way imports and uses+GHC.Exts.Heap.InfoTableProf.  When it was not also imported in the+vanilla way, there were intermittent build failures due to this module+being compiled in the profiling way before GHC.Exts.Heap.InfoTableProf+in the profiling way. (#15197)+-}+#endif++import GHC.Internal.Heap.ProfInfo.Types++import GHC.Internal.Data.Bits+import GHC.Internal.Data.Foldable (Foldable, toList)+import GHC.Internal.Data.Traversable (Traversable)+import GHC.Internal.Int+import GHC.Internal.Num+import GHC.Internal.Real+import GHC.Internal.Word+import GHC.Internal.Exts+import GHC.Internal.Generics+import GHC.Internal.Numeric+import GHC.Internal.Stack (HasCallStack)++------------------------------------------------------------------------+-- Boxes++foreign import prim "Ghclib_aToWordzh" aToWord# :: Any -> Word#++foreign import prim "Ghclib_reallyUnsafePtrEqualityUpToTag"+    reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#++-- | An arbitrary Haskell value in a safe Box. The point is that even+-- unevaluated thunks can safely be moved around inside the Box, and when+-- required, e.g. in 'getBoxedClosureData', the function knows how far it has+-- to evaluate the argument.+data Box = Box Any++instance Show Box where+-- From libraries/base/GHC/Ptr.lhs+   showsPrec _ (Box a) rs =+    -- unsafePerformIO (print "↓" >> pClosure a) `seq`+    pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs+     where+       ptr  = W# (aToWord# a)+       tag  = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)+       addr = ptr - tag+       pad_out ls = '0':'x':ls++-- |This takes an arbitrary value and puts it into a box.+-- Note that calls like+--+-- > asBox (head list)+--+-- will put the thunk \"head list\" into the box, /not/ the element at the head+-- of the list. For that, use careful case expressions:+--+-- > case list of x:_ -> asBox x+asBox :: a -> Box+asBox x = Box (unsafeCoerce# x)++-- | Boxes can be compared, but this is not pure, as different heap objects can,+-- after garbage collection, become the same object.+areBoxesEqual :: Box -> Box -> IO Bool+areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of+    0# -> pure False+    _  -> pure True+++------------------------------------------------------------------------+-- Closures+type Closure = GenClosure Box++-- | This is the representation of a Haskell value on the heap. It reflects+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/Closures.h>+--+-- The data type is parametrized by `b`: the type to store references in.+-- Usually this is a 'Box' with the type synonym 'Closure'.+--+-- All Heap objects have the same basic layout. A header containing a pointer to+-- the info table and a payload with various fields. The @info@ field below+-- always refers to the info table pointed to by the header. The remaining+-- fields are the payload.+--+-- See+-- <https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/storage/heap-objects>+-- for more information.+data GenClosure b+  = -- | A data constructor+    ConstrClosure+        { info       :: !StgInfoTable+        , ptrArgs    :: ![b]            -- ^ Pointer arguments+        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments+        , pkg        :: !String         -- ^ Package name+        , modl       :: !String         -- ^ Module name+        , name       :: !String         -- ^ Constructor name+        }++    -- | A function+  | FunClosure+        { info       :: !StgInfoTable+        , ptrArgs    :: ![b]            -- ^ Pointer arguments+        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments+        }++    -- | A thunk, an expression not obviously in head normal form+  | ThunkClosure+        { info       :: !StgInfoTable+        , ptrArgs    :: ![b]            -- ^ Pointer arguments+        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments+        }++    -- | A thunk which performs a simple selection operation+  | SelectorClosure+        { info       :: !StgInfoTable+        , selectee   :: !b              -- ^ Pointer to the object being+                                        --   selected from+        }++    -- | An unsaturated function application+  | PAPClosure+        { info       :: !StgInfoTable+        , arity      :: !HalfWord       -- ^ Arity of the partial application+        , n_args     :: !HalfWord       -- ^ Size of the payload in words+        , fun        :: !b              -- ^ Pointer to a 'FunClosure'+        , payload    :: ![b]            -- ^ Sequence of already applied+                                        --   arguments+        }++    -- In GHCi, if Linker.h would allow a reverse lookup, we could for exported+    -- functions fun actually find the name here.+    -- At least the other direction works via "lookupSymbol+    -- base_GHCziBase_zpzp_closure" and yields the same address (up to tags)+    -- | A function application+  | APClosure+        { info       :: !StgInfoTable+        , arity      :: !HalfWord       -- ^ Always 0+        , n_args     :: !HalfWord       -- ^ Size of payload in words+        , fun        :: !b              -- ^ Pointer to a 'FunClosure'+        , payload    :: ![b]            -- ^ Sequence of already applied+                                        --   arguments+        }++    -- | A suspended thunk evaluation+  | APStackClosure+        { info       :: !StgInfoTable+        , fun        :: !b              -- ^ Function closure+        , payload    :: ![b]            -- ^ Stack right before suspension+        }++    -- | A pointer to another closure, introduced when a thunk is updated+    -- to point at its value+  | IndClosure+        { info       :: !StgInfoTable+        , indirectee :: !b              -- ^ Target closure+        }++   -- | A byte-code object (BCO) which can be interpreted by GHC's byte-code+   -- interpreter (e.g. as used by GHCi)+  | BCOClosure+        { info       :: !StgInfoTable+        , instrs     :: !b              -- ^ A pointer to an ArrWords+                                        --   of instructions+        , literals   :: !b              -- ^ A pointer to an ArrWords+                                        --   of literals+        , bcoptrs    :: !b              -- ^ A pointer to an ArrWords+                                        --   of byte code objects+        , arity      :: !HalfWord       -- ^ The arity of this BCO+        , size       :: !HalfWord       -- ^ The size of this BCO in words+        , bitmap     :: ![Word]         -- ^ An StgLargeBitmap describing the+                                        --   pointerhood of its args/free vars+        }++    -- | A thunk under evaluation by another thread+  | BlackholeClosure+        { info       :: !StgInfoTable+        , indirectee :: !b              -- ^ The target closure+        }++    -- | A @ByteArray#@+  | ArrWordsClosure+        { info       :: !StgInfoTable+        , bytes      :: !Word           -- ^ Size of array in bytes+        , arrWords   :: ![Word]         -- ^ Array payload+        }++    -- | A @MutableByteArray#@+  | MutArrClosure+        { info       :: !StgInfoTable+        , mccPtrs    :: !Word           -- ^ Number of pointers+        , mccSize    :: !Word           -- ^ ?? Closures.h vs ClosureMacros.h+        , mccPayload :: ![b]            -- ^ Array payload+        -- Card table ignored+        }++    -- | A @SmallMutableArray#@+    --+    -- @since 8.10.1+  | SmallMutArrClosure+        { info       :: !StgInfoTable+        , mccPtrs    :: !Word           -- ^ Number of pointers+        , mccPayload :: ![b]            -- ^ Array payload+        }++  -- | An @MVar#@, with a queue of thread state objects blocking on them+  | MVarClosure+    { info       :: !StgInfoTable+    , queueHead  :: !b              -- ^ Pointer to head of queue+    , queueTail  :: !b              -- ^ Pointer to tail of queue+    , value      :: !b              -- ^ Pointer to closure+    }++    -- | A @MutVar#@+  | MutVarClosure+        { info       :: !StgInfoTable+        , var        :: !b              -- ^ Pointer to contents+        }++    -- | An STM blocking queue.+  | BlockingQueueClosure+        { info       :: !StgInfoTable+        , link       :: !b              -- ^ ?? Here so it looks like an IND+        , blackHole  :: !b              -- ^ The blackhole closure+        , owner      :: !b              -- ^ The owning thread state object+        , queue      :: !b              -- ^ ??+        }++  | WeakClosure+        { info        :: !StgInfoTable+        , cfinalizers :: !b+        , key         :: !b+        , value       :: !b+        , finalizer   :: !b+        , weakLink    :: !(Maybe b) -- ^ next weak pointer for the capability+        }++  -- | Representation of StgTSO: A Thread State Object. The values for+  -- 'what_next', 'why_blocked' and 'flags' are defined in @Constants.h@.+  | TSOClosure+      { info                :: !StgInfoTable+      -- pointers+      , link                :: !b+      , global_link         :: !b+      , tsoStack            :: !b -- ^ stackobj from StgTSO+      , trec                :: !b+      , blocked_exceptions  :: !b+      , bq                  :: !b+      , thread_label        :: !(Maybe b)+      -- values+      , what_next           :: !WhatNext+      , why_blocked         :: !WhyBlocked+      , flags               :: ![TsoFlags]+      , threadId            :: !Word64+      , saved_errno         :: !Word32+      , tso_dirty           :: !Word32 -- ^ non-zero => dirty+      , alloc_limit         :: !Int64+      , tot_stack_size      :: !Word32+      , prof                :: !(Maybe StgTSOProfInfo)+      }++  -- | Representation of StgStack: The 'tsoStack ' of a 'TSOClosure'.+  | StackClosure+      { info            :: !StgInfoTable+      , stack_size      :: !Word32 -- ^ stack size in *words*+      , stack_dirty     :: !Word8 -- ^ non-zero => dirty+      , stack_marking   :: !Word8+      }++    ------------------------------------------------------------+    -- Unboxed unlifted closures++    -- | Primitive Int+  | IntClosure+        { ptipe      :: PrimType+        , intVal     :: !Int }++    -- | Primitive Word+  | WordClosure+        { ptipe      :: PrimType+        , wordVal    :: !Word }++    -- | Primitive Int64+  | Int64Closure+        { ptipe      :: PrimType+        , int64Val   :: !Int64 }++    -- | Primitive Word64+  | Word64Closure+        { ptipe      :: PrimType+        , word64Val  :: !Word64 }++    -- | Primitive Addr+  | AddrClosure+        { ptipe      :: PrimType+        , addrVal    :: !(Ptr ()) }++    -- | Primitive Float+  | FloatClosure+        { ptipe      :: PrimType+        , floatVal   :: !Float }++    -- | Primitive Double+  | DoubleClosure+        { ptipe      :: PrimType+        , doubleVal  :: !Double }++    -----------------------------------------------------------+    -- Anything else++    -- | Another kind of closure+  | OtherClosure+        { info       :: !StgInfoTable+        , hvalues    :: ![b]+        , rawWords   :: ![Word]+        }++  | UnsupportedClosure+        { info       :: !StgInfoTable+        }++    -- | A primitive word from a bitmap encoded stack frame payload+    --+    -- The type itself cannot be restored (i.e. it might represent a Word8#+    -- or an Int#).+  |  UnknownTypeWordSizedPrimitive+        { wordVal :: !Word }+  deriving (Show, Generic, Functor, Foldable, Traversable)++-- | Get the info table for a heap closure, or Nothing for a prim value+--+-- @since 9.14.1+getClosureInfoTbl_maybe :: GenClosure b -> Maybe StgInfoTable+{-# INLINE getClosureInfoTbl_maybe #-} -- Ensure we can get rid of the just box+getClosureInfoTbl_maybe closure = case closure of+  ConstrClosure{info} ->Just info+  FunClosure{info} ->Just info+  ThunkClosure{info} ->Just info+  SelectorClosure{info} ->Just info+  PAPClosure{info} ->Just info+  APClosure{info} ->Just info+  APStackClosure{info} ->Just info+  IndClosure{info} ->Just info+  BCOClosure{info} ->Just info+  BlackholeClosure{info} ->Just info+  ArrWordsClosure{info} ->Just info+  MutArrClosure{info} ->Just info+  SmallMutArrClosure{info} ->Just info+  MVarClosure{info} ->Just info+  MutVarClosure{info} ->Just info+  BlockingQueueClosure{info} ->Just info+  WeakClosure{info} ->Just info+  TSOClosure{info} ->Just info+  StackClosure{info} ->Just info++  IntClosure{} -> Nothing+  WordClosure{} -> Nothing+  Int64Closure{} -> Nothing+  Word64Closure{} -> Nothing+  AddrClosure{} -> Nothing+  FloatClosure{} -> Nothing+  DoubleClosure{} -> Nothing++  OtherClosure{info} -> Just info+  UnsupportedClosure {info} -> Just info++  UnknownTypeWordSizedPrimitive{} -> Nothing++-- | Partial version of getClosureInfoTbl_maybe for when we know we deal with a+-- heap closure.+--+-- @since 9.14.1+getClosureInfoTbl :: HasCallStack => GenClosure b -> StgInfoTable+getClosureInfoTbl closure = case getClosureInfoTbl_maybe closure of+  Just info -> info+  Nothing -> error "getClosureInfoTbl - Closure without info table"++-- | Get the info table for a heap closure, or Nothing for a prim value+--+-- @since 9.14.1+getClosurePtrArgs_maybe :: GenClosure b -> Maybe [b]+{-# INLINE getClosurePtrArgs_maybe #-} -- Ensure we can get rid of the just box+getClosurePtrArgs_maybe closure = case closure of+  ConstrClosure{ptrArgs} -> Just ptrArgs+  FunClosure{ptrArgs} -> Just ptrArgs+  ThunkClosure{ptrArgs} -> Just ptrArgs+  SelectorClosure{} -> Nothing+  PAPClosure{} -> Nothing+  APClosure{} -> Nothing+  APStackClosure{} -> Nothing+  IndClosure{} -> Nothing+  BCOClosure{} -> Nothing+  BlackholeClosure{} -> Nothing+  ArrWordsClosure{} -> Nothing+  MutArrClosure{} -> Nothing+  SmallMutArrClosure{} -> Nothing+  MVarClosure{} -> Nothing+  MutVarClosure{} -> Nothing+  BlockingQueueClosure{} -> Nothing+  WeakClosure{} -> Nothing+  TSOClosure{} -> Nothing+  StackClosure{} -> Nothing++  IntClosure{} -> Nothing+  WordClosure{} -> Nothing+  Int64Closure{} -> Nothing+  Word64Closure{} -> Nothing+  AddrClosure{} -> Nothing+  FloatClosure{} -> Nothing+  DoubleClosure{} -> Nothing++  OtherClosure{} -> Nothing+  UnsupportedClosure{} -> Nothing++  UnknownTypeWordSizedPrimitive{} -> Nothing++-- | Partial version of getClosureInfoTbl_maybe for when we know we deal with a+-- heap closure.+--+-- @since 9.14.1+getClosurePtrArgs :: HasCallStack => GenClosure b -> [b]+getClosurePtrArgs closure = case getClosurePtrArgs_maybe closure of+  Just ptrs -> ptrs+  Nothing -> error "getClosurePtrArgs - Closure without ptrArgs field"++type StgStackClosure = GenStgStackClosure Box++-- | A decoded @StgStack@ with `StackFrame`s+--+-- Stack related data structures (`GenStgStackClosure`, `GenStackField`,+-- `GenStackFrame`) are defined separately from `GenClosure` as their related+-- functions are very different. Though, both are closures in the sense of RTS+-- structures, their decoding logic differs: While it's safe to keep a reference+-- to a heap closure, the garbage collector does not update references to stack+-- located closures.+--+-- Additionally, stack frames don't appear outside of the stack. Thus, keeping+-- `GenStackFrame` and `GenClosure` separated, makes these types more precise+-- (in the sense what values to expect.)+data GenStgStackClosure b = GenStgStackClosure+      { ssc_info            :: !StgInfoTable+      , ssc_stack_size      :: !Word32 -- ^ stack size in *words*+      , ssc_stack           :: ![GenStackFrame b]+      }+  deriving (Foldable, Functor, Generic, Show, Traversable)++type StackField = GenStackField Box++-- | Bitmap-encoded payload on the stack+data GenStackField b+    -- | A non-pointer field+    = StackWord !Word+    -- | A pointer field+    | StackBox  !b+  deriving (Foldable, Functor, Generic, Show, Traversable)++type StackFrame = GenStackFrame Box++-- | A single stack frame+data GenStackFrame b =+   UpdateFrame+      { info_tbl           :: !StgInfoTable+      , updatee            :: !b+      }++  | CatchFrame+      { info_tbl            :: !StgInfoTable+      , handler             :: !b+      }++  | CatchStmFrame+      { info_tbl            :: !StgInfoTable+      , catchFrameCode      :: !b+      , handler             :: !b+      }++  | CatchRetryFrame+      { info_tbl            :: !StgInfoTable+      , running_alt_code    :: !Word+      , first_code          :: !b+      , alt_code            :: !b+      }++  | AtomicallyFrame+      { info_tbl            :: !StgInfoTable+      , atomicallyFrameCode :: !b+      , result              :: !b+      }++  | UnderflowFrame+      { info_tbl            :: !StgInfoTable+      , nextChunk           :: !(GenStgStackClosure b)+      }++  | StopFrame+      { info_tbl            :: !StgInfoTable }++  | RetSmall+      { info_tbl            :: !StgInfoTable+      , stack_payload       :: ![GenStackField b]+      }++  | RetBig+      { info_tbl            :: !StgInfoTable+      , stack_payload       :: ![GenStackField b]+      }++  | RetFun+      { info_tbl            :: !StgInfoTable+      , retFunSize          :: !Word+      , retFunFun           :: !b+      , retFunPayload       :: ![GenStackField b]+      }++  | RetBCO+      { info_tbl            :: !StgInfoTable+      , bco                 :: !b -- ^ always a BCOClosure+      , bcoArgs             :: ![GenStackField b]+      }+  | AnnFrame+      { info_tbl            :: !StgInfoTable+      , annotation          :: !b+      }+  deriving (Foldable, Functor, Generic, Show, Traversable)++data PrimType+  = PInt+  | PWord+  | PInt64+  | PWord64+  | PAddr+  | PFloat+  | PDouble+  deriving (Eq, Show, Generic, Ord)++data WhatNext+  = ThreadRunGHC+  | ThreadInterpret+  | ThreadKilled+  | ThreadComplete+  | WhatNextUnknownValue Word16 -- ^ Please report this as a bug+  deriving (Eq, Show, Generic, Ord)++data WhyBlocked+  = NotBlocked+  | BlockedOnMVar+  | BlockedOnMVarRead+  | BlockedOnBlackHole+  | BlockedOnRead+  | BlockedOnWrite+  | BlockedOnDelay+  | BlockedOnSTM+  | BlockedOnDoProc+  | BlockedOnCCall+  | BlockedOnCCall_Interruptible+  | BlockedOnMsgThrowTo+  | ThreadMigrating+  | WhyBlockedUnknownValue Word16 -- ^ Please report this as a bug+  deriving (Eq, Show, Generic, Ord)++data TsoFlags+  = TsoLocked+  | TsoBlockx+  | TsoInterruptible+  | TsoStoppedOnBreakpoint+  | TsoMarked+  | TsoSqueezed+  | TsoAllocLimit+  | TsoStopNextBreakpoint+  | TsoStopAfterReturn+  | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug+  deriving (Eq, Show, Generic, Ord)++-- | For generic code, this function returns all referenced closures.+allClosures :: GenClosure b -> [b]+allClosures (ConstrClosure {..}) = ptrArgs+allClosures (ThunkClosure {..}) = ptrArgs+allClosures (SelectorClosure {..}) = [selectee]+allClosures (IndClosure {..}) = [indirectee]+allClosures (BlackholeClosure {..}) = [indirectee]+allClosures (APClosure {..}) = fun:payload+allClosures (PAPClosure {..}) = fun:payload+allClosures (APStackClosure {..}) = fun:payload+allClosures (BCOClosure {..}) = [instrs,literals,bcoptrs]+allClosures (ArrWordsClosure {}) = []+allClosures (MutArrClosure {..}) = mccPayload+allClosures (SmallMutArrClosure {..}) = mccPayload+allClosures (MutVarClosure {..}) = [var]+allClosures (MVarClosure {..}) = [queueHead,queueTail,value]+allClosures (FunClosure {..}) = ptrArgs+allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]+allClosures (WeakClosure {..}) = [cfinalizers, key, value, finalizer] ++ GHC.Internal.Data.Foldable.toList weakLink+allClosures (OtherClosure {..}) = hvalues+allClosures _ = []++-- | Get the size of the top-level closure in words.+-- Includes header and payload. Does not follow pointers.+--+-- @since 8.10.1+closureSize :: Box -> Int+closureSize (Box x) = I# (closureSize# x)
+ libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc view
@@ -0,0 +1,18 @@+{-# LANGUAGE CPP #-}++module GHC.Internal.Heap.Constants+    ( wORD_SIZE+    , tAG_MASK+    , wORD_SIZE_IN_BITS+    ) where++#include "MachDeps.h"++import GHC.Internal.Data.Bits+import GHC.Internal.Int+import GHC.Internal.Num++wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS :: Int+wORD_SIZE = #const SIZEOF_HSWORD+wORD_SIZE_IN_BITS = #const WORD_SIZE_IN_BITS+tAG_MASK = (1 `shift` #const TAG_BITS) - 1
+ libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc view
@@ -0,0 +1,83 @@+{-# LANGUAGE NoMonoLocalBinds #-}+module GHC.Internal.Heap.InfoTable+    ( module GHC.Internal.Heap.InfoTable.Types+    , itblSize+    , peekItbl+    , pokeItbl+    ) where++#include "Rts.h"++import GHC.Internal.Base+import GHC.Internal.Real+import GHC.Internal.Enum++import GHC.Internal.Heap.InfoTable.Types+#if !defined(TABLES_NEXT_TO_CODE)+import GHC.Internal.Heap.Constants+import GHC.Internal.Data.Functor ((<$>))+import GHC.Internal.Data.Maybe+import GHC.Internal.Num (negate)+#else+import GHC.Internal.Data.Either+import GHC.Internal.Foreign.Marshal.Array+#endif+import GHC.Internal.Foreign.Ptr+import GHC.Internal.Foreign.Storable++-------------------------------------------------------------------------+-- Profiling specific code+--+-- The functions that follow all rely on PROFILING. They are duplicated in+-- ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc where PROFILING is defined. This+-- allows hsc2hs to generate values for both profiling and non-profiling builds.++-- | Read an InfoTable from the heap into a haskell type.+-- WARNING: This code assumes it is passed a pointer to a "standard" info+-- table. If tables_next_to_code is disabled, it will look 1 word before the+-- start for the entry field.+peekItbl :: Ptr StgInfoTable -> IO StgInfoTable+peekItbl a0 = do+#if !defined(TABLES_NEXT_TO_CODE)+  let ptr = a0 `plusPtr` (negate wORD_SIZE)+  entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr+#else+  let ptr = a0+      entry' = Nothing+#endif+  ptrs'   <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr+  nptrs'  <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr+  tipe'   <- (#peek struct StgInfoTable_, type) ptr+  srtlen' <- (#peek struct StgInfoTable_, srt) a0+  return StgInfoTable+    { entry  = entry'+    , ptrs   = ptrs'+    , nptrs  = nptrs'+    , tipe   = toEnum (fromIntegral (tipe' :: HalfWord))+    , srtlen = srtlen'+    , code   = Nothing+    }++pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()+pokeItbl a0 itbl = do+#if !defined(TABLES_NEXT_TO_CODE)+  (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))+#endif+  (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)+  (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)+  (#poke StgInfoTable, type) a0 (toHalfWord (fromEnum (tipe itbl)))+  (#poke StgInfoTable, srt) a0 (srtlen itbl)+#if defined(TABLES_NEXT_TO_CODE)+  let code_offset = a0 `plusPtr` (#offset StgInfoTable, code)+  case code itbl of+    Nothing -> return ()+    Just (Left xs) -> pokeArray code_offset xs+    Just (Right xs) -> pokeArray code_offset xs+#endif+  where+    toHalfWord :: Int -> HalfWord+    toHalfWord i = fromIntegral i++-- | Size in bytes of a standard InfoTable+itblSize :: Int+itblSize = (#size struct StgInfoTable_)
+ libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc view
@@ -0,0 +1,53 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module GHC.Internal.Heap.InfoTable.Types+    ( StgInfoTable(..)+    , EntryFunPtr+    , HalfWord(..)+    , ItblCodes+    ) where++#include "Rts.h"++import GHC.Internal.Base+import GHC.Internal.Generics+import GHC.Internal.ClosureTypes+import GHC.Internal.Foreign.Ptr+import GHC.Internal.Foreign.Storable+import GHC.Internal.Enum+import GHC.Internal.Num+import GHC.Internal.Word+import GHC.Internal.Show+import GHC.Internal.Real+import GHC.Internal.Data.Either++type ItblCodes = Either [Word8] [Word32]++#include "ghcautoconf.h"+-- Ultra-minimalist version specially for constructors+#if SIZEOF_VOID_P == 8+type HalfWord' = Word32+#elif SIZEOF_VOID_P == 4+type HalfWord' = Word16+#else+#error Unknown SIZEOF_VOID_P+#endif++newtype HalfWord = HalfWord HalfWord'+    deriving newtype (Enum, Eq, Integral, Num, Ord, Real, Show, Storable)++type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))++-- | This is a somewhat faithful representation of an info table. See+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/InfoTables.h>+-- for more details on this data structure.+data StgInfoTable = StgInfoTable {+   entry  :: Maybe EntryFunPtr, -- Just <=> not TABLES_NEXT_TO_CODE+   ptrs   :: HalfWord,+   nptrs  :: HalfWord,+   tipe   :: ClosureType,+   srtlen :: HalfWord,+   code   :: Maybe ItblCodes -- Just <=> TABLES_NEXT_TO_CODE+  } deriving (Eq, Show, Generic)
+ libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc view
@@ -0,0 +1,76 @@+{-# LANGUAGE NoMonoLocalBinds #-}+module GHC.Internal.Heap.InfoTableProf+    ( module GHC.Internal.Heap.InfoTable.Types+    , itblSize+    , peekItbl+    , pokeItbl+    ) where++-- This file overrides InfoTable.hsc's implementation of peekItbl and pokeItbl.+-- Manually defining PROFILING gives the #peek and #poke macros an accurate+-- representation of StgInfoTable_ when hsc2hs runs.+#define PROFILING+#include "Rts.h"++import GHC.Internal.Base+import GHC.Internal.Real+import GHC.Internal.Enum++import GHC.Internal.Heap.InfoTable.Types+#if !defined(TABLES_NEXT_TO_CODE)+import GHC.Internal.Heap.Constants+import GHC.Internal.Data.Functor ((<$>))+import GHC.Internal.Data.Maybe+import GHC.Internal.Num (negate)+#else+import GHC.Internal.Data.Either+import GHC.Internal.Foreign.Marshal.Array+#endif+import GHC.Internal.Foreign.Ptr+import GHC.Internal.Foreign.Storable++-- | Read an InfoTable from the heap into a haskell type.+-- WARNING: This code assumes it is passed a pointer to a "standard" info+-- table. If tables_next_to_code is enabled, it will look 1 byte before the+-- start for the entry field.+peekItbl :: Ptr StgInfoTable -> IO StgInfoTable+peekItbl a0 = do+#if !defined(TABLES_NEXT_TO_CODE)+  let ptr = a0 `plusPtr` (negate wORD_SIZE)+  entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr+#else+  let ptr = a0+      entry' = Nothing+#endif+  ptrs'   <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr+  nptrs'  <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr+  tipe'   <- (#peek struct StgInfoTable_, type) ptr+  srtlen' <- (#peek struct StgInfoTable_, srt) a0+  return StgInfoTable+    { entry  = entry'+    , ptrs   = ptrs'+    , nptrs  = nptrs'+    , tipe   = toEnum (fromIntegral (tipe' :: HalfWord))+    , srtlen = srtlen'+    , code   = Nothing+    }++pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()+pokeItbl a0 itbl = do+#if !defined(TABLES_NEXT_TO_CODE)+  (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))+#endif+  (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)+  (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)+  (#poke StgInfoTable, type) a0 (fromEnum (tipe itbl))+  (#poke StgInfoTable, srt) a0 (srtlen itbl)+#if defined(TABLES_NEXT_TO_CODE)+  let code_offset = a0 `plusPtr` (#offset StgInfoTable, code)+  case code itbl of+    Nothing -> return ()+    Just (Left xs) -> pokeArray code_offset xs+    Just (Right xs) -> pokeArray code_offset xs+#endif++itblSize :: Int+itblSize = (#size struct StgInfoTable_)
+ libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE DeriveGeneric #-}++module GHC.Internal.Heap.ProfInfo.Types where++import GHC.Internal.Base+import GHC.Internal.Word+import GHC.Internal.Generics+import GHC.Internal.Show++-- | This is a somewhat faithful representation of StgTSOProfInfo. See+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/TSO.h>+-- for more details on this data structure.+newtype StgTSOProfInfo = StgTSOProfInfo {+    cccs :: Maybe CostCentreStack+} deriving (Show, Generic, Eq, Ord)++-- | This is a somewhat faithful representation of CostCentreStack. See+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h>+-- for more details on this data structure.+data CostCentreStack = CostCentreStack {+    ccs_ccsID :: Int,+    ccs_cc :: CostCentre,+    ccs_prevStack :: Maybe CostCentreStack,+    ccs_indexTable :: Maybe IndexTable,+    ccs_root :: Maybe CostCentreStack,+    ccs_depth :: Word,+    ccs_scc_count :: Word64,+    ccs_selected :: Word,+    ccs_time_ticks :: Word,+    ccs_mem_alloc :: Word64,+    ccs_inherited_alloc :: Word64,+    ccs_inherited_ticks :: Word+} deriving (Show, Generic, Eq, Ord)++-- | This is a somewhat faithful representation of CostCentre. See+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h>+-- for more details on this data structure.+data CostCentre = CostCentre {+    cc_ccID :: Int,+    cc_label :: String,+    cc_module :: String,+    cc_srcloc :: Maybe String,+    cc_mem_alloc :: Word64,+    cc_time_ticks :: Word,+    cc_is_caf :: Bool,+    cc_link :: Maybe CostCentre+} deriving (Show, Generic, Eq, Ord)++-- | This is a somewhat faithful representation of IndexTable. See+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h>+-- for more details on this data structure.+data IndexTable = IndexTable {+    it_cc :: CostCentre,+    it_ccs :: Maybe CostCentreStack,+    it_next :: Maybe IndexTable,+    it_back_edge :: Bool+} deriving (Show, Generic, Eq, Ord)
libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs view
@@ -165,6 +165,8 @@    | ExtendedLiterals    | ListTuplePuns    | MultilineStrings+   | ExplicitLevelImports+   | ImplicitStagePersistence    deriving (Eq, Enum, Show, Generic, Bounded) -- 'Ord' and 'Bounded' are provided for GHC API users (see discussions -- in https://gitlab.haskell.org/ghc/ghc/merge_requests/2707 and
libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs view
@@ -32,7 +32,6 @@ import Data.Data hiding (Fixity(..)) import Data.IORef import System.IO.Unsafe ( unsafePerformIO )-import GHC.IO.Unsafe    ( unsafeDupableInterleaveIO ) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Fix (MonadFix (..)) import Control.Exception (BlockedIndefinitelyOnMVar (..), catch, throwIO)@@ -42,16 +41,18 @@ import Data.Char        ( isAlpha, isAlphaNum, isUpper ) import Data.List.NonEmpty ( NonEmpty(..) ) import Data.Word-import GHC.Generics     ( Generic ) import qualified Data.Kind as Kind (Type)-import GHC.Ptr          ( Ptr, plusPtr ) import Foreign.ForeignPtr import Foreign.C.String import Foreign.C.Types+import GHC.IO.Unsafe    ( unsafeDupableInterleaveIO )+import GHC.Ptr          ( Ptr, plusPtr )+import GHC.Generics     ( Generic ) import GHC.Types        (TYPE, RuntimeRep(..)) #else-import GHC.Internal.Base hiding (Type, Module, sequence)+import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence) import GHC.Internal.Data.Data hiding (Fixity(..))+import GHC.Internal.Data.NonEmpty (NonEmpty(..)) import GHC.Internal.Data.Traversable import GHC.Internal.Word import GHC.Internal.Generics (Generic)@@ -76,7 +77,7 @@ import GHC.Internal.MVar import GHC.Internal.IO.Exception import GHC.Internal.Unicode-import qualified GHC.Types as Kind (Type)+import qualified GHC.Internal.Types as Kind (Type) #endif import GHC.Internal.ForeignSrcLang import GHC.Internal.LanguageExtensions@@ -429,8 +430,8 @@ -- expressions: -- -- >>> fmap ppr $ runQ (unTypeCode [| True == $( [| "foo" |] ) |])--- GHC.Types.True GHC.Classes.== "foo"--- >>> GHC.Types.True GHC.Classes.== "foo"+-- GHC.Internal.Types.True GHC.Internal.Classes.== "foo"+-- >>> GHC.Internal.Types.True GHC.Internal.Classes.== "foo" -- <interactive> error: --     • Couldn't match expected type ‘Bool’ with actual type ‘[Char]’ --     • In the second argument of ‘(==)’, namely ‘"foo"’@@ -846,12 +847,6 @@ addTopDecls :: [Dec] -> Q () addTopDecls ds = Q (qAddTopDecls ds) --- |-addForeignFile :: ForeignSrcLang -> String -> Q ()-addForeignFile = addForeignSource-{-# DEPRECATED addForeignFile-               "Use 'Language.Haskell.TH.Syntax.addForeignSource' instead"-  #-} -- deprecated in 8.6  -- | Emit a foreign file which will be compiled and linked to the object for -- the current module. Currently only languages that can be compiled with@@ -1000,10 +995,10 @@ sequenceQ = sequence  oneName, manyName :: Name--- | Synonym for @''GHC.Types.One'@, from @ghc-prim@.-oneName  = mkNameG DataName "ghc-prim" "GHC.Types" "One"--- | Synonym for @''GHC.Types.Many'@, from @ghc-prim@.-manyName = mkNameG DataName "ghc-prim" "GHC.Types" "Many"+-- | Synonym for @''GHC.Internal.Types.One'@, from @ghc-internal@.+oneName  = mkNameG DataName "ghc-internal" "GHC.Internal.Types" "One"+-- | Synonym for @''GHC.Internal.Types.Many'@, from @ghc-internal@.+manyName = mkNameG DataName "ghc-internal" "GHC.Internal.Types" "Many"   -----------------------------------------------------@@ -1401,7 +1396,7 @@  mk_tup_name :: Int -> NameSpace -> Bool -> Name mk_tup_name n space boxed-  = Name (mkOccName tup_occ) (NameG space (mkPkgName "ghc-prim") tup_mod)+  = Name (mkOccName tup_occ) (NameG space (mkPkgName "ghc-internal") tup_mod)   where     withParens thing       | boxed     = "("  ++ thing ++ ")"@@ -1411,7 +1406,7 @@             | space == TcClsName = "Tuple" ++ show n ++ if boxed then "" else "#"             | otherwise = withParens (replicate n_commas ',')     n_commas = n - 1-    tup_mod  = mkModName (if boxed then "GHC.Tuple" else "GHC.Types")+    tup_mod  = mkModName (if boxed then "GHC.Internal.Tuple" else "GHC.Internal.Types")     solo       | space == DataName = "MkSolo"       | otherwise = "Solo"@@ -1436,7 +1431,7 @@    | otherwise   = Name (mkOccName sum_occ)-         (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Types"))+         (NameG DataName (mkPkgName "ghc-internal") (mkModName "GHC.Internal.Types"))    where     prefix     = "unboxedSumDataName: "@@ -1455,7 +1450,7 @@    | otherwise   = Name (mkOccName sum_occ)-         (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Types"))+         (NameG TcClsName (mkPkgName "ghc-internal") (mkModName "GHC.Internal.Types"))    where     -- Synced with the definition of mkSumTyConOcc in GHC.Builtin.Types@@ -2163,8 +2158,8 @@             -- 'Inline' and 'RuleMatch'.             | OpaqueP         Name             -- ^ @{ {\-\# OPAQUE T #-} }@-            | SpecialiseP     Name Type (Maybe Inline) Phases-            -- ^ @{ {\-\# SPECIALISE [INLINE] [phases] T #-} }@+            | SpecialiseEP    (Maybe [TyVarBndr ()]) [RuleBndr] Exp (Maybe Inline) Phases+            -- ^ @{ {\-\# SPECIALISE [forall t_1 ... t_i]. [forall b_1 ... b_j] [INLINE] [phases] exp #-} }@             | SpecialiseInstP Type             -- ^ @{ {\-\# SPECIALISE instance I #-} }@             | RuleP           String (Maybe [TyVarBndr ()]) [RuleBndr] Exp Exp Phases
libraries/ghci/GHCi/BreakArray.hs view
@@ -30,11 +30,9 @@     , setupBreakpoint     , breakOn     , breakOff-    , showBreakArray     ) where  import Prelude -- See note [Why do we import Prelude here?]-import Control.Monad  import GHC.Exts import GHC.IO ( IO(..) )@@ -47,13 +45,6 @@ breakOff, breakOn :: Int breakOn  = 0 breakOff = -1--showBreakArray :: BreakArray -> IO ()-showBreakArray array = do-    forM_ [0 .. (size array - 1)] $ \i -> do-        val <- readBreakArray array i-        putStr $ ' ' : show val-    putStr "\n"  setupBreakpoint :: BreakArray -> Int -> Int -> IO Bool setupBreakpoint breakArray ind val
libraries/ghci/GHCi/Message.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables,     GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards,-    CPP #-}+    CPP, NamedFieldPuns #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}  -- |@@ -11,6 +11,7 @@ -- module GHCi.Message   ( Message(..), Msg(..)+  , ConInfoTable(..)   , THMessage(..), THMsg(..)   , QResult(..)   , EvalStatus_(..), EvalStatus, EvalResult(..), EvalOpts(..), EvalExpr(..)@@ -21,8 +22,9 @@   , ResumeContext(..)   , QState(..)   , getMessage, putMessage, getTHMessage, putTHMessage-  , Pipe(..), remoteCall, remoteTHCall, readPipe, writePipe+  , Pipe, mkPipeFromHandles, mkPipeFromContinuations, remoteCall, remoteTHCall, readPipe, writePipe   , BreakModule+  , BreakUnitId   , LoadedDLL   ) where @@ -34,11 +36,17 @@ import GHCi.ResolvedBCO  import GHC.LanguageExtensions+import GHC.InfoProv+#if MIN_VERSION_ghc_internal(9,1500,0) import qualified GHC.Exts.Heap as Heap+#else+import qualified GHC.Exts.Heap as Heap+#endif import GHC.ForeignSrcLang import GHC.Fingerprint import GHC.Conc (pseq, par) import Control.Concurrent+import Control.DeepSeq import Control.Exception #if MIN_VERSION_base(4,20,0) import Control.Exception.Context@@ -48,7 +56,9 @@ import Data.Binary.Put import Data.ByteString (ByteString) import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.Short as BS import Data.Dynamic import Data.Typeable (TypeRep) import Data.IORef@@ -113,12 +123,7 @@    -- | Create an info table for a constructor   MkConInfoTable-   :: Bool    -- TABLES_NEXT_TO_CODE-   -> Int     -- ptr words-   -> Int     -- non-ptr words-   -> Int     -- constr tag-   -> Int     -- pointer tag-   -> ByteString -- constructor desccription+   :: !ConInfoTable    -> Message (RemotePtr Heap.StgInfoTable)    -- | Evaluate a statement@@ -217,13 +222,19 @@                    -> [RemoteRef (TH.Q ())]                    -> Message (QResult ()) -  -- | Remote interface to GHC.Exts.Heap.getClosureData. This is used by+  -- | Remote interface to GHC.Internal.Heap.getClosureData. This is used by   -- the GHCi debugger to inspect values in the heap for :print and   -- type reconstruction.   GetClosure     :: HValueRef     -> Message (Heap.GenClosure HValueRef) +  -- | Remote interface to GHC.InfoProv.whereFrom. This is used by+  -- the GHCi debugger to inspect the provenance of thunks for :print.+  WhereFrom+    :: HValueRef+    -> Message (Maybe InfoProv)+   -- | Evaluate something. This is used to support :force in GHCi.   Seq     :: HValueRef@@ -234,15 +245,24 @@     :: RemoteRef (ResumeContext ())     -> Message (EvalStatus ()) -  -- | Allocate a string for a breakpoint module name.-  -- This uses an empty dummy type because @ModuleName@ isn't available here.-  NewBreakModule-   :: String-   -> Message (RemotePtr BreakModule)- deriving instance Show (Message a) +-- | Used to dynamically create a data constructor's info table at+-- run-time.+data ConInfoTable = ConInfoTable {+  conItblTablesNextToCode :: !Bool, -- ^ TABLES_NEXT_TO_CODE+  conItblPtrs :: !Int,              -- ^ ptr words+  conItblNPtrs :: !Int,             -- ^ non-ptr words+  conItblConTag :: !Int,            -- ^ constr tag+  conItblPtrTag :: !Int,            -- ^ pointer tag+  conItblDescr :: !ByteString       -- ^ constructor desccription+}+  deriving (Generic, Show) +instance Binary ConInfoTable++instance NFData ConInfoTable+ -- | Template Haskell return values data QResult a   = QDone a@@ -362,6 +382,7 @@ data EvalOpts = EvalOpts   { useSandboxThread :: Bool   , singleStep :: Bool+  , stepOut :: Bool   , breakOnException :: Bool   , breakOnError :: Bool   }@@ -401,10 +422,9 @@ instance Binary a => Binary (EvalStatus_ a b)  data EvalBreakpoint = EvalBreakpoint-  { eb_tick_mod   :: String -- ^ Breakpoint tick module-  , eb_tick_index :: Int    -- ^ Breakpoint tick index-  , eb_info_mod   :: String -- ^ Breakpoint info module-  , eb_info_index :: Int    -- ^ Breakpoint info index+  { eb_info_mod      :: String -- ^ Breakpoint info module+  , eb_info_mod_unit :: BS.ShortByteString -- ^ Breakpoint tick module unit id+  , eb_info_index    :: Int    -- ^ Breakpoint info index   }   deriving (Generic, Show) @@ -421,6 +441,10 @@ -- that type isn't available here. data BreakModule +-- | A dummy type that tags the pointer to a breakpoint's @UnitId@, because+-- that type isn't available here.+data BreakUnitId+ -- | A dummy type that tags pointers returned by 'LoadDLL'. data LoadedDLL @@ -503,13 +527,6 @@   get = fromIntegral <$> (get :: Get Word32)  -- Binary instances to support the GetClosure message-#ifndef MIN_VERSION_ghc_heap-#define MIN_VERSION_ghc_heap(major1,major2,minor) (\-  (major1) <  9 || \-  (major1) == 9 && (major2) <  12 || \-  (major1) == 9 && (major2) == 12 && (minor) <= 3)-#endif /* MIN_VERSION_ghc_heap */-#if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo instance Binary Heap.CostCentreStack instance Binary Heap.CostCentre@@ -517,12 +534,20 @@ instance Binary Heap.WhatNext instance Binary Heap.WhyBlocked instance Binary Heap.TsoFlags-#endif  instance Binary Heap.StgInfoTable instance Binary Heap.ClosureType instance Binary Heap.PrimType instance Binary a => Binary (Heap.GenClosure a)+instance Binary InfoProv where+#if MIN_VERSION_base(4,20,0)+  get = InfoProv <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get+  put (InfoProv x1 x2 x3 x4 x5 x6 x7 x8)+    = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 >> put x7 >> put x8+#else+  get = InfoProv <$> get <*> get <*> get <*> get <*> get <*> get <*> get+  put (InfoProv x1 x2 x3 x4 x5 x6 x7) = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 >> put x7+#endif  data Msg = forall a . (Binary a, Show a) => Msg (Message a) @@ -549,7 +574,7 @@       15 -> Msg <$> MallocStrings <$> get       16 -> Msg <$> (PrepFFI <$> get <*> get)       17 -> Msg <$> FreeFFI <$> get-      18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get <*> get <*> get)+      18 -> Msg <$> MkConInfoTable <$> get       19 -> Msg <$> (EvalStmt <$> get <*> get)       20 -> Msg <$> (ResumeStmt <$> get <*> get)       21 -> Msg <$> (AbandonStmt <$> get)@@ -570,8 +595,8 @@       36 -> Msg <$> (Seq <$> get)       37 -> Msg <$> return RtsRevertCAFs       38 -> Msg <$> (ResumeSeq <$> get)-      39 -> Msg <$> (NewBreakModule <$> get)-      40 -> Msg <$> (LookupSymbolInDLL <$> get <*> get)+      39 -> Msg <$> (LookupSymbolInDLL <$> get <*> get)+      40 -> Msg <$> (WhereFrom <$> get)       _  -> error $ "Unknown Message code " ++ (show b)  putMessage :: Message a -> Put@@ -595,7 +620,7 @@   MallocStrings bss           -> putWord8 15 >> put bss   PrepFFI args res            -> putWord8 16 >> put args >> put res   FreeFFI p                   -> putWord8 17 >> put p-  MkConInfoTable tc p n t pt d -> putWord8 18 >> put tc >> put p >> put n >> put t >> put pt >> put d+  MkConInfoTable itbl         -> putWord8 18 >> put itbl   EvalStmt opts val           -> putWord8 19 >> put opts >> put val   ResumeStmt opts val         -> putWord8 20 >> put opts >> put val   AbandonStmt val             -> putWord8 21 >> put val@@ -616,8 +641,8 @@   Seq a                       -> putWord8 36 >> put a   RtsRevertCAFs               -> putWord8 37   ResumeSeq a                 -> putWord8 38 >> put a-  NewBreakModule name         -> putWord8 39 >> put name-  LookupSymbolInDLL dll str   -> putWord8 40 >> put dll >> put str+  LookupSymbolInDLL dll str   -> putWord8 39 >> put dll >> put str+  WhereFrom a                 -> putWord8 40 >> put a  {- Note [Parallelize CreateBCOs serialization]@@ -650,47 +675,58 @@ -- ----------------------------------------------------------------------------- -- Reading/writing messages +-- | An opaque pipe for bidirectional binary data transmission. data Pipe = Pipe-  { pipeRead :: Handle-  , pipeWrite ::  Handle-  , pipeLeftovers :: IORef (Maybe ByteString)+  { getSome :: !(IO ByteString)+  , putAll :: !(B.Builder -> IO ())+  , pipeLeftovers :: !(IORef (Maybe ByteString))   } +-- | Make a 'Pipe' from a 'Handle' to read and a 'Handle' to write.+mkPipeFromHandles :: Handle -> Handle -> IO Pipe+mkPipeFromHandles pipeRead pipeWrite = do+  let getSome = B.hGetSome pipeRead (32*1024)+      putAll b = do+        B.hPutBuilder pipeWrite b+        hFlush pipeWrite+  pipeLeftovers <- newIORef Nothing+  pure $ Pipe { getSome, putAll, pipeLeftovers }++-- | Make a 'Pipe' from a reader function and a writer function.+mkPipeFromContinuations :: IO ByteString -> (B.Builder -> IO ()) -> IO Pipe+mkPipeFromContinuations getSome putAll = do+  pipeLeftovers <- newIORef Nothing+  pure $ Pipe { getSome, putAll, pipeLeftovers }+ remoteCall :: Binary a => Pipe -> Message a -> IO a remoteCall pipe msg = do   writePipe pipe (putMessage msg)   readPipe pipe get +writePipe :: Pipe -> Put -> IO ()+writePipe Pipe{..} put = putAll $ execPut put+ remoteTHCall :: Binary a => Pipe -> THMessage a -> IO a remoteTHCall pipe msg = do   writePipe pipe (putTHMessage msg)   readPipe pipe get -writePipe :: Pipe -> Put -> IO ()-writePipe Pipe{..} put-  | LB.null bs = return ()-  | otherwise  = do-    LB.hPut pipeWrite bs-    hFlush pipeWrite- where-  bs = runPut put- readPipe :: Pipe -> Get a -> IO a readPipe Pipe{..} get = do   leftovers <- readIORef pipeLeftovers-  m <- getBin pipeRead get leftovers+  m <- getBin getSome get leftovers   case m of     Nothing -> throw $-      mkIOError eofErrorType "GHCi.Message.remoteCall" (Just pipeRead) Nothing+      mkIOError eofErrorType "GHCi.Message.readPipe" Nothing Nothing     Just (result, new_leftovers) -> do       writeIORef pipeLeftovers new_leftovers       return result  getBin-  :: Handle -> Get a -> Maybe ByteString+  :: (IO ByteString) -> Get a -> Maybe ByteString   -> IO (Maybe (a, Maybe ByteString)) -getBin h get leftover = go leftover (runGetIncremental get)+getBin getsome get leftover = go leftover (runGetIncremental get)  where    go Nothing (Done leftover _ msg) =      return (Just (msg, if B.null leftover then Nothing else Just leftover))@@ -699,7 +735,7 @@      go Nothing (fun (Just leftover))    go Nothing (Partial fun) = do      -- putStrLn "before hGetSome"-     b <- B.hGetSome h (32*1024)+     b <- getsome      -- putStrLn $ "hGetSome: " ++ show (B.length b)      if B.null b         then return Nothing
libraries/ghci/GHCi/ResolvedBCO.hs view
@@ -41,10 +41,11 @@    = ResolvedBCO {         resolvedBCOIsLE   :: Bool,         resolvedBCOArity  :: {-# UNPACK #-} !Int,-        resolvedBCOInstrs :: BCOByteArray Word16,       -- insns-        resolvedBCOBitmap :: BCOByteArray Word,         -- bitmap-        resolvedBCOLits   :: BCOByteArray Word,         -- non-ptrs-        resolvedBCOPtrs   :: (SizedSeq ResolvedBCOPtr)  -- ptrs+        resolvedBCOInstrs :: BCOByteArray Word16,       -- ^ insns+        resolvedBCOBitmap :: BCOByteArray Word,         -- ^ bitmap+        resolvedBCOLits   :: BCOByteArray Word,+          -- ^ non-ptrs - subword sized entries still take up a full (host) word+        resolvedBCOPtrs   :: (SizedSeq ResolvedBCOPtr)  -- ^ ptrs    }    deriving (Generic, Show) 
libraries/ghci/ghci.cabal view
@@ -2,7 +2,7 @@ -- ../../configure.  Make sure you are editing ghci.cabal.in, not ghci.cabal.  name:           ghci-version:        9.12.3+version:        9.14.1 license:        BSD3 license-file:   LICENSE category:       GHC@@ -60,6 +60,7 @@         CPP-Options: -DHAVE_INTERNAL_INTERPRETER         exposed-modules:             GHCi.Run+            GHCi.Debugger             GHCi.CreateBCO             GHCi.ObjLink             GHCi.Signals@@ -84,31 +85,27 @@     Build-Depends:         rts,         array            == 0.5.*,-        base             >= 4.8 && < 4.22,-        -- ghc-internal     == 9.1203.*-        -- TODO: Use GHC.Internal.Desugar and GHC.Internal.Base from-        -- ghc-internal instead of ignoring the deprecation warning in GHCi.TH-        -- and GHCi.CreateBCO when we require ghc-internal of the bootstrap-        -- compiler+        base             >= 4.8 && < 4.23,+        ghc-internal     >= 9.1001.0 && <=9.1401.0,         ghc-prim         >= 0.5.0 && < 0.14,         binary           == 0.8.*,         bytestring       >= 0.10 && < 0.13,-        containers       >= 0.5 && < 0.8,+        containers       >= 0.5 && < 0.9,         deepseq          >= 1.4 && < 1.6,         filepath         >= 1.4 && < 1.6,-        ghc-boot         == 9.12.3,-        ghc-heap         == 9.12.3,+        ghc-boot         == 9.14.1,+        ghc-heap         >= 9.10.1 && <=9.14.1,         transformers     >= 0.5 && < 0.7      if flag(bootstrap)       build-depends:-            ghc-boot-th-next  == 9.12.3+            ghc-boot-th-next  == 9.14.1     else       build-depends:-            ghc-boot-th       == 9.12.3+            ghc-boot-th       == 9.14.1      if !os(windows)         Build-Depends: unix >= 2.7 && < 2.9      if arch(wasm32)-        build-depends: ghc-experimental == 9.1203.0+        build-depends: ghc-experimental == 9.1401.0
libraries/template-haskell/template-haskell.cabal view
@@ -3,7 +3,7 @@ -- template-haskell.cabal.  name:           template-haskell-version:        2.23.0.0+version:        2.24.0.0 -- NOTE: Don't forget to update ./changelog.md license:        BSD3 license-file:   LICENSE@@ -43,7 +43,6 @@     exposed-modules:         Language.Haskell.TH         Language.Haskell.TH.Lib-        Language.Haskell.TH.Lib.Internal         Language.Haskell.TH.Ppr         Language.Haskell.TH.PprLib         Language.Haskell.TH.Quote@@ -52,12 +51,12 @@         Language.Haskell.TH.CodeDo      build-depends:-        base        >= 4.11 && < 4.22,+        base        >= 4.11 && < 4.23,         -- We don't directly depend on any of the modules from `ghc-internal`         -- But we need to depend on it to work around a hadrian bug.         -- See: https://gitlab.haskell.org/ghc/ghc/-/issues/25705-        ghc-internal == 9.1203.*,-        ghc-boot-th == 9.12.3+        ghc-internal == 9.1401.*,+        ghc-boot-th == 9.14.1      build-depends:       filepath
rts/include/stg/MachRegs/loongarch64.h view
@@ -46,6 +46,3 @@ #define REG_D2          fs5 #define REG_D3          fs6 #define REG_D4          fs7--#define MAX_REAL_FLOAT_REG   4-#define MAX_REAL_DOUBLE_REG  4
rts/include/stg/MachRegs/ppc.h view
@@ -60,6 +60,3 @@ #define REG_SpLim       r25 #define REG_Hp          r26 #define REG_Base        r27--#define MAX_REAL_FLOAT_REG   6-#define MAX_REAL_DOUBLE_REG  6
rts/include/stg/MachRegs/riscv64.h view
@@ -56,6 +56,3 @@ #define REG_D4          fs9 #define REG_D5          fs10 #define REG_D6          fs11--#define MAX_REAL_FLOAT_REG   6-#define MAX_REAL_DOUBLE_REG  6